diff --git a/thys/ArrowImpossibilityGS/Thys/Arrow_Order.thy b/thys/ArrowImpossibilityGS/Thys/Arrow_Order.thy --- a/thys/ArrowImpossibilityGS/Thys/Arrow_Order.thy +++ b/thys/ArrowImpossibilityGS/Thys/Arrow_Order.thy @@ -1,316 +1,317 @@ (* Author: Tobias Nipkow, 2007 *) section "Arrow's Theorem for Strict Linear Orders" theory Arrow_Order imports Main "HOL-Library.FuncSet" begin text\This theory formalizes the third proof due to Geanakoplos~\cite{Geanakoplos05}. Preferences are modeled as strict linear orderings. The set of alternatives need not be finite. Individuals are assumed to be finite but are not a priori identified with an initial segment of the naturals. In retrospect this generality appears gratuitous and complicates some of the low-level reasoning where we use a bijection with such an initial segment.\ typedecl alt typedecl indi abbreviation "I == (UNIV::indi set)" axiomatization where alt3: "\a b c::alt. distinct[a,b,c]" and finite_indi: "finite I" abbreviation "N == card I" lemma third_alt: "a \ b \ \c::alt. distinct[a,b,c]" using alt3 by simp metis lemma alt2: "\b::alt. b \ a" using alt3 by simp metis type_synonym pref = "(alt * alt)set" definition "Lin == {L::pref. strict_linear_order L}" lemmas slo_defs = Lin_def strict_linear_order_on_def total_on_def irrefl_def lemma notin_Lin_iff: "L : Lin \ x\y \ (x,y) \ L \ (y,x) : L" apply(auto simp add: slo_defs) apply(metis trans_def) done lemma converse_in_Lin[simp]: "L\ : Lin \ L : Lin" apply (simp add: slo_defs) apply blast done lemma Lin_irrefl: "L:Lin \ (a,b):L \ (b,a):L \ False" by(simp add:slo_defs)(metis trans_def) corollary linear_alt: "\L::pref. L : Lin" using well_order_on[where 'a = "alt", of UNIV] apply (auto simp:well_order_on_def Lin_def) apply (metis strict_linear_order_on_diff_Id) done abbreviation rem :: "pref \ alt \ pref" where "rem L a \ {(x,y). (x,y) \ L \ x\a \ y\a}" definition mktop :: "pref \ alt \ pref" where "mktop L b \ rem L b \ {(x,b)|x. x\b}" definition mkbot :: "pref \ alt \ pref" where "mkbot L b \ rem L b \ {(b,y)|y. y\b}" definition below :: "pref \ alt \ alt \ pref" where "below L a b \ rem L a \ {(a,b)} \ {(x,a)|x. (x,b) : L \ x\a} \ {(a,y)|y. (b,y) : L \ y\a}" definition above :: "pref \ alt \ alt \ pref" where "above L a b \ rem L b \ {(a,b)} \ {(x,b)|x. (x,a) : L \ x\b} \ {(b,y)|y. (a,y) : L \ y\b}" lemma in_mktop: "(x,y) \ mktop L z \ x\z \ (if y=z then x\y else (x,y) \ L)" by(auto simp:mktop_def) lemma in_mkbot: "(x,y) \ mkbot L z \ y\z \ (if x=z then x\y else (x,y) \ L)" by(auto simp:mkbot_def) lemma in_above: "a\b \ L:Lin \ (x,y) : above L a b \ x\y \ (if x=b then (a,y) : L else if y=b then x=a | (x,a) : L else (x,y) : L)" by(auto simp:above_def slo_defs) lemma in_below: "a\b \ L:Lin \ (x,y) : below L a b \ x\y \ (if y=a then (x,b) : L else if x=a then y=b | (b,y) : L else (x,y) : L)" by(auto simp:below_def slo_defs) declare [[simp_depth_limit = 2]] lemma mktop_Lin: "L : Lin \ mktop L x : Lin" by(auto simp add:slo_defs mktop_def trans_def) lemma mkbot_Lin: "L : Lin \ mkbot L x : Lin" by(auto simp add:slo_defs trans_def mkbot_def) lemma below_Lin: "x\y \ L : Lin \ below L x y : Lin" unfolding slo_defs below_def trans_def apply(simp) apply blast done lemma above_Lin: "x\y \ L : Lin \ above L x y : Lin" unfolding slo_defs above_def trans_def apply(simp) apply blast done declare [[simp_depth_limit = 50]] abbreviation lessLin :: "alt \ pref \ alt \ bool" ("(_ <\<^bsub>_\<^esub> _)" [51, 51] 50) where "a <\<^bsub>L\<^esub> b == (a,b) : L" definition "Prof = I \ Lin" abbreviation "SWF == Prof \ Lin" definition "unanimity F == \P\Prof.\a b. (\i. a <\<^bsub>P i\<^esub> b) \ a <\<^bsub>F P\<^esub> b" definition "IIA F == \P\Prof.\P'\Prof.\a b. (\i. a <\<^bsub>P i\<^esub> b \ a <\<^bsub>P' i\<^esub> b) \ (a <\<^bsub>F P\<^esub> b \ a <\<^bsub>F P'\<^esub> b)" definition "dictator F i == \P\Prof. F P = P i" lemma dictatorI: "F : SWF \ \P\Prof. \a b. a \ b \ (a,b) : P i \ (a,b) : F P \ dictator F i" apply(simp add:dictator_def Prof_def Pi_def Lin_def strict_linear_order_on_def) apply safe apply(erule_tac x=P in allE) apply(erule_tac x=P in allE) apply(simp add:total_on_def irrefl_def) apply (metis trans_def) apply (metis irrefl_def) done lemma const_Lin_Prof: "L:Lin \ (%p. L) : Prof" by(simp add:Prof_def Pi_def) lemma complete_Lin: assumes "a\b" shows "\L\Lin. (a,b) : L" proof - from linear_alt obtain R where "R:Lin" by auto thus ?thesis by (metis assms in_mkbot mkbot_Lin) qed declare Let_def[simp] theorem Arrow: assumes "F : SWF" and u: "unanimity F" and "IIA F" shows "\i. dictator F i" proof - { fix a b a' b' and P P' assume d1: "a\b" "a'\b'" and d2: "a\b'" "b\a'" and "P : Prof" "P' : Prof" and 1: "\i. (a,b) : P i \ (a',b') : P' i" assume "(a,b) : F P" define Q where "Q i = (let L = (if a=a' then P i else below (P i) a' a) in if b=b' then L else above L b b')" for i have "Q : Prof" using \P : Prof\ by(simp add:Q_def Prof_def Pi_def above_Lin below_Lin) hence "F Q : Lin" using \F : SWF\ by(simp add:Pi_def) have "\i. (a,b) : P i \ (a,b) : Q i" using d1 d2 \P : Prof\ by(simp add:in_above in_below Q_def Prof_def Pi_def below_Lin) hence "(a,b) : F Q" using $$a,b) : F P\ \IIA F\ \P:Prof\ \Q : Prof\ unfolding IIA_def by blast moreover { assume "a\a'" hence "!!i. (a',a) : Q i" using d1 d2 \P : Prof\ by(simp add:in_above in_below Q_def Prof_def Pi_def below_Lin) hence "(a',a) : F Q" using u \Q : Prof\ by(simp add:unanimity_def) } moreover { assume "b\b'" hence "!!i. (b,b') : Q i" using d1 d2 \P : Prof\ by(simp add:in_above in_below Q_def Prof_def Pi_def below_Lin) hence "(b,b') : F Q" using u \Q : Prof\ by(simp add:unanimity_def) } ultimately have "(a',b') : F Q" using \F Q : Lin\ unfolding slo_defs trans_def by safe metis moreover have "\i. (a',b') : Q i \ (a',b') : P' i" using d1 d2 \P : Prof\ 1 by(simp add:Q_def in_below in_above Prof_def Pi_def below_Lin) blast ultimately have "(a',b') : F P'" using \IIA F\ \P' : Prof\ \Q : Prof\ unfolding IIA_def by blast } note 1 = this { fix a b a' b' and P P' assume "a\b" "a'\b'" "a\b'" "b\a'" "P : Prof" "P' : Prof" "\i. (a,b) : P i \ (a',b') : P' i" hence "(a,b) : F P \ (a',b') : F P'" using 1 by blast } note 2 = this { fix a b P P' assume "a\b" "P : Prof" "P' : Prof" and iff: "\i. (a,b) : P i \ (b,a) : P' i" from \a\b\ obtain c where dist: "distinct[a,b,c]" using third_alt by metis let ?Q = "%p. below (P p) c b" let ?R = "%p. below (?Q p) b a" let ?S = "%p. below (?R p) a c" have "?Q : Prof" using \P : Prof\ dist by(auto simp add:Prof_def Pi_def below_Lin) hence "?R : Prof" using dist by(auto simp add:Prof_def Pi_def below_Lin) hence "?S : Prof" using dist by(auto simp add:Prof_def Pi_def below_Lin) have "\i. (a,b) : P i \ (a,c) : ?Q i" using \P : Prof\ dist by(auto simp add:in_below Prof_def Pi_def) hence ab: "(a,b) : F P \ (a,c) : F ?Q" using 2 \P : Prof\ \?Q : Prof\ dist[simplified] by (blast) have "\i. (a,c) : ?Q i \ (b,c) : ?R i" using \P : Prof\ dist by(auto simp add:in_below Prof_def Pi_def below_Lin) hence ac: "(a,c) : F ?Q \ (b,c) : F ?R" using 2 \?Q : Prof\ \?R : Prof\ dist[simplified] by (blast) have "\i. (b,c) : ?R i \ (b,a) : ?S i" using \P : Prof\ dist by(auto simp add:in_below Prof_def Pi_def below_Lin) hence bc: "(b,c) : F ?R \ (b,a) : F ?S" using \?R : Prof\ \?S : Prof\ dist[simplified] 2 apply - apply(rule 2) by fast+ have "\i. (b,a) : ?S i \ (a,b) : P i" using \P : Prof\ dist by(auto simp add:in_below Prof_def Pi_def below_Lin) hence "\i. (b,a) : ?S i \ (b,a) : P' i" using iff by blast hence ba: "(b,a) : F ?S \ (b,a) : F P'" using \IIA F\ \P' : Prof\ \?S : Prof\ unfolding IIA_def by fast from ab ac bc ba have "(a,b) : F P \ (b,a) : F P'" by simp } note 3 = this { fix a b c P P' assume A: "a\b" "b\c" "a\c" "P : Prof" "P' : Prof" and iff: "\i. (a,b) : P i \ (b,c) : P' i" hence "\i. (b,a) : (converse o P)i \ (b,c) : P' i" by simp moreover have cP: "converse o P : Prof" using \P:Prof\ by(simp add:Prof_def Pi_def) ultimately have "(b,a) : F(converse o P) \ (b,c) : F P'" using A 2 by metis moreover have "(a,b) : F P \ (b,a) : F(converse o P)" by (rule 3[OF \a\b\ \P:Prof\ cP]) simp ultimately have "(a,b) : F P \ (b,c) : F P'" by blast } note 4 = this { fix a b a' b' :: alt and P P' assume A: "a\b" "a'\b'" "P : Prof" "P' : Prof" "\i. (a,b) : P i \ (a',b') : P' i" have "(a,b) : F P \ (a',b') : F P'" proof- { assume "a\b' & b\a'" hence ?thesis using 2 A by blast } moreover { assume "a=b' & b\a'" hence ?thesis using 4 A by blast } moreover { assume "a\b' & b=a'" hence ?thesis using 4 A by blast } moreover { assume "a=b' & b=a'" hence ?thesis using 3 A by blast } ultimately show ?thesis by blast qed } note pairwise_neutrality = this obtain h :: "indi \ nat" where injh: "inj h" and surjh: "h  I = {0.. b" using alt3 by auto obtain Lab where "(a,b) : Lab" "Lab:Lin" using \a\b\ by (metis complete_Lin) hence "(b,a) \ Lab" by(simp add:slo_defs trans_def) metis obtain Lba where "(b,a) : Lba" "Lba:Lin" using \a\b\ by (metis complete_Lin) hence "(a,b) \ Lba" by(simp add:slo_defs trans_def) metis let ?Pi = "%n. %i. if h i < n then Lab else Lba" have PiProf: "!!n. ?Pi n : Prof" using \Lab:Lin\ \Lba:Lin\ unfolding Prof_def Pi_def by simp have "\nm\n. (b,a) : F(?Pi m)) & (a,b) : F(?Pi(n+1))" proof - have 0: "!!n. F(?Pi n) : Lin" using \F : SWF\ PiProf by(simp add:Pi_def) have "F(%i. Lba):Lin" using \F:SWF\ \Lba:Lin\ by(simp add:Prof_def Pi_def) hence 1: "(a,b) \ F(?Pi 0)" using u \(a,b) \ Lba\ \Lba:Lin\ \Lba:Lin\ \a\b\ by(simp add:unanimity_def notin_Lin_iff const_Lin_Prof) have "?Pi N = (%p. Lab)" using surjh [THEN equalityD1] by(auto simp: subset_eq) moreover have "F(%i. Lab):Lin" using \F:SWF\ \Lab:Lin\ by(simp add:Prof_def Pi_def) ultimately have 2: "(a,b) \ F(?Pi N)" using u \(a,b) : Lab\ \Lab:Lin\ by(simp add:unanimity_def const_Lin_Prof) - with ex_least_nat_less[of "%n. (a,b) : F(?Pi n)"] 1 2 notin_Lin_iff[OF 0 \a\b\] + with ex_least_nat_less[of "%n. (a,b) : F(?Pi n)",OF 1 2] + notin_Lin_iff[OF 0 \a\b\] show ?thesis by simp qed then obtain n where n: "nm\n. (b,a) : F(?Pi m)" "(a,b) : F(?Pi(n+1))" by blast have "dictator F (inv h n)" proof (rule dictatorI [OF \F : SWF\], auto) fix P c d assume "P \ Prof" "c\d" "(c,d) \ P(inv h n)" then obtain e where dist: "distinct[c,d,e]" using third_alt by metis let ?W = "%i. if h i < n then mktop (P i) e else if h i = n then above (P i) c e else mkbot (P i) e" have "?W : Prof" using \P : Prof\ dist by(simp add:Pi_def Prof_def mkbot_Lin mktop_Lin above_Lin) have "\i. (c,d) : P i \ (c,d) : ?W i" using dist \P : Prof\ by(auto simp: in_above in_mkbot in_mktop Prof_def Pi_def) hence PW: "(c,d) : F P \ (c,d) : F ?W" using \IIA F$unfolded IIA_def] \P:Prof\ \?W:Prof\ by fast have "\i. (c,e) : ?W i \ (a,b) : ?Pi (n+1) i" using dist \P : Prof\ by (auto simp: \(a,b):Lab\ \(a,b)\Lba\ in_mkbot in_mktop in_above Prof_def Pi_def) hence "(c,e) : F ?W \ (a,b) : F(?Pi(n+1))" using pairwise_neutrality[of c e a b ?W "?Pi(n+1)"] \a\b\ dist \?W : Prof\ PiProf by simp hence "(c,e) : F ?W" using n(3) by blast have "\i. (e,d) : ?W i \ (b,a) : ?Pi n i" using dist \P : Prof\ \(c,d) \ P(inv h n)\ \inj h\ by(auto simp: \(b,a):Lba\ \(b,a)\Lab\ in_mkbot in_mktop in_above Prof_def Pi_def) hence "(e,d) : F ?W \ (b,a) : F(?Pi n)" using pairwise_neutrality[of e d b a ?W "?Pi n"] \a\b\ dist \?W : Prof\ PiProf by simp blast hence "(e,d) : F ?W" using n(2) by auto with \(c,e) : F ?W\ \?W : Prof\ \F:SWF\ have "(c,d) \ F ?W" unfolding Pi_def slo_defs trans_def by blast thus "(c,d) \ F P" using PW by blast qed thus ?thesis .. qed end diff --git a/thys/Auto2_HOL/HOL/Arith_Thms.thy b/thys/Auto2_HOL/HOL/Arith_Thms.thy --- a/thys/Auto2_HOL/HOL/Arith_Thms.thy +++ b/thys/Auto2_HOL/HOL/Arith_Thms.thy @@ -1,252 +1,252 @@ (* File: Arith_Thms.thy Author: Bohua Zhan Setup for proof steps related to arithmetic, mostly on natural numbers. *) section \Setup for arithmetic\ theory Arith_Thms imports Order_Thms HOL.Binomial begin (* Reducing inequality on natural numbers. *) theorem reduce_le_plus_consts: "(x::nat) + n1 \ y + n2 \ x \ y + (n2-n1)" by simp theorem reduce_le_plus_consts': "n1 \ n2 \ (x::nat) + n1 \ y + n2 \ x + (n1-n2) \ y" by simp theorem reduce_less_plus_consts: "(x::nat) + n1 < y + n2 \ x < y + (n2-n1)" by simp theorem reduce_less_plus_consts': "n1 \ n2 \ (x::nat) + n1 < y + n2 \ x + (n1-n2) < y" by simp (* To normal form. *) theorem norm_less_lminus: "(x::nat) - n < y \ x \ y + (n-1)" by simp theorem norm_less_lplus: "(x::nat) + n < y \ x + (n+1) \ y" by simp theorem norm_less_rminus: "(x::nat) < y - n \ x + (n+1) \ y" by simp theorem norm_less_rplus: "(x::nat) < y + n \ x \ y + (n-1)" by simp theorem norm_less: "(x::nat) < y \ x + 1 \ y" by simp theorem norm_le_lminus: "(x::nat) - n \ y \ x \ y + n" by simp theorem norm_le_rminus: "(x::nat) \ y - n \ x \ y + 0" by simp theorem norm_le: "(x::nat) \ y \ x \ y + 0" by simp theorem norm_le_lplus0: "(x::nat) + 0 \ y \ x \ y + 0" by simp (* Transitive resolve. *) theorem trans_resolve1: "n1 > 0 \ (x::nat) + n1 \ y \ (y::nat) + n2 \ x \ False" by simp theorem trans_resolve2: "n1 > n2 \ (x::nat) + n1 \ y \ (y::nat) \ x + n2 \ False" by simp (* Transitive. *) theorem trans1: "(x::nat) + n1 \ y \ y + n2 \ z \ x + (n1+n2) \ z" by simp theorem trans2: "(x::nat) \ y + n1 \ y \ z + n2 \ x \ z + (n1+n2)" by simp theorem trans3: "(x::nat) + n1 \ y \ y \ z + n2 \ x \ z + (n2-n1)" by simp theorem trans4: "n1 > n2 \ (x::nat) + n1 \ y \ y \ z + n2 \ x + (n1-n2) \ z" by simp theorem trans5: "(x::nat) \ y + n1 \ y + n2 \ z \ x \ z + (n1-n2)" by simp theorem trans6: "n2 > n1 \ (x::nat) \ y + n1 \ y + n2 \ z \ x + (n2-n1) \ z" by simp (* Resolve. *) theorem single_resolve: "n > 0 \ (x::nat) + n \ x \ False" by simp theorem single_resolve_const: "n > 0 \ (x::nat) + n \ 0 \ False" by simp (* Comparison with constants. *) theorem cv_const1: "(x::nat) + n \ y \ 0 + (x+n) \ y" by simp (* x is const *) theorem cv_const2: "(x::nat) + n \ y \ x \ 0 + (y-n)" by simp (* y is const *) theorem cv_const3: "y < n \ (x::nat) + n \ y \ x + (n-y) \ 0" by simp (* y is const (contradiction with 0 \ x) *) theorem cv_const4: "(x::nat) \ y + n \ 0 + (x-n) \ y" by simp (* x is const *) theorem cv_const5: "(x::nat) \ y + n \ 0 \ y + (n-x)" by simp (* x is const (trivial) *) theorem cv_const6: "(x::nat) \ y + n \ x \ 0 + (y+n)" by simp (* y is const *) (* Misc *) theorem nat_eq_to_ineqs: "(x::nat) = y + n \ x \ y + n \ x \ y + n" by simp theorem nat_ineq_impl_not_eq: "(x::nat) + n \ y \ n > 0 \ x \ y" by simp theorem eq_to_ineqs: "(x::nat) \ y \ x \ y \ y \ x" by simp theorem ineq_to_eqs1: "(x::nat) \ y + 0 \ y \ x + 0 \ x = y" by simp ML_file \arith.ML\ ML_file \order.ML\ ML_file \order_test.ML\ setup \register_wellform_data ("(a::nat) - b", ["a \ b"])\ setup \add_prfstep_check_req ("(a::nat) - b", "(a::nat) \ b")\ (* Normalize any expression to "a - b" form. *) lemma nat_sub_norm: "(a::nat) = a - 0 \ a \ 0" by simp (* Adding and subtracting two normalized expressions. *) lemma nat_sub1: "(a::nat) \ b \ c \ d \ (a - b) + (c - d) = (a + c) - (b + d) \ a + c \ b + d" by simp lemma nat_sub2: "(a::nat) \ b \ c \ d \ a - b \ c - d \ (a - b) - (c - d) = (a + d) - (b + c) \ a + d \ b + c" by simp lemma nat_sub3: "(a::nat) \ b \ c \ d \ (a - b) * (c - d) = (a * c + b * d) - (a * d + b * c) \ a * c + b * d \ a * d + b * c" by (smt diff_mult_distrib mult.commute mult_le_mono1 nat_sub2) (* Cancel identical terms on two sides, yielding a normalized expression. *) lemma nat_sub_combine: "(a::nat) + b \ c + b \ (a + b) - (c + b) = a - c \ a \ c" by simp lemma nat_sub_combine2: "n \ m \ (a::nat) + b * n \ c + b * m \ (a + b * n) - (c + b * m) = (a + b * (n - m)) - c \ a + b * (n - m) \ c \ n \ m" by (simp add: add.commute right_diff_distrib') lemma nat_sub_combine3: "n \ m \ (a::nat) + b * n \ c + b * m \ (a + b * n) - (c + b * m) = a - (c + b * (m - n)) \ a \ c + b * (m - n) \ m \ n" by (smt add.commute mult.commute nat_diff_add_eq2 nat_le_add_iff1) ML_file \nat_sub.ML\ ML_file \nat_sub_test.ML\ (* Ordering on Nats. *) lemma le_neq_implies_less' [forward]: "(m::nat) \ n \ m \ n \ m < n" by simp lemma le_zero_to_equal_zero [forward]: "(n::nat) \ 0 \ n = 0" by simp lemma less_one_to_equal_zero [forward]: "(n::nat) < 1 \ n = 0" by simp setup \add_backward_prfstep_cond @{thm Nat.mult_le_mono1} [with_cond "?k \ 1"]\ setup \add_resolve_prfstep @{thm Nat.not_add_less1}\ lemma not_minus_less [resolve]: "\(i::nat) < (i - j)" by simp lemma nat_le_prod_with_same [backward]: "m \ 0 \ (n::nat) \ m * n" by simp lemma nat_le_prod_with_le [backward1]: "k \ 0 \ (n::nat) \ m \ (n::nat) \ k * m" using le_trans nat_le_prod_with_same by blast lemma nat_plus_le_to_less [backward1]: "b \ 0 \ (a::nat) + b \ c \ a < c" by simp lemma nat_plus_le_to_less2 [backward1]: "a \ 0 \ (a::nat) + b \ c \ b < c" by simp setup \add_forward_prfstep @{thm add_right_imp_eq}\ setup \add_forward_prfstep @{thm add_left_imp_eq}\ setup \add_rewrite_rule_cond @{thm Nat.le_diff_conv2} [with_term "?i + ?k"]\ lemma nat_less_diff_conv: "(i::nat) < j - k \ i + k < j" by simp setup \add_forward_prfstep_cond @{thm nat_less_diff_conv} [with_cond "?k \ ?NUMC", with_term "?i + ?k"]\ lemma Nat_le_diff_conv2_same [forward]: "i \ j \ (i::nat) \ i - j \ j = 0" by simp lemma nat_gt_zero [forward]: "b - a > 0 \ b > (a::nat)" by simp lemma n_minus_1_less_n: "(n::nat) \ 1 \ n - 1 < n" by simp setup \add_forward_prfstep_cond @{thm n_minus_1_less_n} [with_term "?n - 1"]\ - + (* Monotonicity of ordering *) setup \add_backward_prfstep @{thm Nat.diff_le_mono}\ setup \add_backward2_prfstep @{thm Nat.diff_less_mono}\ setup \add_backward_prfstep @{thm Nat.mult_le_mono2}\ setup \add_resolve_prfstep @{thm Nat.le_add1}\ setup \add_resolve_prfstep @{thm Nat.le_add2}\ setup \add_backward_prfstep @{thm add_left_mono}\ setup \add_backward_prfstep @{thm add_right_mono}\ lemma add_mono_neutr [backward]: "(0::'a::linordered_ring) \ b \ a \ a + b" by simp lemma add_mono_neutl [backward]: "(0::'a::linordered_ring) \ b \ a \ b + a" by simp setup \add_forward_prfstep @{thm add_less_imp_less_left}\ lemma sum_le_zero1 [forward]: "(a::'a::linordered_ring) + b < 0 \ a \ 0 \ b < 0" by (meson add_less_same_cancel1 less_le_trans) lemma less_sum1 [backward]: "b > 0 \ a < a + (b::nat)" by auto setup \add_backward_prfstep @{thm Nat.trans_less_add2}\ setup \add_backward_prfstep @{thm Nat.add_less_mono1}\ setup \add_backward1_prfstep @{thm Nat.add_less_mono}\ setup \add_backward1_prfstep @{thm Nat.add_le_mono}\ setup \add_backward1_prfstep @{thm add_increasing2}\ setup \add_backward1_prfstep @{thm add_mono}\ setup \add_backward_prfstep @{thm add_strict_left_mono}\ setup \add_backward1_prfstep @{thm Nat.mult_le_mono}\ (* Addition. *) theorem nat_add_eq_self_zero [forward]: "(m::nat) = m + n \ n = 0" by simp theorem nat_add_eq_self_zero' [forward]: "(m::nat) = n + m \ n = 0" by simp theorem nat_mult_2: "(a::nat) + a = 2 * a" by simp setup \add_rewrite_rule_cond @{thm nat_mult_2} [with_cond "?a \ 0"]\ theorem plus_one_non_zero [resolve]: "\(n::nat) + 1 = 0" by simp (* Diff. *) lemma nat_same_minus_ge [forward]: "(c::nat) - a \ c - b \ a \ c \ a \ b" by arith lemma diff_eq_zero [forward]: "(k::nat) \ j \ j - k = 0 \ j = k" by simp lemma diff_eq_zero' [forward]: "(k::nat) \ j \ j - k + i = j \ k = i" by simp (* Divides. *) theorem dvd_defD1 [resolve]: "(a::nat) dvd b \ \k. b = a * k" using dvdE by blast theorem dvd_defD2 [resolve]: "(a::nat) dvd b \ \k. b = k * a" by (metis dvd_mult_div_cancel mult.commute) setup \add_forward_prfstep @{thm Nat.dvd_imp_le}\ theorem dvd_ineq2 [forward]: "(k::nat) dvd n \ n > 0 \ k \ 1" by (simp add: Suc_leI dvd_pos_nat) setup \add_forward_prfstep_cond @{thm dvd_trans} (with_conds ["?a \ ?b", "?b \ ?c", "?a \ ?c"])\ setup \add_forward_prfstep_cond @{thm Nat.dvd_antisym} [with_cond "?m \ ?n"]\ theorem dvd_cancel [backward1]: "c > 0 \ (a::nat) * c dvd b * c \ a dvd b" by simp setup \add_forward_prfstep (equiv_forward_th @{thm dvd_add_right_iff})\ (* Divisibility: existence. *) setup \add_resolve_prfstep @{thm dvd_refl}\ theorem exists_n_dvd_n [backward]: "P (n::nat) \ \k. k dvd n \ P k" using dvd_refl by blast setup \add_resolve_prfstep @{thm one_dvd}\ theorem any_n_dvd_0 [forward]: "\ (\ k. k dvd (0::nat) \ P k) \ \ (\ k. P k)" by simp theorem n_dvd_one: "(n::nat) dvd 1 \ n = 1" by simp setup \add_forward_prfstep_cond @{thm n_dvd_one} [with_cond "?n \ 1"]\ (* Products. *) setup \add_rewrite_rule @{thm mult_zero_left}\ lemma prod_ineqs1 [forward]: "(m::nat) * k > 0 \ m > 0 \ k > 0" by simp lemma prod_ineqs2 [backward]: "(k::nat) > 0 \ m \ m * k" by simp theorem prod_cancel: "(a::nat) * b = a * c \ a > 0 \ b = c" by auto setup \add_forward_prfstep_cond @{thm prod_cancel} [with_cond "?b \ ?c"]\ theorem mult_n1n: "(n::nat) = m * n \ n > 0 \ m = 1" by auto setup \add_forward_prfstep_cond @{thm mult_n1n} [with_cond "?m \ 1"]\ theorem prod_is_one [forward]: "(x::nat) * y = 1 \ x = 1" by simp theorem prod_dvd_intro [backward]: "(k::nat) dvd m \ k dvd n \ k dvd m * n" using dvd_mult dvd_mult2 by blast (* Definition of gcd. *) setup \add_forward_prfstep_cond @{thm gcd_dvd1} [with_term "gcd ?a ?b"]\ setup \add_forward_prfstep_cond @{thm gcd_dvd2} [with_term "gcd ?a ?b"]\ (* Coprimality. *) setup \add_rewrite_rule_bidir @{thm coprime_iff_gcd_eq_1}\ lemma coprime_exp [backward]: "coprime d a \ coprime (d::nat) (a ^ n)" by simp setup \add_backward_prfstep @{thm coprime_exp}\ setup \add_rewrite_rule @{thm gcd.commute}\ lemma coprime_dvd_mult [backward1]: "coprime (a::nat) b \ a dvd c * b \ a dvd c" by (metis coprime_dvd_mult_left_iff) lemma coprime_dvd_mult' [backward1]: "coprime (a::nat) b \ a dvd b * c \ a dvd c" by (metis coprime_dvd_mult_right_iff) theorem coprime_dvd [forward]: "coprime (a::nat) b \ p dvd a \ p > 1 \ \ p dvd b" using coprime_common_divisor_nat by blast (* Powers. *) setup \add_rewrite_rule @{thm power_0}\ theorem power_ge_0 [rewrite]: "m \ 0 \ p ^ m = p * (p ^ (m - 1))" by (simp add: power_eq_if) setup \add_rewrite_rule_cond @{thm power_one} [with_cond "?n \ 0"]\ setup \add_rewrite_rule_cond @{thm power_one_right} [with_cond "?a \ 1"]\ setup \add_gen_prfstep ("power_case_intro", [WithTerm @{term_pat "?p ^ (?FREE::nat)"}, CreateCase @{term_pat "(?FREE::nat) = 0"}])\ lemma one_is_power_of_any [resolve]: "\i. (1::nat) = a ^ i" by (metis power.simps(1)) setup \add_rewrite_rule @{thm power_Suc}\ theorem power_dvd [forward]: "(p::nat)^n dvd a \ n \ 0 \ p dvd a" using dvd_power dvd_trans by blast theorem power_eq_one: "(b::nat) ^ n = 1 \ b = 1 \ n = 0" by (metis One_nat_def Suc_lessI nat_zero_less_power_iff power_0 power_inject_exp) setup \add_forward_prfstep_cond @{thm power_eq_one} (with_conds ["?b \ 1", "?n \ 0"])\ (* Factorial. *) theorem fact_ge_1_nat: "fact (n::nat) \ (1::nat)" by simp setup \add_forward_prfstep_cond @{thm fact_ge_1_nat} [with_term "fact ?n"]\ setup \add_backward1_prfstep @{thm dvd_fact}\ (* Successor function. *) setup \add_rewrite_rule @{thm Nat.Suc_eq_plus1}\ setup \add_backward_prfstep @{thm Nat.gr0_implies_Suc}\ (* Cases *) setup \fold add_rewrite_rule @{thms Nat.nat.case}\ (* Induction. *) lemma nat_cases: "P 0 \ (\n. P (Suc n)) \ P n" using nat_induct by auto (* div *) declare times_div_less_eq_dividend [resolve] setup \ add_var_induct_rule @{thm nat_induct} #> add_strong_induct_rule @{thm nat_less_induct} #> add_cases_rule @{thm nat_cases} \ end diff --git a/thys/Buchi_Complementation/Ranking.thy b/thys/Buchi_Complementation/Ranking.thy --- a/thys/Buchi_Complementation/Ranking.thy +++ b/thys/Buchi_Complementation/Ranking.thy @@ -1,480 +1,478 @@ section \Rankings\ theory Ranking imports "Alternate" "Graph" begin subsection \Rankings\ type_synonym 'state ranking = "'state node \ nat" definition ranking :: "('label, 'state) nba \ 'label stream \ 'state ranking \ bool" where "ranking A w f \ (\ v \ gunodes A w. f v \ 2 * card (nodes A)) \ (\ v \ gunodes A w. \ u \ gusuccessors A w v. f u \ f v) \ (\ v \ gunodes A w. gaccepting A v \ even (f v)) \ (\ v \ gunodes A w. \ r k. gurun A w r v \ smap f (gtrace r v) = sconst k \ odd k)" subsection \Ranking Implies Word not in Language\ lemma ranking_stuck: assumes "ranking A w f" assumes "v \ gunodes A w" "gurun A w r v" obtains n k where "smap f (gtrace (sdrop n r) (gtarget (stake n r) v)) = sconst k" proof - have 0: "f u \ f v" if "v \ gunodes A w" "u \ gusuccessors A w v" for v u using assms(1) that unfolding ranking_def by auto have 1: "shd (v ## gtrace r v) \ gunodes A w" using assms(2) by auto have 2: "sdescending (smap f (v ## gtrace r v))" using 1 assms(3) proof (coinduction arbitrary: r v rule: sdescending.coinduct) case sdescending obtain u s where 1: "r = u ## s" using stream.exhaust by blast have 2: "v \ gunodes A w" using sdescending(1) by simp have 3: "gurun A w (u ## s) v" using sdescending(2) 1 by auto have 4: "u \ gusuccessors A w v" using 3 by auto have 5: "u \ gureachable A w v" using graph.reachable_successors 4 by blast show ?case unfolding 1 proof (intro exI conjI disjI1) show "f u \ f v" using 0 2 4 by this show "shd (u ## gtrace s u) \ gunodes A w" using 2 5 by auto show "gurun A w s u" using 3 by auto qed auto qed obtain n k where 3: "sdrop n (smap f (v ## gtrace r v)) = sconst k" using sdescending_stuck[OF 2] by metis have "gtrace (sdrop (Suc n) r) (gtarget (stake (Suc n) r) v) = sdrop (Suc n) (gtrace r v)" using sscan_sdrop by rule also have "smap f \ = sdrop n (smap f (v ## gtrace r v))" by (auto, metis 3 id_apply sdrop_smap sdrop_stl siterate.simps(2) sscan_const stream.map stream.map_sel(2) stream.sel(2)) also have "\ = sconst k" using 3 by this finally show ?thesis using that by blast qed lemma ranking_stuck_odd: assumes "ranking A w f" assumes "v \ gunodes A w" "gurun A w r v" obtains n where "sset (smap f (gtrace (sdrop n r) (gtarget (stake n r) v))) \ Collect odd" proof - obtain n k where 1: "smap f (gtrace (sdrop n r) (gtarget (stake n r) v)) = sconst k" using ranking_stuck assms by this have 2: "gtarget (stake n r) v \ gunodes A w" using assms(2, 3) by (simp add: graph.nodes_target graph.run_stake) have 3: "gurun A w (sdrop n r) (gtarget (stake n r) v)" using assms(2, 3) by (simp add: graph.run_sdrop) have 4: "odd k" using 1 2 3 assms(1) unfolding ranking_def by meson have "sset (smap f (gtrace (sdrop n r) (gtarget (stake n r) v))) = sset (sconst k)" unfolding 1 by rule also have "\ \ Collect odd" using 4 by simp finally show ?thesis using that by simp qed lemma ranking_language: assumes "ranking A w f" shows "w \ language A" proof assume 1: "w \ language A" obtain r p where 2: "run A (w ||| r) p" "p \ initial A" "infs (accepting A) (p ## r)" using 1 by rule let ?r = "fromN 1 ||| r" let ?v = "(0, p)" have 3: "?v \ gunodes A w" "gurun A w ?r ?v" using 2(1, 2) by (auto intro: run_grun) obtain n where 4: "sset (smap f (gtrace (sdrop n ?r) (gtarget (stake n ?r) ?v))) \ {a. odd a}" using ranking_stuck_odd assms 3 by this let ?s = "stake n ?r" let ?t = "sdrop n ?r" let ?u = "gtarget ?s ?v" have "sset (gtrace ?t ?u) \ gureachable A w ?v" proof (intro graph.reachable_trace graph.reachable_target graph.reachable.reflexive) show "gupath A w ?s ?v" using graph.run_stake 3(2) by this show "gurun A w ?t ?u" using graph.run_sdrop 3(2) by this qed also have "\ \ gunodes A w" using 3(1) by blast finally have 7: "sset (gtrace ?t ?u) \ gunodes A w" by this have 8: "\ p. p \ gunodes A w \ gaccepting A p \ even (f p)" using assms unfolding ranking_def by auto have 9: "\ p. p \ sset (gtrace ?t ?u) \ gaccepting A p \ even (f p)" using 7 8 by auto have 19: "infs (accepting A) (smap snd ?r)" using 2(3) by simp have 18: "infs (gaccepting A) ?r" using 19 by simp have 17: "infs (gaccepting A) (gtrace ?r ?v)" using 18 unfolding gtrace_alt_def by this have 16: "infs (gaccepting A) (gtrace (?s @- ?t) ?v)" using 17 unfolding stake_sdrop by this have 15: "infs (gaccepting A) (gtrace ?t ?u)" using 16 by simp have 13: "infs (even \ f) (gtrace ?t ?u)" using infs_mono[OF _ 15] 9 by simp have 12: "infs even (smap f (gtrace ?t ?u))" using 13 by (simp add: comp_def) have 11: "Bex (sset (smap f (gtrace ?t ?u))) even" using 12 infs_any by metis show False using 4 11 by auto qed subsection \Word not in Language implies Ranking\ subsubsection \Removal of Endangered Nodes\ definition clean :: "('label, 'state) nba \ 'label stream \ 'state node set \ 'state node set" where "clean A w V \ {v \ V. infinite (greachable A w V v)}" lemma clean_decreasing: "clean A w V \ V" unfolding clean_def by auto lemma clean_successors: assumes "v \ V" "u \ gusuccessors A w v" shows "u \ clean A w V \ v \ clean A w V" proof - assume 1: "u \ clean A w V" have 2: "u \ V" "infinite (greachable A w V u)" using 1 unfolding clean_def by auto have 3: "u \ greachable A w V v" using graph.reachable.execute assms(2) 2(1) by blast have 4: "greachable A w V u \ greachable A w V v" using 3 by blast have 5: "infinite (greachable A w V v)" using 2(2) 4 by (simp add: infinite_super) show "v \ clean A w V" unfolding clean_def using assms(1) 5 by simp qed subsubsection \Removal of Safe Nodes\ definition prune :: "('label, 'state) nba \ 'label stream \ 'state node set \ 'state node set" where "prune A w V \ {v \ V. \ u \ greachable A w V v. gaccepting A u}" lemma prune_decreasing: "prune A w V \ V" unfolding prune_def by auto lemma prune_successors: assumes "v \ V" "u \ gusuccessors A w v" shows "u \ prune A w V \ v \ prune A w V" proof - assume 1: "u \ prune A w V" have 2: "u \ V" "\ x \ greachable A w V u. gaccepting A x" using 1 unfolding prune_def by auto have 3: "u \ greachable A w V v" using graph.reachable.execute assms(2) 2(1) by blast have 4: "greachable A w V u \ greachable A w V v" using 3 by blast show "v \ prune A w V" unfolding prune_def using assms(1) 2(2) 4 by auto qed subsubsection \Run Graph Interation\ definition graph :: "('label, 'state) nba \ 'label stream \ nat \ 'state node set" where "graph A w k \ alternate (clean A w) (prune A w) k (gunodes A w)" abbreviation "level A w k l \ {v \ graph A w k. fst v = l}" lemma graph_0[simp]: "graph A w 0 = gunodes A w" unfolding graph_def by simp lemma graph_Suc[simp]: "graph A w (Suc k) = (if even k then clean A w else prune A w) (graph A w k)" unfolding graph_def by simp lemma graph_antimono: "antimono (graph A w)" using alternate_antimono clean_decreasing prune_decreasing unfolding antimono_def le_fun_def graph_def by metis lemma graph_nodes: "graph A w k \ gunodes A w" using graph_0 graph_antimono le0 antimonoD by metis lemma graph_successors: assumes "v \ gunodes A w" "u \ gusuccessors A w v" shows "u \ graph A w k \ v \ graph A w k" using assms proof (induct k arbitrary: u v) case 0 show ?case using 0(2) by simp next case (Suc k) have 1: "v \ graph A w k" using Suc using antimono_iff_le_Suc graph_antimono rev_subsetD by blast show ?case using Suc(2) clean_successors[OF 1 Suc(4)] prune_successors[OF 1 Suc(4)] by auto qed lemma graph_level_finite: assumes "finite (nodes A)" shows "finite (level A w k l)" proof - have "level A w k l \ {v \ gunodes A w. fst v = l}" by (simp add: graph_nodes subset_CollectI) also have "{v \ gunodes A w. fst v = l} \ {l} \ nodes A" using gnodes_nodes by force also have "finite ({l} \ nodes A)" using assms(1) by simp finally show ?thesis by this qed lemma find_safe: assumes "w \ language A" assumes "V \ {}" "V \ gunodes A w" assumes "\ v. v \ V \ gsuccessors A w V v \ {}" obtains v where "v \ V" "\ u \ greachable A w V v. \ gaccepting A u" proof (rule ccontr) assume 1: "\ thesis" have 2: "\ v. v \ V \ \ u \ greachable A w V v. gaccepting A u" using that 1 by auto have 3: "\ r v. v \ initial A \ run A (w ||| r) v \ fins (accepting A) r" using assms(1) by auto obtain v where 4: "v \ V" using assms(2) by force obtain x where 5: "x \ greachable A w V v" "gaccepting A x" using 2 4 by blast obtain y where 50: "gpath A w V y v" "x = gtarget y v" using 5(1) by rule obtain r where 6: "grun A w V r x" "infs (\ x. x \ V \ gaccepting A x) r" proof (rule graph.recurring_condition) show "x \ V \ gaccepting A x" using greachable_subset 4 5 by blast next fix v assume 1: "v \ V \ gaccepting A v" obtain v' where 20: "v' \ gsuccessors A w V v" using assms(4) 1 by (meson IntE equals0I) have 21: "v' \ V" using 20 by auto have 22: "\ u \ greachable A w V v'. u \ V \ gaccepting A u" using greachable_subset 2 21 by blast obtain r where 30: "gpath A w V r v'" "gtarget r v' \ V \ gaccepting A (gtarget r v')" using 22 by blast show "\ r. r \ [] \ gpath A w V r v \ gtarget r v \ V \ gaccepting A (gtarget r v)" proof (intro exI conjI) show "v' # r \ []" by simp show "gpath A w V (v' # r) v" using 20 30 by auto show "gtarget (v' # r) v \ V" using 30 by simp show "gaccepting A (gtarget (v' # r) v)" using 30 by simp qed qed auto obtain u where 100: "u \ ginitial A" "v \ gureachable A w u" using 4 assms(3) by blast have 101: "gupath A w y v" using gpath_subset 50(1) subset_UNIV by this have 102: "gurun A w r x" using grun_subset 6(1) subset_UNIV by this obtain t where 103: "gupath A w t u" "v = gtarget t u" using 100(2) by rule have 104: "gurun A w (t @- y @- r) u" using 101 102 103 50(2) by auto obtain s q where 7: "t @- y @- r = fromN (Suc 0) ||| s" "u = (0, q)" using grun_elim[OF 104] 100(1) by blast have 8: "run A (w ||| s) q" using grun_run[OF 104[unfolded 7]] by simp have 9: "q \ initial A" using 100(1) 7(2) by auto have 91: "sset (trace (w ||| s) q) \ reachable A q" using nba.reachable_trace nba.reachable.reflexive 8 by this have 10: "fins (accepting A) s" using 3 9 8 by this have 12: "infs (gaccepting A) r" using infs_mono[OF _ 6(2)] by simp have "s = smap snd (t @- y @- r)" unfolding 7(1) by simp also have "infs (accepting A) \" using 12 by (simp add: comp_def) finally have 13: "infs (accepting A) s" by this show False using 10 13 by simp qed lemma remove_run: assumes "finite (nodes A)" "w \ language A" assumes "V \ gunodes A w" "clean A w V \ {}" obtains v r where "grun A w V r v" "sset (gtrace r v) \ clean A w V" "sset (gtrace r v) \ - prune A w (clean A w V)" proof - obtain u where 1: "u \ clean A w V" "\ x \ greachable A w (clean A w V) u. \ gaccepting A x" proof (rule find_safe) show "w \ language A" using assms(2) by this show "clean A w V \ {}" using assms(4) by this show "clean A w V \ gunodes A w" using assms(3) by (meson clean_decreasing subset_iff) next fix v assume 1: "v \ clean A w V" have 2: "v \ V" using 1 clean_decreasing by blast have 3: "infinite (greachable A w V v)" using 1 clean_def by auto have "gsuccessors A w V v \ gusuccessors A w v" by auto also have "finite \" using 2 assms(1, 3) finite_nodes_gsuccessors by blast finally have 4: "finite (gsuccessors A w V v)" by this have 5: "infinite (insert v (\((greachable A w V)  (gsuccessors A w V v))))" using graph.reachable_step 3 by metis obtain u where 6: "u \ gsuccessors A w V v" "infinite (greachable A w V u)" using 4 5 by auto have 7: "u \ clean A w V" using 6 unfolding clean_def by auto show "gsuccessors A w (clean A w V) v \ {}" using 6(1) 7 by auto qed auto have 2: "u \ V" using 1(1) unfolding clean_def by auto have 3: "infinite (greachable A w V u)" using 1(1) unfolding clean_def by simp have 4: "finite (gsuccessors A w V v)" if "v \ greachable A w V u" for v proof - have 1: "v \ V" using that greachable_subset 2 by blast have "gsuccessors A w V v \ gusuccessors A w v" by auto also have "finite \" using 1 assms(1, 3) finite_nodes_gsuccessors by blast finally show ?thesis by this qed obtain r where 5: "grun A w V r u" using graph.koenig[OF 3 4] by this have 6: "greachable A w V u \ V" using 2 greachable_subset by blast have 7: "sset (gtrace r u) \ V" using graph.reachable_trace[OF graph.reachable.reflexive 5(1)] 6 by blast have 8: "sset (gtrace r u) \ clean A w V" unfolding clean_def using 7 infinite_greachable_gtrace[OF 5(1)] by auto have 9: "sset (gtrace r u) \ greachable A w (clean A w V) u" using 5 8 by (metis graph.reachable.reflexive graph.reachable_trace grun_subset) show ?thesis proof show "grun A w V r u" using 5(1) by this show "sset (gtrace r u) \ clean A w V" using 8 by this show "sset (gtrace r u) \ - prune A w (clean A w V)" proof (intro subsetI ComplI) fix p assume 10: "p \ sset (gtrace r u)" "p \ prune A w (clean A w V)" have 20: "\ x \ greachable A w (clean A w V) p. gaccepting A x" using 10(2) unfolding prune_def by auto have 30: "greachable A w (clean A w V) p \ greachable A w (clean A w V) u" using 10(1) 9 by blast show "False" using 1(2) 20 30 by force qed qed qed lemma level_bounded: assumes "finite (nodes A)" "w \ language A" obtains n where "\ l. l \ n \ card (level A w (2 * k) l) \ card (nodes A) - k" proof (induct k arbitrary: thesis) case (0) show ?case proof (rule 0) fix l :: nat have "finite ({l} \ nodes A)" using assms(1) by simp also have "level A w 0 l \ {l} \ nodes A" using gnodes_nodes by force also (card_mono) have "card \ = card (nodes A)" using assms(1) by simp finally show "card (level A w (2 * 0) l) \ card (nodes A) - 0" by simp qed next case (Suc k) show ?case proof (cases "graph A w (Suc (2 * k)) = {}") case True have 3: "graph A w (2 * Suc k) = {}" using True prune_decreasing by simp blast show ?thesis using Suc(2) 3 by simp next case False obtain v r where 1: "grun A w (graph A w (2 * k)) r v" "sset (gtrace r v) \ graph A w (Suc (2 * k))" "sset (gtrace r v) \ - graph A w (Suc (Suc (2 * k)))" proof (rule remove_run) show "finite (nodes A)" "w \ language A" using assms by this show "clean A w (graph A w (2 * k)) \ {}" using False by simp show "graph A w (2 * k) \ gunodes A w" using graph_nodes by this qed auto obtain l q where 2: "v = (l, q)" by force obtain n where 90: "\ l. n \ l \ card (level A w (2 * k) l) \ card (nodes A) - k" using Suc(1) by blast show ?thesis proof (rule Suc(2)) fix j assume 100: "n + Suc l \ j" have 6: "graph A w (Suc (Suc (2 * k))) \ graph A w (Suc (2 * k))" using graph_antimono antimono_iff_le_Suc by blast have 101: "gtrace r v !! (j - Suc l) \ graph A w (Suc (2 * k))" using 1(2) snth_sset by auto have 102: "gtrace r v !! (j - Suc l) \ graph A w (Suc (Suc (2 * k)))" using 1(3) snth_sset by blast have 103: "gtrace r v !! (j - Suc l) \ level A w (Suc (2 * k)) j" using 1(1) 100 101 2 by (auto elim: grun_elim) have 104: "gtrace r v !! (j - Suc l) \ level A w (Suc (Suc (2 * k))) j" using 100 102 by simp have "level A w (2 * Suc k) j = level A w (Suc (Suc (2 * k))) j" by simp also have "\ \ level A w (Suc (2 * k)) j" using 103 104 6 by blast also have "\ \ level A w (2 * k) j" by (simp add: Collect_mono clean_def) finally have 105: "level A w (2 * Suc k) j \ level A w (2 * k) j" by this have "card (level A w (2 * Suc k) j) < card (level A w (2 * k) j)" using assms(1) 105 by (simp add: graph_level_finite psubset_card_mono) also have "\ \ card (nodes A) - k" using 90 100 by simp finally show "card (level A w (2 * Suc k) j) \ card (nodes A) - Suc k" by simp qed qed qed lemma graph_empty: assumes "finite (nodes A)" "w \ language A" shows "graph A w (Suc (2 * card (nodes A))) = {}" proof - obtain n where 1: "\ l. l \ n \ card (level A w (2 * card (nodes A)) l) = 0" using level_bounded[OF assms(1, 2), of "card (nodes A)"] by auto have "graph A w (2 * card (nodes A)) = (\ l \ {..< n}. level A w (2 * card (nodes A)) l) \ (\ l \ {n ..}. level A w (2 * card (nodes A)) l)" by auto also have "(\ l \ {n ..}. level A w (2 * card (nodes A)) l) = {}" using graph_level_finite assms(1) 1 by fastforce also have "finite ((\ l \ {..< n}. level A w (2 * card (nodes A)) l) \ {})" using graph_level_finite assms(1) by auto finally have 100: "finite (graph A w (2 * card (nodes A)))" by this have 101: "finite (greachable A w (graph A w (2 * card (nodes A))) v)" for v using 100 greachable_subset[of A w "graph A w (2 * card (nodes A))" v] using finite_insert infinite_super by auto show ?thesis using 101 by (simp add: clean_def) qed lemma graph_le: assumes "finite (nodes A)" "w \ language A" assumes "v \ graph A w k" shows "k \ 2 * card (nodes A)" using graph_empty graph_antimono assms by (metis (no_types, lifting) Suc_leI antimono_def basic_trans_rules(30) empty_iff not_le_imp_less) subsection \Node Ranks\ definition rank :: "('label, 'state) nba \ 'label stream \ 'state node \ nat" where "rank A w v \ GREATEST k. v \ graph A w k" lemma rank_member: assumes "finite (nodes A)" "w \ language A" "v \ gunodes A w" shows "v \ graph A w (rank A w v)" unfolding rank_def proof (rule GreatestI_nat) show "v \ graph A w 0" using assms(3) by simp - show "\k. v \ graph A w k \ k \ 2 * card (nodes A)" - using graph_le assms(1, 2) by blast + show "\ k. v \ graph A w k \ k \ 2 * card (nodes A)" using graph_le assms(1, 2) by blast qed lemma rank_removed: assumes "finite (nodes A)" "w \ language A" shows "v \ graph A w (Suc (rank A w v))" proof assume "v \ graph A w (Suc (rank A w v))" then have 2: "Suc (rank A w v) \ rank A w v" unfolding rank_def using Greatest_le_nat graph_le assms by metis then show "False" by auto qed lemma rank_le: assumes "finite (nodes A)" "w \ language A" assumes "v \ gunodes A w" "u \ gusuccessors A w v" shows "rank A w u \ rank A w v" unfolding rank_def proof (rule Greatest_le_nat) have 1: "u \ gureachable A w v" using graph.reachable_successors assms(4) by blast have 2: "u \ gunodes A w" using assms(3) 1 by auto show "v \ graph A w (GREATEST k. u \ graph A w k)" unfolding rank_def[symmetric] proof (rule graph_successors) show "v \ gunodes A w" using assms(3) by this show "u \ gusuccessors A w v" using assms(4) by this show "u \ graph A w (rank A w u)" using rank_member assms(1, 2) 2 by this qed - show "\k. v \ graph A w k \ k \ 2 * card (nodes A)" - using graph_le assms(1, 2) by blast + show "\ k. v \ graph A w k \ k \ 2 * card (nodes A)" using graph_le assms(1, 2) by blast qed lemma language_ranking: assumes "finite (nodes A)" "w \ language A" shows "ranking A w (rank A w)" unfolding ranking_def proof (intro conjI ballI allI impI) fix v assume 1: "v \ gunodes A w" have 2: "v \ graph A w (rank A w v)" using rank_member assms 1 by this show "rank A w v \ 2 * card (nodes A)" using graph_le assms 2 by this next fix v u assume 1: "v \ gunodes A w" "u \ gusuccessors A w v" show "rank A w u \ rank A w v" using rank_le assms 1 by this next fix v assume 1: "v \ gunodes A w" "gaccepting A v" have 2: "v \ graph A w (rank A w v)" using rank_member assms 1(1) by this have 3: "v \ graph A w (Suc (rank A w v))" using rank_removed assms by this have 4: "v \ prune A w (graph A w (rank A w v))" using 2 1(2) unfolding prune_def by auto have 5: "graph A w (Suc (rank A w v)) \ prune A w (graph A w (rank A w v))" using 3 4 by blast show "even (rank A w v)" using 5 by auto next fix v r k assume 1: "v \ gunodes A w" "gurun A w r v" "smap (rank A w) (gtrace r v) = sconst k" have "sset (gtrace r v) \ gureachable A w v" using 1(2) by (metis graph.reachable.reflexive graph.reachable_trace) then have 6: "sset (gtrace r v) \ gunodes A w" using 1(1) by blast have 60: "rank A w  sset (gtrace r v) \ {k}" using 1(3) by (metis equalityD1 sset_sconst stream.set_map) have 50: "sset (gtrace r v) \ graph A w k" using rank_member[OF assms] subsetD[OF 6] 60 unfolding image_subset_iff by auto have 70: "grun A w (graph A w k) r v" using grun_subset 1(2) 50 by this have 7: "sset (gtrace r v) \ clean A w (graph A w k)" unfolding clean_def using 50 infinite_greachable_gtrace[OF 70] by auto have 8: "sset (gtrace r v) \ graph A w (Suc k) = {}" using rank_removed[OF assms] 60 by blast have 9: "sset (gtrace r v) \ {}" using stream.set_sel(1) by auto have 10: "graph A w (Suc k) \ clean A w (graph A w k)" using 7 8 9 by blast show "odd k" using 10 unfolding graph_Suc by auto qed subsection \Correctness Theorem\ theorem language_ranking_iff: assumes "finite (nodes A)" shows "w \ language A \ (\ f. ranking A w f)" using ranking_language language_ranking assms by blast end diff --git a/thys/DynamicArchitectures/Configuration_Traces.thy b/thys/DynamicArchitectures/Configuration_Traces.thy --- a/thys/DynamicArchitectures/Configuration_Traces.thy +++ b/thys/DynamicArchitectures/Configuration_Traces.thy @@ -1,1803 +1,1803 @@ (* Title: Configuration_Traces.thy Author: Diego Marmsoler *) section "A Theory of Dynamic Architectures" text \ The following theory formalizes configuration traces~\cite{Marmsoler2016a,Marmsoler2016} as a model for dynamic architectures. Since configuration traces may be finite as well as infinite, the theory depends on Lochbihler's theory of co-inductive lists~\cite{Lochbihler2010}. \ theory Configuration_Traces imports Coinductive.Coinductive_List begin text \ In the following we first provide some preliminary results for natural numbers, extended natural numbers, and lazy lists. Then, we introduce a locale @text{dynamic\_architectures} which introduces basic definitions and corresponding properties for dynamic architectures. \ subsection "Natural Numbers" text \ We provide one additional property for natural numbers. \ lemma boundedGreatest: assumes "P (i::nat)" and "\n' > n. \ P n'" shows "\i'\n. P i' \ (\n'. P n' \ n'\i')" proof - have "P (i::nat) \ n\i \ \n' > n. \ P n' \ (\i'\n. P i' \ (\n'\n. P n' \ n'\i'))" proof (induction n) case 0 then show ?case by auto next case (Suc n) then show ?case proof cases assume "i = Suc n" then show ?thesis using Suc.prems by auto next assume "\(i = Suc n)" thus ?thesis proof cases assume "P (Suc n)" thus ?thesis by auto next assume "\ P (Suc n)" with Suc.prems have "\n' > n. \ P n'" using Suc_lessI by blast moreover from \\(i = Suc n)\ have "i \ n" and "P i" using Suc.prems by auto ultimately obtain i' where "i'\n \ P i' \ (\n'\n. P n' \ n' \ i')" using Suc.IH by blast hence "i' \ n" and "P i'" and "(\n'\n. P n' \ n' \ i')" by auto thus ?thesis by (metis le_SucI le_Suc_eq) qed qed qed moreover have "n\i" proof (rule ccontr) assume "\ (n \ i)" hence "n < i" by arith thus False using assms by blast qed ultimately obtain i' where "i'\n" and "P i'" and "\n'\n. P n' \ n' \ i'" using assms by blast with assms have "\n'. P n' \ n' \ i'" using not_le_imp_less by blast with \i' \ n\ and \P i'\ show ?thesis by auto qed subsection "Extended Natural Numbers" text \ We provide one simple property for the \emph{strict} order over extended natural numbers. \ lemma enat_min: assumes "m \ enat n'" and "enat n < m - enat n'" shows "enat n + enat n' < m" using assms by (metis add.commute enat.simps(3) enat_add_mono enat_add_sub_same le_iff_add) subsection "Lazy Lists" text \ In the following we provide some additional notation and properties for lazy lists. \ notation LNil ("[]\<^sub>l") notation LCons (infixl "#\<^sub>l" 60) notation lappend (infixl "@\<^sub>l" 60) lemma lnth_lappend[simp]: assumes "lfinite xs" and "\ lnull ys" shows "lnth (xs @\<^sub>l ys) (the_enat (llength xs)) = lhd ys" proof - from assms have "\k. llength xs = enat k" using lfinite_conv_llength_enat by auto then obtain k where "llength xs = enat k" by blast hence "lnth (xs @\<^sub>l ys) (the_enat (llength xs)) = lnth ys 0" using lnth_lappend2[of xs k k ys] by simp with assms show ?thesis using lnth_0_conv_lhd by simp qed lemma lfilter_ltake: assumes "\(n::nat)\llength xs. n\i \ (\ P (lnth xs n))" shows "lfilter P xs = lfilter P (ltake i xs)" proof - have "lfilter P xs = lfilter P ((ltake i xs) @\<^sub>l (ldrop i xs))" using lappend_ltake_ldrop[of "(enat i)" xs] by simp hence "lfilter P xs = (lfilter P ((ltake i) xs)) @\<^sub>l (lfilter P (ldrop i xs))" by simp show ?thesis proof cases assume "enat i \ llength xs" have "\x P (lnth (ldrop i xs) x)" proof (rule allI) fix x show "enat x < llength (ldrop (enat i) xs) \ \ P (lnth (ldrop (enat i) xs) x)" proof assume "enat x < llength (ldrop (enat i) xs)" moreover have "llength (ldrop (enat i) xs) = llength xs - enat i" using llength_ldrop[of "enat i"] by simp ultimately have "enat x < llength xs - enat i" by simp with \enat i \ llength xs\ have "enat x + enat i < llength xs" using enat_min[of i "llength xs" x] by simp moreover have "enat i + enat x = enat x + enat i" by simp ultimately have "enat i + enat x < llength xs" by arith hence "i + x < llength xs" by simp hence "lnth (ldrop i xs) x = lnth xs (x + the_enat i)" using lnth_ldrop[of "enat i" "x" xs] by simp moreover have "x + i \ i" by simp with assms \i + x < llength xs\ have "\ P (lnth xs (x + the_enat i))" by (simp add: assms(1) add.commute) ultimately show "\ P (lnth (ldrop i xs) x)" using assms by simp qed qed hence "lfilter P (ldrop i xs) = []\<^sub>l" by (metis diverge_lfilter_LNil in_lset_conv_lnth) with \lfilter P xs = (lfilter P ((ltake i) xs)) @\<^sub>l (lfilter P (ldrop i xs))\ show "lfilter P xs = lfilter P (ltake i xs)" by simp next assume "\ enat i \ llength xs" hence "enat i > llength xs" by simp hence "ldrop i xs = []\<^sub>l" by simp hence "lfilter P (ldrop i xs) = []\<^sub>l" using lfilter_LNil[of P] by arith with \lfilter P xs = (lfilter P ((ltake i) xs)) @\<^sub>l (lfilter P (ldrop i xs))\ show "lfilter P xs = lfilter P (ltake i xs)" by simp qed qed lemma lfilter_lfinite[simp]: assumes "lfinite (lfilter P t)" and "\ lfinite t" shows "\n. \n'>n. \ P (lnth t n')" proof - from assms have "finite {n. enat n < llength t \ P (lnth t n)}" using lfinite_lfilter by auto then obtain k where sset: "{n. enat n < llength t \ P (lnth t n)} \ {n. n enat n < llength t \ P (lnth t n)}" using finite_nat_bounded[of "{n. enat n < llength t \ P (lnth t n)}"] by auto show ?thesis proof (rule ccontr) assume "\(\n. \n'>n. \ P (lnth t n'))" hence "\n. \n'>n. P (lnth t n')" by simp then obtain n' where "n'>k" and "P (lnth t n')" by auto moreover from \\ lfinite t\ have "n' < llength t" by (simp add: not_lfinite_llength) ultimately have "n' \ {n. n enat n < llength t \ P (lnth t n)}" and "n'\{n. enat n < llength t \ P (lnth t n)}" by auto with sset show False by auto qed qed subsection "Specifying Dynamic Architectures" text \ In the following we formalize dynamic architectures in terms of configuration traces, i.e., sequences of architecture configurations. Moreover, we introduce definitions for operations to support the specification of configuration traces. \ typedecl cnf type_synonym trace = "nat \ cnf" consts arch:: "trace set" type_synonym cta = "trace \ nat \ bool" subsubsection "Implication" definition imp :: "cta \ cta \ cta" (infixl "\\<^sup>c" 10) where "\ \\<^sup>c \' \ \ t n. \ t n \ \' t n" declare imp_def[simp] lemma impI[intro!]: fixes t n assumes "\ t n \ \' t n" shows "(\ \\<^sup>c \') t n" using assms by simp lemma impE[elim!]: fixes t n assumes "(\ \\<^sup>c \') t n" and "\ t n" and "\' t n \ \'' t n" shows "\'' t n" using assms by simp subsubsection "Disjunction" definition disj :: "cta \ cta \ cta" (infixl "\\<^sup>c" 15) where "\ \\<^sup>c \' \ \ t n. \ t n \ \' t n" declare disj_def[simp] lemma disjI1[intro]: assumes "\ t n" shows "(\ \\<^sup>c \') t n" using assms by simp lemma disjI2[intro]: assumes "\' t n" shows "(\ \\<^sup>c \') t n" using assms by simp lemma disjE[elim!]: assumes "(\ \\<^sup>c \') t n" and "\ t n \ \'' t n" and "\' t n \ \'' t n" shows "\'' t n" using assms by auto subsubsection "Conjunction" definition conj :: "cta \ cta \ cta" (infixl "\\<^sup>c" 20) where "\ \\<^sup>c \' \ \ t n. \ t n \ \' t n" declare conj_def[simp] lemma conjI[intro!]: fixes n assumes "\ t n" and "\' t n" shows "(\ \\<^sup>c \') t n" using assms by simp lemma conjE[elim!]: fixes n assumes "(\ \\<^sup>c \') t n" and "\ t n \ \' t n \ \'' t n" shows "\'' t n" using assms by simp subsubsection "Negation" definition neg :: "cta \ cta" ("\\<^sup>c _" [19] 19) where "\\<^sup>c \ \ \ t n. \ \ t n" declare neg_def[simp] lemma negI[intro!]: assumes "\ t n \ False" shows "(\\<^sup>c$$ t n" using assms by auto lemma negE[elim!]: assumes "(\\<^sup>c \) t n" and "\ t n" shows "\' t n" using assms by simp subsubsection "Quantifiers" definition all :: "('a \ cta) \ cta" (binder "\\<^sub>c" 10) where "all P \ \t n. (\y. (P y t n))" declare all_def[simp] lemma allI[intro!]: assumes "\x. \ x t n" shows "(\\<^sub>cx. \ x) t n" using assms by simp lemma allE[elim!]: fixes n assumes "(\\<^sub>cx. \ x) t n" and "\ x t n \ \' t n" shows "\' t n" using assms by simp definition ex :: "('a \ cta) \ cta" (binder "\\<^sub>c" 10) where "ex P \ \t n. (\y. (P y t n))" declare ex_def[simp] lemma exI[intro!]: assumes "\ x t n" shows "(\\<^sub>cx. \ x) t n" using assms HOL.exI by simp lemma exE[elim!]: assumes "(\\<^sub>cx. \ x) t n" and "\x. \ x t n \ \' t n" shows "\' t n" using assms HOL.exE by auto subsubsection "Atomic Assertions" text \ First we provide rules for basic behavior assertions. \ definition ca :: "(cnf \ bool) \ cta" where "ca \ \ \ t n. \ (t n)" lemma caI[intro]: fixes n assumes "\ (t n)" shows "(ca \) t n" using assms ca_def by simp lemma caE[elim]: fixes n assumes "(ca \) t n" shows "\ (t n)" using assms ca_def by simp subsubsection "Next Operator" definition nxt :: "cta \ cta" ("\\<^sub>c(_)" 24) where "\\<^sub>c(\) \ $$t::(nat \ cnf)) n. \ t (Suc n)" subsubsection "Eventually Operator" definition evt :: "cta \ cta" ("\\<^sub>c(_)" 23) where "\\<^sub>c($$ \ $$t::(nat \ cnf)) n. \n'\n. \ t n'" subsubsection "Globally Operator" definition glob :: "cta \ cta" ("\\<^sub>c(_)" 22) where "\\<^sub>c($$ \ $$t::(nat \ cnf)) n. \n'\n. \ t n'" lemma globI[intro!]: fixes n' assumes "\n\n'. \ t n" shows "(\\<^sub>c($$) t n'" using assms glob_def by simp lemma globE[elim!]: fixes n n' assumes "(\\<^sub>c(\)) t n" and "n'\n" shows "\ t n'" using assms glob_def by simp subsubsection "Until Operator" definition until :: "cta \ cta \ cta" (infixl "\\<^sub>c" 21) where "\' \\<^sub>c \ \ $$t::(nat \ cnf)) n. \n''\n. \ t n'' \ (\n'\n. n' < n'' \ \' t n')" lemma untilI[intro]: fixes n assumes "\n''\n. \ t n'' \ (\n'\n. n' \' t n')" shows "(\' \\<^sub>c$$ t n" using assms until_def by simp lemma untilE[elim]: fixes n assumes "(\' \\<^sub>c \) t n" shows "\n''\n. \ t n'' \ (\n'\n. n' \' t n')" using assms until_def by simp subsubsection "Weak Until" definition wuntil :: "cta \ cta \ cta" (infixl "\\<^sub>c" 20) where "\' \\<^sub>c \ \ \' \\<^sub>c \ \\<^sup>c \\<^sub>c(\')" lemma wUntilI[intro]: fixes n assumes "(\n''\n. \ t n'' \ (\n'\n. n' \' t n')) \ (\n'\n. \' t n')" shows "(\' \\<^sub>c \) t n" using assms wuntil_def by auto lemma wUntilE[elim]: fixes n n' assumes "(\' \\<^sub>c \) t n" shows "(\n''\n. \ t n'' \ (\n'\n. n' \' t n')) \ (\n'\n. \' t n')" proof - from assms have "(\' \\<^sub>c \ \\<^sup>c \\<^sub>c(\')) t n" using wuntil_def by simp hence "(\' \\<^sub>c \) t n \ (\\<^sub>c(\')) t n" by simp thus ?thesis proof assume "(\' \\<^sub>c \) t n" hence "\n''\n. \ t n'' \ (\n'\n. n' < n'' \ \' t n')" by auto thus ?thesis by auto next assume "(\\<^sub>c\') t n" hence "\n'\n. \' t n'" by auto thus ?thesis by auto qed qed lemma wUntil_Glob: assumes "(\' \\<^sub>c \) t n" and "(\\<^sub>c(\' \\<^sup>c \'')) t n" shows "(\'' \\<^sub>c \) t n" proof from assms(1) have "(\n''\n. \ t n'' \ (\n'\n. n' < n'' \ \' t n')) \ (\n'\n. \' t n')" using wUntilE by simp thus "(\n''\n. \ t n'' \ (\n'\n. n' < n'' \ \'' t n')) \ (\n'\n. \'' t n')" proof assume "\n''\n. \ t n'' \ (\n'\n. n' < n'' \ \' t n')" show "(\n''\n. \ t n'' \ (\n'\n. n' < n'' \ \'' t n')) \ (\n'\n. \'' t n')" proof - from \\n''\n. \ t n'' \ (\n'\n. n' < n'' \ \' t n')\ obtain n'' where "n''\n" and "\ t n''" and a1: "\n'\n. n' < n'' \ \' t n'" by auto moreover have "\n'\n. n' < n'' \ \'' t n'" proof fix n' show "n'\n \ n'< n'' \ \'' t n'" proof (rule HOL.impI[OF HOL.impI]) assume "n'\n" and "n'' \\<^sup>c \'') t n'" using globE by simp hence "\' t n' \ \'' t n'" using impE by auto moreover from a1 \n'\n\ \n' have "\' t n'" by simp ultimately show "\'' t n'" by simp qed qed ultimately show ?thesis by auto qed next assume a1: "\n'\n. \' t n'" have "\n'\n. \'' t n'" proof fix n' show "n'\n \ \'' t n'" proof assume "n'\n" with assms(2) have "(\' \\<^sup>c \'') t n'" using globE by simp hence "\' t n' \ \'' t n'" using impE by auto moreover from a1 \n'\n\ have "\' t n'" by simp ultimately show "\'' t n'" by simp qed qed thus "(\n''\n. \ t n'' \ (\n'\n. n' < n'' \ \'' t n')) \ (\n'\n. \'' t n')" by simp qed qed subsection "Dynamic Components" text \ To support the specification of patterns over dynamic architectures we provide a locale for dynamic components. It takes the following type parameters: \begin{itemize} \item id: a type for component identifiers \item cmp: a type for components \item cnf: a type for architecture configurations \end{itemize} \ locale dynamic_component = fixes tCMP :: "'id \ cnf \ 'cmp" ("\\<^bsub>_\<^esub>(_)" [0,110]60) and active :: "'id \ cnf \ bool" ("\_\\<^bsub>_\<^esub>" [0,110]60) begin text \ The locale requires two parameters: \begin{itemize} \item @{term tCMP} is an operator to obtain a component with a certain identifier from an architecture configuration. \item @{term active} is a predicate to assert whether a certain component is activated within an architecture configuration. \end{itemize} \ text \ The locale provides some general properties about its parameters and introduces six important operators over configuration traces: \begin{itemize} \item An operator to extract the behavior of a certain component out of a given configuration trace. \item An operator to obtain the number of activations of a certain component within a given configuration trace. \item An operator to obtain the least point in time (before a certain point in time) from which on a certain component is not activated anymore. \item An operator to obtain the latest point in time where a certain component was activated. \item Two operators to map time-points between configuration traces and behavior traces. \end{itemize} Moreover, the locale provides several properties about the operators and their relationships. \ lemma nact_active: fixes t::"nat \ cnf" and n::nat and n'' and id assumes "\id\\<^bsub>t n\<^esub>" and "n'' \ n" and "\ (\n'\n. n' < n'' \ \id\\<^bsub>t n'\<^esub>)" shows "n=n''" using assms le_eq_less_or_eq by auto lemma nact_exists: fixes t::"nat \ cnf" assumes "\i\n. \c\\<^bsub>t i\<^esub>" shows "\i\n. \c\\<^bsub>t i\<^esub> \ (\k. n\k \ k \c\\<^bsub>t k\<^esub>)" proof - let ?L = "LEAST i. (i\n \ \c\\<^bsub>t i\<^esub>)" from assms have "?L\n \ \c\\<^bsub>t ?L\<^esub>" using LeastI[of "\x::nat. (x\n \ \c\\<^bsub>t x\<^esub>)"] by auto moreover have "\k. n\k \ k \c\\<^bsub>t k\<^esub>" using not_less_Least by auto ultimately show ?thesis by blast qed lemma lActive_least: assumes "\i\n. i < llength t \ \c\\<^bsub>lnth t i\<^esub>" shows "\i\n. (i < llength t \ \c\\<^bsub>lnth t i\<^esub> \ (\k. n\k \ k k \c\\<^bsub>lnth t k\<^esub>))" proof - let ?L = "LEAST i. (i\n \ i < llength t \ \c\\<^bsub>lnth t i\<^esub>)" from assms have "?L\n \ ?L < llength t \ \c\\<^bsub>lnth t ?L\<^esub>" using LeastI[of "\x::nat.(x\n \ x \c\\<^bsub>lnth t x\<^esub>)"] by auto moreover have "\k. n\k \ k k \c\\<^bsub>lnth t k\<^esub>" using not_less_Least by auto ultimately show ?thesis by blast qed subsection "Projection" text \ In the following we introduce an operator which extracts the behavior of a certain component out of a given configuration trace. \ definition proj:: "'id \ (cnf llist) \ ('cmp llist)" ("\\<^bsub>_\<^esub>(_)" [0,110]60) where "proj c = lmap (\cnf. (\\<^bsub>c\<^esub>(cnf))) \ (lfilter (active c))" lemma proj_lnil [simp,intro]: "\\<^bsub>c\<^esub>([]\<^sub>l) = []\<^sub>l" using proj_def by simp lemma proj_lnull [simp]: "\\<^bsub>c\<^esub>(t) = []\<^sub>l \ (\k \ lset t. \ \c\\<^bsub>k\<^esub>)" proof assume "\\<^bsub>c\<^esub>(t) = []\<^sub>l" hence "lfilter (active c) t = []\<^sub>l" using proj_def lmap_eq_LNil by auto thus "\k \ lset t. \ \c\\<^bsub>k\<^esub>" using lfilter_eq_LNil[of "active c"] by simp next assume "\k\lset t. \ \c\\<^bsub>k\<^esub>" hence "lfilter (active c) t = []\<^sub>l" by simp thus "\\<^bsub>c\<^esub>(t) = []\<^sub>l" using proj_def by simp qed lemma proj_LCons [simp]: "\\<^bsub>i\<^esub>(x #\<^sub>l xs) = (if \i\\<^bsub>x\<^esub> then (\\<^bsub>i\<^esub>(x)) #\<^sub>l (\\<^bsub>i\<^esub>(xs)) else \\<^bsub>i\<^esub>(xs))" using proj_def by simp lemma proj_llength[simp]: "llength (\\<^bsub>c\<^esub>(t)) \ llength t" using llength_lfilter_ile proj_def by simp lemma proj_ltake: assumes "$$n'::nat)\llength t. n'\n \ (\ \c\\<^bsub>lnth t n'\<^esub>)" shows "\\<^bsub>c\<^esub>(t) = \\<^bsub>c\<^esub>(ltake n t)" using lfilter_ltake proj_def assms by (metis comp_apply) lemma proj_finite_bound: assumes "lfinite (\\<^bsub>c\<^esub>(inf_llist t))" shows "\n. \n'>n. \ \c\\<^bsub>t n'\<^esub>" using assms lfilter_lfinite[of "active c" "inf_llist t"] proj_def by simp subsubsection "Monotonicity and Continuity" lemma proj_mcont: shows "mcont lSup lprefix lSup lprefix (proj c)" proof - have "mcont lSup lprefix lSup lprefix (\x. lmap (\cnf. \\<^bsub>c\<^esub>(cnf)) (lfilter (active c) x))" by simp moreover have "(\x. lmap (\cnf. \\<^bsub>c\<^esub>(cnf)) (lfilter (active c) x)) = lmap (\cnf. \\<^bsub>c\<^esub>(cnf)) \ lfilter (active c)" by auto ultimately show ?thesis using proj_def by simp qed lemma proj_mcont2mcont: assumes "mcont lub ord lSup lprefix f" shows "mcont lub ord lSup lprefix (\x. \\<^bsub>c\<^esub>(f x))" proof - have "mcont lSup lprefix lSup lprefix (proj c)" using proj_mcont by simp with assms show ?thesis using llist.mcont2mcont[of lSup lprefix "proj c"] by simp qed lemma proj_mono_prefix[simp]: assumes "lprefix t t'" shows "lprefix (\\<^bsub>c\<^esub>(t)) (\\<^bsub>c\<^esub>(t'))" proof - from assms have "lprefix (lfilter (active c) t) (lfilter (active c) t')" using lprefix_lfilterI by simp hence "lprefix (lmap (\cnf. \\<^bsub>c\<^esub>(cnf)) (lfilter (active c) t)) (lmap (\cnf. \\<^bsub>c\<^esub>(cnf)) (lfilter (active c) t'))" using lmap_lprefix by simp thus ?thesis using proj_def by simp qed subsubsection "Finiteness" lemma proj_finite[simp]: assumes "lfinite t" shows "lfinite (\\<^bsub>c\<^esub>(t))" using assms proj_def by simp lemma proj_finite2: assumes "\(n'::nat)\llength t. n'\n \ (\ \c\\<^bsub>lnth t n'\<^esub>)" shows "lfinite (\\<^bsub>c\<^esub>(t))" using assms proj_ltake proj_finite by simp lemma proj_append_lfinite[simp]: fixes t t' assumes "lfinite t" shows "\\<^bsub>c\<^esub>(t @\<^sub>l t') = (\\<^bsub>c\<^esub>(t)) @\<^sub>l (\\<^bsub>c\<^esub>(t'))" (is "?lhs=?rhs") proof - have "?lhs = (lmap (\cnf. \\<^bsub>c\<^esub>(cnf)) \ (lfilter (active c))) (t @\<^sub>l t')" using proj_def by simp also have "\ = lmap (\cnf. \\<^bsub>c\<^esub>(cnf)) (lfilter (active c) (t @\<^sub>l t'))" by simp also from assms have "\ = lmap (\cnf. \\<^bsub>c\<^esub>(cnf)) ((lfilter (active c) t) @\<^sub>l (lfilter (active c) t'))" by simp also have "\ = (@\<^sub>l) (lmap (\cnf. \\<^bsub>c\<^esub>(cnf)) (lfilter (active c) t)) (lmap (\cnf. \\<^bsub>c\<^esub>(cnf)) (lfilter (active c) t'))" using lmap_lappend_distrib by simp also have "\ = ?rhs" using proj_def by simp finally show ?thesis . qed lemma proj_one: assumes "\i. i < llength t \ \c\\<^bsub>lnth t i\<^esub>" shows "llength (\\<^bsub>c\<^esub>(t)) \ 1" proof - from assms have "\x\lset t. \c\\<^bsub>x\<^esub>" using lset_conv_lnth by force hence "\ lfilter (\k. \c\\<^bsub>k\<^esub>) t = []\<^sub>l" using lfilter_eq_LNil[of "(\k. \c\\<^bsub>k\<^esub>)"] by blast hence "\ \\<^bsub>c\<^esub>(t) = []\<^sub>l" using proj_def by fastforce thus ?thesis by (simp add: ileI1 lnull_def one_eSuc) qed subsubsection "Projection not Active" lemma proj_not_active[simp]: assumes "enat n < llength t" and "\ \c\\<^bsub>lnth t n\<^esub>" shows "\\<^bsub>c\<^esub>(ltake (Suc n) t) = \\<^bsub>c\<^esub>(ltake n t)" (is "?lhs = ?rhs") proof - from assms have "ltake (enat (Suc n)) t = (ltake (enat n) t) @\<^sub>l ((lnth t n) #\<^sub>l []\<^sub>l)" using ltake_Suc_conv_snoc_lnth by blast hence "?lhs = \\<^bsub>c\<^esub>((ltake (enat n) t) @\<^sub>l ((lnth t n) #\<^sub>l []\<^sub>l))" by simp moreover have "\ = (\\<^bsub>c\<^esub>(ltake (enat n) t)) @\<^sub>l (\\<^bsub>c\<^esub>((lnth t n) #\<^sub>l []\<^sub>l))" by simp moreover from assms have "\\<^bsub>c\<^esub>((lnth t n) #\<^sub>l []\<^sub>l) = []\<^sub>l" by simp ultimately show ?thesis by simp qed lemma proj_not_active_same: assumes "enat n \ (n'::enat)" and "\ lfinite t \ n'-1 < llength t" and "\k. k\n \ k k < llength t \ \c\\<^bsub>lnth t k\<^esub>" shows "\\<^bsub>c\<^esub>(ltake n' t) = \\<^bsub>c\<^esub>(ltake n t)" proof - have "\\<^bsub>c\<^esub>(ltake (n + (n' - n)) t) = \\<^bsub>c\<^esub>((ltake n t) @\<^sub>l (ltake (n'-n) (ldrop n t)))" by (simp add: ltake_plus_conv_lappend) hence "\\<^bsub>c\<^esub>(ltake (n + (n' - n)) t) = (\\<^bsub>c\<^esub>(ltake n t)) @\<^sub>l (\\<^bsub>c\<^esub>(ltake (n'-n) (ldrop n t)))" by simp moreover have "\\<^bsub>c\<^esub>(ltake (n'-n) (ldrop n t)) = []\<^sub>l" proof - have "\k\{lnth (ltake (n' - enat n) (ldrop (enat n) t)) na | na. enat na < llength (ltake (n' - enat n) (ldrop (enat n) t))}. \ \c\\<^bsub>k\<^esub>" proof fix k assume "k\{lnth (ltake (n' - enat n) (ldrop (enat n) t)) na | na. enat na < llength (ltake (n' - enat n) (ldrop (enat n) t))}" then obtain k' where "enat k' < llength (ltake (n' - enat n) (ldrop (enat n) t))" and "k=lnth (ltake (n' - enat n) (ldrop (enat n) t)) k'" by auto have "enat (k' + n) < llength t" proof - from \enat k' < llength (ltake (n' - enat n) (ldrop (enat n) t))\ have "enat k' < n'-n" by simp hence "enat k' + n < n'" using assms(1) enat_min by auto show ?thesis proof cases assume "lfinite t" with \\ lfinite t \ n'-1 < llength t\ have "n'-1 llength t" using eSuc_ile_mono ileI1 by blast with \enat k' + n < n'\ show ?thesis by (simp add: add.commute) next assume "\ lfinite t" hence "llength t = \" using not_lfinite_llength by auto thus ?thesis by simp qed qed moreover have "k = lnth t (k' + n)" proof - from \enat k' < llength (ltake (n' - enat n) (ldrop (enat n) t))\ have "enat k'enat (k' + n) < llength t\ show ?thesis using lnth_ldrop[of n k' t ] using \k = lnth (ltake (n' - enat n) (ldrop (enat n) t)) k'\ by (simp add: add.commute) qed moreover from \enat n \ (n'::enat)\ have "k' + the_enat n\n" by auto moreover from \enat k' < llength (ltake (n' - enat n) (ldrop (enat n) t))\ have "k' + n \c\\<^bsub>k\<^esub>" using \\k. k\n \ k k < llength t \ \c\\<^bsub>lnth t k\<^esub>\ by simp qed hence "\k\lset (ltake (n'-n) (ldrop n t)). \ \c\\<^bsub>k\<^esub>" using lset_conv_lnth[of "(ltake (n' - enat n) (ldrop (enat n) t))"] by simp thus ?thesis using proj_lnull by auto qed moreover from assms have "n + (n' - n) = n'" by (meson enat.distinct(1) enat_add_sub_same enat_diff_cancel_left enat_le_plus_same(1) less_imp_le) ultimately show ?thesis by simp qed subsubsection "Projection Active" lemma proj_active[simp]: assumes "enat i < llength t" "\c\\<^bsub>lnth t i\<^esub>" shows "\\<^bsub>c\<^esub>(ltake (Suc i) t) = (\\<^bsub>c\<^esub>(ltake i t)) @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l []\<^sub>l)" (is "?lhs = ?rhs") proof - from assms have "ltake (enat (Suc i)) t = (ltake (enat i) t) @\<^sub>l ((lnth t i) #\<^sub>l []\<^sub>l)" using ltake_Suc_conv_snoc_lnth by blast hence "?lhs = \\<^bsub>c\<^esub>((ltake (enat i) t) @\<^sub>l ((lnth t i) #\<^sub>l []\<^sub>l))" by simp moreover have "\ = (\\<^bsub>c\<^esub>(ltake (enat i) t)) @\<^sub>l (\\<^bsub>c\<^esub>((lnth t i) #\<^sub>l []\<^sub>l))" by simp moreover from assms have "\\<^bsub>c\<^esub>((lnth t i) #\<^sub>l []\<^sub>l) = (\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l []\<^sub>l" by simp ultimately show ?thesis by simp qed lemma proj_active_append: assumes a1: "(n::nat) \ i" and a2: "enat i < (n'::enat)" and a3: "\ lfinite t \ n'-1 < llength t" and a4: "\c\\<^bsub>lnth t i\<^esub>" and "\i'. (n \ i' \ enat i' i' < llength t \ \c\\<^bsub>lnth t i'\<^esub>) \ (i' = i)" shows "\\<^bsub>c\<^esub>(ltake n' t) = (\\<^bsub>c\<^esub>(ltake n t)) @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l []\<^sub>l)" (is "?lhs = ?rhs") proof - have "?lhs = \\<^bsub>c\<^esub>(ltake (Suc i) t)" proof - from a2 have "Suc i \ n'" by (simp add: Suc_ile_eq) moreover from a3 have "\ lfinite t \ n'-1 < llength t" by simp moreover have "\k. enat k\enat (Suc i) \ k k < llength t \ \c\\<^bsub>lnth t k\<^esub>" proof assume "\k. enat k\enat (Suc i) \ k k < llength t \ \c\\<^bsub>lnth t k\<^esub>" then obtain k where "enat k\enat (Suc i)" and "kc\\<^bsub>lnth t k\<^esub>" by blast moreover from \enat k\enat (Suc i)\ have "enat k\n" using assms by (meson dual_order.trans enat_ord_simps(1) le_SucI) ultimately have "enat k=enat i" using assms using enat_ord_simps(1) by blast with \enat k\enat (Suc i)\ show False by simp qed ultimately show ?thesis using proj_not_active_same[of "Suc i" n' t c] by simp qed also have "\ = (\\<^bsub>c\<^esub>(ltake i t)) @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l []\<^sub>l)" proof - have "i < llength t" proof cases assume "lfinite t" with a3 have "n'-1 < llength t" by simp hence "n' \ llength t" by (metis eSuc_minus_1 enat_minus_mono1 ileI1 not_le) with a2 show "enat i < llength t" by simp next assume "\ lfinite t" thus ?thesis by (metis enat_ord_code(4) llength_eq_infty_conv_lfinite) qed with a4 show ?thesis by simp qed also have "\ = ?rhs" proof - from a1 have "enat n \ enat i" by simp moreover from a2 a3 have "\ lfinite t \ enat i-1 < llength t" using enat_minus_mono1 less_imp_le order.strict_trans1 by blast moreover have "\k. k\n \ enat k enat k < llength t \ \c\\<^bsub>lnth t k\<^esub>" proof assume "\k. k\n \ enat k enat k < llength t \ \c\\<^bsub>lnth t k\<^esub>" then obtain k where "k\n" and "enat kc\\<^bsub>lnth t k\<^esub>" by blast moreover from \enat k have "enat kenat k show False by simp qed ultimately show ?thesis using proj_not_active_same[of n i t c] by simp qed finally show ?thesis by simp qed subsubsection "Same and not Same" lemma proj_same_not_active: assumes "n \ n'" and "enat (n'-1) < llength t" and "\\<^bsub>c\<^esub>(ltake n' t) = \\<^bsub>c\<^esub>(ltake n t)" shows "\k. k\n \ k \c\\<^bsub>lnth t k\<^esub>" proof assume "\k. k\n \ k \c\\<^bsub>lnth t k\<^esub>" then obtain i where "i\n" and "ic\\<^bsub>lnth t i\<^esub>" by blast moreover from \enat (n'-1) and \i have "i\<^bsub>c\<^esub>(ltake (Suc i) t) = (\\<^bsub>c\<^esub>(ltake i t)) @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l []\<^sub>l)" by simp moreover from \i have "Suc i \ n'" by simp hence "lprefix(\\<^bsub>c\<^esub>(ltake (Suc i) t)) (\\<^bsub>c\<^esub>(ltake n' t))" by simp then obtain "tl" where "\\<^bsub>c\<^esub>(ltake n' t) = (\\<^bsub>c\<^esub>(ltake (Suc i) t)) @\<^sub>l tl" using lprefix_conv_lappend by auto moreover from \n\i\ have "lprefix(\\<^bsub>c\<^esub>(ltake n t)) (\\<^bsub>c\<^esub>(ltake i t))" by simp hence "lprefix(\\<^bsub>c\<^esub>(ltake n t)) (\\<^bsub>c\<^esub>(ltake i t))" by simp then obtain "hd" where "\\<^bsub>c\<^esub>(ltake i t) = (\\<^bsub>c\<^esub>(ltake n t)) @\<^sub>l hd" using lprefix_conv_lappend by auto ultimately have "\\<^bsub>c\<^esub>(ltake n' t) = (((\\<^bsub>c\<^esub>(ltake n t)) @\<^sub>l hd) @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l []\<^sub>l)) @\<^sub>l tl" by simp also have "\ = ((\\<^bsub>c\<^esub>(ltake n t)) @\<^sub>l hd) @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l tl)" using lappend_snocL1_conv_LCons2[of "(\\<^bsub>c\<^esub>(ltake n t)) @\<^sub>l hd" "\\<^bsub>c\<^esub>(lnth t i)"] by simp also have "\ = (\\<^bsub>c\<^esub>(ltake n t)) @\<^sub>l (hd @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l tl))" using lappend_assoc by auto also have "\\<^bsub>c\<^esub>(ltake n' t) = (\\<^bsub>c\<^esub>(ltake n' t)) @\<^sub>l []\<^sub>l" by simp finally have "(\\<^bsub>c\<^esub>(ltake n' t)) @\<^sub>l []\<^sub>l = (\\<^bsub>c\<^esub>(ltake n t)) @\<^sub>l (hd @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l tl))" . moreover from assms(3) have "llength (\\<^bsub>c\<^esub>(ltake n' t)) = llength (\\<^bsub>c\<^esub>(ltake n t))" by simp ultimately have "lfinite (\\<^bsub>c\<^esub>(ltake n' t)) \ []\<^sub>l = hd @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l tl)" using assms(3) lappend_eq_lappend_conv[of "\\<^bsub>c\<^esub>(ltake n' t)" "\\<^bsub>c\<^esub>(ltake n t)" "[]\<^sub>l"] by simp moreover have "lfinite (\\<^bsub>c\<^esub>(ltake n' t))" by simp ultimately have "[]\<^sub>l = hd @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l tl)" by simp hence "(\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l tl = []\<^sub>l" using LNil_eq_lappend_iff by auto thus False by simp qed lemma proj_not_same_active: assumes "enat n \ (n'::enat)" and "(\ lfinite t) \ n'-1 < llength t" and "\(\\<^bsub>c\<^esub>(ltake n' t) = \\<^bsub>c\<^esub>(ltake n t))" shows "\k. k\n \ k enat k < llength t \ \c\\<^bsub>lnth t k\<^esub>" proof (rule ccontr) assume "\(\k. k\n \ k enat k < llength t \ \c\\<^bsub>lnth t k\<^esub>)" have "\\<^bsub>c\<^esub>(ltake n' t) = \\<^bsub>c\<^esub>(ltake (enat n) t)" proof cases assume "lfinite t" hence "llength t\\" by (simp add: lfinite_llength_enat) hence "enat (the_enat (llength t)) = llength t" by auto with assms \\ (\k\n. k < n' \ enat k < llength t \ \c\\<^bsub>lnth t k\<^esub>)\ show ?thesis using proj_not_active_same[of n n' t c] by simp next assume "\ lfinite t" with assms \\ (\k\n. k < n' \ enat k < llength t \ \c\\<^bsub>lnth t k\<^esub>)\ show ?thesis using proj_not_active_same[of n n' t c] by simp qed with assms show False by simp qed subsection "Activations" text \ We also introduce an operator to obtain the number of activations of a certain component within a given configuration trace. \ definition nAct :: "'id \ enat \ (cnf llist) \ enat" ("\_ #\<^bsub>_\<^esub>_\") where "\c #\<^bsub>n\<^esub> t\ \ llength (\\<^bsub>c\<^esub>(ltake n t))" lemma nAct_0[simp]: "\c #\<^bsub>0\<^esub> t\ = 0" by (simp add: nAct_def) lemma nAct_NIL[simp]: "\c #\<^bsub>n\<^esub> []\<^sub>l\ = 0" by (simp add: nAct_def) lemma nAct_Null: assumes "llength t \ n" and "\c #\<^bsub>n\<^esub> t\ = 0" shows "\i \c\\<^bsub>lnth t i\<^esub>" proof - from assms have "lnull (\\<^bsub>c\<^esub>(ltake n t))" using nAct_def lnull_def by simp hence "\\<^bsub>c\<^esub>(ltake n t) = []\<^sub>l" using lnull_def by blast hence "(\k\lset (ltake n t). \ \c\\<^bsub>k\<^esub>)" by simp show ?thesis proof (rule ccontr) assume "\ (\i \c\\<^bsub>lnth t i\<^esub>)" then obtain i where "ic\\<^bsub>lnth t i\<^esub>" by blast moreover have "enat i < llength (ltake n t) \ lnth (ltake n t) i = (lnth t i)" proof from \llength t \ n\ have "n = min n (llength t)" using min.orderE by auto hence "llength (ltake n t) = n" by simp with \i show "enat i < llength (ltake n t)" by auto from \i show "lnth (ltake n t) i = (lnth t i)" using lnth_ltake by auto qed hence "(lnth t i \ lset (ltake n t))" using in_lset_conv_lnth[of "lnth t i" "ltake n t"] by blast ultimately show False using \(\k\lset (ltake n t). \ \c\\<^bsub>k\<^esub>)\ by simp qed qed lemma nAct_ge_one[simp]: assumes "llength t \ n" and "i < n" and "\c\\<^bsub>lnth t i\<^esub>" shows "\c #\<^bsub>n\<^esub> t\ \ enat 1" proof (rule ccontr) assume "\ (\c #\<^bsub>n\<^esub> t\ \ enat 1)" hence "\c #\<^bsub>n\<^esub> t\ < enat 1" by simp hence "\c #\<^bsub>n\<^esub> t\ < 1" using enat_1 by simp hence "\c #\<^bsub>n\<^esub> t\ = 0" using Suc_ile_eq \\ enat 1 \ \c #\<^bsub>n\<^esub> t\\ zero_enat_def by auto with \llength t \ n\ have "\i \c\\<^bsub>lnth t i\<^esub>" using nAct_Null by simp with assms show False by simp qed lemma nAct_finite[simp]: assumes "n \ \" shows "\n'. \c #\<^bsub>n\<^esub> t\ = enat n'" proof - from assms have "lfinite (ltake n t)" by simp hence "lfinite (\\<^bsub>c\<^esub>(ltake n t))" by simp hence "\n'. llength (\\<^bsub>c\<^esub>(ltake n t)) = enat n'" using lfinite_llength_enat[of "\\<^bsub>c\<^esub>(ltake n t)"] by simp thus ?thesis using nAct_def by simp qed lemma nAct_enat_the_nat[simp]: assumes "n \ \" shows "enat (the_enat (\c #\<^bsub>n\<^esub> t$$) = \c #\<^bsub>n\<^esub> t\" proof - from assms have "\c #\<^bsub>n\<^esub> t\ \ \" by simp thus ?thesis using enat_the_enat by simp qed subsubsection "Monotonicity and Continuity" lemma nAct_mcont: shows "mcont lSup lprefix Sup (\) (nAct c n)" proof - have "mcont lSup lprefix lSup lprefix (ltake n)" by simp hence "mcont lSup lprefix lSup lprefix (\t. \\<^bsub>c\<^esub>(ltake n t))" using proj_mcont2mcont[of lSup lprefix "(ltake n)"] by simp hence "mcont lSup lprefix Sup (\) (\t. llength (\\<^bsub>c\<^esub>(ltake n t)))" by simp moreover have "nAct c n = (\t. llength (\\<^bsub>c\<^esub>(ltake n t)))" using nAct_def by auto ultimately show ?thesis by simp qed lemma nAct_mono: assumes "n \ n'" shows "\c #\<^bsub>n\<^esub> t\ \ \c #\<^bsub>n'\<^esub> t\" proof - from assms have "lprefix (ltake n t) (ltake n' t)" by simp hence "lprefix (\\<^bsub>c\<^esub>(ltake n t)) (\\<^bsub>c\<^esub>(ltake n' t))" by simp hence "llength (\\<^bsub>c\<^esub>(ltake n t)) \ llength (\\<^bsub>c\<^esub>(ltake n' t))" using lprefix_llength_le[of "(\\<^bsub>c\<^esub>(ltake n t))"] by simp thus ?thesis using nAct_def by simp qed lemma nAct_strict_mono_back: assumes "\c #\<^bsub>n\<^esub> t\ < \c #\<^bsub>n'\<^esub> t\" shows "n < n'" proof (rule ccontr) assume "\ nn'" by simp hence "\c #\<^bsub>n\<^esub> t\ \ \c #\<^bsub>n'\<^esub> t\" using nAct_mono by simp thus False using assms by simp qed subsubsection "Not Active" lemma nAct_not_active[simp]: fixes n::nat and n'::nat and t::"(cnf llist)" and c::'id assumes "enat i < llength t" and "\ \c\\<^bsub>lnth t i\<^esub>" shows "\c #\<^bsub>Suc i\<^esub> t\ = \c #\<^bsub>i\<^esub> t\" proof - from assms have "\\<^bsub>c\<^esub>(ltake (Suc i) t) = \\<^bsub>c\<^esub>(ltake i t)" by simp hence "llength (\\<^bsub>c\<^esub>(ltake (enat (Suc i)) t)) = llength (\\<^bsub>c\<^esub>(ltake i t))" by simp moreover have "llength (\\<^bsub>c\<^esub>(ltake i t)) \ \" using llength_eq_infty_conv_lfinite[of "\\<^bsub>c\<^esub>(ltake (enat i) t)"] by simp ultimately have "llength (\\<^bsub>c\<^esub>(ltake (Suc i) t)) = llength (\\<^bsub>c\<^esub>(ltake i t))" using the_enat_eSuc by simp with nAct_def show ?thesis by simp qed lemma nAct_not_active_same: assumes "enat n \ (n'::enat)" and "n'-1 < llength t" and "\k. enat k\n \ k \c\\<^bsub>lnth t k\<^esub>" shows "\c #\<^bsub>n'\<^esub> t\ = \c #\<^bsub>n\<^esub> t\" using assms proj_not_active_same nAct_def by simp subsubsection "Active" lemma nAct_active[simp]: fixes n::nat and n'::nat and t::"(cnf llist)" and c::'id assumes "enat i < llength t" and "\c\\<^bsub>lnth t i\<^esub>" shows "\c #\<^bsub>Suc i\<^esub> t\ = eSuc (\c #\<^bsub>i\<^esub> t\)" proof - from assms have "\\<^bsub>c\<^esub>(ltake (Suc i) t) = (\\<^bsub>c\<^esub>(ltake i t)) @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l []\<^sub>l)" by simp hence "llength (\\<^bsub>c\<^esub>(ltake (enat (Suc i)) t)) = eSuc (llength (\\<^bsub>c\<^esub>(ltake i t)))" using plus_1_eSuc one_eSuc by simp moreover have "llength (\\<^bsub>c\<^esub>(ltake i t)) \ \" using llength_eq_infty_conv_lfinite[of "\\<^bsub>c\<^esub>(ltake (enat i) t)"] by simp ultimately have "llength (\\<^bsub>c\<^esub>(ltake (Suc i) t)) = eSuc (llength (\\<^bsub>c\<^esub>(ltake i t)))" using the_enat_eSuc by simp with nAct_def show ?thesis by simp qed lemma nAct_active_suc: fixes n::nat and n'::enat and t::"(cnf llist)" and c::'id assumes "\ lfinite t \ n'-1 < llength t" and "n \ i" and "enat i < n'" and "\c\\<^bsub>lnth t i\<^esub>" and "\i'. (n \ i' \ enat i' i' < llength t \ \c\\<^bsub>lnth t i'\<^esub>) \ (i' = i)" shows "\c #\<^bsub>n'\<^esub> t\ = eSuc (\c #\<^bsub>n\<^esub> t\)" proof - from assms have "\\<^bsub>c\<^esub>(ltake n' t) = (\\<^bsub>c\<^esub>(ltake (enat n) t)) @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l []\<^sub>l)" using proj_active_append[of n i n' t c] by blast moreover have "llength ((\\<^bsub>c\<^esub>(ltake (enat n) t)) @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l []\<^sub>l)) = eSuc (llength (\\<^bsub>c\<^esub>(ltake (enat n) t)))" using one_eSuc eSuc_plus_1 by simp ultimately show ?thesis using nAct_def by simp qed lemma nAct_less: assumes "enat k < llength t" and "n \ k" and "k < (n'::enat)" and "\c\\<^bsub>lnth t k\<^esub>" shows "\c #\<^bsub>n\<^esub> t\ < \c #\<^bsub>n'\<^esub> t\" proof - have "\c #\<^bsub>k\<^esub> t\ \ \" by simp then obtain en where en_def: "\c #\<^bsub>k\<^esub> t\ = enat en" by blast moreover have "eSuc (enat en) \ \c #\<^bsub>n'\<^esub> t\" proof - from assms have "Suc k \ n'" using Suc_ile_eq by simp hence "\c #\<^bsub>Suc k\<^esub> t\ \ \c #\<^bsub>n'\<^esub> t\" using nAct_mono by simp moreover from assms have "\c #\<^bsub>Suc k\<^esub> t\ = eSuc (\c #\<^bsub>k\<^esub> t\)" by simp ultimately have "eSuc (\c #\<^bsub>k\<^esub> t\) \ \c #\<^bsub>n'\<^esub> t\" by simp thus ?thesis using en_def by simp qed moreover have "enat en < eSuc (enat en)" by simp ultimately have "enat en < \c #\<^bsub>n'\<^esub> t\" using less_le_trans[of "enat en" "eSuc (enat en)"] by simp moreover have "\c #\<^bsub>n\<^esub> t\ \ enat en" proof - from assms have "\c #\<^bsub>n\<^esub> t\ \ \c #\<^bsub>k\<^esub> t\" using nAct_mono by simp thus ?thesis using en_def by simp qed ultimately show ?thesis using le_less_trans[of "\c #\<^bsub>n\<^esub> t\"] by simp qed lemma nAct_less_active: assumes "n' - 1 < llength t" and "\c #\<^bsub>enat n\<^esub> t\ < \c #\<^bsub>n'\<^esub> t\" shows "\i\n. i \c\\<^bsub>lnth t i\<^esub>" proof (rule ccontr) assume "\ (\i\n. i \c\\<^bsub>lnth t i\<^esub>)" moreover have "enat n \ n'" using assms(2) less_imp_le nAct_strict_mono_back by blast ultimately have "\c #\<^bsub>n\<^esub> t\ = \c #\<^bsub>n'\<^esub> t\" using \n' - 1 < llength t\ nAct_not_active_same by simp thus False using assms by simp qed subsubsection "Same and Not Same" lemma nAct_same_not_active: assumes "\c #\<^bsub>n'\<^esub> inf_llist t\ = \c #\<^bsub>n\<^esub> inf_llist t\" shows "\k\n. k \ \c\\<^bsub>t k\<^esub>" proof (rule ccontr) assume "$$\k\n. k \ \c\\<^bsub>t k\<^esub>)" then obtain k where "k\n" and "kc\\<^bsub>t k\<^esub>" by blast hence "\c #\<^bsub>Suc k\<^esub> inf_llist t\ = eSuc (\c #\<^bsub>k\<^esub> inf_llist t$$" by simp moreover have "\c #\<^bsub>k\<^esub> inf_llist t\\\" by simp ultimately have "\c #\<^bsub>k\<^esub> inf_llist t\ < \c #\<^bsub>Suc k\<^esub> inf_llist t\" by fastforce moreover from \n\k\ have "\c #\<^bsub>n\<^esub> inf_llist t\ \ \c #\<^bsub>k\<^esub> inf_llist t\" using nAct_mono by simp moreover from \k have "Suc k \ n'" by (simp add: Suc_ile_eq) hence "\c #\<^bsub>Suc k\<^esub> inf_llist t\ \ \c #\<^bsub>n'\<^esub> inf_llist t\" using nAct_mono by simp ultimately show False using assms by simp qed lemma nAct_not_same_active: assumes "\c #\<^bsub>enat n\<^esub> t\ < \c #\<^bsub>n'\<^esub> t\" and "\ lfinite t \ n' - 1 < llength t" shows "$$i::nat)\n. enat i< n' \ i \c\\<^bsub>lnth t i\<^esub>" proof - from assms have "llength(\\<^bsub>c\<^esub>(ltake n t)) < llength (\\<^bsub>c\<^esub>(ltake n' t))" using nAct_def by simp hence "\\<^bsub>c\<^esub>(ltake n' t) \ \\<^bsub>c\<^esub>(ltake n t)" by auto moreover from assms have "enat n < n'" using nAct_strict_mono_back[of c "enat n" t n'] by simp ultimately show ?thesis using proj_not_same_active[of n n' t c] assms by simp qed lemma nAct_less_llength_active: assumes "x < llength (\\<^bsub>c\<^esub>(t))" and "enat x = \c #\<^bsub>enat n'\<^esub> t\" shows "\(i::nat)\n'. i \c\\<^bsub>lnth t i\<^esub>" proof - have "llength(\\<^bsub>c\<^esub>(ltake n' t)) < llength (\\<^bsub>c\<^esub>(t))" using assms(1) assms(2) nAct_def by auto hence "llength(\\<^bsub>c\<^esub>(ltake n' t)) < llength (\\<^bsub>c\<^esub>(ltake (llength t) t))" by (simp add: ltake_all) hence "\c #\<^bsub>enat n'\<^esub> t\ < \c #\<^bsub>llength t\<^esub> t\" using nAct_def by simp moreover have "\ lfinite t \ llength t - 1 < llength t" proof (rule Meson.imp_to_disjD[OF HOL.impI]) assume "lfinite t" hence "llength t \ \" by (simp add: llength_eq_infty_conv_lfinite) moreover have "llength t>0" proof - from \x < llength (\\<^bsub>c\<^esub>(t))\ have "llength (\\<^bsub>c\<^esub>(t))>0" by auto thus ?thesis using proj_llength Orderings.order_class.order.strict_trans2 by blast qed ultimately show "llength t - 1 < llength t" by (metis One_nat_def \lfinite t\ diff_Suc_less enat_ord_simps(2) idiff_enat_enat lfinite_conv_llength_enat one_enat_def zero_enat_def) qed ultimately show ?thesis using nAct_not_same_active[of c n' t "llength t"] by simp qed lemma nAct_exists: assumes "x < llength (\\<^bsub>c\<^esub>(t))" shows "\(n'::nat). enat x = \c #\<^bsub>n'\<^esub> t\" proof - have "x < llength (\\<^bsub>c\<^esub>(t)) \ (\(n'::nat). enat x = \c #\<^bsub>n'\<^esub> t$$" proof (induction x) case 0 thus ?case by (metis nAct_0 zero_enat_def) next case (Suc x) show ?case proof assume "Suc x < llength (\\<^bsub>c\<^esub>(t))" hence "x < llength (\\<^bsub>c\<^esub>(t))" using Suc_ile_eq less_imp_le by auto with Suc.IH obtain n' where "enat x = \c #\<^bsub>enat n'\<^esub> t\" by blast with \x < llength (\\<^bsub>c\<^esub>(t))\ have "\i\n'. i < llength t \ \c\\<^bsub>lnth t i\<^esub>" using nAct_less_llength_active[of x c t n'] by simp then obtain i where "i\n'" and "ic\\<^bsub>lnth t i\<^esub>" and "\k. n'\k \ k k \c\\<^bsub>lnth t k\<^esub>" using lActive_least[of n' t c] by auto moreover from \i have "\ lfinite t \ enat (Suc i) - 1 < llength t" by (simp add: one_enat_def) moreover have "enat i < enat (Suc i)" by simp moreover have "\i'. (n' \ i' \ enat i' i' \c\\<^bsub>lnth t i'\<^esub>) \ (i' = i)" proof (rule HOL.impI[THEN HOL.allI]) fix i' assume "n' \ i' \ enat i' i' \c\\<^bsub>lnth t i'\<^esub>" with \\k. n'\k \ k k \c\\<^bsub>lnth t k\<^esub>\ show "i'=i" by fastforce qed ultimately have "\c #\<^bsub>Suc i\<^esub> t\ = eSuc (\c #\<^bsub>n'\<^esub> t\)" using nAct_active_suc[of t "Suc i" n' i c] by simp with \enat x = \c #\<^bsub>enat n'\<^esub> t\\ have "\c #\<^bsub>Suc i\<^esub> t\ = eSuc (enat x)" by simp thus "\n'. enat (Suc x) = \c #\<^bsub>enat n'\<^esub> t\" by (metis eSuc_enat) qed qed with assms show ?thesis by simp qed subsection "Projection and Activation" text \ In the following we provide some properties about the relationship between the projection and activations operator. \ lemma nAct_le_proj: "\c #\<^bsub>n\<^esub> t\ \ llength (\\<^bsub>c\<^esub>(t))" proof - from nAct_def have "\c #\<^bsub>n\<^esub> t\ = llength (\\<^bsub>c\<^esub>(ltake n t))" by simp moreover have "llength (\\<^bsub>c\<^esub>(ltake n t)) \ llength (\\<^bsub>c\<^esub>(t))" proof - have "lprefix (ltake n t) t" by simp hence "lprefix (\\<^bsub>c\<^esub>(ltake n t)) (\\<^bsub>c\<^esub>(t))" by simp hence "llength (\\<^bsub>c\<^esub>(ltake n t)) \ llength (\\<^bsub>c\<^esub>(t))" using lprefix_llength_le by blast thus ?thesis by auto qed thus ?thesis using nAct_def by simp qed lemma proj_nAct: assumes "(enat n < llength t)" shows "\\<^bsub>c\<^esub>(ltake n t) = ltake (\c #\<^bsub>n\<^esub> t\) (\\<^bsub>c\<^esub>(t))" (is "?lhs = ?rhs") proof - have "?lhs = ltake (llength (\\<^bsub>c\<^esub>(ltake n t))) (\\<^bsub>c\<^esub>(ltake n t))" using ltake_all[of "\\<^bsub>c\<^esub>(ltake n t)" "llength (\\<^bsub>c\<^esub>(ltake n t))"] by simp also have "\ = ltake (llength (\\<^bsub>c\<^esub>(ltake n t))) ((\\<^bsub>c\<^esub>(ltake n t)) @\<^sub>l (\\<^bsub>c\<^esub>(ldrop n t)))" using ltake_lappend1[of "llength (\\<^bsub>c\<^esub>(ltake (enat n) t))" "\\<^bsub>c\<^esub>(ltake n t)" "(\\<^bsub>c\<^esub>(ldrop n t))"] by simp also have "\ = ltake (\c #\<^bsub>n\<^esub> t\) ((\\<^bsub>c\<^esub>(ltake n t)) @\<^sub>l (\\<^bsub>c\<^esub>(ldrop n t)))" using nAct_def by simp also have "\ = ltake (\c #\<^bsub>n\<^esub> t\) (\\<^bsub>c\<^esub>((ltake (enat n) t) @\<^sub>l (ldrop n t)))" by simp also have "\ = ltake (\c #\<^bsub>n\<^esub> t\) (\\<^bsub>c\<^esub>(t))" using lappend_ltake_ldrop[of n t] by simp finally show ?thesis by simp qed lemma proj_active_nth: assumes "enat (Suc i) < llength t" "\c\\<^bsub>lnth t i\<^esub>" shows "lnth (\\<^bsub>c\<^esub>(t)) (the_enat (\c #\<^bsub>i\<^esub> t\)) = \\<^bsub>c\<^esub>(lnth t i)" proof - from assms have "enat i < llength t" using Suc_ile_eq[of i "llength t"] by auto with assms have "\\<^bsub>c\<^esub>(ltake (Suc i) t) = (\\<^bsub>c\<^esub>(ltake i t)) @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l []\<^sub>l)" by simp moreover have "lnth ((\\<^bsub>c\<^esub>(ltake i t)) @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l []\<^sub>l)) (the_enat (llength (\\<^bsub>c\<^esub>(ltake i t)))) = \\<^bsub>c\<^esub>(lnth t i)" proof - have "\ lnull ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l []\<^sub>l)" by simp moreover have "lfinite (\\<^bsub>c\<^esub>(ltake i t))" by simp ultimately have "lnth ((\\<^bsub>c\<^esub>(ltake i t)) @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l []\<^sub>l)) (the_enat (llength (\\<^bsub>c\<^esub>(ltake i t)))) = lhd ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l []\<^sub>l)" by simp also have "\ = \\<^bsub>c\<^esub>(lnth t i)" by simp finally show "lnth ((\\<^bsub>c\<^esub>(ltake i t)) @\<^sub>l ((\\<^bsub>c\<^esub>(lnth t i)) #\<^sub>l []\<^sub>l)) (the_enat (llength (\\<^bsub>c\<^esub>(ltake i t)))) = \\<^bsub>c\<^esub>(lnth t i)" by simp qed ultimately have "\\<^bsub>c\<^esub>(lnth t i) = lnth (\\<^bsub>c\<^esub>(ltake (Suc i) t)) (the_enat (llength (\\<^bsub>c\<^esub>(ltake i t))))" by simp also have "\ = lnth (\\<^bsub>c\<^esub>(ltake (Suc i) t)) (the_enat (\c #\<^bsub>i\<^esub> t\))" using nAct_def by simp also have "\ = lnth (ltake (\c #\<^bsub>Suc i\<^esub> t\) (\\<^bsub>c\<^esub>(t))) (the_enat (\c #\<^bsub>i\<^esub> t\))" using proj_nAct[of "Suc i" t c] assms by simp also have "\ = lnth (\\<^bsub>c\<^esub>(t)) (the_enat (\c #\<^bsub>i\<^esub> t\))" proof - from assms have "\c #\<^bsub>Suc i\<^esub> t\ = eSuc (\c #\<^bsub>i\<^esub> t\)" using \enat i < llength t\ by simp moreover have "\c #\<^bsub>i\<^esub> t\ < eSuc (\c #\<^bsub>i\<^esub> t\)" using iless_Suc_eq[of "the_enat (\c #\<^bsub>enat i\<^esub> t\)"] by simp ultimately have "\c #\<^bsub>i\<^esub> t\ < (\c #\<^bsub>Suc i\<^esub> t\)" by simp hence "enat (the_enat (\c #\<^bsub>Suc i\<^esub> t\)) > enat (the_enat (\c #\<^bsub>i\<^esub> t\))" by simp thus ?thesis using lnth_ltake[of "the_enat (\c #\<^bsub>i\<^esub> t\)" "the_enat (\c #\<^bsub>enat (Suc i)\<^esub> t\)" "\\<^bsub>c\<^esub>(t)"] by simp qed finally show ?thesis .. qed lemma nAct_eq_proj: assumes "$$\i\n. \c\\<^bsub>lnth t i\<^esub>)" shows "\c #\<^bsub>n\<^esub> t\ = llength (\\<^bsub>c\<^esub>(t))" (is "?lhs = ?rhs") proof - from nAct_def have "?lhs = llength (\\<^bsub>c\<^esub>(ltake n t))" by simp moreover from assms have "\(n'::nat)\llength t. n'\n \ (\ \c\\<^bsub>lnth t n'\<^esub>)" by simp hence "\\<^bsub>c\<^esub>(t) = \\<^bsub>c\<^esub>(ltake n t)" using proj_ltake by simp ultimately show ?thesis by simp qed lemma nAct_llength_proj: assumes "\i\n. \c\\<^bsub>t i\<^esub>" shows "llength (\\<^bsub>c\<^esub>(inf_llist t)) \ eSuc (\c #\<^bsub>n\<^esub> inf_llist t$$" proof - from \\i\n. \c\\<^bsub>t i\<^esub>\ obtain i where "i\n" and "\c\\<^bsub>t i\<^esub>" and "\ (\k\n. k < i \ k < llength (inf_llist t) \ \c\\<^bsub>t k\<^esub>)" using lActive_least[of n "inf_llist t" c] by auto moreover have "llength (\\<^bsub>c\<^esub>(inf_llist t)) \ \c #\<^bsub>Suc i\<^esub> inf_llist t\" using nAct_le_proj by simp moreover have "eSuc (\c #\<^bsub>n\<^esub> inf_llist t\) = \c #\<^bsub>Suc i\<^esub> inf_llist t\" proof - have "enat (Suc i) < llength (inf_llist t)" by simp moreover have "i < Suc i" by simp moreover from \\ (\k\n. k < i \ k < llength (inf_llist t) \ \c\\<^bsub>t k\<^esub>)\ have "\i'. n \ i' \ i' < Suc i \ \c\\<^bsub>lnth (inf_llist t) i'\<^esub> \ i' = i" by fastforce ultimately show ?thesis using nAct_active_suc \i\n\ \\c\\<^bsub>t i\<^esub>\ by simp qed ultimately show ?thesis by simp qed subsection "Least not Active" text \ In the following, we introduce an operator to obtain the least point in time before a certain point in time where a component was deactivated. \ definition lNAct :: "'id \ (nat \ cnf) \ nat \ nat" ("\_ \ _\\<^bsub>_\<^esub>") where "\c \ t\\<^bsub>n\<^esub> \ (LEAST n'. n=n' \ (n' (\k. k\n' \ k \c\\<^bsub>t k\<^esub>)))" lemma lNact0[simp]: "\c \ t\\<^bsub>0\<^esub> = 0" by (simp add: lNAct_def) lemma lNact_least: assumes "n=n' \ n' (\k. k\n' \ k \c\\<^bsub>t k\<^esub>)" shows "\c \ t\\<^bsub>n\<^esub> \ n'" using Least_le[of "\n'. n=n' \ (n' (\k. k\n' \ k \c\\<^bsub>t k\<^esub>))" n'] lNAct_def using assms by auto lemma lNAct_ex: "\c \ t\\<^bsub>n\<^esub>=n \ \c \ t\\<^bsub>n\<^esub> (\k. k\\c \ t\\<^bsub>n\<^esub> \ k \c\\<^bsub>t k\<^esub>)" proof - let ?P="\n'. n=n' \ n' (\k. k\n' \ k \c\\<^bsub>t k\<^esub>)" from lNAct_def have "\c \ t\\<^bsub>n\<^esub> = (LEAST n'. ?P n')" by simp moreover have "?P n" by simp with LeastI have "?P (LEAST n'. ?P n')" . ultimately show ?thesis by auto qed lemma lNact_notActive: fixes c t n k assumes "k\\c \ t\\<^bsub>n\<^esub>" and "k\c\\<^bsub>t k\<^esub>" by (metis assms lNAct_ex leD) lemma lNactGe: fixes c t n n' assumes "n' \ \c \ t\\<^bsub>n\<^esub>" and "\c\\<^bsub>t n'\<^esub>" shows "n' \ n" using assms lNact_notActive leI by blast lemma lNactLe[simp]: fixes n n' shows "\c \ t\\<^bsub>n\<^esub> \ n" using lNAct_ex less_or_eq_imp_le by blast lemma lNactLe_nact: fixes n n' assumes "n'=n \ (n' (\k. k\n' \ k \c\\<^bsub>t k\<^esub>))" shows "\c \ t\\<^bsub>n\<^esub> \ n'" using assms lNAct_def Least_le[of "\n'. n=n' \ (n' (\k. k\n' \ k \c\\<^bsub>t k\<^esub>))"] by auto lemma lNact_active: fixes cid t n assumes "\kcid\\<^bsub>t k\<^esub>" shows "\cid \ t\\<^bsub>n\<^esub> = n" using assms lNAct_ex by blast lemma nAct_mono_back: fixes c t and n and n' assumes "\c #\<^bsub>n'\<^esub> inf_llist t\ \ \c #\<^bsub>n\<^esub> inf_llist t\" shows "n'\\c \ t\\<^bsub>n\<^esub>" proof cases assume "\c #\<^bsub>n'\<^esub> inf_llist t\ = \c #\<^bsub>n\<^esub> inf_llist t\" thus ?thesis proof cases assume "n'\n" thus ?thesis using lNactLe by (metis HOL.no_atp(11)) next assume "\ n'\n" hence "n'\c #\<^bsub>n'\<^esub> inf_llist t\ = \c #\<^bsub>n\<^esub> inf_llist t\\ have "\k. k\n' \ k \c\\<^bsub>t k\<^esub>" by (metis enat_ord_simps(1) enat_ord_simps(2) nAct_same_not_active) thus ?thesis using lNactLe_nact by (simp add: \n' < n\) qed next assume "\\c #\<^bsub>n'\<^esub> inf_llist t\ = \c #\<^bsub>n\<^esub> inf_llist t\" with assms have "\c #\<^bsub>enat n'\<^esub> inf_llist t\ > \c #\<^bsub>enat n\<^esub> inf_llist t\" by simp hence "n' > n" using nAct_strict_mono_back[of c "enat n" "inf_llist t" "enat n'"] by simp thus ?thesis by (meson dual_order.strict_implies_order lNactLe le_trans) qed lemma nAct_mono_lNact: assumes "\c \ t\\<^bsub>n\<^esub> \ n'" shows "\c #\<^bsub>n\<^esub> inf_llist t\ \ \c #\<^bsub>n'\<^esub> inf_llist t\" proof - have "\k. k\\c \ t\\<^bsub>n\<^esub> \ k \c\\<^bsub>t k\<^esub>" using lNact_notActive by auto moreover have "enat n - 1 < llength (inf_llist t)" by (simp add: one_enat_def) moreover from \\c \ t\\<^bsub>n\<^esub> \ n'\ have "enat \c \ t\\<^bsub>n\<^esub> \ enat n" by simp ultimately have "\c #\<^bsub>n\<^esub> inf_llist t\=\c #\<^bsub>\c \ t\\<^bsub>n\<^esub>\<^esub> inf_llist t\" using nAct_not_active_same by simp thus ?thesis using nAct_mono assms by simp qed subsection "Next Active" text \ In the following, we introduce an operator to obtain the next point in time when a component is activated. \ definition nxtAct :: "'id \ (nat \ cnf) \ nat \ nat" ("\_ \ _\\<^bsub>_\<^esub>") where "\c \ t\\<^bsub>n\<^esub> \ (THE n'. n'\n \ \c\\<^bsub>t n'\<^esub> \ (\k. k\n \ k \c\\<^bsub>t k\<^esub>))" lemma nxtActI: fixes n::nat and t::"nat \ cnf" and c::'id assumes "\i\n. \c\\<^bsub>t i\<^esub>" shows "\c \ t\\<^bsub>n\<^esub> \ n \ \c\\<^bsub>t \c \ t\\<^bsub>n\<^esub>\<^esub> \ (\k. k\n \ k<\c \ t\\<^bsub>n\<^esub> \ \c\\<^bsub>t k\<^esub>)" proof - let ?P = "THE n'. n'\n \ \c\\<^bsub>t n'\<^esub> \ (\k. k\n \ k \c\\<^bsub>t k\<^esub>)" from assms obtain i where "i\n \ \c\\<^bsub>t i\<^esub> \ (\k. k\n \ k \c\\<^bsub>t k\<^esub>)" using lActive_least[of n "inf_llist t" c] by auto moreover have "(\x. n \ x \ \c\\<^bsub>t x\<^esub> \ \ (\k\n. k < x \ \c\\<^bsub>t k\<^esub>) \ x = i)" proof - fix x assume "n \ x \ \c\\<^bsub>t x\<^esub> \ \ (\k\n. k < x \ \c\\<^bsub>t k\<^esub>)" show "x = i" proof (rule ccontr) assume "\ (x = i)" thus False using \i\n \ \c\\<^bsub>t i\<^esub> \ (\k. k\n \ k \c\\<^bsub>t k\<^esub>)\ \n \ x \ \c\\<^bsub>t x\<^esub> \ \ (\k\n. k < x \ \c\\<^bsub>t k\<^esub>)\ by fastforce qed qed ultimately have "(?P) \ n \ \c\\<^bsub>t (?P)\<^esub> \ (\k. k\n \ k \c\\<^bsub>t k\<^esub>)" using theI[of "\n'. n'\n \ \c\\<^bsub>t n'\<^esub> \ (\k. k\n \ k \c\\<^bsub>t k\<^esub>)"] by blast thus ?thesis using nxtAct_def[of c t n] by metis qed lemma nxtActLe: fixes n n' assumes "\i\n. \c\\<^bsub>t i\<^esub>" shows "n \ \c \ t\\<^bsub>n\<^esub>" by (simp add: assms nxtActI) lemma nxtAct_eq: assumes "n'\n" and "\c\\<^bsub>t n'\<^esub>" and "\n''\n. n'' \ \c\\<^bsub>t n''\<^esub>" shows "n' = \c \ t\\<^bsub>n\<^esub>" by (metis assms(1) assms(2) assms(3) nxtActI linorder_neqE_nat nxtActLe) lemma nxtAct_active: fixes i::nat and t::"nat \ cnf" and c::'id assumes "\c\\<^bsub>t i\<^esub>" shows "\c \ t\\<^bsub>i\<^esub> = i" by (metis assms le_eq_less_or_eq nxtActI) lemma nxtActive_no_active: assumes "\!i. i\n \ \c\\<^bsub>t i\<^esub>" shows "\ (\i'\Suc \c \ t\\<^bsub>n\<^esub>. \c\\<^bsub>t i'\<^esub>)" proof assume "\i'\Suc \c \ t\\<^bsub>n\<^esub>. \c\\<^bsub>t i'\<^esub>" then obtain i' where "i'\Suc \c \ t\\<^bsub>n\<^esub>" and "\c\\<^bsub>t i'\<^esub>" by auto moreover from assms(1) have "\c \ t\\<^bsub>n\<^esub>\n" using nxtActI by auto ultimately have "i'\n" and "\c\\<^bsub>t i'\<^esub>" and "i'\\c \ t\\<^bsub>n\<^esub>" by auto moreover from assms(1) have "\c\\<^bsub>t \c \ t\\<^bsub>n\<^esub>\<^esub>" and "\c \ t\\<^bsub>n\<^esub>\n" using nxtActI by auto ultimately show False using assms(1) by auto qed lemma nxt_geq_lNact[simp]: assumes "\i\n. \c\\<^bsub>t i\<^esub>" shows "\c \ t\\<^bsub>n\<^esub>\\c \ t\\<^bsub>n\<^esub>" proof - from assms have "n \ \c \ t\\<^bsub>n\<^esub>" using nxtActLe by simp moreover have "\c \ t\\<^bsub>n\<^esub>\n" by simp ultimately show ?thesis by arith qed lemma active_geq_nxtAct: assumes "\c\\<^bsub>t i\<^esub>" and "the_enat (\c #\<^bsub>i\<^esub> inf_llist t\)\the_enat (\c #\<^bsub>n\<^esub> inf_llist t\)" shows "i\\c \ t\\<^bsub>n\<^esub>" proof cases assume "\c #\<^bsub>i\<^esub> inf_llist t\=\c #\<^bsub>n\<^esub> inf_llist t\" show ?thesis proof (rule ccontr) assume "\ i\\c \ t\\<^bsub>n\<^esub>" hence "i<\c \ t\\<^bsub>n\<^esub>" by simp with \\c #\<^bsub>i\<^esub> inf_llist t\=\c #\<^bsub>n\<^esub> inf_llist t\\ have "\ (\k\i. k < n \ \c\\<^bsub>t k\<^esub>)" by (metis enat_ord_simps(1) leD leI nAct_same_not_active) moreover have "\ (\k\n. k <\c \ t\\<^bsub>n\<^esub> \ \c\\<^bsub>t k\<^esub>)" using nxtActI by blast ultimately have "\ (\k\i. k <\c \ t\\<^bsub>n\<^esub> \ \c\\<^bsub>t k\<^esub>)" by auto with \i<\c \ t\\<^bsub>n\<^esub>\ show False using \\c\\<^bsub>t i\<^esub>\ by simp qed next assume "\\c #\<^bsub>i\<^esub> inf_llist t\=\c #\<^bsub>n\<^esub> inf_llist t\" moreover from \the_enat (\c #\<^bsub>i\<^esub> inf_llist t\)\the_enat (\c #\<^bsub>n\<^esub> inf_llist t\)\ have "\c #\<^bsub>i\<^esub> inf_llist t\\\c #\<^bsub>n\<^esub> inf_llist t\" by (metis enat.distinct(2) enat_ord_simps(1) nAct_enat_the_nat) ultimately have "\c #\<^bsub>i\<^esub> inf_llist t\>\c #\<^bsub>n\<^esub> inf_llist t\" by simp hence "i>n" using nAct_strict_mono_back[of c n "inf_llist t" i] by simp with \\c\\<^bsub>t i\<^esub>\ show ?thesis by (meson dual_order.strict_implies_order leI nxtActI) qed lemma nAct_same: assumes "\c \ t\\<^bsub>n\<^esub> \ n'" and "n' \ \c \ t\\<^bsub>n\<^esub>" shows "the_enat (\c #\<^bsub>enat n'\<^esub> inf_llist t\) = the_enat (\c #\<^bsub>enat n\<^esub> inf_llist t\)" proof cases assume "n \ n'" moreover have "n' - 1 < llength (inf_llist t)" by simp moreover have "\ (\i\n. i \c\\<^bsub>t i\<^esub>)" by (meson assms(2) less_le_trans nxtActI) ultimately show ?thesis using nAct_not_active_same by (simp add: one_enat_def) next assume "\ n \ n'" hence "n' < n" by simp moreover have "n - 1 < llength (inf_llist t)" by simp moreover have "\ (\i\n'. i < n \ \c\\<^bsub>t i\<^esub>)" by (metis \\ n \ n'\ assms(1) dual_order.trans lNAct_ex) ultimately show ?thesis using nAct_not_active_same[of n' n] by (simp add: one_enat_def) qed lemma nAct_mono_nxtAct: assumes "\i\n. \c\\<^bsub>t i\<^esub>" and "\c \ t\\<^bsub>n\<^esub> \ n'" shows "\c #\<^bsub>n\<^esub> inf_llist t\ \ \c #\<^bsub>n'\<^esub> inf_llist t\" proof - from assms have "\c #\<^bsub>\c \ t\\<^bsub>n\<^esub>\<^esub> inf_llist t\ \ \c #\<^bsub>n'\<^esub> inf_llist t\" using nAct_mono assms by simp moreover have "\c #\<^bsub>\c \ t\\<^bsub>n\<^esub>\<^esub> inf_llist t\=\c #\<^bsub>n\<^esub> inf_llist t\" proof - from assms have "\k. k\n \ k<\c \ t\\<^bsub>n\<^esub> \ \c\\<^bsub>t k\<^esub>" and "n \ \c \ t\\<^bsub>n\<^esub>" using nxtActI by auto moreover have "enat \c \ t\\<^bsub>n\<^esub> - 1 < llength (inf_llist t)" by (simp add: one_enat_def) ultimately show ?thesis using nAct_not_active_same[of n "\c \ t\\<^bsub>n\<^esub>"] by auto qed ultimately show ?thesis by simp qed subsection "Latest Activation" text \ In the following, we introduce an operator to obtain the latest point in time when a component is activated. \ abbreviation latestAct_cond:: "'id \ trace \ nat \ nat \ bool" where "latestAct_cond c t n n' \ n' \c\\<^bsub>t n'\<^esub>" definition latestAct:: "'id \ trace \ nat \ nat" ("\_ \ _\\<^bsub>_\<^esub>") where "latestAct c t n = (GREATEST n'. latestAct_cond c t n n')" lemma latestActEx: assumes "\n'nid\\<^bsub>t n'\<^esub>" shows "\n'. latestAct_cond nid t n n' \ (\n''. latestAct_cond nid t n n'' \ n'' \ n')" proof - from assms obtain n' where "latestAct_cond nid t n n'" by auto moreover have "\n''>n. \ latestAct_cond nid t n n''" by simp ultimately obtain n' where "latestAct_cond nid t n n' \ (\n''. latestAct_cond nid t n n'' \ n'' \ n')" using boundedGreatest[of "latestAct_cond nid t n" n'] by blast thus ?thesis .. qed lemma latestAct_prop: assumes "\n'nid\\<^bsub>t n'\<^esub>" shows "\nid\\<^bsub>t (latestAct nid t n)\<^esub>" and "latestAct nid t nnid\\<^bsub>t \nid \ t\\<^bsub>n\<^esub>\<^esub>" and "latestAct nid t n \nid \ t\\<^bsub>n\<^esub>" proof - from assms latestActEx have "n' \ (GREATEST x. latestAct_cond nid t n x)" using Greatest_le_nat[of "latestAct_cond nid t n"] by blast thus ?thesis using latestAct_def by auto qed lemma latestActNxt: assumes "\n'nid\\<^bsub>t n'\<^esub>" shows "\nid \ t\\<^bsub>\nid \ t\\<^bsub>n\<^esub>\<^esub>=\nid \ t\\<^bsub>n\<^esub>" using assms latestAct_prop(1) nxtAct_active by auto lemma latestActNxtAct: assumes "\n'\n. \tid\\<^bsub>t n'\<^esub>" and "\n'tid\\<^bsub>t n'\<^esub>" shows "\tid \ t\\<^bsub>n\<^esub> > \tid \ t\\<^bsub>n\<^esub>" by (meson assms latestAct_prop(2) less_le_trans nxtActI zero_le) lemma latestActless: assumes "\n'\n\<^sub>s. n' \nid\\<^bsub>t n'\<^esub>" shows "\nid \ t\\<^bsub>n\<^esub>\n\<^sub>s" by (meson assms dual_order.trans latestAct_less) lemma latestActEq: fixes nid::'id assumes "\nid\\<^bsub>t n'\<^esub>" and "$$\n''>n'. n'' \nid\\<^bsub>t n'\<^esub>)" and "n'nid \ t\\<^bsub>n\<^esub> = n'" using latestAct_def proof have "(GREATEST n'. latestAct_cond nid t n n') = n'" proof (rule Greatest_equality[of "latestAct_cond nid t n" n']) from assms(1) assms (3) show "latestAct_cond nid t n n'" by simp next fix y assume "latestAct_cond nid t n y" hence "\nid\\<^bsub>t y\<^esub>" and "y n'" using assms(1) assms (2) leI by blast qed thus "n' = (GREATEST n'. latestAct_cond nid t n n')" by simp qed subsection "Last Activation" text \ In the following we introduce an operator to obtain the latest point in time where a certain component was activated within a certain configuration trace. \ definition lActive :: "'id \ (nat \ cnf) \ nat" ("\_ \ _\") where "\c \ t\ \ (GREATEST i. \c\\<^bsub>t i\<^esub>)" lemma lActive_active: assumes "\c\\<^bsub>t i\<^esub>" and "\n' > n. \ (\c\\<^bsub>t n'\<^esub>)" shows "\c\\<^bsub>t (\c \ t$$\<^esub>" proof - - from assms obtain i' where "\c\\<^bsub>t i'\<^esub>" and "\y. \c\\<^bsub>t y\<^esub> \ y \ i'" + from assms obtain i' where "\c\\<^bsub>t i'\<^esub>" and "(\y. \c\\<^bsub>t y\<^esub> \ y \ i')" using boundedGreatest[of "\i'. \c\\<^bsub>t i'\<^esub>" i n] by blast - thus ?thesis using lActive_def Nat.GreatestI_nat[of "\i'. \c\\<^bsub>t i'\<^esub>"] by metis + thus ?thesis using lActive_def Nat.GreatestI_nat[of "\i'. \c\\<^bsub>t i'\<^esub>"] by simp qed lemma lActive_less: assumes "\c\\<^bsub>t i\<^esub>" and "\n' > n. \ (\c\\<^bsub>t n'\<^esub>)" shows "\c \ t\ \ n" proof (rule ccontr) assume "\ \c \ t\ \ n" hence "\c \ t\ > n" by simp moreover from assms have "\c\\<^bsub>t (\c \ t\)\<^esub>" using lActive_active by simp ultimately show False using assms by simp qed lemma lActive_greatest: assumes "\c\\<^bsub>t i\<^esub>" and "\n' > n. \ (\c\\<^bsub>t n'\<^esub>)" shows "i \ \c \ t\" proof - - from assms obtain i' where "\c\\<^bsub>t i'\<^esub>" and "\y. \c\\<^bsub>t y\<^esub> \ y \ i'" + from assms obtain i' where "\c\\<^bsub>t i'\<^esub>" and "(\y. \c\\<^bsub>t y\<^esub> \ y \ i')" using boundedGreatest[of "\i'. \c\\<^bsub>t i'\<^esub>" i n] by blast - with assms show ?thesis using lActive_def Nat.Greatest_le_nat[of "\i'. \c\\<^bsub>t i'\<^esub>" i] by metis + with assms show ?thesis using lActive_def Nat.Greatest_le_nat[of "\i'. \c\\<^bsub>t i'\<^esub>" i] by simp qed lemma lActive_greater_active: assumes "n > \c \ t\" and "\n'' > n'. \ \c\\<^bsub>t n''\<^esub>" shows "\ \c\\<^bsub>t n\<^esub>" proof (rule ccontr) assume "\ \ \c\\<^bsub>t n\<^esub>" with \\n'' > n'. \ \c\\<^bsub>t n''\<^esub>\ have "n \ \c \ t\" using lActive_greatest by simp thus False using assms by simp qed lemma lActive_greater_active_all: assumes "\n'' > n'. \ \c\\<^bsub>t n''\<^esub>" shows "$$\n > \c \ t\. \c\\<^bsub>t n\<^esub>)" proof (rule ccontr) assume "\\(\n > \c \ t\. \c\\<^bsub>t n\<^esub>)" then obtain "n" where "n>\c \ t\" and "\c\\<^bsub>t n\<^esub>" by blast with \\n'' > n'. \ (\c\\<^bsub>t n''\<^esub>)\ have "\ \c\\<^bsub>t n\<^esub>" using lActive_greater_active by simp with \\c\\<^bsub>t n\<^esub>\ show False by simp qed lemma lActive_equality: assumes "\c\\<^bsub>t i\<^esub>" and "(\x. \c\\<^bsub>t x\<^esub> \ x \ i)" shows "\c \ t\ = i" unfolding lActive_def using assms Greatest_equality[of "\i'. \c\\<^bsub>t i'\<^esub>"] by simp lemma nxtActive_lactive: assumes "\i\n. \c\\<^bsub>t i\<^esub>" and "\ (\i>\c \ t\\<^bsub>n\<^esub>. \c\\<^bsub>t i\<^esub>)" shows "\c \ t\\<^bsub>n\<^esub>=\c \ t\" proof - from assms(1) have "\c\\<^bsub>t \c \ t\\<^bsub>n\<^esub>\<^esub>" using nxtActI by auto moreover from assms have "\ (\i'\Suc \c \ t\\<^bsub>n\<^esub>. \c\\<^bsub>t i'\<^esub>)" using nxtActive_no_active by simp hence "(\x. \c\\<^bsub>t x\<^esub> \ x \ \c \ t\\<^bsub>n\<^esub>)" using not_less_eq_eq by auto ultimately show ?thesis using \\ (\i'\Suc \c \ t\\<^bsub>n\<^esub>. \c\\<^bsub>t i'\<^esub>)\ lActive_equality by simp qed subsection "Mapping Time Points" text \ In the following we introduce two operators to map time-points between configuration traces and behavior traces. \ subsubsection "Configuration Trace to Behavior Trace" text \ First we provide an operator which maps a point in time of a configuration trace to the corresponding point in time of a behavior trace. \ definition cnf2bhv :: "'id \ (nat \ cnf) \ nat \ nat" ("\<^bsub>_\<^esub>\\<^bsub>_\<^esub>(_)" [150,150,150] 110) where "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n) \ the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1 + (n - \c \ t$$" lemma cnf2bhv_mono: assumes "n'\n" shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n') \ \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n)" by (simp add: assms cnf2bhv_def diff_le_mono) lemma cnf2bhv_mono_strict: assumes "n\\c \ t\" and "n'>n" shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n') > \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n)" using assms cnf2bhv_def by auto text "Note that the functions are nat, that means that also in the case the difference is negative they will return a 0!" lemma cnf2bhv_ge_llength[simp]: assumes "n\\c \ t\" shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n) \ the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1" using assms cnf2bhv_def by simp lemma cnf2bhv_greater_llength[simp]: assumes "n>\c \ t\" shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n) > the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1" using assms cnf2bhv_def by simp lemma cnf2bhv_suc[simp]: assumes "n\\c \ t\" shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(Suc n) = Suc (\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n))" using assms cnf2bhv_def by simp lemma cnf2bhv_lActive[simp]: shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(\c \ t\) = the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1" using cnf2bhv_def by simp lemma cnf2bhv_lnth_lappend: assumes act: "\i. \c\\<^bsub>t i\<^esub>" and nAct: "\i. i\n \ \c\\<^bsub>t i\<^esub>" shows "lnth ((\\<^bsub>c\<^esub>(inf_llist t)) @\<^sub>l (inf_llist t')) (\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n)) = lnth (inf_llist t') (n - \c \ t\ - 1)" (is "?lhs = ?rhs") proof - from nAct have "lfinite (\\<^bsub>c\<^esub>(inf_llist t))" using proj_finite2 by auto then obtain k where k_def: "llength (\\<^bsub>c\<^esub>(inf_llist t)) = enat k" using lfinite_llength_enat by blast moreover have "k \ \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n)" proof - from nAct have "\i. i>n-1 \ \c\\<^bsub>t i\<^esub>" by simp with act have "\c \ t\ \ n-1" using lActive_less by auto moreover have "n>0" using act nAct by auto ultimately have "\c \ t\ < n" by simp hence "the_enat (llength (\\<^bsub>c\<^esub>inf_llist t)) - 1 < \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n)" using cnf2bhv_greater_llength by simp with k_def show ?thesis by simp qed ultimately have "?lhs = lnth (inf_llist t') (\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n) - k)" using lnth_lappend2 by blast moreover have "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n) - k = n - \c \ t\ - 1" proof - from cnf2bhv_def have "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n) - k = the_enat (llength (\\<^bsub>c\<^esub>inf_llist t)) - 1 + (n - \c \ t\) - k" by simp also have "\ = the_enat (llength (\\<^bsub>c\<^esub>inf_llist t)) - 1 + (n - \c \ t\) - the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t)))" using k_def by simp also have "\ = the_enat (llength (\\<^bsub>c\<^esub>inf_llist t)) + (n - \c \ t\) - 1 - the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t)))" proof - have "\i. enat i < llength (inf_llist t) \ \c\\<^bsub>lnth (inf_llist t) i\<^esub>" by (simp add: act) hence "llength (\\<^bsub>c\<^esub>inf_llist t) \ 1" using proj_one by simp moreover from k_def have "llength (\\<^bsub>c\<^esub>inf_llist t) \ \" by simp ultimately have "the_enat (llength (\\<^bsub>c\<^esub>inf_llist t)) \ 1" by (simp add: k_def one_enat_def) thus ?thesis by simp qed also have "\ = the_enat (llength (\\<^bsub>c\<^esub>inf_llist t)) + (n - \c \ t\) - the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1" by simp also have "\ = n - \c \ t\ - 1" by simp finally show ?thesis . qed ultimately show ?thesis by simp qed lemma nAct_cnf2proj_Suc_dist: assumes "\i\n. \c\\<^bsub>t i\<^esub>" and "$$\i>\c \ t\\<^bsub>n\<^esub>. \c\\<^bsub>t i\<^esub>)" shows "Suc (the_enat \c #\<^bsub>enat n\<^esub>inf_llist t$$=\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(Suc \c \ t\\<^bsub>n\<^esub>)" proof - have "the_enat \c #\<^bsub>enat n\<^esub>inf_llist t\ = \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(\c \ t\\<^bsub>n\<^esub>)" (is "?LHS = ?RHS") proof - from assms have "?RHS = the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1" using nxtActive_lactive[of n c t] by simp also have "llength (\\<^bsub>c\<^esub>(inf_llist t)) = eSuc (\c #\<^bsub>\c \ t\\<^bsub>n\<^esub>\<^esub> inf_llist t\)" proof - from assms have "\ (\i'\ Suc (\c \ t\\<^bsub>n\<^esub>). \c\\<^bsub>t i'\<^esub>)" using nxtActive_no_active by simp hence "\c #\<^bsub>Suc (\c \ t\\<^bsub>n\<^esub>)\<^esub> inf_llist t\ = llength (\\<^bsub>c\<^esub>(inf_llist t))" using nAct_eq_proj[of "Suc (\c \ t\\<^bsub>n\<^esub>)" c "inf_llist t"] by simp moreover from assms(1) have "\c\\<^bsub>t (\c \ t\\<^bsub>n\<^esub>)\<^esub>" using nxtActI by blast hence "\c #\<^bsub>Suc (\c \ t\\<^bsub>n\<^esub>)\<^esub> inf_llist t\ = eSuc (\c #\<^bsub>\c \ t\\<^bsub>n\<^esub>\<^esub> inf_llist t\)" by simp ultimately show ?thesis by simp qed also have "the_enat(eSuc (\c #\<^bsub>\c \ t\\<^bsub>n\<^esub>\<^esub> inf_llist t\)) - 1 = (\c #\<^bsub>\c \ t\\<^bsub>n\<^esub>\<^esub> inf_llist t\)" proof - have "\c #\<^bsub>\c \ t\\<^bsub>n\<^esub>\<^esub> inf_llist t\ \ \" by simp hence "the_enat(eSuc (\c #\<^bsub>\c \ t\\<^bsub>n\<^esub>\<^esub> inf_llist t\)) = Suc(the_enat(\c #\<^bsub>\c \ t\\<^bsub>n\<^esub>\<^esub> inf_llist t\))" using the_enat_eSuc by simp thus ?thesis by simp qed also have "\ = ?LHS" proof - have "enat \c \ t\\<^bsub>n\<^esub> - 1 < llength (inf_llist t)" by (simp add: one_enat_def) moreover from assms(1) have "\c \ t\\<^bsub>n\<^esub>\n" and "\k. enat n \ enat k \ enat k < enat \c \ t\\<^bsub>n\<^esub> \ \c\\<^bsub>lnth (inf_llist t) k\<^esub>" using nxtActI by auto ultimately have "\c #\<^bsub>enat \c \ t\\<^bsub>n\<^esub>\<^esub>inf_llist t\ = \c #\<^bsub>enat n\<^esub>inf_llist t\" using nAct_not_active_same[of n "\c \ t\\<^bsub>n\<^esub>" "inf_llist t" c] by simp moreover have "\c #\<^bsub>enat n\<^esub>inf_llist t\\\" by simp ultimately show ?thesis by auto qed finally show ?thesis by fastforce qed moreover from assms have "\c \ t\\<^bsub>n\<^esub>=\c \ t\" using nxtActive_lactive by simp hence "Suc (\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(\c \ t\\<^bsub>n\<^esub>)) = \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(Suc \c \ t\\<^bsub>n\<^esub>)" using cnf2bhv_suc[where n="\c \ t\\<^bsub>n\<^esub>"] by simp ultimately show ?thesis by simp qed subsubsection "Behavior Trace to Configuration Trace" text \ Next we define an operator to map a point in time of a behavior trace back to a corresponding point in time for a configuration trace. \ definition bhv2cnf :: "'id \ (nat \ cnf) \ nat \ nat" ("\<^bsub>_\<^esub>\\<^bsub>_\<^esub>(_)" [150,150,150] 110) where "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n) \ \c \ t\ + (n - (the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1))" lemma bhv2cnf_mono: assumes "n'\n" shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n') \ \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n)" by (simp add: assms bhv2cnf_def diff_le_mono) lemma bhv2cnf_mono_strict: assumes "n'>n" and "n \ the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1" shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n') > \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n)" using assms bhv2cnf_def by auto text "Note that the functions are nat, that means that also in the case the difference is negative they will return a 0!" lemma bhv2cnf_ge_lActive[simp]: shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n) \ \c \ t\" using bhv2cnf_def by simp lemma bhv2cnf_greater_lActive[simp]: assumes "n>the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1" shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n) > \c \ t\" using assms bhv2cnf_def by simp lemma bhv2cnf_lActive[simp]: assumes "\i. \c\\<^bsub>t i\<^esub>" and "lfinite (\\<^bsub>c\<^esub>(inf_llist t))" shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t)))) = Suc (\c \ t\)" proof - from assms have "\\<^bsub>c\<^esub>(inf_llist t)\ []\<^sub>l" by simp hence "llength (\\<^bsub>c\<^esub>(inf_llist t)) > 0" by (simp add: lnull_def) moreover from \lfinite (\\<^bsub>c\<^esub>(inf_llist t))\ have "llength (\\<^bsub>c\<^esub>(inf_llist t)) \ \" using llength_eq_infty_conv_lfinite by auto ultimately have "the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) > 0" using enat_0_iff(1) by fastforce hence "the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - (the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1) = 1" by simp thus ?thesis using bhv2cnf_def by simp qed subsubsection "Relating the Mappings" text \ In the following we provide some properties about the relationship between the two mapping operators. \ lemma bhv2cnf_cnf2bhv: assumes "n \ \c \ t\" shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n)) = n" (is "?lhs = ?rhs") proof - have "?lhs = \c \ t\ + ((\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n)) - (the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1))" using bhv2cnf_def by simp also have "\ = \c \ t\ + (((the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t)))) - 1 + (n - \c \ t\)) - (the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1))" using cnf2bhv_def by simp also have "(the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t)))) - 1 + (n - (\c \ t\)) - (the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1) = (the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t)))) - 1 - ((the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t)))) - 1) + (n - (\c \ t\))" by simp also have "\ = n - (\c \ t\)" by simp also have "(\c \ t\) + (n - (\c \ t\)) = (\c \ t\) + n - \c \ t\" using assms by simp also have "\ = ?rhs" by simp finally show ?thesis . qed lemma cnf2bhv_bhv2cnf: assumes "n \ the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1" shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n)) = n" (is "?lhs = ?rhs") proof - have "?lhs = the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1 + ((\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n)) - (\c \ t\))" using cnf2bhv_def by simp also have "\ = the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1 + (\c \ t\ + (n - (the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1)) - (\c \ t\))" using bhv2cnf_def by simp also have "\c \ t\ + (n - (the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1)) - (\c \ t\) = \c \ t\ - (\c \ t\) + (n - (the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1))" by simp also have "\ = n - (the_enat(llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1)" by simp also have "the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1 + (n - (the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1)) = n - (the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1) + (the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1)" by simp also have "\ = n + ((the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1) - (the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1))" using assms by simp also have "\ = ?rhs" by simp finally show ?thesis . qed lemma p2c_mono_c2p: assumes "n \ \c \ t\" and "n' \ \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n)" shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n') \ n" proof - from \n' \ \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n)\ have "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n') \ \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n))" using bhv2cnf_mono by simp thus ?thesis using bhv2cnf_cnf2bhv \n \ \c \ t\\ by simp qed lemma p2c_mono_c2p_strict: assumes "n \ \c \ t\" and "n<\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n')" shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n) < n'" proof (rule ccontr) assume "\ (\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n) < n')" hence "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n) \ n'" by simp with \n \ \c \ t\\ have "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(nat (\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n))) \ \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n')" using bhv2cnf_mono by simp hence "$$\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(nat (\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n))) < \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n'))" by simp with \n \ \c \ t\\ have "\(n < \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n'))" using "bhv2cnf_cnf2bhv" by simp with assms show False by simp qed lemma c2p_mono_p2c: assumes "n \ the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1" and "n' \ \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n)" shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n') \ n" proof - from \n' \ \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n)\ have "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n') \ \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n))" using cnf2bhv_mono by simp thus ?thesis using cnf2bhv_bhv2cnf \n \ the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1\ by simp qed lemma c2p_mono_p2c_strict: assumes "n \ the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1" and "n<\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n')" shows "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n) < n'" proof (rule ccontr) assume "\ (\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n) < n')" hence "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n) \ n'" by simp with \n \ the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1\ have "\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(nat (\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n))) \ \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n')" using cnf2bhv_mono by simp hence "\(\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(nat (\<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n))) < \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n'))" by simp with \n \ the_enat (llength (\\<^bsub>c\<^esub>(inf_llist t))) - 1\ have "\(n < \<^bsub>c\<^esub>\\<^bsub>t\<^esub>(n'))" using "cnf2bhv_bhv2cnf" by simp with assms show False by simp qed end end diff --git a/thys/Gauss_Jordan/Rank.thy b/thys/Gauss_Jordan/Rank.thy --- a/thys/Gauss_Jordan/Rank.thy +++ b/thys/Gauss_Jordan/Rank.thy @@ -1,46 +1,46 @@ (* Title: Rank.thy Author: Jose Divasón Author: Jesús Aransay Maintainer: Jose Divasón *) section\Rank of a matrix\ theory Rank imports Rank_Nullity_Theorem.Dim_Formula begin subsection\Row rank, column rank and rank\ text\Definitions of row rank, column rank and rank\ definition row_rank :: "'a::{field}^'n^'m=>nat" where "row_rank A = vec.dim (row_space A)" definition col_rank :: "'a::{field}^'n^'m=>nat" where "col_rank A = vec.dim (col_space A)" lemma rank_def: "rank A = row_rank A" by (auto simp: row_rank_def row_rank_def_gen row_space_def) subsection\Properties\ lemma rrk_is_preserved: fixes A::"'a::{field}^'cols^'rows::{finite, wellorder}" and P::"'a::{field}^'rows::{finite, wellorder}^'rows::{finite, wellorder}" assumes inv_P: "invertible P" shows "row_rank A = row_rank (P**A)" by (metis row_space_is_preserved row_rank_def inv_P) lemma crk_is_preserved: fixes A::"'a::{field}^'cols::{finite, wellorder}^'rows" and P::"'a::{field}^'rows^'rows" assumes inv_P: "invertible P" shows "col_rank A = col_rank (P**A)" using rank_nullity_theorem_matrices unfolding ncols_def - by (metis col_rank_def inv_P add_left_cancel null_space_is_preserved) + by (metis col_rank_def inv_P nat_add_left_cancel null_space_is_preserved) end diff --git a/thys/List-Infinite/CommonArith/Util_Nat.thy b/thys/List-Infinite/CommonArith/Util_Nat.thy --- a/thys/List-Infinite/CommonArith/Util_Nat.thy +++ b/thys/List-Infinite/CommonArith/Util_Nat.thy @@ -1,311 +1,311 @@ (* Title: Util_Nat.thy Date: Oct 2006 Author: David Trachtenherz *) section \Results for natural arithmetics\ theory Util_Nat imports Main begin subsection \Some convenience arithmetic lemmata\ lemma add_1_Suc_conv: "m + 1 = Suc m" by simp lemma sub_Suc0_sub_Suc_conv: "b - a - Suc 0 = b - Suc a" by simp lemma Suc_diff_Suc: "m < n \ Suc (n - Suc m) = n - m" apply (rule subst[OF sub_Suc0_sub_Suc_conv]) apply (rule Suc_pred) apply (simp only: zero_less_diff) done lemma nat_grSuc0_conv: "(Suc 0 < n) = (n \ 0 \ n \ Suc 0)" by fastforce lemma nat_geSucSuc0_conv: "(Suc (Suc 0) \ n) = (n \ 0 \ n \ Suc 0)" by fastforce lemma nat_lessSucSuc0_conv: "(n < Suc (Suc 0)) = (n = 0 \ n = Suc 0)" by fastforce lemma nat_leSuc0_conv: "(n \ Suc 0) = (n = 0 \ n = Suc 0)" by fastforce lemma mult_pred: "(m - Suc 0) * n = m * n - n" by (simp add: diff_mult_distrib) lemma mult_pred_right: "m * (n - Suc 0) = m * n - m" by (simp add: diff_mult_distrib2) lemma gr_implies_gr0: "m < (n::nat) \ 0 < n" by simp corollary mult_cancel1_gr0: " (0::nat) < k \ (k * m = k * n) = (m = n)" by simp corollary mult_cancel2_gr0: " (0::nat) < k \ (m * k = n * k) = (m = n)" by simp corollary mult_le_cancel1_gr0: " (0::nat) < k \ (k * m \ k * n) = (m \ n)" by simp corollary mult_le_cancel2_gr0: " (0::nat) < k \ (m * k \ n * k) = (m \ n)" by simp lemma gr0_imp_self_le_mult1: "0 < (k::nat) \ m \ m * k" by (drule Suc_leI, drule mult_le_mono[OF order_refl], simp) lemma gr0_imp_self_le_mult2: "0 < (k::nat) \ m \ k * m" by (subst mult.commute, rule gr0_imp_self_le_mult1) lemma less_imp_Suc_mult_le: "m < n \ Suc m * k \ n * k" by (rule mult_le_mono1, simp) lemma less_imp_Suc_mult_pred_less: "\ m < n; 0 < k \ \ Suc m * k - Suc 0 < n * k" apply (rule Suc_le_lessD) apply (simp only: Suc_pred[OF nat_0_less_mult_iff[THEN iffD2, OF conjI, OF zero_less_Suc]]) apply (rule less_imp_Suc_mult_le, assumption) done lemma ord_zero_less_diff: "(0 < (b::'a::ordered_ab_group_add) - a) = (a < b)" by (simp add: less_diff_eq) lemma ord_zero_le_diff: "(0 \ (b::'a::ordered_ab_group_add) - a) = (a \ b)" by (simp add: le_diff_eq) text \\diff_diff_right\ in rule format\ lemmas diff_diff_right = Nat.diff_diff_right[rule_format] lemma less_add1: "(0::nat) < j \ i < i + j" by simp lemma less_add2: "(0::nat) < j \ i < j + i" by simp lemma add_lessD2: "i + j < (k::nat) \ j < k" by simp lemma add_le_mono2: "i \ (j::nat) \ k + i \ k + j" by simp lemma add_less_mono2: "i < (j::nat) \ k + i < k + j" by simp lemma diff_less_self: "\ (0::nat) < i; 0 < j \ \ i - j < i" by simp lemma ge_less_neq_conv: "((a::'a::linorder) \ n) = (\x. x < a \ n \ x)" and le_greater_neq_conv: "(n \ (a::'a::linorder)) = (\x. a < x \ n \ x)" by (subst linorder_not_less[symmetric], blast)+ lemma greater_le_neq_conv: "((a::'a::linorder) < n) = (\x. x \ a \ n \ x)" and less_ge_neq_conv: "(n < (a::'a::linorder)) = (\x. a \ x \ n \ x)" by (subst linorder_not_le[symmetric], blast)+ text \Lemmas for @term{abs} function\ lemma leq_pos_imp_abs_leq: "\ 0 \ (a::'a::ordered_ab_group_add_abs); a \ b \ \ \a\ \ \b\" by simp lemma leq_neg_imp_abs_geq: "\ (a::'a::ordered_ab_group_add_abs) \ 0; b \ a \ \ \a\ \ \b\" by simp lemma abs_range: "\ 0 \ (a::'a::{ordered_ab_group_add_abs,abs_if}); -a \ x; x \ a \ \ \x\ \ a" apply (clarsimp simp: abs_if) apply (rule neg_le_iff_le[THEN iffD1], simp) done text \Lemmas for @term{sgn} function\ lemma sgn_abs:"(x::'a::linordered_idom) \ 0 \ \sgn x\ = 1" by (case_tac "x < 0", simp+) lemma sgn_mult_abs:"\x\ * \sgn (a::'a::linordered_idom)\ = \x * sgn a\" by (fastforce simp add: sgn_if abs_if) lemma abs_imp_sgn_abs: "\a\ = \b\ \ \sgn (a::'a::linordered_idom)\ = \sgn b\" by (fastforce simp add: abs_if) lemma sgn_mono: "a \ b \ sgn (a::'a::{linordered_idom,linordered_semidom}) \ sgn b" by (auto simp add: sgn_if) subsection \Additional facts about inequalities\ lemma add_diff_le: "k \ n \ m + k - n \ (m::nat)" by (case_tac "m + k < n", simp_all) lemma less_add_diff: "k < (n::nat) \ m < n + m - k" by (rule add_less_imp_less_right[of _ k], simp) lemma add_diff_less: "\ k < n; 0 < m \ \ m + k - n < (m::nat)" by (case_tac "m + k < n", simp_all) lemma add_le_imp_le_diff1: "i + k \ j \ i \ j - (k::nat)" by (case_tac "k \ j", simp_all) lemma add_le_imp_le_diff2: "k + i \ j \ i \ j - (k::nat)" by simp lemma diff_less_imp_less_add: "j - (k::nat) < i \ j < i + k" by simp lemma diff_less_conv: "0 < i \ (j - (k::nat) < i) = (j < i + k)" by (safe, simp_all) lemma le_diff_swap: "\ i \ (k::nat); j \ k \ \ (k - j \ i) = (k - i \ j)" by (safe, simp_all) lemma diff_less_imp_swap: "\ 0 < (i::nat); k - i < j \ \ (k - j < i)" by simp lemma diff_less_swap: "\ 0 < (i::nat); 0 < j \ \ (k - j < i) = (k - i < j)" by (blast intro: diff_less_imp_swap) lemma less_diff_imp_less: "(i::nat) < j - m \ i < j" by simp lemma le_diff_imp_le: "(i::nat) \ j - m \ i \ j" by simp lemma less_diff_le_imp_less: "\ (i::nat) < j - m; n \ m \ \ i < j - n" by simp lemma le_diff_le_imp_le: "\ (i::nat) \ j - m; n \ m \ \ i \ j - n" by simp lemma le_imp_diff_le: "(j::nat) \ k \ j - n \ k" by simp subsection \Inequalities for Suc and pred\ corollary less_eq_le_pred: "0 < (n::nat) \ (m < n) = (m \ n - Suc 0)" by (safe, simp_all) corollary less_imp_le_pred: "m < n \ m \ n - Suc 0" by simp corollary le_pred_imp_less: "\ 0 < n; m \ n - Suc 0 \ \ m < n" by simp corollary pred_less_eq_le: "0 < m \ (m - Suc 0 < n) = (m \ n)" by (safe, simp_all) corollary pred_less_imp_le: "m - Suc 0 < n \ m \ n" by simp corollary le_imp_pred_less: "\ 0 < m; m \ n \ \ m - Suc 0 < n" by simp lemma diff_add_inverse_Suc: "n < m \ n + (m - Suc n) = m - Suc 0" by simp lemma pred_mono: "\ m < n; 0 < m \ \ m - Suc 0 < n - Suc 0" by simp corollary pred_Suc_mono: "\ m < Suc n; 0 < m \ \ m - Suc 0 < n" by simp lemma Suc_less_pred_conv: "(Suc m < n) = (m < n - Suc 0)" by (safe, simp_all) lemma Suc_le_pred_conv: "0 < n \ (Suc m \ n) = (m \ n - Suc 0)" by (safe, simp_all) lemma Suc_le_imp_le_pred: "Suc m \ n \ m \ n - Suc 0" by simp subsection \Additional facts about cancellation in (in-)equalities\ lemma diff_cancel_imp_eq: "\ 0 < (n::nat); n + i - j = n \ \ i = j" by simp lemma nat_diff_left_cancel_less: "k - m < k - (n::nat) \ n < m" by simp lemma nat_diff_right_cancel_less: "n - k < (m::nat) - k \ n < m" by simp lemma nat_diff_left_cancel_le1: "\ k - m \ k - (n::nat); m < k \ \ n \ m" by simp lemma nat_diff_left_cancel_le2: "\ k - m \ k - (n::nat); n \ k \ \ n \ m" by simp lemma nat_diff_right_cancel_le1: "\ m - k \ n - (k::nat); k < m \ \ m \ n" by simp lemma nat_diff_right_cancel_le2: "\ m - k \ n - (k::nat); k \ n \ \ m \ n" by simp lemma nat_diff_left_cancel_eq1: "\ k - m = k - (n::nat); m < k \ \ m = n" by simp lemma nat_diff_left_cancel_eq2: "\ k - m = k - (n::nat); n < k \ \ m = n" by simp lemma nat_diff_right_cancel_eq1: "\ m - k = n - (k::nat); k < m \ \ m = n" by simp lemma nat_diff_right_cancel_eq2: "\ m - k = n - (k::nat); k < n \ \ m = n" by simp lemma eq_diff_left_iff: "\ (m::nat) \ k; n \ k\ \ (k - m = k - n) = (m = n)" by (safe, simp_all) lemma eq_imp_diff_eq: "m = (n::nat) \ m - k = n - k" by simp text \List of definitions and lemmas\ thm Nat.add_Suc_right add_1_Suc_conv sub_Suc0_sub_Suc_conv thm Nat.mult_cancel1 Nat.mult_cancel2 mult_cancel1_gr0 mult_cancel2_gr0 thm Nat.add_lessD1 add_lessD2 thm Nat.zero_less_diff ord_zero_less_diff ord_zero_le_diff thm - le_add_diff + Nat.le_add_diff add_diff_le less_add_diff add_diff_less thm - Nat.le_diff_conv le_diff_conv2 + Nat.le_diff_conv Nat.le_diff_conv2 Nat.less_diff_conv diff_less_imp_less_add diff_less_conv thm le_diff_swap diff_less_imp_swap diff_less_swap thm less_diff_imp_less le_diff_imp_le thm less_diff_le_imp_less le_diff_le_imp_le thm Nat.less_imp_diff_less le_imp_diff_le thm Nat.less_Suc_eq_le less_eq_le_pred less_imp_le_pred le_pred_imp_less thm Nat.Suc_le_eq pred_less_eq_le pred_less_imp_le le_imp_pred_less thm diff_cancel_imp_eq thm diff_add_inverse_Suc thm Nat.nat_add_left_cancel_less Nat.nat_add_left_cancel_le - add_right_cancel - add_left_cancel + Nat.nat_add_right_cancel + Nat.nat_add_left_cancel Nat.eq_diff_iff Nat.less_diff_iff Nat.le_diff_iff thm nat_diff_left_cancel_less nat_diff_right_cancel_less thm nat_diff_left_cancel_le1 nat_diff_left_cancel_le2 nat_diff_right_cancel_le1 nat_diff_right_cancel_le2 thm nat_diff_left_cancel_eq1 nat_diff_left_cancel_eq2 nat_diff_right_cancel_eq1 nat_diff_right_cancel_eq2 thm Nat.eq_diff_iff eq_diff_left_iff thm - add_right_cancel add_left_cancel + Nat.nat_add_right_cancel Nat.nat_add_left_cancel Nat.diff_le_mono eq_imp_diff_eq end diff --git a/thys/List-Infinite/ListInf/List2.thy b/thys/List-Infinite/ListInf/List2.thy --- a/thys/List-Infinite/ListInf/List2.thy +++ b/thys/List-Infinite/ListInf/List2.thy @@ -1,1194 +1,1194 @@ (* Title: List2.thy Date: Oct 2006 Author: David Trachtenherz *) section \Additional definitions and results for lists\ theory List2 imports "../CommonSet/SetIntervalCut" begin subsection \Additional definitions and results for lists\ text \ Infix syntactical abbreviations for operators @{term take} and @{term drop}. The abbreviations resemble to the operator symbols used later for take and drop operators on infinite lists in ListInf.\ abbreviation f_take' :: "'a list \ nat \ 'a list" (infixl "\" 100) where "xs \ n \ take n xs" abbreviation f_drop' :: "'a list \ nat \ 'a list" (infixl "\" 100) where "xs \ n \ drop n xs" lemma append_eq_Cons: "[x] @ xs = x # xs" by simp lemma length_Cons: "length (x # xs) = Suc (length xs)" by simp lemma length_snoc: "length (xs @ [x]) = Suc (length xs)" by simp subsubsection \Additional lemmata about list emptiness\ lemma length_greater_imp_not_empty:"n < length xs \ xs \ []" by fastforce lemma length_ge_Suc_imp_not_empty:"Suc n \ length xs \ xs \ []" by fastforce lemma length_take_le: "length (xs \ n) \ length xs" by simp lemma take_not_empty_conv:"(xs \ n \ []) = (0 < n \ xs \ [])" by simp lemma drop_not_empty_conv:"(xs \ n \ []) = (n < length xs)" by fastforce lemma zip_eq_Nil: "(zip xs ys = []) = (xs = [] \ ys = [])" by (force simp: length_0_conv[symmetric] min_def simp del: length_0_conv) lemma zip_not_empty_conv: "(zip xs ys \ []) = (xs \ [] \ ys \ [])" by (simp add: zip_eq_Nil) subsubsection \Additional lemmata about @{term take}, @{term drop}, @{term hd}, @{term last}, \nth\ and \filter\\ lemma nth_tl_eq_nth_Suc: " Suc n \ length xs \ (tl xs) ! n = xs ! Suc n" by (rule hd_Cons_tl[OF length_ge_Suc_imp_not_empty, THEN subst], simp+) corollary nth_tl_eq_nth_Suc2: " n < length xs \ (tl xs) ! n = xs ! Suc n" by (simp add: nth_tl_eq_nth_Suc) lemma hd_eq_first: "xs \ [] \ xs ! 0 = hd xs" by (induct xs, simp_all) corollary take_first:"xs \ [] \ xs \ (Suc 0) = [xs ! 0]" by (induct xs, simp_all) corollary take_hd:"xs \ [] \ xs \ (Suc 0) = [hd xs]" by (simp add: take_first hd_eq_first) theorem last_nth: "xs \ [] \ last xs = xs ! (length xs - Suc 0)" by (simp add: last_conv_nth) lemma last_take: "n < length xs \ last (xs \ Suc n) = xs ! n" by (simp add: last_nth length_greater_imp_not_empty min_eqR) corollary last_take2:" \ 0 < n; n \ length xs \ \ last (xs \ n) = xs ! (n - Suc 0)" apply (frule diff_Suc_less[THEN order_less_le_trans, of _ "length xs" 0], assumption) apply (drule last_take[of "n - Suc 0" xs]) apply simp done corollary nth_0_drop: "n \ length xs \ (xs \ n) ! 0 = xs ! n" by (cut_tac nth_drop[of n xs 0], simp+) lemma drop_eq_tl: "xs \ (Suc 0) = tl xs" by (simp add: drop_Suc) lemma drop_take_1: " n < length xs \ xs \ n \ (Suc 0) = [xs ! n]" by (simp add: take_hd hd_drop_conv_nth) lemma upt_append: "m \ n \ [0.. (xs @ ys) ! n = xs ! n" by (simp add: nth_append) lemma nth_append2: "length xs \ n \ (xs @ ys) ! n = ys ! (n - length xs)" by (simp add: nth_append) lemma list_all_conv: "list_all P xs = (\iys. (xs = ys) = (length xs = length ys \ (\i xs \ n = ys \ n; xs \ n = ys \ n \ \ xs = ys" apply (rule subst[OF append_take_drop_id[of n xs]]) apply (rule subst[OF append_take_drop_id[of n ys]]) apply simp done lemma list_take_drop_eq_conv: " (xs = ys) = (\n. (xs \ n = ys \ n \ xs \ n = ys \ n))" by (blast intro: list_take_drop_imp_eq) lemma list_take_eq_conv: "(xs = ys) = (\n. xs \ n = ys \ n)" apply (rule iffI, simp) apply (drule_tac x="max (length xs) (length ys)" in spec) apply simp done lemma list_drop_eq_conv: "(xs = ys) = (\n. xs \ n = ys \ n)" apply (rule iffI, simp) apply (drule_tac x=0 in spec) apply simp done abbreviation replicate' :: "'a \ nat \ 'a list" ("_\<^bsup>_\<^esup>" [1000,65]) where "x\<^bsup>n\<^esup> \ replicate n x" lemma replicate_snoc: "x\<^bsup>n\<^esup> @ [x] = x\<^bsup>Suc n\<^esup>" by (simp add: replicate_app_Cons_same) lemma eq_replicate_conv: "(\ilength xs\<^esup>)" apply (rule iffI) apply (simp add: expand_list_eq) apply clarsimp apply (rule ssubst[of xs "replicate (length xs) m"], assumption) apply (rule nth_replicate, simp) done lemma replicate_Cons_length: "length (x # a\<^bsup>n\<^esup>) = Suc n" by simp lemma replicate_pred_Cons_length: "0 < n \ length (x # a\<^bsup>n - Suc 0\<^esup>) = n" by simp lemma replicate_le_diff: "m \ n \ x\<^bsup>m\<^esup> @ x\<^bsup>n - m\<^esup> = x\<^bsup>n\<^esup>" by (simp add: replicate_add[symmetric]) lemma replicate_le_diff2: "\ k \ m; m \ n \ \ x\<^bsup>m - k\<^esup> @ x\<^bsup>n - m\<^esup> = x\<^bsup>n - k\<^esup>" by (subst replicate_add[symmetric], simp) lemma append_constant_length_induct_aux: "\xs. \ length xs div k = n; \ys. k = 0 \ length ys < k \ P ys; \xs ys. \ length xs = k; P ys \ \ P (xs @ ys) \ \ P xs" apply (case_tac "k = 0", blast) apply simp apply (induct n) apply (simp add: div_eq_0_conv') apply (subgoal_tac "k \ length xs") prefer 2 apply (rule div_gr_imp_gr_divisor[of 0], simp) apply (simp only: atomize_all atomize_imp, clarsimp) apply (erule_tac x="drop k xs" in allE) apply (simp add: div_diff_self2) apply (erule_tac x=undefined in allE) apply (erule_tac x="take k xs" in allE) apply (simp add: min_eqR) apply (erule_tac x="drop k xs" in allE) apply simp done lemma append_constant_length_induct: " \ \ys. k = 0 \ length ys < k \ P ys; \xs ys. \ length xs = k; P ys \ \ P (xs @ ys) \ \ P xs" by (simp add: append_constant_length_induct_aux[of _ _ "length xs div k"]) lemma zip_swap: "map (\(y,x). (x,y)) (zip ys xs) = (zip xs ys)" by (simp add: expand_list_eq) lemma zip_takeL: "(zip xs ys) \ n = zip (xs \ n) ys" by (simp add: expand_list_eq) lemma zip_takeR: "(zip xs ys) \ n = zip xs (ys \ n)" apply (subst zip_swap[of ys, symmetric]) apply (subst take_map) apply (subst zip_takeL) apply (simp add: zip_swap) done lemma zip_take: "(zip xs ys) \ n = zip (xs \ n) (ys \ n)" by (rule take_zip) lemma hd_zip: "\ xs \ []; ys \ [] \ \ hd (zip xs ys) = (hd xs, hd ys)" by (simp add: hd_conv_nth zip_not_empty_conv) lemma map_id: "map id xs = xs" by (simp add: id_def) lemma map_id_subst: "P (map id xs) \ P xs" by (subst map_id[symmetric]) lemma map_one: "map f [x] = [f x]" by simp lemma map_last: "xs \ [] \ last (map f xs) = f (last xs)" by (rule last_map) lemma filter_list_all: "list_all P xs \ filter P xs = xs" by (induct xs, simp+) lemma filter_snoc: "filter P (xs @ [x]) = (if P x then (filter P xs) @ [x] else filter P xs)" by (case_tac "P x", simp+) lemma filter_filter_eq: "list_all (\x. P x = Q x) xs \ filter P xs = filter Q xs" by (induct xs, simp+) lemma filter_nth: "\n. n < length (filter P xs) \ (filter P xs) ! n = xs ! (LEAST k. k < length xs \ n < card {i. i \ k \ i < length xs \ P (xs ! i)})" apply (induct xs rule: rev_induct, simp) apply (rename_tac x xs n) apply (simp only: filter_snoc) apply (simp split del: if_split) apply (case_tac "xs = []") apply (simp split del: if_split) apply (rule_tac t = "\k i. i = 0 \ i \ k \ P ([x] ! i)" and s = "\k i. i = 0 \ P x" in subst) apply (simp add: fun_eq_iff) apply fastforce apply (fastforce simp: Least_def) apply (rule_tac t = "\k. card {i. i \ k \ i < Suc (length xs) \ P ((xs @ [x]) ! i)}" and s = "\k. (card {i. i \ k \ i < length xs \ P (xs ! i)} + (if k \ length xs \ P x then Suc 0 else 0))" in subst) apply (clarsimp simp: fun_eq_iff split del: if_split, rename_tac k) apply (simp split del: if_split add: less_Suc_eq conj_disj_distribL conj_disj_distribR Collect_disj_eq) apply (subst card_Un_disjoint) apply (rule_tac n="length xs" in bounded_nat_set_is_finite, blast) apply (rule_tac n="Suc (length xs)" in bounded_nat_set_is_finite, blast) apply blast apply (rule_tac t = "\i. i < length xs \ P ((xs @ [x]) ! i)" and s = "\i. i < length xs \ P (xs ! i)" in subst) apply (rule fun_eq_iff[THEN iffD2]) apply (fastforce simp: nth_append1) - apply (rule add_left_cancel[THEN iffD2]) + apply (rule nat_add_left_cancel[THEN iffD2]) apply (rule_tac t = "\i. i = length xs \ i \ k \ P ((xs @ [x]) ! i)" and s = "\i. i = length xs \ i \ k \ P x" in subst) apply (rule fun_eq_iff[THEN iffD2]) apply fastforce apply (case_tac "length xs \ k") apply clarsimp apply (rule_tac t = "\i. i = length xs \ i \ k" and s = "\i. i = length xs" in subst) apply (rule fun_eq_iff[THEN iffD2]) apply fastforce apply simp apply simp apply (simp split del: if_split add: less_Suc_eq conj_disj_distribL conj_disj_distribR) apply (rule_tac t = "\k. k < length xs \ n < card {i. i \ k \ i < length xs \ P (xs ! i)} + (if length xs \ k \ P x then Suc 0 else 0)" and s = "\k. k < length xs \ n < card {i. i \ k \ i < length xs \ P (xs ! i)}" in subst) apply (simp add: fun_eq_iff) apply (rule_tac t = "\k. k = length xs \ n < card {i. i \ k \ i < length xs \ P (xs ! i)} + (if length xs \ k \ P x then Suc 0 else 0)" and s = "\k. k = length xs \ n < card {i. i \ k \ i < length xs \ P (xs ! i)} + (if P x then Suc 0 else 0)" in subst) apply (simp add: fun_eq_iff) apply (case_tac "n < length (filter P xs)") apply (rule_tac t = "(if P x then filter P xs @ [x] else filter P xs) ! n" and s = "(filter P xs) ! n" in subst) apply (simp add: nth_append1) apply (simp split del: if_split) apply (subgoal_tac "\k k \ i < length xs \ P (xs ! i)}") prefer 2 apply (rule_tac x="length xs - Suc 0" in exI) apply (simp add: length_filter_conv_card less_eq_le_pred[symmetric]) apply (subgoal_tac "\k\length xs. n < card {i. i \ k \ i < length xs \ P (xs ! i)}") prefer 2 apply (blast intro: less_imp_le) apply (subst Least_le_imp_le_disj) apply simp apply simp apply (rule sym, rule nth_append1) apply (rule LeastI2_ex, assumption) apply blast apply (simp add: linorder_not_less) apply (subgoal_tac "P x") prefer 2 apply (rule ccontr, simp) apply (simp add: length_snoc) apply (drule less_Suc_eq_le[THEN iffD1], drule_tac x=n in order_antisym, assumption) apply (simp add: nth_append2) apply (simp add: length_filter_conv_card) apply (rule_tac t = "\k. card {i. i < length xs \ P (xs ! i)} < card {i. i \ k \ i < length xs \ P (xs ! i)}" and s = "\k. False" in subst) apply (rule fun_eq_iff[THEN iffD2], rule allI, rename_tac k) apply (simp add: linorder_not_less) apply (rule card_mono) apply fastforce apply blast apply simp apply (rule_tac t = "(LEAST k. k = length xs \ card {i. i < length xs \ P (xs ! i)} < Suc (card {i. i \ k \ i < length xs \ P (xs ! i)}))" and s = "length xs" in subst) apply (rule sym, rule Least_equality) apply simp apply (rule le_imp_less_Suc) apply (rule card_mono) apply fastforce apply fastforce apply simp apply simp done subsubsection \Ordered lists\ fun list_ord :: "('a \ 'a \ bool) \ ('a::ord) list \ bool" where "list_ord ord (x1 # x2 # xs) = (ord x1 x2 \ list_ord ord (x2 # xs))" | "list_ord ord xs = True" definition list_asc :: "('a::ord) list \ bool" where "list_asc xs \ list_ord ($$ xs" definition list_strict_asc :: "('a::ord) list \ bool" where "list_strict_asc xs \ list_ord (<) xs" value "list_asc [1::nat, 2, 2]" value "list_strict_asc [1::nat, 2, 2]" definition list_desc :: "('a::ord) list \ bool" where "list_desc xs \ list_ord (\) xs" definition list_strict_desc :: "('a::ord) list \ bool" where "list_strict_desc xs \ list_ord (>) xs" lemma list_ord_Nil: "list_ord ord []" by simp lemma list_ord_one: "list_ord ord [x]" by simp lemma list_ord_Cons: " list_ord ord (x # xs) = (xs = [] \ (ord x (hd xs) \ list_ord ord xs))" by (induct xs, simp+) lemma list_ord_Cons_imp: "\ list_ord ord xs; ord x (hd xs) \ \ list_ord ord (x # xs)" by (induct xs, simp+) lemma list_ord_append: "\ys. list_ord ord (xs @ ys) = (list_ord ord xs \ (ys = [] \ (list_ord ord ys \ (xs = [] \ ord (last xs) (hd ys)))))" apply (induct xs, fastforce) apply (case_tac xs, case_tac ys, fastforce+) done lemma list_ord_snoc: " list_ord ord (xs @ [x]) = (xs = [] \ (ord (last xs) x \ list_ord ord xs))" by (fastforce simp: list_ord_append) lemma list_ord_all_conv: " (list_ord ord xs) = (\n < length xs - 1. ord (xs ! n) (xs ! Suc n))" apply (rule iffI) apply (induct xs, simp) apply clarsimp apply (simp add: list_ord_Cons) apply (erule disjE, simp) apply clarsimp apply (case_tac n) apply (simp add: hd_conv_nth) apply simp apply (induct xs, simp) apply (simp add: list_ord_Cons) apply (case_tac "xs = []", simp) apply (drule meta_mp) apply (intro allI impI, rename_tac n) apply (drule_tac x="Suc n" in spec, simp) apply (drule_tac x=0 in spec) apply (simp add: hd_conv_nth) done lemma list_ord_imp: " \ \x y. ord x y \ ord' x y; list_ord ord xs \ \ list_ord ord' xs" apply (induct xs, simp) apply (simp add: list_ord_Cons) apply fastforce done corollary list_strict_asc_imp_list_asc: " list_strict_asc (xs::'a::preorder list) \ list_asc xs" by (unfold list_strict_asc_def list_asc_def, rule list_ord_imp[of "(<)"], rule order_less_imp_le) corollary list_strict_desc_imp_list_desc: " list_strict_desc (xs::'a::preorder list) \ list_desc xs" by (unfold list_strict_desc_def list_desc_def, rule list_ord_imp[of "(>)"], rule order_less_imp_le) lemma list_ord_trans_imp: "\i. \ transP ord; list_ord ord xs; j < length xs; i < j \ \ ord (xs ! i) (xs ! j)" apply (simp add: list_ord_all_conv) apply (induct j, simp) apply (case_tac "j < i", simp) apply (simp add: linorder_not_less) apply (case_tac "i = j", simp) apply (drule_tac x=i in meta_spec, simp) apply (drule_tac x=j in spec, simp add: Suc_less_pred_conv) apply (unfold trans_def) apply (drule_tac x="xs ! i" in spec, drule_tac x="xs ! j" in spec, drule_tac x="xs ! Suc j" in spec) apply simp done lemma list_ord_trans: " transP ord \ (list_ord ord xs) = (\j < length xs. \i < j. ord (xs ! i) (xs ! j))" apply (rule iffI) apply (simp add: list_ord_trans_imp) apply (simp add: list_ord_all_conv) done lemma list_ord_trans_refl_le: " \ transP ord; reflP ord \ \ (list_ord ord xs) = (\j < length xs. \i \ j. ord (xs ! i) (xs ! j))" apply (subst list_ord_trans, simp) apply (rule iffI) apply clarsimp apply (case_tac "i = j") apply (simp add: refl_on_def) apply simp+ done lemma list_ord_trans_refl_le_imp: " \ transP ord; \x y. ord x y \ ord' x y; reflP ord'; list_ord ord xs \ \ (\j < length xs. \i \ j. ord' (xs ! i) (xs ! j))" apply clarify apply (case_tac "i = j") apply (simp add: refl_on_def) apply (simp add: list_ord_trans_imp) done corollary list_asc_trans: " (list_asc (xs::'a::preorder list)) = (\j < length xs. \i < j. xs ! i \ xs ! j)" and list_strict_asc_trans: " (list_strict_asc (xs::'a::preorder list)) = (\j < length xs. \i < j. xs ! i < xs ! j)" and list_desc_trans: " (list_desc (xs::'a::preorder list)) = (\j < length xs. \i < j. xs ! j \ xs ! i)" and list_strict_desc_trans: " (list_strict_desc (xs::'a::preorder list)) = (\j < length xs. \i < j. xs ! j < xs ! i)" apply (unfold list_asc_def list_strict_asc_def list_desc_def list_strict_desc_def) apply (rule list_ord_trans, unfold trans_def, blast intro: order_trans order_less_trans)+ done corollary list_asc_trans_le: " (list_asc (xs::'a::preorder list)) = (\j < length xs. \i \ j. xs ! i \ xs ! j)" and list_desc_trans_le: " (list_desc (xs::'a::preorder list)) = (\j < length xs. \i \ j. xs ! j \ xs ! i)" apply (unfold list_asc_def list_strict_asc_def list_desc_def list_strict_desc_def) apply (rule list_ord_trans_refl_le, unfold trans_def, blast intro: order_trans, simp add: refl_on_def)+ done corollary list_strict_asc_trans_le: " (list_strict_asc (xs::'a::preorder list)) \ (\j < length xs. \i \ j. xs ! i \ xs ! j)" apply (unfold list_strict_asc_def) apply (rule list_ord_trans_refl_le_imp[where ord="(\)"]) apply (unfold trans_def, blast intro: order_trans) apply assumption apply (unfold refl_on_def, clarsimp) apply (rule list_ord_imp[where ord="(<)"], simp_all add: less_imp_le) done lemma list_ord_le_sorted_eq: "list_asc xs = sorted xs" apply (rule sym) apply (simp add: list_asc_def) apply (induct xs, simp) apply (rename_tac x xs) apply (simp add: list_ord_Cons) apply (case_tac "xs = []", simp_all) apply (case_tac "list_ord (\) xs", simp_all) apply (rule iffI) apply (drule_tac x="hd xs" in bspec, simp_all) apply clarify apply (drule in_set_conv_nth[THEN iffD1], clarsimp, rename_tac i1) apply (simp add: hd_conv_nth) apply (case_tac i1, simp) apply (rename_tac i2) apply simp apply (fold list_asc_def) apply (fastforce simp: list_asc_trans) done corollary list_asc_upto: "list_asc [m..n]" by (simp add: list_ord_le_sorted_eq) lemma list_strict_asc_upt: "list_strict_asc [m.. irrefl {(a, b). ord a b}; transP ord; list_ord ord xs; i < length xs; j < length xs; i < j \ \ xs ! i \ xs ! j" apply (subgoal_tac "\x y. ord x y \ x \ y") prefer 2 apply (rule ccontr) apply (simp add: irrefl_def) apply (simp add: list_ord_trans) done lemma list_ord_distinct: " \ irrefl {(a,b). ord a b}; transP ord; list_ord ord xs \ \ distinct xs" apply (simp add: distinct_conv_nth, intro allI impI, rename_tac i j) apply (drule neq_iff[THEN iffD1], erule disjE) apply (simp add: list_ord_distinct_aux) apply (simp add: list_ord_distinct_aux[THEN not_sym]) done lemma list_strict_asc_distinct: "list_strict_asc (xs::'a::preorder list) \ distinct xs" apply (rule_tac ord="(<)" in list_ord_distinct) apply (unfold irrefl_def list_strict_asc_def trans_def) apply (blast intro: less_trans)+ done lemma list_strict_desc_distinct: "list_strict_desc (xs::'a::preorder list) \ distinct xs" apply (rule_tac ord="(>)" in list_ord_distinct) apply (unfold irrefl_def list_strict_desc_def trans_def) apply (blast intro: less_trans)+ done subsubsection \Additional definitions and results for sublists\ primrec sublist_list :: "'a list \ nat list \ 'a list" where "sublist_list xs [] = []" | "sublist_list xs (y # ys) = (xs ! y) # (sublist_list xs ys)" value "sublist_list [0::int,10::int,20,30,40,50] [1::nat,2,3]" value "sublist_list [0::int,10::int,20,30,40,50] [1::nat,1,2,3]" value [nbe] "sublist_list [0::int,10::int,20,30,40,50] [1::nat,1,2,3,10]" lemma sublist_list_length: "length (sublist_list xs ys) = length ys" by (induct ys, simp_all) lemma sublist_list_append: " \zs. sublist_list xs (ys @ zs) = sublist_list xs ys @ sublist_list xs zs" by (induct ys, simp_all) lemma sublist_list_Nil: "sublist_list xs [] =[]" by simp lemma sublist_list_is_Nil_conv: " (sublist_list xs ys = []) = (ys = [])" apply (rule iffI) apply (rule ccontr) apply (clarsimp simp: neq_Nil_conv) apply simp done lemma sublist_list_eq_imp_length_eq: " sublist_list xs ys = sublist_list xs zs \ length ys = length zs" by (drule arg_cong[where f=length], simp add: sublist_list_length) lemma sublist_list_nth: " \n. n < length ys \ sublist_list xs ys ! n = xs ! (ys ! n)" apply (induct ys, simp) apply (case_tac n, simp_all) done lemma take_drop_eq_sublist_list: " m + n \ length xs \ xs \ m \ n = sublist_list xs [m.. nat list \ 'a list" where "sublist_list_if xs [] = []" | "sublist_list_if xs (y # ys) = (if y < length xs then (xs ! y) # (sublist_list_if xs ys) else (sublist_list_if xs ys))" value "sublist_list_if [0::int,10::int,20,30,40,50] [1::nat,2,3]" value "sublist_list_if [0::int,10::int,20,30,40,50] [1::nat,1,2,3]" value "sublist_list_if [0::int,10::int,20,30,40,50] [1::nat,1,2,3,10]" lemma sublist_list_if_sublist_list_filter_conv: "\xs. sublist_list_if xs ys = sublist_list xs (filter (\i. i < length xs) ys)" by (induct ys, simp+) corollary sublist_list_if_sublist_list_eq: "\xs. list_all (\i. i < length xs) ys \ sublist_list_if xs ys = sublist_list xs ys" by (simp add: sublist_list_if_sublist_list_filter_conv filter_list_all) corollary sublist_list_if_sublist_list_eq2: "\xs. \n sublist_list_if xs ys = sublist_list xs ys" by (rule sublist_list_if_sublist_list_eq, rule list_all_conv[THEN iffD2]) lemma sublist_list_if_Nil_left: "sublist_list_if [] ys = []" by (induct ys, simp+) lemma sublist_list_if_Nil_right: "sublist_list_if xs [] = []" by simp lemma sublist_list_if_length: " length (sublist_list_if xs ys) = length (filter (\i. i < length xs) ys)" by (simp add: sublist_list_if_sublist_list_filter_conv sublist_list_length) lemma sublist_list_if_append: " sublist_list_if xs (ys @ zs) = sublist_list_if xs ys @ sublist_list_if xs zs" by (simp add: sublist_list_if_sublist_list_filter_conv sublist_list_append) lemma sublist_list_if_snoc: " sublist_list_if xs (ys @ [y]) = sublist_list_if xs ys @ (if y < length xs then [xs ! y] else [])" by (simp add: sublist_list_if_append) lemma sublist_list_if_is_Nil_conv: " (sublist_list_if xs ys = []) = (list_all (\i. length xs \ i) ys)" by (simp add: sublist_list_if_sublist_list_filter_conv sublist_list_is_Nil_conv filter_empty_conv list_all_iff linorder_not_less) lemma sublist_list_if_nth: " n < length ((filter (\i. i < length xs) ys)) \ sublist_list_if xs ys ! n = xs ! ((filter (\i. i < length xs) ys) ! n)" by (simp add: sublist_list_if_sublist_list_filter_conv sublist_list_nth) lemma take_drop_eq_sublist_list_if: " m + n \ length xs \ xs \ m \ n = sublist_list_if xs [m..i\I. length xs \ i)" using [[hypsubst_thin = true]] by (fastforce simp: set_empty[symmetric] set_nths linorder_not_le[symmetric]) lemma nths_singleton2: "nths xs {y} = (if y < length xs then [xs ! y] else [])" apply (unfold nths_def) apply (induct xs rule: rev_induct, simp) apply (simp add: nth_append) done lemma nths_take_eq: " \ finite I; Max I < n \ \ nths (xs \ n) I = nths xs I" apply (case_tac "I = {}", simp) apply (case_tac "n < length xs") prefer 2 apply simp apply (rule_tac t = "nths xs I" and s = "nths (xs \ n @ xs \ n) I" in subst) apply simp apply (subst nths_append) apply (simp add: min_eqR) apply (rule_tac t="{j. j + n \ I}" and s="{}" in subst) apply blast apply simp done lemma nths_drop_eq: " n \ iMin I \ nths (xs \ n) {j. j + n \ I} = nths xs I" apply (case_tac "I = {}", simp) apply (case_tac "n < length xs") prefer 2 apply (simp add: nths_def filter_empty_conv linorder_not_less) apply (clarsimp, rename_tac a b) apply (drule set_zip_rightD) apply fastforce apply (rule_tac t = "nths xs I" and s = "nths (xs \ n @ xs \ n) I" in subst) apply simp apply (subst nths_append) apply (fastforce simp: nths_empty_conv min_eqR) done lemma nths_cut_less_eq: " length xs \ n \ nths xs (I \< n) = nths xs I" apply (simp add: nths_def cut_less_mem_iff) apply (rule_tac f="\xs. map fst xs" in arg_cong) apply (rule filter_filter_eq) apply (simp add: list_all_conv) done lemma nths_disjoint_Un: " \ finite A; Max A < iMin B \ \ nths xs (A \ B) = nths xs A @ nths xs B" apply (case_tac "A = {}", simp) apply (case_tac "B = {}", simp) apply (case_tac "length xs \ iMin B") apply (subst nths_cut_less_eq[of xs "iMin B", symmetric], assumption) apply (simp (no_asm_simp) add: cut_less_Un cut_less_Min_empty cut_less_Max_all) apply (simp add: nths_empty_conv iMin_ge_iff) apply (simp add: linorder_not_le) apply (rule_tac t = "nths xs (A \ B)" and s = "nths (xs \ (iMin B) @ xs \ (iMin B)) (A \ B)" in subst) apply simp apply (subst nths_append) apply (simp add: min_eqR) apply (subst nths_cut_less_eq[where xs="xs \ iMin B" and n="iMin B", symmetric], simp) apply (simp add: cut_less_Un cut_less_Min_empty cut_less_Max_all) apply (simp add: nths_take_eq) apply (rule_tac t = "\j. j + iMin B \ A \ j + iMin B \ B" and s = "\j. j + iMin B \ B" in subst) apply (force simp: fun_eq_iff) apply (simp add: nths_drop_eq) done corollary nths_disjoint_insert_left: " \ finite I; x < iMin I \ \ nths xs (insert x I) = nths xs {x} @ nths xs I" apply (rule_tac t="insert x I" and s="{x} \ I" in subst, simp) apply (subst nths_disjoint_Un) apply simp_all done corollary nths_disjoint_insert_right: " \ finite I; Max I < x \ \ nths xs (insert x I) = nths xs I @ nths xs {x}" apply (rule_tac t="insert x I" and s="I \ {x}" in subst, simp) apply (subst nths_disjoint_Un) apply simp_all done lemma nths_all: "{.. I \ nths xs I = xs" apply (case_tac "xs = []", simp) apply (rule_tac t = "I" and s = "I \< (length xs) \ I \\ (length xs)" in subst) apply (simp add: cut_less_cut_ge_ident) apply (rule_tac t = "I \< length xs" and s = "{..\ (length xs) = {}", simp) apply (subst nths_disjoint_Un[OF finite_lessThan]) apply (rule less_imp_Max_less_iMin[OF finite_lessThan]) apply blast apply blast apply (blast intro: less_le_trans) apply (fastforce simp: nths_empty_conv) done corollary nths_UNIV: "nths xs UNIV = xs" by (rule nths_all[OF subset_UNIV]) lemma sublist_list_nths_eq: "\xs. list_strict_asc ys \ sublist_list_if xs ys = nths xs (set ys)" apply (case_tac "xs = []") apply (simp add: sublist_list_if_Nil_left) apply (induct ys rule: rev_induct, simp) apply (rename_tac y ys xs) apply (case_tac "ys = []") apply (simp add: nths_singleton2) apply (unfold list_strict_asc_def) apply (simp add: sublist_list_if_snoc split del: if_split) apply (frule list_ord_append[THEN iffD1]) apply (clarsimp split del: if_split) apply (subst nths_disjoint_insert_right) apply simp apply (clarsimp simp: in_set_conv_nth, rename_tac i) apply (drule_tac i=i and j="length ys" in list_strict_asc_trans[unfolded list_strict_asc_def, THEN iffD1, rule_format]) apply (simp add: nth_append split del: if_split)+ apply (simp add: nths_singleton2) done lemma set_sublist_list_if: "\xs. set (sublist_list_if xs ys) = {xs ! i |i. i < length xs \ i \ set ys}" apply (induct ys, simp_all) apply blast done lemma set_sublist_list: " list_all (\i. i < length xs) ys \ set (sublist_list xs ys) = {xs ! i |i. i < length xs \ i \ set ys}" by (simp add: sublist_list_if_sublist_list_eq[symmetric] set_sublist_list_if) lemma set_sublist_list_if_eq_set_sublist: "set (sublist_list_if xs ys) = set (nths xs (set ys))" by (simp add: set_nths set_sublist_list_if) lemma set_sublist_list_eq_set_sublist: " list_all (\i. i < length xs) ys \ set (sublist_list xs ys) = set (nths xs (set ys))" by (simp add: sublist_list_if_sublist_list_eq[symmetric] set_sublist_list_if_eq_set_sublist) subsubsection \Natural set images with lists\ definition f_image :: "'a list \ nat set \ 'a set" (infixr "\<^sup>f" 90) where "xs \<^sup>f A \ {y. \n\A. n < length xs \ y = xs ! n}" abbreviation f_range :: "'a list \ 'a set" where "f_range xs \ f_image xs UNIV" lemma f_image_eqI[simp, intro]: " \ x = xs ! n; n \ A; n < length xs \ \ x \ xs \<^sup>f A" by (unfold f_image_def, blast) lemma f_imageI: "\ n \ A; n < length xs \ \ xs ! n \ xs \<^sup>f A" by blast lemma rev_f_imageI: "\ n \ A; n < length xs; x = xs ! n \ \ x \ xs \<^sup>f A" by (rule f_image_eqI) lemma f_imageE[elim!]: " \ x \ xs \<^sup>f A; \n. \ x = xs ! n; n \ A; n < length xs \ \ P \ \ P" by (unfold f_image_def, blast) lemma f_image_Un: "xs \<^sup>f (A \ B) = xs \<^sup>f A \ xs \<^sup>f B" by blast lemma f_image_mono: "A \ B ==> xs \<^sup>f A \ xs \<^sup>f B" by blast lemma f_image_iff: "(x \ xs \<^sup>f A) = (\n\A. n < length xs \ x = xs ! n)" by blast lemma f_image_subset_iff: " (xs \<^sup>f A \ B) = (\n\A. n < length xs \ xs ! n \ B)" by blast lemma subset_f_image_iff: "(B \ xs \<^sup>f A) = (\A'\A. B = xs \<^sup>f A')" apply (rule iffI) apply (rule_tac x="{ n. n \ A \ n < length xs \ xs ! n \ B }" in exI) apply blast apply (blast intro: f_image_mono) done lemma f_image_subsetI: " \ \n. n \ A \ n < length xs \ xs ! n \ B \ \ xs \<^sup>f A \ B" by blast lemma f_image_empty: "xs \<^sup>f {} = {}" by blast lemma f_image_insert_if: " xs \<^sup>f (insert n A) = ( if n < length xs then insert (xs ! n) (xs \<^sup>f A) else (xs \<^sup>f A))" by (split if_split, blast) lemma f_image_insert_eq1: " n < length xs \ xs \<^sup>f (insert n A) = insert (xs ! n) (xs \<^sup>f A)" by (simp add: f_image_insert_if) lemma f_image_insert_eq2: " length xs \ n \ xs \<^sup>f (insert n A) = (xs \<^sup>f A)" by (simp add: f_image_insert_if) lemma insert_f_image: " \ n \ A; n < length xs \ \ insert (xs ! n) (xs \<^sup>f A) = (xs \<^sup>f A)" by blast lemma f_image_is_empty: "(xs \<^sup>f A = {}) = ({x. x \ A \ x < length xs} = {})" by blast lemma f_image_Collect: "xs \<^sup>f {n. P n} = {xs ! n |n. P n \ n < length xs}" by blast lemma f_image_eq_set: "\n A \ xs \<^sup>f A = set xs" by (fastforce simp: in_set_conv_nth) lemma f_range_eq_set: "f_range xs = set xs" by (simp add: f_image_eq_set) lemma f_image_eq_set_nths: "xs \<^sup>f A = set (nths xs A)" by (unfold set_nths, blast) lemma f_image_eq_set_sublist_list_if: "xs \<^sup>f (set ys) = set (sublist_list_if xs ys)" by (simp add: set_sublist_list_if_eq_set_sublist f_image_eq_set_nths) lemma f_image_eq_set_sublist_list: " list_all (\i. i < length xs) ys \ xs \<^sup>f (set ys) = set (sublist_list xs ys)" by (simp add: sublist_list_if_sublist_list_eq f_image_eq_set_sublist_list_if) lemma f_range_eqI: "\ x = xs ! n; n < length xs \ \ x \ f_range xs" by blast lemma f_rangeI: "n < length xs \ xs ! n \ f_range xs" by blast lemma f_rangeE[elim?]: " \ x \ f_range xs; \n. \ n < length xs; x = xs ! n \ \ P \ \ P" by blast subsubsection \Mapping lists of functions to lists\ primrec map_list :: "('a \ 'b) list \ 'a list \ 'b list" where "map_list [] xs = []" | "map_list (f # fs) xs = f (hd xs) # map_list fs (tl xs)" lemma map_list_Nil: "map_list [] xs = []" by simp lemma map_list_Cons_Cons: " map_list (f # fs) (x # xs) = (f x) # map_list fs xs" by simp lemma map_list_length: "\xs. length (map_list fs xs) = length fs" by (induct fs, simp+) corollary map_list_empty_conv: " (map_list fs xs = []) = (fs = [])" by (simp del: length_0_conv add: length_0_conv[symmetric] map_list_length) corollary map_list_not_empty_conv: " (map_list fs xs \ []) = (fs \ [])" by (simp add: map_list_empty_conv) lemma map_list_nth: "\n xs. \ n < length fs; n < length xs \ \ (map_list fs xs ! n) = (fs ! n) (xs ! n)" apply (induct fs, simp+) apply (case_tac n) apply (simp add: hd_conv_nth) apply (simp add: nth_tl_eq_nth_Suc2) done lemma map_list_xs_take: "\n xs. length fs \ n \ map_list fs (xs \ n) = map_list fs xs" apply (induct fs, simp+) apply (rename_tac fs n xs) apply (simp add: tl_take) done lemma map_list_take: "\n xs. (map_list fs xs) \ n = (map_list (fs \ n) xs)" apply (induct fs, simp) apply (case_tac n, simp+) done lemma map_list_take_take: "\n xs. (map_list fs xs) \ n = (map_list (fs \ n) (xs \ n))" by (simp add: map_list_take map_list_xs_take) lemma map_list_drop: "\n xs. (map_list fs xs) \ n = (map_list (fs \ n) (xs \ n))" apply (induct fs, simp) apply (case_tac n) apply (simp add: drop_Suc)+ done lemma map_list_append_append: "\xs1 . length fs1 = length xs1 \ map_list (fs1 @ fs2) (xs1 @ xs2) = map_list fs1 xs1 @ map_list fs2 xs2" apply (induct fs1, simp+) apply (case_tac "xs1", simp+) done lemma map_list_snoc_snoc: " length fs = length xs \ map_list (fs @ [f]) (xs @ [x]) = map_list fs xs @ [f x]" by (simp add: map_list_append_append) lemma map_list_snoc: "\xs. length fs < length xs \ map_list (fs @ [f]) xs = map_list fs xs @ [f (xs ! (length fs))]" apply (induct fs) apply (simp add: hd_conv_nth) apply (simp add: nth_tl_eq_nth_Suc2) done lemma map_list_Cons_if: " map_list fs (x # xs) = (if (fs = []) then [] else ( ((hd fs) x) # map_list (tl fs) xs))" by (case_tac "fs", simp+) lemma map_list_Cons_not_empty: " fs \ [] \ map_list fs (x # xs) = ((hd fs) x) # map_list (tl fs) xs" by (simp add: map_list_Cons_if) lemma map_eq_map_list_take: "\xs. \ length fs \ length xs; list_all (\x. x = f) fs \ \ map_list fs xs = map f (xs \ length fs)" apply (induct fs, simp+) apply (case_tac xs, simp+) done lemma map_eq_map_list_take2: " \ length fs = length xs; list_all (\x. x = f) fs \ \ map_list fs xs = map f xs" by (simp add: map_eq_map_list_take) lemma map_eq_map_list_replicate: " map_list (f\<^bsup>length xs\<^esup>) xs = map f xs" by (induct xs, simp+) subsubsection \Mapping functions with two arguments to lists\ primrec map2 :: " \ \Function taking two parameters\ ('a \ 'b \ 'c) \ \ \Lists of parameters\ 'a list \ 'b list \ 'c list" where "map2 f [] ys = []" | "map2 f (x # xs) ys = f x (hd ys) # map2 f xs (tl ys)" lemma map2_map_list_conv: "\ys. map2 f xs ys = map_list (map f xs) ys" by (induct xs, simp+) lemma map2_Nil: "map2 f [] ys = []" by simp lemma map2_Cons_Cons: " map2 f (x # xs) (y # ys) = (f x y) # map2 f xs ys" by simp lemma map2_length: "\ys. length (map2 f xs ys) = length xs" by (induct xs, simp+) corollary map2_empty_conv: " (map2 f xs ys = []) = (xs = [])" by (simp del: length_0_conv add: length_0_conv[symmetric] map2_length) corollary map2_not_empty_conv: " (map2 f xs ys \ []) = (xs \ [])" by (simp add: map2_empty_conv) lemma map2_nth: "\n ys. \ n < length xs; n < length ys \ \ (map2 f xs ys ! n) = f (xs ! n) (ys ! n)" by (simp add: map2_map_list_conv map_list_nth) lemma map2_ys_take: "\n ys. length xs \ n \ map2 f xs (ys \ n) = map2 f xs ys" by (simp add: map2_map_list_conv map_list_xs_take) lemma map2_take: "\n ys. (map2 f xs ys) \ n = (map2 f (xs \ n) ys)" by (simp add: map2_map_list_conv take_map map_list_take) lemma map2_take_take: "\n ys. (map2 f xs ys) \ n = (map2 f (xs \ n) (ys \ n))" by (simp add: map2_take map2_ys_take) lemma map2_drop: "\n ys. (map2 f xs ys) \ n = (map2 f (xs \ n) (ys \ n))" by (simp add: map2_map_list_conv map_list_drop drop_map) lemma map2_append_append: "\ys1 . length xs1 = length ys1 \ map2 f (xs1 @ xs2) (ys1 @ ys2) = map2 f xs1 ys1 @ map2 f xs2 ys2" by (simp add: map2_map_list_conv map_list_append_append) lemma map2_snoc_snoc: " length xs = length ys \ map2 f (xs @ [x]) (ys @ [y]) = map2 f xs ys @ [f x y]" by (simp add: map2_append_append) lemma map2_snoc: "\ys. length xs < length ys \ map2 f (xs @ [x]) ys = map2 f xs ys @ [f x (ys ! (length xs))]" by (simp add: map2_map_list_conv map_list_snoc) lemma map2_Cons_if: " map2 f xs (y # ys) = (if (xs = []) then [] else ( (f (hd xs) y) # map2 f (tl xs) ys))" by (case_tac "xs", simp+) lemma map2_Cons_not_empty: " xs \ [] \ map2 f xs (y # ys) = (f (hd xs) y) # map2 f (tl xs) ys" by (simp add: map2_Cons_if) lemma map2_append1_take_drop: " length xs1 \ length ys \ map2 f (xs1 @ xs2) ys = map2 f xs1 (ys \ length xs1) @ map2 f xs2 (ys \ length xs1)" apply (rule_tac t = "map2 f (xs1 @ xs2) ys" and s = "map2 f (xs1 @ xs2) (ys \ length xs1 @ ys \ length xs1)" in subst) apply simp apply (simp add: map2_append_append del: append_take_drop_id) done lemma map2_append2_take_drop: " length ys1 \ length xs \ map2 f xs (ys1 @ ys2) = map2 f (xs \ length ys1) ys1 @ map2 f (xs \ length ys1) ys2" apply (rule_tac t = "map2 f xs (ys1 @ ys2)" and s = "map2 f (xs \ length ys1 @ xs \ length ys1) (ys1 @ ys2)" in subst) apply simp apply (simp add: map2_append_append del: append_take_drop_id) done lemma map2_cong: " \ xs1 = xs2; ys1 = ys2; length xs2 \ length ys2; \x y. \ x \ set xs2; y \ set ys2 \ \ f x y = g x y \ \ map2 f xs1 ys1 = map2 g xs2 ys2" by (simp (no_asm_simp) add: expand_list_eq map2_length map2_nth) lemma map2_eq_conv: " length xs \ length ys \ (map2 f xs ys = map2 g xs ys) = (\in\<^esup> y\<^bsup>n\<^esup> = (f x y)\<^bsup>n\<^esup>" by (induct n, simp+) lemma map2_zip_conv: "\ys. length xs \ length ys \ map2 f xs ys = map ($$x,y). f x y) (zip xs ys)" apply (induct xs, simp) apply (case_tac ys, simp+) done lemma map2_rev: "\ys. length xs = length ys \ rev (map2 f xs ys) = map2 f (rev xs) (rev ys)" apply (induct xs, simp) apply (case_tac ys, simp) apply (simp add: map2_Cons_Cons map2_snoc_snoc) done hide_const (open) map2 end diff --git a/thys/LocalLexing/Derivations.thy b/thys/LocalLexing/Derivations.thy --- a/thys/LocalLexing/Derivations.thy +++ b/thys/LocalLexing/Derivations.thy @@ -1,942 +1,942 @@ theory Derivations imports CFG ListTools InductRules begin (* leftderives and leftderives1 *) context CFG begin lemma [simp]: "is_terminal t \ is_symbol t" by (auto simp add: is_terminal_def is_symbol_def) lemma [simp]: "is_sentence []" by (auto simp add: is_sentence_def) lemma [simp]: "is_word []" by (auto simp add: is_word_def) lemma [simp]: "is_word u \ is_sentence u" by (induct u, auto simp add: is_word_def is_sentence_def) definition leftderives1 :: "sentence \ sentence \ bool" where "leftderives1 u v = (\ x y N \. u = x @ [N] @ y \ v = x @ \ @ y \ is_word x \ is_sentence y \ (N,$$ \ \)" lemma leftderives1_implies_derives1[simp]: "leftderives1 u v \ derives1 u v" apply (auto simp add: leftderives1_def derives1_def) apply (rule_tac x="x" in exI) apply (rule_tac x="y" in exI) apply (rule_tac x="N" in exI) by auto definition leftderivations1 :: "(sentence \ sentence) set" where "leftderivations1 = { (u,v) | u v. leftderives1 u v }" lemma [simp]: "leftderivations1 \ derivations1" by (auto simp add: leftderivations1_def derivations1_def) definition leftderivations :: "(sentence \ sentence) set" where "leftderivations = leftderivations1^*" lemma rtrancl_subset_implies: "a \ b \ a \ b^*" by blast lemma leftderivations_subset_derivations[simp]: "leftderivations \ derivations" apply (simp add: leftderivations_def derivations_def) apply (rule rtrancl_subset_rtrancl) apply (rule rtrancl_subset_implies) by simp definition leftderives :: "sentence \ sentence \ bool" where "leftderives u v = ((u, v) \ leftderivations)" lemma leftderives_implies_derives[simp]: "leftderives u v \ derives u v" apply (auto simp add: leftderives_def derives_def) by (rule subsetD[OF leftderivations_subset_derivations]) definition is_leftderivation :: "sentence \ bool" where "is_leftderivation u = leftderives [$ u" lemma leftderivation_implies_derivation[simp]: "is_leftderivation u \ is_derivation u" by (simp add: is_leftderivation_def is_derivation_def) lemma leftderives_refl[simp]: "leftderives u u" by (auto simp add: leftderives_def leftderivations_def) lemma leftderives1_implies_leftderives[simp]:"leftderives1 a b \ leftderives a b" by (auto simp add: leftderives_def leftderivations_def leftderivations1_def) lemma leftderives_trans: "leftderives a b \ leftderives b c \ leftderives a c" by (auto simp add: leftderives_def leftderivations_def) lemma leftderives1_eq_leftderivations1: "leftderives1 x y = ((x, y) \ leftderivations1)" by (simp add: leftderivations1_def) lemma leftderives_induct[consumes 1, case_names Base Step]: assumes derives: "leftderives a b" assumes Pa: "P a" assumes induct: "\y z. leftderives a y \ leftderives1 y z \ P y \ P z" shows "P b" proof - note rtrancl_lemma = rtrancl_induct[where a = a and b = b and r = leftderivations1 and P=P] from derives Pa induct rtrancl_lemma show "P b" by (metis leftderives_def leftderivations_def leftderives1_eq_leftderivations1) qed end (* Basic lemmas about derives1 and derives *) context CFG begin lemma derives1_implies_derives[simp]:"derives1 a b \ derives a b" by (auto simp add: derives_def derivations_def derivations1_def) lemma derives_trans: "derives a b \ derives b c \ derives a c" by (auto simp add: derives_def derivations_def) lemma derives1_eq_derivations1: "derives1 x y = ((x, y) \ derivations1)" by (simp add: derivations1_def) lemma derives_induct[consumes 1, case_names Base Step]: assumes derives: "derives a b" assumes Pa: "P a" assumes induct: "\y z. derives a y \ derives1 y z \ P y \ P z" shows "P b" proof - note rtrancl_lemma = rtrancl_induct[where a = a and b = b and r = derivations1 and P=P] from derives Pa induct rtrancl_lemma show "P b" by (metis derives_def derivations_def derives1_eq_derivations1) qed end (* Derives1 and Derivation, LDerives1 and LDerivation *) context CFG begin definition Derives1 :: "sentence \ nat \ rule \ sentence \ bool" where "Derives1 u i r v = (\ x y N \. u = x @ [N] @ y \ v = x @ \ @ y \ is_sentence x \ is_sentence y \ (N, \) \ \ \ r = (N, \) \ i = length x)" lemma Derives1_split: "Derives1 u i r v \ \ x y. u = x @ [fst r] @ y \ v = x @ (snd r) @ y \ length x = i" by (metis Derives1_def fst_conv snd_conv) lemma Derives1_implies_derives1: "Derives1 u i r v \ derives1 u v" by (auto simp add: Derives1_def derives1_def) lemma derives1_implies_Derives1: "derives1 u v \ \ i r. Derives1 u i r v" by (auto simp add: Derives1_def derives1_def) lemma Derives1_unique_dest: "Derives1 u i r v \ Derives1 u i r w \ v = w" by (auto simp add: Derives1_def derives1_def) lemma Derives1_unique_src: "Derives1 u i r w \ Derives1 v i r w \ u = v" by (auto simp add: Derives1_def derives1_def) type_synonym derivation = "(nat \ rule) list" fun Derivation :: "sentence \ derivation \ sentence \ bool" where "Derivation a [] b = (a = b)" | "Derivation a (d#D) b = (\ x. Derives1 a (fst d) (snd d) x \ Derivation x D b)" lemma Derivation_implies_derives: "Derivation a D b \ derives a b" proof (induct D arbitrary: a b) case Nil thus ?case by (simp add: derives_def derivations_def) next case (Cons d D) note ihyps = this from ihyps have "\ x. Derives1 a (fst d) (snd d) x \ Derivation x D b" by auto then obtain x where "Derives1 a (fst d) (snd d) x" and xb: "Derivation x D b" by blast with Derives1_implies_derives1 have d1: "derives a x" by auto from ihyps xb have d2:"derives x b" by simp show "derives a b" by (rule derives_trans[OF d1 d2]) qed lemma Derivation_Derives1: "Derivation a S y \ Derives1 y i r z \ Derivation a (S@[(i,r)]) z" proof (induct S arbitrary: a y z i r) case Nil thus ?case by simp next case (Cons s S) thus ?case by (metis Derivation.simps(2) append_Cons) qed lemma derives_implies_Derivation: "derives a b \ \ D. Derivation a D b" proof (induct rule: derives_induct) case Base show ?case by (rule exI[where x="[]"], simp) next case (Step y z) note ihyps = this from ihyps obtain D where ay: "Derivation a D y" by blast from ihyps derives1_implies_Derives1 obtain i r where yz: "Derives1 y i r z" by blast from Derivation_Derives1[OF ay yz] show ?case by auto qed lemma Derives1_take: "Derives1 a i r b \ take i a = take i b" by (auto simp add: Derives1_def) lemma Derives1_drop: "Derives1 a i r b \ drop (Suc i) a = drop (i + length (snd r)) b" by (auto simp add: Derives1_def) lemma Derives1_bound: "Derives1 a i r b \ i < length a" by (auto simp add: Derives1_def) lemma Derives1_length: "Derives1 a i r b \ length b = length a + length (snd r) - 1" by (auto simp add: Derives1_def) definition leftmost :: "nat \ sentence \ bool" where "leftmost i s = (i < length s \ is_word (take i s) \ is_nonterminal (s ! i))" lemma set_take: "set (take n s) = { s ! i | i. i < n \ i < length s}" proof (cases "n \ length s") case True thus ?thesis by (subst List.nth_image[symmetric], auto) next case False thus ?thesis apply (subst set_conv_nth) by (metis less_trans linear not_le take_all) qed lemma list_all_take: "list_all P (take n s) = (\ i. i < n \ i < length s \ P (s ! i))" by (auto simp add: set_take list_all_iff) lemma is_sentence_concat: "is_sentence (x@y) = (is_sentence x \ is_sentence y)" by (auto simp add: is_sentence_def) lemma is_sentence_cons: "is_sentence (x#xs) = (is_symbol x \ is_sentence xs)" by (auto simp add: is_sentence_def) lemma rule_nonterminal_type[simp]: "(N, \) \ \ \ is_nonterminal N" apply (insert validRules) by (auto simp add: is_nonterminal_def) lemma rule_\_type[simp]: "(N, \) \ \ \ is_sentence \" apply (insert validRules) by (auto simp add: is_sentence_def is_symbol_def list_all_iff is_terminal_def is_nonterminal_def) lemma [simp]: "is_nonterminal N \ is_symbol N" by (simp add: is_symbol_def) lemma Derives1_sentence1[elim]: "Derives1 a i r b \ is_sentence a" by (auto simp add: Derives1_def is_sentence_cons is_sentence_concat) lemma Derives1_sentence2[elim]: "Derives1 a i r b \ is_sentence b" by (auto simp add: Derives1_def is_sentence_cons is_sentence_concat) lemma [elim]: "Derives1 a i r b \ r \ \" using Derives1_def by auto lemma is_sentence_symbol: "is_sentence a \ i < length a \ is_symbol (a ! i)" by (simp add: is_sentence_def list_all_iff) lemma is_symbol_distinct: "is_symbol x \ is_terminal x \ is_nonterminal x" apply (insert disjunct_symbols) apply (auto simp add: is_symbol_def is_terminal_def is_nonterminal_def) done lemma is_terminal_nonterminal: "is_terminal x \ is_nonterminal x \ False" by (metis is_symbol_def is_symbol_distinct) lemma Derives1_leftmost: assumes "Derives1 a i r b" shows "\ j. leftmost j a \ j \ i" proof - let ?J = "{j . j < length a \ is_nonterminal (a ! j)}" let ?M = "Min ?J" from assms have J1:"i \ ?J" apply (auto simp add: Derives1_def is_nonterminal_def) by (metis (mono_tags, lifting) prod.simps(2) validRules) have J2:"finite ?J" by auto note J = J1 J2 from J have M1: "?M \ ?J" by (rule_tac Min_in, auto) { fix j assume "j \ ?J" with J have "?M \ j" by auto } note M3 = this[OF J1] from assms have a_sentence: "is_sentence a" by (simp add: Derives1_sentence1) have is_word: "is_word (take ?M a)" apply (auto simp add: is_word_def list_all_take) proof - fix i assume i_less_M: "i < ?M" assume i_inbounds: "i < length a" show "is_terminal (a ! i)" proof(cases "is_terminal (a ! i)") case True thus ?thesis by auto next case False then have "is_nonterminal (a ! i)" using i_inbounds a_sentence is_sentence_symbol is_symbol_distinct by blast then have "i \ ?J" by (metis i_inbounds mem_Collect_eq) then have "?M < i" by (metis J2 Min_le i_less_M leD) then have "False" by (metis i_less_M less_asym') then show ?thesis by auto qed qed show ?thesis apply (rule_tac exI[where x="?M"]) apply (simp add: leftmost_def) by (metis (mono_tags, lifting) M1 M3 is_word mem_Collect_eq) qed lemma Derivation_leftmost: "D \ [] \ Derivation a D b \ \ i. leftmost i a" apply (case_tac "D") apply (auto) apply (metis Derives1_leftmost) done lemma nonword_has_nonterminal: "is_sentence a \ \ (is_word a) \ \ k. k < length a \ is_nonterminal (a ! k)" apply (auto simp add: is_sentence_def list_all_iff is_word_def) by (metis in_set_conv_nth is_symbol_distinct) lemma leftmost_cons_nonterminal: "is_nonterminal x \ leftmost 0 (x#xs)" by (metis CFG.is_word_def CFG_axioms leftmost_def length_greater_0_conv list.distinct(1) list_all_simps(2) nth_Cons_0 take_Cons') lemma leftmost_cons_terminal: "is_terminal x \ leftmost i (x#xs) = (i > 0 \ leftmost (i - 1) xs)" by (metis Suc_diff_1 Suc_less_eq is_terminal_nonterminal is_word_def leftmost_def length_Cons list_all_simps(1) not_gr0 nth_Cons' take_Cons') lemma is_nonterminal_cons_terminal: "is_terminal x \ k < length (x # a) \ is_nonterminal ((x # a) ! k) \ k > 0 \ k - 1 < length a \ is_nonterminal (a ! (k - 1))" by (metis One_nat_def Suc_leI is_terminal_nonterminal less_diff_conv2 list.size(4) nth_non_equal_first_eq) lemma leftmost_exists: "is_sentence a \ k < length a \ is_nonterminal (a ! k) \ \ i. leftmost i a \ i \ k" proof (induct a arbitrary: k) case Nil thus ?case by auto next case (Cons x a) show ?case proof(cases "is_nonterminal x") case True thus ?thesis apply(rule_tac exI[where x="0"]) apply (simp add: leftmost_cons_nonterminal) done next case False then have x: "is_terminal x" by (metis Cons.prems(1) is_sentence_cons is_symbol_distinct) note k = is_nonterminal_cons_terminal[OF x Cons(3) Cons(4)] with Cons have "\i. leftmost i a \ i \ k - 1" by (metis is_sentence_cons) then show ?thesis apply (auto simp add: leftmost_cons_terminal[OF x]) - by (metis le_diff_conv2 Suc_leI add_Suc_right add_diff_cancel_right' k + by (metis Nat.le_diff_conv2 Suc_leI add_Suc_right add_diff_cancel_right' k le_0_eq le_imp_less_Suc nat_le_linear) qed qed lemma nonword_leftmost_exists: "is_sentence a \ \ (is_word a) \ \ i. leftmost i a" by (metis leftmost_exists nonword_has_nonterminal) lemma leftmost_unaffected_Derives1: "leftmost j a \ j < i \ Derives1 a i r b \ leftmost j b" apply (simp add: leftmost_def) proof - assume a1: "j < length a \ is_word (take j a) \ is_nonterminal (a ! j)" assume a2: "j < i" assume "Derives1 a i r b" then have f3: "take i a = take i b" by (metis Derives1_take) have f4: "\n ss ssa. take (length (take n (ss::symbol list))) (ssa::symbol list) = take (length ss) (take n ssa)" by (metis length_take take_take) have f5: "\ss. take j (ss::symbol list) = take i (take j ss)" using a2 by (metis dual_order.strict_implies_order min.absorb2 take_take) have f6: "length (take j a) = j" using a1 by (metis dual_order.strict_implies_order length_take min.absorb2) then have f7: "\n. min j n = length (take n (take j a))" by (metis length_take) have f8: "\n ss. n = length (take n (ss::symbol list)) \ length ss < n" by (metis leI length_take min.absorb2) have f9: "\ss. take j (ss::symbol list) = take j (take i ss)" using f7 f6 f5 by (metis take_take) have f10: "\ss n. length (ss::symbol list) \ n \ length (take n ss) = n" using f8 by (metis dual_order.strict_implies_order) then have f11: "\ss ssa. length (ss::symbol list) = length (take (length ss) (ssa::symbol list)) \ length (take (length ssa) ss) = length ssa" by (metis length_take min.absorb2) have f12: "\ss ssa n. take (length (ss::symbol list)) (ssa::symbol list) = take n (take (length ss) ssa) \ length (take n ss) = n" using f10 by (metis min.absorb2 take_take) { assume "\ j < j" { assume "\ j < j \ i \ j" moreover { assume "length a \ j \ length (take i a) \ i" then have "\ss. length (take (length (take i (take (length a) (ss::symbol list)))) (take j ss)) \ length (take i (take (length a) ss))" using f12 f11 f6 f5 f4 by metis then have "\ss ssa. take (length (ss::symbol list)) (take j (ssa::symbol list)) \ take (length ss) (take i (take (length a) ssa))" using f11 by metis then have "length b \ j" using f9 f4 f3 by metis } ultimately have "length b \ j" using f7 f6 f5 f3 a1 by (metis length_take) } then have "length b = j \ j < j" using a2 by metis } then have "j < length b" using f9 f8 f7 f6 f4 f3 by metis then show "j < length b \ is_word (take j b) \ is_nonterminal (b ! j)" using f9 f3 a2 a1 by (metis nth_take) qed definition derivation_ge :: "derivation \ nat \ bool" where "derivation_ge D i = (\ d \ set D. fst d \ i)" lemma derivation_ge_cons: "derivation_ge (d#D) i = (fst d \ i \ derivation_ge D i)" by (auto simp add: derivation_ge_def) lemma derivation_ge_append: "derivation_ge (D@E) i = (derivation_ge D i \ derivation_ge E i)" by (auto simp add: derivation_ge_def) lemma leftmost_unaffected_Derivation: "derivation_ge D (Suc i) \ leftmost i a \ Derivation a D b \ leftmost i b" proof (induct D arbitrary: a) case Nil thus ?case by auto next case (Cons d D) then have "\ x. Derives1 a (fst d) (snd d) x \ Derivation x D b" by simp then obtain x where x1: "Derives1 a (fst d) (snd d) x" and x2: "Derivation x D b" by blast with Cons have leftmost_x: "leftmost i x" apply (rule_tac leftmost_unaffected_Derives1[ where a=a and j=i and b="x" and i="fst d" and r="snd d"]) by (auto simp add: derivation_ge_def) with Cons x2 show ?case by (auto simp add: derivation_ge_def) qed lemma le_Derives1_take: assumes le: "i \ j" and D: "Derives1 a j r b" shows "take i a = take i b" proof - note Derives1_take[where a=a and i=j and r=r and b=b] with le D show ?thesis by (rule_tac le_take_same[where i=i and j=j], auto) qed lemma Derivation_take: "derivation_ge D i \ Derivation a D b \ take i a = take i b" proof(induct D arbitrary: a b) case Nil thus ?case by auto next case (Cons d D) then have "\ x. Derives1 a (fst d) (snd d) x \ Derivation x D b" by simp then obtain x where ax: "Derives1 a (fst d) (snd d) x" and xb: "Derivation x D b" by blast from derivation_ge_cons Cons(2) have d: "i \ fst d" and D: "derivation_ge D i" by auto note take_i_xb = Cons(1)[OF D xb] note take_i_ax = le_Derives1_take[OF d ax] from take_i_xb take_i_ax show ?case by auto qed lemma leftmost_cons_less: "i < length u \ leftmost i (u@v) = leftmost i u" by (auto simp add: leftmost_def nth_append) lemma leftmost_is_nonterminal: "leftmost i u \ is_nonterminal (u ! i)" by (metis leftmost_def) lemma is_word_is_terminal: "i < length u \ is_word u \ is_terminal (u ! i)" by (metis is_word_def list_all_length) lemma leftmost_append: assumes leftmost: "leftmost i (u@v)" and is_word: "is_word u" shows "length u \ i" proof (cases "i < length u") case False thus ?thesis by auto next case True with leftmost have "leftmost i u" using leftmost_cons_less[OF True] by simp then have is_nonterminal: "is_nonterminal (u ! i)" by (rule leftmost_is_nonterminal) note is_terminal = is_word_is_terminal[OF True is_word] note is_terminal_nonterminal[OF is_terminal is_nonterminal] then show ?thesis by auto qed lemma derivation_ge_empty[simp]: "derivation_ge [] i" by (simp add: derivation_ge_def) lemma leftmost_notword: "leftmost i a \ j > i \ \ (is_word (take j a))" by (metis is_terminal_nonterminal is_word_def leftmost_def list_all_take) lemma leftmost_unique: "leftmost i a \ leftmost j a \ i = j" by (metis leftmost_def leftmost_notword linorder_neqE_nat) lemma leftmost_Derives1: "leftmost i a \ Derives1 a j r b \ i \ j" by (metis Derives1_leftmost leftmost_unique) lemma leftmost_Derives1_propagate: assumes leftmost: "leftmost i a" and Derives1: "Derives1 a j r b" shows "(is_word b \ i = j) \ (\ k. leftmost k b \ i \ k)" proof - from leftmost_Derives1[OF leftmost Derives1] have ij: "i \ j" by auto show ?thesis proof (cases "is_word b") case True show ?thesis by (metis Derives1 True ij le_neq_implies_less leftmost leftmost_unaffected_Derives1 order_refl) next case False show ?thesis by (metis (no_types, hide_lams) Derives1 Derives1_bound Derives1_sentence2 Derives1_take append_take_drop_id ij le_neq_implies_less leftmost leftmost_append leftmost_cons_less leftmost_def length_take min.absorb2 nat_le_linear nonword_leftmost_exists not_le) qed qed lemma is_word_Derives1[elim]: "is_word a \ Derives1 a i r b \ False" by (metis Derives1_leftmost is_terminal_nonterminal is_word_is_terminal leftmost_def) lemma is_word_Derivation[elim]: "is_word a \ Derivation a D b \ D = []" by (metis Derivation_leftmost is_terminal_nonterminal is_word_def leftmost_def list_all_length) lemma leftmost_Derivation: "leftmost i a \ Derivation a D b \ j \ i \ derivation_ge D j" proof (induct D arbitrary: a b i j) case Nil thus ?case by auto next case (Cons d D) then have "\ x. Derives1 a (fst d) (snd d) x \ Derivation x D b" by auto then obtain x where ax:"Derives1 a (fst d) (snd d) x" and xb:"Derivation x D b" by blast note ji = Cons(4) note i_fstd = leftmost_Derives1[OF Cons(2) ax] note disj = leftmost_Derives1_propagate[OF Cons(2) ax] thus ?case proof(induct rule: disjCases2) case 1 with xb have "D = []" by auto with 1 ji show ?case by (simp add: derivation_ge_def) next case 2 then obtain k where k: "leftmost k x" and ik: "i \ k" by blast note ge = Cons(1)[OF k xb, where j=j] from ji ik i_fstd ge show ?case by (simp add: derivation_ge_cons) qed qed lemma derivation_ge_list_all: "derivation_ge D i = list_all (\ d. fst d \ i) D" by (simp add: Ball_set derivation_ge_def) lemma split_derivation_leftmost: assumes "derivation_ge D i" and "\ (derivation_ge D (Suc i))" shows "\ E F r. D = E@[(i, r)]@F \ derivation_ge E (Suc i)" proof - from assms have "\ k. k < length D \ fst(D ! k) \ i \ $$fst(D ! k) \ Suc i)" by (metis derivation_ge_def in_set_conv_nth) then have "\ k. k < length D \ fst(D ! k) = i" by auto then show ?thesis proof(induct rule: ex_minimal_witness) case (Minimal k) then have k_len: "k < length D" and k_i: "fst (D ! k) = i" by auto let ?E = "take k D" let ?r = "snd (D ! k)" let ?F = "drop (Suc k) D" note split = split_list_at[OF k_len] from k_i have D_k: "D ! k = (i, ?r)" by auto show ?case apply (rule exI[where x="?E"]) apply (rule exI[where x="?F"]) apply (rule exI[where x="?r"]) apply (subst D_k[symmetric]) apply (rule conjI) apply (rule split) by (metis (mono_tags, lifting) Minimal.hyps(2) Suc_leI assms(1) derivation_ge_list_all le_neq_implies_less list_all_length list_all_take) qed qed lemma Derives1_Derives1_swap: assumes "i < j" and "Derives1 a j p b" and "Derives1 b i q c" shows "\ b'. Derives1 a i q b' \ Derives1 b' (j - 1 + length (snd q)) p c" proof - from Derives1_split[OF assms(2)] obtain a1 a2 where a_src: "a = a1 @ [fst p] @ a2" and a_dest: "b = a1 @ snd p @ a2" and a1_len: "length a1 = j" by blast note a = this from a have is_sentence_a1: "is_sentence a1" using Derives1_sentence2 assms(2) is_sentence_concat by blast from a have is_sentence_a2: "is_sentence a2" using Derives1_sentence2 assms(2) is_sentence_concat by blast from a have is_symbol_fst_p: "is_symbol (fst p)" by (metis Derives1_sentence1 assms(2) is_sentence_concat is_sentence_cons) from Derives1_split[OF assms(3)] obtain b1 b2 where b_src: "b = b1 @ [fst q] @ b2" and b_dest: "c = b1 @ snd q @ b2" and b1_len: "length b1 = i" by blast have a_take_j: "a1 = take j a" by (metis a1_len a_src append_eq_conv_conj) have b_take_i: "b1 @ [fst q] = take (Suc i) b" by (metis append_assoc append_eq_conv_conj b1_len b_src length_append_singleton) from a_take_j b_take_i take_eq_take_append[where j=j and i="Suc i" and a=a] have "\ u. a1 = (b1 @ [fst q]) @ u" by (metis le_iff_add Suc_leI a1_len a_dest append_eq_conv_conj assms(1) take_add) then obtain u where u1: "a1 = (b1 @ [fst q]) @ u" by blast then have j_i_u: "j = i + 1 + length u" using Suc_eq_plus1 a1_len b1_len length_append length_append_singleton by auto from u1 is_sentence_a1 have is_sentence_b1_u: "is_sentence b1 \ is_sentence u" using is_sentence_concat by blast have u2: "b2 = u @ snd p @ a2" by (metis a_dest append_assoc b_src same_append_eq u1) let ?b = "b1 @ (snd q) @ u @ [fst p] @ a2" from assms have q_dom: "q \ \" by auto have a_b': "Derives1 a i q ?b" apply (subst Derives1_def) apply (rule exI[where x="b1"]) apply (rule exI[where x="u@[fst p]@a2"]) apply (rule exI[where x="fst q"]) apply (rule exI[where x="snd q"]) apply (auto simp add: b1_len is_sentence_cons is_sentence_concat is_sentence_a2 is_symbol_fst_p is_sentence_b1_u a_src u1 q_dom) done from assms have p_dom: "p \ \" by auto have is_sentence_snd_q: "is_sentence (snd q)" using Derives1_sentence2 a_b' is_sentence_concat by blast have b'_c: "Derives1 ?b (j - 1 + length (snd q)) p c" apply (subst Derives1_def) apply (rule exI[where x="b1 @ (snd q) @ u"]) apply (rule exI[where x="a2"]) apply (rule exI[where x="fst p"]) apply (rule exI[where x="snd p"]) apply (auto simp add: is_sentence_concat is_sentence_b1_u is_sentence_a2 p_dom is_sentence_snd_q b_dest u2 b1_len j_i_u) done show ?thesis apply (rule exI[where x="?b"]) apply (rule conjI) apply (rule a_b') apply (rule b'_c) done qed definition derivation_shift :: "derivation \ nat \ nat \ derivation" where "derivation_shift D left right = map (\ d. (fst d - left + right, snd d)) D" lemma derivation_shift_empty[simp]: "derivation_shift [] left right = []" by (auto simp add: derivation_shift_def) lemma derivation_shift_cons[simp]: "derivation_shift (d#D) left right = ((fst d - left + right, snd d)#(derivation_shift D left right))" by (simp add: derivation_shift_def) lemma Derivation_append: "Derivation a (D@E) c = (\ b. Derivation a D b \ Derivation b E c)" proof(induct D arbitrary: a c E) case Nil thus ?case by auto next case (Cons d D) thus ?case by auto qed lemma Derivation_implies_append: "Derivation a D b \ Derivation b E c \ Derivation a (D@E) c" using Derivation_append by blast lemma Derivation_swap_single_end_to_front: "i < j \ derivation_ge D j \ Derivation a (D@[(i,r)]) b \ Derivation a ((i,r)#(derivation_shift D 1 (length (snd r)))) b" proof(induct D arbitrary: a) case Nil thus ?case by auto next case (Cons d D) from Cons have "\ c. Derives1 a (fst d) (snd d) c \ Derivation c (D @ [(i, r)]) b" by simp then obtain c where ac: "Derives1 a (fst d) (snd d) c" and cb: "Derivation c (D @ [(i, r)]) b" by blast from Cons(3) have D_j: "derivation_ge D j" by (simp add: derivation_ge_cons) from Cons(1)[OF Cons(2) D_j cb, simplified] obtain x where cx: "Derives1 c i r x" and xb: "Derivation x (derivation_shift D 1 (length (snd r))) b" by auto have i_fst_d: "i < fst d" using Cons derivation_ge_cons by auto from Derives1_Derives1_swap[OF i_fst_d ac cx] obtain b' where ab': "Derives1 a i r b'" and b'x: "Derives1 b' (fst d - 1 + length (snd r)) (snd d) x" by blast show ?case using ab' b'x xb by auto qed lemma Derivation_swap_single_mid_to_front: assumes "i < j" and "derivation_ge D j" and "Derivation a (D@[(i,r)]@E) b" shows "Derivation a ((i,r)#((derivation_shift D 1 (length (snd r)))@E)) b" proof - from assms have "\ x. Derivation a (D@[(i, r)]) x \ Derivation x E b" using Derivation_append by auto then obtain x where ax: "Derivation a (D@[(i, r)]) x" and xb: "Derivation x E b" by blast with assms have "Derivation a ((i, r)#(derivation_shift D 1 (length (snd r)))) x" using Derivation_swap_single_end_to_front by blast then show ?thesis using Derivation_append xb by auto qed lemma length_derivation_shift[simp]: "length(derivation_shift D left right) = length D" by (simp add: derivation_shift_def) definition LeftDerives1 :: "sentence \ nat \ rule \ sentence \ bool" where "LeftDerives1 u i r v = (leftmost i u \ Derives1 u i r v)" lemma LeftDerives1_implies_leftderives1: "LeftDerives1 u i r v \ leftderives1 u v" by (metis Derives1_def LeftDerives1_def append_eq_conv_conj leftderives1_def leftmost_def) lemma leftmost_Derives1_leftderives: "leftmost i a \ Derives1 a i r b \ leftderives b c \ leftderives a c" using LeftDerives1_def LeftDerives1_implies_leftderives1 leftderives1_implies_leftderives leftderives_trans by blast theorem Derivation_implies_leftderives_gen: "Derivation a D (u@v) \ is_word u \ (\ w. leftderives a (u@w) \ (v = [] \ w = []) \ (\ X. is_first X v \ is_first X w))" proof (induct "length D" arbitrary: D a u v) case 0 then have "a = u@v" by auto thus ?case by (rule_tac x = v in exI, auto) next case (Suc n) from Suc have "D \ []" by auto with Suc Derivation_leftmost have "\ i. leftmost i a" by auto then obtain i where i: "leftmost i a" by blast show "?case" proof (cases "derivation_ge D (Suc i)") case True with Suc have leftmost: "leftmost i (u@v)" by (rule_tac leftmost_unaffected_Derivation[OF True i], auto) have length_u: "length u \ i" using leftmost_append[OF leftmost Suc(4)] . have take_Suc: "take (Suc i) a = take (Suc i) (u@v)" using Derivation_take[OF True Suc(3)] . with length_u have is_prefix_u: "is_prefix u a" by (metis append_assoc append_take_drop_id dual_order.strict_implies_order is_prefix_def le_imp_less_Suc take_all take_append) have a: "u @ drop (length u) a = a" using is_prefix_unsplit[OF is_prefix_u] . from take_Suc have length_take_Suc: "length (take (Suc i) a) = Suc i" by (metis Suc_leI i leftmost_def length_take min.absorb2) have v: "v \ []" proof(cases "v = []") case False thus ?thesis by auto next case True with length_u have right: "length(take (Suc i) (u@v)) = length u" by simp note left = length_take_Suc from left right take_Suc have "Suc i = length u" by auto with length_u show ?thesis by auto qed then have "\ X w. v = X#w" by (cases v, auto) then obtain X w where v: "v = X#w" by blast have is_first_X: "is_first X (drop (length u) a)" apply (rule_tac is_first_drop_length[where v=v and w=w and k="Suc i"]) apply (simp_all add: take_Suc v) apply (metis Suc_leI i leftmost_def) apply (insert length_u) apply arith done show ?thesis apply (rule exI[where x="drop (length u) a"]) by (simp add: a v is_first_cons is_first_X) next case False have Di: "derivation_ge D i" using leftmost_Derivation[OF i Suc(3), where j=i, simplified] . from split_derivation_leftmost[OF Di False] obtain E F r where D_split: "D = E @ [(i, r)] @ F" and E_Suc: "derivation_ge E (Suc i)" by auto let ?D = "(derivation_shift E 1 (length (snd r)))@F" from D_split have "Derivation a ((i,r) # ?D) (u @ v)" using Derivation_swap_single_mid_to_front E_Suc Suc.prems(1) lessI by blast then have "\ y. Derives1 a i r y \ Derivation y ?D (u @ v)" by simp then obtain y where ay:"Derives1 a i r y" and yuv: "Derivation y ?D (u @ v)" by blast have length_D': "length ?D = n" using D_split Suc.hyps(2) by auto from Suc(1)[OF length_D'[symmetric] yuv Suc(4)] obtain w where "leftderives y (u @ w)" and "(v = [] \ w = [])" and "\X. is_first X v \ is_first X w" by blast then show ?thesis using ay i leftmost_Derives1_leftderives by blast qed qed lemma derives_implies_leftderives_gen: "derives a (u@v) \ is_word u \ (\ w. leftderives a (u@w) \ (v = [] \ w = []) \ (\ X. is_first X v \ is_first X w))" using Derivation_implies_leftderives_gen derives_implies_Derivation by blast lemma derives_implies_leftderives: "derives a b \ is_word b \ leftderives a b" using derives_implies_leftderives_gen by force fun LeftDerivation :: "sentence \ derivation \ sentence \ bool" where "LeftDerivation a [] b = (a = b)" | "LeftDerivation a (d#D) b = (\ x. LeftDerives1 a (fst d) (snd d) x \ LeftDerivation x D b)" lemma LeftDerives1_implies_Derives1: "LeftDerives1 a i r b \ Derives1 a i r b" by (metis LeftDerives1_def) lemma LeftDerivation_implies_Derivation: "LeftDerivation a D b \ Derivation a D b" proof (induct D arbitrary: a) case (Nil) thus ?case by simp next case (Cons d D) thus ?case using CFG.LeftDerivation.simps(2) CFG_axioms Derivation.simps(2) LeftDerives1_implies_Derives1 by blast qed lemma LeftDerivation_implies_leftderives: "LeftDerivation a D b \ leftderives a b" proof (induct D arbitrary: a b) case Nil thus ?case by simp next case (Cons d D) note ihyps = this from ihyps have "\ x. LeftDerives1 a (fst d) (snd d) x \ LeftDerivation x D b" by auto then obtain x where "LeftDerives1 a (fst d) (snd d) x" and xb: "LeftDerivation x D b" by blast with LeftDerives1_implies_leftderives1 have d1: "leftderives a x" by auto from ihyps xb have d2:"leftderives x b" by simp show "leftderives a b" by (rule leftderives_trans[OF d1 d2]) qed lemma leftmost_witness[simp]: "leftmost (length x) (x@(N#y)) = (is_word x \ is_nonterminal N)" by (auto simp add: leftmost_def) lemma leftderives1_implies_LeftDerives1: assumes leftderives1: "leftderives1 u v" shows "\ i r. LeftDerives1 u i r v" proof - from leftderives1 have "\x y N \. u = x @ [N] @ y \ v = x @ \ @ y \ is_word x \ is_sentence y \ (N,$$ \ \" by (simp add: leftderives1_def) then obtain x y N \ where u:"u = x @ [N] @ y" and v:"v = x @ \ @ y" and x:"is_word x" and y:"is_sentence y" and r:"(N, \) \ \" by blast show ?thesis apply (rule_tac x="length x" in exI) apply (rule_tac x="(N, \)" in exI) apply (auto simp add: LeftDerives1_def) apply (simp add: leftmost_def x u rule_nonterminal_type[OF r]) apply (simp add: Derives1_def u v) apply (rule_tac x=x in exI) apply (rule_tac x=y in exI) apply (auto simp add: x y r) done qed lemma LeftDerivation_LeftDerives1: "LeftDerivation a S y \ LeftDerives1 y i r z \ LeftDerivation a (S@[(i,r)]) z" proof (induct S arbitrary: a y z i r) case Nil thus ?case by simp next case (Cons s S) thus ?case by (metis LeftDerivation.simps(2) append_Cons) qed lemma leftderives_implies_LeftDerivation: "leftderives a b \ \ D. LeftDerivation a D b" proof (induct rule: leftderives_induct) case Base show ?case by (rule exI[where x="[]"], simp) next case (Step y z) note ihyps = this from ihyps obtain D where ay: "LeftDerivation a D y" by blast from ihyps leftderives1_implies_LeftDerives1 obtain i r where yz: "LeftDerives1 y i r z" by blast from LeftDerivation_LeftDerives1[OF ay yz] show ?case by auto qed lemma LeftDerivation_append: "LeftDerivation a (D@E) c = (\ b. LeftDerivation a D b \ LeftDerivation b E c)" proof(induct D arbitrary: a c E) case Nil thus ?case by auto next case (Cons d D) thus ?case by auto qed lemma LeftDerivation_implies_append: "LeftDerivation a D b \ LeftDerivation b E c \ LeftDerivation a (D@E) c" using LeftDerivation_append by blast lemma Derivation_unique_dest: "Derivation a D b \ Derivation a D c \ b = c" apply (induct D arbitrary: a b c) apply auto using Derives1_unique_dest by blast lemma Derivation_unique_src: "Derivation a D c \ Derivation b D c \ a = b" apply (induct D arbitrary: a b c) apply auto using Derives1_unique_src by blast lemma LeftDerives1_unique: "LeftDerives1 a i r b \ LeftDerives1 a j s b \ i = j \ r = s" using Derives1_def LeftDerives1_def leftmost_unique by auto lemma leftlang: "\ = { v | v. is_word v \ is_leftderivation v }" by (metis (no_types, lifting) CFG.is_derivation_def CFG.is_leftderivation_def CFG.leftderivation_implies_derivation CFG_axioms Collect_cong \_def derives_implies_leftderives) lemma leftprefixlang: "\\<^sub>P = { u | u v. is_word u \ is_leftderivation (u@v) }" apply (auto simp add: \\<^sub>P_def) using derives_implies_leftderives_gen is_derivation_def is_leftderivation_def apply blast using leftderivation_implies_derivation by blast lemma derives_implies_leftderives_cons: "is_word a \ derives u (a@X#b) \ \ c. leftderives u (a@X#c)" by (metis append_Cons append_Nil derives_implies_leftderives_gen is_first_def) lemma is_word_append[simp]: "is_word (a@b) = (is_word a \ is_word b)" by (auto simp add: is_word_def) lemma \\<^sub>P_split: "a@b \ \\<^sub>P \ a \ \\<^sub>P" by (auto simp add: \\<^sub>P_def) lemma \\<^sub>P_is_word: "a \ \\<^sub>P \ is_word a" by (metis (no_types, lifting) leftprefixlang mem_Collect_eq) definition Derive :: "sentence \ derivation \ sentence" where "Derive a D = (THE b. Derivation a D b)" lemma Derivation_dest_ex_unique: "Derivation a D b \ \! x. Derivation a D x" using CFG.Derivation_unique_dest CFG_axioms by blast lemma Derive: assumes ab: "Derivation a D b" shows "Derive a D = b" proof - note the1_equality[OF Derivation_dest_ex_unique[OF ab] ab] thus ?thesis by (simp add: Derive_def) qed end end diff --git a/thys/LocalLexing/Ladder.thy b/thys/LocalLexing/Ladder.thy --- a/thys/LocalLexing/Ladder.thy +++ b/thys/LocalLexing/Ladder.thy @@ -1,3579 +1,3579 @@ theory Ladder imports TheoremD9 begin context LocalLexing begin definition LeftDerivationFix :: "sentence \ nat \ derivation \ nat \ sentence \ bool" where "LeftDerivationFix \ i D j \ = (is_sentence \ \ is_sentence \ \ LeftDerivation \ D \ \ i < length \ \ j < length \ \ \ ! i = \ ! j \ (\ E F. D = E@(derivation_shift F 0 (Suc j)) \ LeftDerivation (take i \) E (take j \) \ LeftDerivation (drop (Suc i) \) F (drop (Suc j) \)))" definition LeftDerivationIntro :: "sentence \ nat \ rule \ nat \ derivation \ nat \ sentence \ bool" where "LeftDerivationIntro \ i r ix D j \ = (\ \. LeftDerives1 \ i r \ \ ix < length (snd r) \ (snd r) ! ix = \ ! j \ LeftDerivationFix \ (i + ix) D j \)" lemma LeftDerivationFix_empty[simp]: "is_sentence \ \ i < length \ \ LeftDerivationFix \ i [] i \" apply (auto simp add: LeftDerivationFix_def) apply (rule_tac x="[]" in exI) apply auto done lemma Derive_empty[simp]: "Derive a [] = a" by (auto simp add: Derive_def) lemma LeftDerivation_append1: "LeftDerivation a (D@[(i, r)]) c \ \ b. LeftDerivation a D b \ LeftDerives1 b i r c" by (simp add: LeftDerivation_append) lemma Derivation_append1: "Derivation a (D@[(i, r)]) c \ \ b. Derivation a D b \ Derives1 b i r c" by (simp add: Derivation_append) lemma Derivation_take_derive: assumes "Derivation a D b" shows "Derivation a (take n D) (Derive a (take n D))" by (metis Derivation_append Derive append_take_drop_id assms) lemma LeftDerivation_take_derive: assumes "LeftDerivation a D b" shows "LeftDerivation a (take n D) (Derive a (take n D))" by (metis Derive LeftDerivation_append LeftDerivation_implies_Derivation append_take_drop_id assms) lemma Derivation_Derive_take_Derives1: assumes "N \ 0" assumes "N \ length D" assumes "Derivation a D b" assumes \: "\ = Derive a (take (N - 1) D)" assumes "\ = Derive a (take N D)" shows "Derives1 \ (fst (D ! (N - 1))) (snd (D ! (N - 1))) \" proof - let ?D1 = "take (N - 1) D" let ?D2 = "take N D" from assms have app: "?D2 = ?D1 @ [D ! (N - 1)]" apply auto by (metis Suc_less_eq Suc_pred le_imp_less_Suc take_Suc_conv_app_nth) from assms have "Derivation a ?D2 \" using Derivation_take_derive by blast with app show ?thesis using Derivation.simps Derivation_append Derive \ by auto qed lemma LeftDerivation_Derive_take_LeftDerives1: assumes "N \ 0" assumes "N \ length D" assumes "LeftDerivation a D b" assumes \: "\ = Derive a (take (N - 1) D)" assumes "\ = Derive a (take N D)" shows "LeftDerives1 \ (fst (D ! (N - 1))) (snd (D ! (N - 1))) \" proof - let ?D1 = "take (N - 1) D" let ?D2 = "take N D" from assms have app: "?D2 = ?D1 @ [D ! (N - 1)]" apply auto by (metis Suc_less_eq Suc_pred le_imp_less_Suc take_Suc_conv_app_nth) from assms have "LeftDerivation a ?D2 \" using LeftDerivation_take_derive by blast with app show ?thesis by (metis Derive LeftDerivation_append1 LeftDerivation_implies_Derivation \ prod.collapse) qed lemma LeftDerives1_skip_prefix: "length a \ i \ LeftDerives1 (a@b) i r (a@c) \ LeftDerives1 b (i - length a) r c" apply (auto simp add: LeftDerives1_def) using leftmost_skip_prefix apply blast by (simp add: Derives1_skip_prefix) lemma LeftDerives1_skip_suffix: assumes i: "i < length a" assumes D: "LeftDerives1 (a@c) i r (b@c)" shows "LeftDerives1 a i r b" proof - note Derives1_def[where u="a@c" and v="b@c" and i=i and r=r] then have "\x y N \. a @ c = x @ [N] @ y \ b @ c = x @ \ @ y \ is_sentence x \ is_sentence y \ (N, \) \ \ \ r = (N, \) \ i = length x" using D LeftDerives1_implies_Derives1 by auto then obtain x y N \ where split: "a @ c = x @ [N] @ y \ b @ c = x @ \ @ y \ is_sentence x \ is_sentence y \ (N, \) \ \ \ r = (N, \) \ i = length x" by blast from split have "length (a@c) = length (x @ [N] @ y)" by auto then have "length a + length c = length x + length y + 1" by simp with split have "length a + length c = i + length y + 1" by simp with i have len_c_y: "length c \ length y" by arith let ?y = "take (length y - length c) y" from split have ac: "a @ c = (x @ [N]) @ y" by auto note cancel_suffix[where a=a and c = c and b = "x@[N]" and d = "y", OF ac len_c_y] then have a: "a = x @ [N] @ ?y" by auto from split have bc: "b @ c = (x @ \) @ y" by auto note cancel_suffix[where a=b and c = c and b = "x@\" and d = "y", OF bc len_c_y] then have b: "b = x @ \ @ ?y" by auto from split len_c_y a b show ?thesis apply (simp only: LeftDerives1_def Derives1_def) apply (rule_tac conjI) using D LeftDerives1_def i leftmost_cons_less apply blast apply (rule_tac x=x in exI) apply (rule_tac x="?y" in exI) apply (rule_tac x="N" in exI) apply (rule_tac x="\" in exI) apply auto by (rule is_sentence_take) qed lemma LeftDerives1_X_is_part_of_rule[consumes 2, case_names Suffix Prefix]: assumes aXb: "LeftDerives1 \ i r (a@[X]@b)" assumes split: "splits_at \ i \ N \" assumes prefix: "\ \. \ = a @ [X] @ \ \ length a < i \ is_word (a @ [X]) \ LeftDerives1 \ (i - length a - 1) r b \ False" assumes suffix: "\ \. \ = \ @ [X] @ b \ LeftDerives1 \ i r a \ False" shows "\ u v. a = \ @ u \ b = v @ \ \ (snd r) = u@[X]@v" proof - have aXb_old: "Derives1 \ i r (a@[X]@b)" using LeftDerives1_implies_Derives1 aXb by blast have prefix_or: "is_prefix \ a \ is_proper_prefix a \" by (metis Derives1_prefix split aXb_old is_prefix_eq_proper_prefix) have is_word_\: "is_word \" using LeftDerives1_splits_at_is_word aXb assms(2) by blast have "is_proper_prefix a \ \ False" proof - assume proper:"is_proper_prefix a \" then have "\ u. u \ [] \ \ = a@u" by (metis is_proper_prefix_def) then obtain u where u: "u \ [] \ \ = a@u" by blast note splits_at = splits_at_$OF aXb_old split] splits_at_combine[OF split] from splits_at have \1: "\ = take i \" by blast from splits_at have \2: "\ = take i (a@[X]@b)" by blast from splits_at have len\: "length \ = i" by blast with proper have lena: "length a < i" using append_eq_conv_conj drop_eq_Nil leI u by auto with is_word_\ \2 have is_word_aX: "is_word (a@[X])" by (simp add: is_word_terminals not_less take_Cons' u) from u \2 have "a@u = take i (a@[X]@b)" by auto with lena have "u = take (i - length a) ([X]@b)" by (simp add: less_or_eq_imp_le) with lena have uX: "u = [X]@(take (i - length a - 1) b)" by (simp add: not_less take_Cons') let ?\ = "(take (i - length a - 1) b) @ [N] @ \" from splits_at have f1: "\ = \ @ [N] @ \" by blast with u uX have f2: "\ = a @ [X] @ ?\" by simp note skip = LeftDerives1_skip_prefix[where a = "a @ [X]" and b = "?\" and r = r and i = i and c = b] then have D: "LeftDerives1 ?\ (i - length a - 1) r b" using One_nat_def Suc_leI aXb append_assoc diff_diff_left f2 lena length_Cons length_append length_append_singleton list.size(3) by fastforce note prefix[OF f2 lena is_word_aX D] then show "False" . qed with prefix_or have is_prefix: "is_prefix \ a" by blast from aXb have aXb': "LeftDerives1 \ i r ((a@[X])@b)" by auto then have aXb'_old: "Derives1 \ i r ((a@[X])@b)" by (simp add: LeftDerives1_implies_Derives1) note Derives1_suffix[OF aXb'_old split] then have suffix_or: "is_suffix \ b \ is_proper_suffix b \" by (metis is_suffix_eq_proper_suffix) have "is_proper_suffix b \ \ False" proof - assume proper: "is_proper_suffix b \" then have "\ u. u \ [] \ \ = u@b" by (metis is_proper_suffix_def) then obtain u where u: "u \ [] \ \ = u@b" by blast note splits_at = splits_at_\[OF aXb_old split] splits_at_combine[OF split] from splits_at have \1: "\ = drop (Suc i) \" by blast from splits_at have \2: "\ = drop (i + length (snd r)) (a @ [X] @ b)" by blast from splits_at have len\: "length \ = length \ - i - 1" by blast with proper have lenb: "length b < length \" by (metis is_proper_suffix_length_cmp) from u \2 have "u@b = drop (i + length (snd r)) ((a @ [X]) @ b)" by auto hence "u = drop (i + length (snd r)) (a @ [X])" by (metis drop_cancel_suffix) hence uX: "u = drop (i + length (snd r)) a @ [X]" by (metis drop_keep_last u) let ?\ = "\ @ [N] @ (drop (i + length (snd r)) a)" from splits_at have f1: "\ = \ @ [N] @ \" by blast with u uX have f2: "\ = ?\ @ [X] @ b" by simp note skip = LeftDerives1_skip_suffix[where a = "?\" and c = "[X]@b" and b="a" and r = r and i = i] have f3: "i < length (\ @ [N] @ drop (i + length (snd r)) a)" proof - have f1: "1 + i + length b = length [X] + length b + i" by (metis Groups.add_ac(2) Suc_eq_plus1_left length_Cons list.size(3) list.size(4) semiring_normalization_rules(22)) have f2: "length \ - i - 1 = length ((\ @ [N] @ drop (i + length (snd r)) a) @ [X] @ b) - Suc i" by (metis f2 length_drop splits_at(1)) have "length ([]::symbol list) \ length \ - i - 1 - length b" by (metis add_diff_cancel_right' append_Nil2 append_eq_append_conv len\ length_append u) then have "length ([]::symbol list) \ length \ + length ([N] @ drop (i + length (snd r)) a) - i" using f2 f1 by (metis Suc_eq_plus1_left add_diff_cancel_right' diff_diff_left length_append) then show ?thesis by auto qed from aXb f2 have D: "LeftDerives1 (?\ @ [X] @ b) i r (a@[X]@b)" by auto note skip[OF f3 D] note suffix[OF f2 skip[OF f3 D]] then show "False" . qed with suffix_or have is_suffix: "is_suffix \ b" by blast from is_prefix have "\ u. a = \ @ u" by (auto simp add: is_prefix_def) then obtain u where u: "a = \ @ u" by blast from is_suffix have "\ v. b = v @ \" by (auto simp add: is_suffix_def) then obtain v where v: "b = v @ \" by blast from u v splits_at_combine[OF split] aXb have D:"LeftDerives1 (\@[N]@\) i r (\@(u@[X]@v)@\)" by simp from splits_at_\[OF aXb_old split] have i: "length \ = i" by blast from i have i1: "length \ \ i" and i2: "i \ length \" by auto note LeftDerives1_skip_suffix[OF _ LeftDerives1_skip_prefix[OF i1 D], simplified, OF i2] then have "LeftDerives1 [N] 0 r (u @ [X] @ v)" by auto then have "Derives1 [N] 0 r (u @ [X] @ v)" using LeftDerives1_implies_Derives1 by auto then have r: "snd r = u @ [X] @ v" by (metis Derives1_split append_Cons append_Nil length_0_conv list.inject self_append_conv) show ?thesis using u v r by auto qed lemma LeftDerivationFix_grow_suffix: assumes LDF: "LeftDerivationFix (b1@[X]@b2) (length b1) D j c" assumes suffix_b2: "LeftDerives1 suffix e r b2" assumes is_word_b1X: "is_word (b1@[X])" shows "LeftDerivationFix (b1@[X]@suffix) (length b1) ((e + length (b1@[X]), r)#D) j c" proof - from LDF have LDF': "is_sentence (b1@[X]@b2) \ is_sentence c \ LeftDerivation (b1 @ [X] @ b2) D c \ length b1 < length (b1 @ [X] @ b2) \ j < length c \ (b1 @ [X] @ b2) ! length b1 = c ! j \ (\E F. D = E @ derivation_shift F 0 (Suc j) \ LeftDerivation (take (length b1) (b1 @ [X] @ b2)) E (take j c) \ LeftDerivation (drop (Suc (length b1)) (b1 @ [X] @ b2)) F (drop (Suc j) c))" using LeftDerivationFix_def by blast then obtain E F where EF: "D = E @ derivation_shift F 0 (Suc j) \ LeftDerivation (take (length b1) (b1 @ [X] @ b2)) E (take j c) \ LeftDerivation (drop (Suc (length b1)) (b1 @ [X] @ b2)) F (drop (Suc j) c)" by blast then have LD_b1_c: "LeftDerivation b1 E (take j c)" by simp with is_word_b1X have E: "E = []" using LeftDerivation_implies_Derivation is_word_Derivation is_word_append by blast then have b1_def: "b1 = take j c" using LD_b1_c by auto then have b1_len: "j = length b1" by (simp add: LDF' dual_order.strict_implies_order min.absorb2) have D: "D = derivation_shift F 0 (Suc j)" using EF E by simp have step: "LeftDerives1 (b1 @ [X] @ suffix) (Suc (e + length b1)) r (b1 @ [X] @ b2) \ LeftDerivation (b1 @ [X] @ b2) D c" by (metis LDF' LeftDerives1_append_prefix add_Suc_right append_assoc assms(2) is_word_b1X length_append_singleton) then have is_sentence_b1Xsuffix: "is_sentence (b1 @ [X] @ suffix)" using Derives1_sentence1 LeftDerives1_implies_Derives1 by blast have X_eq_cj: "X = c ! j" using LDF' by auto show ?thesis apply (simp add: LeftDerivationFix_def) apply (rule conjI) using is_sentence_b1Xsuffix apply simp apply (rule conjI) using LDF' apply simp apply (rule conjI) using step apply force apply (rule conjI) using LDF' apply simp apply (rule conjI) apply (rule X_eq_cj) apply (rule_tac x="[]" in exI) apply (rule_tac x="(e, r)#F" in exI) apply auto apply (rule b1_len[symmetric]) apply (rule D) apply (rule b1_def) apply (rule_tac x="b2" in exI) apply (simp add: suffix_b2) using EF by auto qed lemma Derives1_append_suffix: assumes Derives1: "Derives1 v i r w" assumes u: "is_sentence u" shows "Derives1 (v@u) i r (w@u)" proof - have "\ \ N \. splits_at v i \ N \" using assms splits_at_ex by auto then obtain \ N \ where split_v: "splits_at v i \ N \" by blast have split_w: "w = \@(snd r)@\" using assms split_v splits_at_combine_dest by blast have split_uv: "splits_at (v@u) i \ N (\@u)" by (simp add: split_v splits_at_append) have is_sentence_uv: "is_sentence (v@u)" using Derives1 Derives1_sentence1 is_sentence_concat u by blast show ?thesis by (metis Derives1 Derives1_nonterminal Derives1_rule append_assoc is_sentence_uv split_uv split_v split_w splits_at_implies_Derives1) qed lemma leftmost_append_suffix: "leftmost i v \ leftmost i (v@u)" by (simp add: leftmost_def nth_append) lemma LeftDerives1_append_suffix: assumes Derives1: "LeftDerives1 v i r w" assumes u: "is_sentence u" shows "LeftDerives1 (v@u) i r (w@u)" proof - have 1: "Derives1 v i r w" by (simp add: Derives1 LeftDerives1_implies_Derives1) have 2: "leftmost i v" using Derives1 LeftDerives1_def by blast have 3: "is_sentence u" using u by fastforce have 4: "Derives1 (v@u) i r (w@u)" by (simp add: "1" "3" Derives1_append_suffix) have 5: "leftmost i (v@u)" by (simp add: "2" leftmost_append_suffix u) show ?thesis by (simp add: "4" "5" LeftDerives1_def) qed lemma LeftDerivationFix_is_sentence: "LeftDerivationFix a i D j b \ is_sentence a \ is_sentence b" using LeftDerivationFix_def by blast lemma LeftDerivationIntro_is_sentence: "LeftDerivationIntro \ i r ix D j \ \ is_sentence \ \ is_sentence \" by (meson Derives1_sentence1 LeftDerivationFix_is_sentence LeftDerivationIntro_def LeftDerives1_implies_Derives1) lemma LeftDerivationFix_grow_prefix: assumes LDF: "LeftDerivationFix (b1@[X]@b2) (length b1) D j c" assumes prefix_b1: "LeftDerives1 prefix e r b1" shows "LeftDerivationFix (prefix@[X]@b2) (length prefix) ((e, r)#D) j c" proof - from LDF have LDF': "LeftDerivation (b1 @ [X] @ b2) D c \ length b1 < length (b1 @ [X] @ b2) \ j < length c \ (b1 @ [X] @ b2) ! length b1 = c ! j \ (\E F. D = E @ derivation_shift F 0 (Suc j) \ LeftDerivation (take (length b1) (b1 @ [X] @ b2)) E (take j c) \ LeftDerivation (drop (Suc (length b1)) (b1 @ [X] @ b2)) F (drop (Suc j) c))" using LeftDerivationFix_def by blast then obtain E F where EF: "D = E @ derivation_shift F 0 (Suc j) \ LeftDerivation (take (length b1) (b1 @ [X] @ b2)) E (take j c) \ LeftDerivation (drop (Suc (length b1)) (b1 @ [X] @ b2)) F (drop (Suc j) c)" by blast then have E_b1_c: "LeftDerivation b1 E (take j c)" by simp with EF have F_b2_c: "LeftDerivation b2 F (drop (Suc j) c)" by simp have step: "LeftDerives1 (prefix @ [X] @ b2) e r (b1 @ [X] @ b2)" using LDF LeftDerivationFix_is_sentence LeftDerives1_append_suffix is_sentence_concat prefix_b1 by blast show ?thesis apply (simp add: LeftDerivationFix_def) apply (rule conjI) apply (metis Derives1_sentence1 LDF LeftDerivationFix_def LeftDerives1_implies_Derives1 is_sentence_concat is_sentence_cons prefix_b1) apply (rule conjI) using LDF LeftDerivationFix_is_sentence apply blast apply (rule conjI) apply (rule_tac x="b1@[X]@b2" in exI) using step apply simp using LDF' apply auto[1] apply (rule conjI) using LDF' apply simp apply (rule conjI) using LDF' apply auto[1] apply (rule_tac x="(e,r)#E" in exI) apply (rule_tac x="F" in exI) apply (auto simp add: EF F_b2_c) apply (rule_tac x="b1" in exI) apply (simp add: prefix_b1 E_b1_c) done qed lemma LeftDerivationFixOrIntro: "LeftDerivation a D \ \ is_sentence \ \ j < length \ \ (\ i. LeftDerivationFix a i D j \) \ (\ d \ ix. d < length D \ LeftDerivation a (take d D) \ \ LeftDerivationIntro \ (fst (D ! d)) (snd (D ! d)) ix (drop (Suc d) D) j \)" proof (induct "length D" arbitrary: a D \ j rule: less_induct) (* The induction here is unnecessary, but we use it anyway for context reasons *) case less have "length D = 0 \ length D \ 0" by blast then show ?case proof (induct rule: disjCases2) case 1 then have D: "D = []" by auto with less have "\i. LeftDerivationFix a i D j \" apply (rule_tac x=j in exI) by auto then show ?case by blast next case 2 note less2 = 2 have "\ n \ i. n \ length D \ \ = Derive a (take n D) \ LeftDerivationFix \ i (drop n D) j \" apply (rule_tac x="length D" in exI) apply auto using Derive LeftDerivationFix_empty LeftDerivation_implies_Derivation less by blast then show ?case proof (induct rule: ex_minimal_witness) case (Minimal N) then obtain \ i where Minimal_N: "N \ length D \ \ = Derive a (take N D) \ LeftDerivationFix \ i (drop N D) j \" by blast have "N = 0 \ N \ 0" by blast then show ?case proof (induct rule: disjCases2) case 1 with Minimal_N have "\ = a" by auto with 1 Minimal_N show ?case apply (rule_tac disjI1) by auto next case 2 let ?\ = "Derive a (take (N - 1) D)" have LeftDerives1_\: "LeftDerives1 ?\ (fst (D ! (N - 1))) (snd (D ! (N - 1))) \" using "2.hyps" LeftDerivation_Derive_take_LeftDerives1 Minimal_N less.prems(1) by blast then have Derives1_\: "Derives1 ?\ (fst (D ! (N - 1))) (snd (D ! (N - 1))) \" using LeftDerives1_implies_Derives1 by blast have i_len: "i < length \" using Minimal_N by (auto simp add: LeftDerivationFix_def) then have "\ X \_1 \_2. splits_at \ i \_1 X \_2" using splits_at_def by blast then obtain X \_1 \_2 where \_split: "splits_at \ i \_1 X \_2" by blast then have \_combine: "\ = \_1 @ [X] @ \_2" using splits_at_combine by blast then have LeftDerives1_\_hyp: "LeftDerives1 ?\ (fst (D ! (N - 1))) (snd (D ! (N - 1))) (\_1 @ [X] @ \_2)" using LeftDerives1_\ by blast from \_split have i_def: "i = length \_1" by (simp add: dual_order.strict_implies_order min.absorb2 splits_at_def) have "\ Y \_1 \_2. splits_at ?\ (fst (D ! (N - 1))) \_1 Y \_2" using Derives1_\ splits_at_ex by blast then obtain Y \_1 \_2 where \_split: "splits_at ?\ (fst (D ! (N - 1))) \_1 Y \_2" by blast have NFix: "LeftDerivationFix (\_1 @ [X] @ \_2) (length \_1) (drop N D) j \" using Minimal_N \_combine i_def by auto from LeftDerives1_\_hyp \_split have "\u v. \_1 = \_1 @ u \ \_2 = v @ \_2 \ snd (snd (D ! (N - 1))) = u @ [X] @ v" proof (induct rule: LeftDerives1_X_is_part_of_rule) case (Suffix suffix) let ?k = "N - 1" let ?\ = "Derive a (take ?k D)" let ?i = "length \_1" have k_less: "?k < length D" using "2.hyps" Minimal_N by linarith then have k_leq: "?k \ length D" by auto have drop_k_d: "drop ?k D = (D ! (N - 1))#(drop N D)" using "2.hyps" Cons_nth_drop_Suc k_less by fastforce from LeftDerivationFix_grow_suffix[OF NFix Suffix(4) Suffix(3)] Suffix(1) Suffix(2) 2 have "LeftDerivationFix ?\ ?i (drop ?k D) j \" apply auto by (metis One_nat_def drop_k_d) with Minimal(2)[where k="?k"] show "False" using "2.hyps" k_leq by auto next case (Prefix prefix) have collapse: "(fst (D ! (N - 1)), snd (D ! (N - 1))) # drop N D = drop (N - 1) D" by (metis "2.hyps" Cons_nth_drop_Suc Minimal_N Suc_diff_1 neq0_conv not_less not_less_eq prod.collapse) from LeftDerivationFix_grow_prefix[OF NFix Prefix(2)] Prefix(1) collapse have "LeftDerivationFix ?\ (length prefix) (drop (N - 1) D) j \" by auto with Minimal(2)[where k = "N - 1"] show "False" by (metis Minimal_N collapse diff_le_self le_neq_implies_less less_imp_diff_less less_or_eq_imp_le not_Cons_self2) qed then obtain u v where uv: "\_1 = \_1 @ u \ \_2 = v @ \_2 \ snd (snd (D ! (N - 1))) = u @ [X] @ v" by blast have X_1: "snd (snd (D ! (N - Suc 0))) ! length u = X" using uv by auto have X_2: "\ ! j = X" using LeftDerivationFix_def NFix by auto show ?case apply (rule disjI2) apply (rule_tac x="N - 1" in exI) apply (rule_tac x="?\" in exI) apply (rule_tac x="length u" in exI) apply (rule conjI) using Minimal_N less2 apply linarith apply (rule conjI) using LeftDerivation_take_derive less.prems(1) apply blast apply (subst LeftDerivationIntro_def) apply (rule_tac x=\ in exI) apply auto using LeftDerives1_\ One_nat_def apply presburger using uv apply auto[1] using X_1 X_2 apply auto[1] by (metis (no_types, lifting) "2.hyps" Derives1_\ Derives1_split Minimal_N One_nat_def Suc_diff_1 \_split append_eq_conv_conj i_def length_append neq0_conv splits_at_def uv) qed qed qed qed type_synonym deriv = "nat \ nat \ nat" type_synonym ladder = "deriv list" definition deriv_n :: "deriv \ nat" where "deriv_n d = fst d" definition deriv_j :: "deriv \ nat" where "deriv_j d = fst (snd d)" definition deriv_ix :: "deriv \ nat" where "deriv_ix d = snd (snd d)" definition deriv_i :: "deriv \ nat" where "deriv_i d = snd (snd d)" definition ladder_j :: "ladder \ nat \ nat" where "ladder_j L index = deriv_j (L ! index)" definition ladder_i :: "ladder \ nat \ nat" where "ladder_i L index = (if index = 0 then deriv_i (hd L) else ladder_j L (index - 1))" definition ladder_n :: "ladder \ nat \ nat" where "ladder_n L index = deriv_n (L ! index)" definition ladder_prev_n :: "ladder \ nat \ nat" where "ladder_prev_n L index = (if index = 0 then 0 else (ladder_n L (index - 1)))" definition ladder_ix :: "ladder \ nat \ nat" where "ladder_ix L index = (if index = 0 then undefined else deriv_ix (L ! index))" definition ladder_last_j :: "ladder \ nat" where "ladder_last_j L = ladder_j L (length L - 1)" definition ladder_last_n :: "ladder \ nat" where "ladder_last_n L = ladder_n L (length L - 1)" definition is_ladder :: "derivation \ ladder \ bool" where "is_ladder D L = (L \ [] \ (\ u. u < length L \ ladder_n L u \ length D) \ (\ u v. u < v \ v < length L \ ladder_n L u < ladder_n L v) \ ladder_last_n L = length D)" definition ladder_\ :: "sentence \ derivation \ ladder \ nat \ sentence" where "ladder_\ a D L index = Derive a (take (ladder_n L index) D)" definition ladder_\ :: "sentence \ derivation \ ladder \ nat \ sentence" where "ladder_\ a D L index = (if index = 0 then a else ladder_\ a D L (index - 1))" definition LeftDerivationIntrosAt :: "sentence \ derivation \ ladder \ nat \ bool" where "LeftDerivationIntrosAt a D L index = ( let \ = ladder_\ a D L index in let i = ladder_i L index in let j = ladder_j L index in let ix = ladder_ix L index in let \ = ladder_\ a D L index in let n = ladder_n L (index - 1) in let m = ladder_n L index in let e = D ! n in let E = drop (Suc n) (take m D) in i = fst e \ LeftDerivationIntro \ i (snd e) ix E j \)" definition LeftDerivationIntros :: "sentence \ derivation \ ladder \ bool" where "LeftDerivationIntros a D L = ( \ index. 1 \ index \ index < length L \ LeftDerivationIntrosAt a D L index)" definition LeftDerivationLadder :: "sentence \ derivation \ ladder \ sentence \ bool" where "LeftDerivationLadder a D L b = ( LeftDerivation a D b \ is_ladder D L \ LeftDerivationFix a (ladder_i L 0) (take (ladder_n L 0) D) (ladder_j L 0) (ladder_\ a D L 0) \ LeftDerivationIntros a D L)" definition mk_deriv_fix :: "nat \ nat \ nat \ deriv" where "mk_deriv_fix i n j = (n, j, i)" definition mk_deriv_intro :: "nat \ nat \ nat \ deriv" where "mk_deriv_intro ix n j = (n, j, ix)" lemma mk_deriv_fix_i[simp]: "deriv_i (mk_deriv_fix i n j) = i" by (simp add: deriv_i_def mk_deriv_fix_def) lemma mk_deriv_fix_j[simp]: "deriv_j (mk_deriv_fix i n j) = j" by (simp add: deriv_j_def mk_deriv_fix_def) lemma mk_deriv_fix_n[simp]: "deriv_n (mk_deriv_fix i n j) = n" by (simp add: deriv_n_def mk_deriv_fix_def) lemma mk_deriv_intro_i[simp]: "deriv_i (mk_deriv_intro i n j) = i" by (simp add: deriv_i_def mk_deriv_intro_def) lemma mk_deriv_intro_ix[simp]: "deriv_ix (mk_deriv_intro ix n j) = ix" by (simp add: deriv_ix_def mk_deriv_intro_def) lemma mk_deriv_intro_j[simp]: "deriv_j (mk_deriv_intro i n j) = j" by (simp add: deriv_j_def mk_deriv_intro_def) lemma mk_deriv_intro_n[simp]: "deriv_n (mk_deriv_intro i n j) = n" by (simp add: deriv_n_def mk_deriv_intro_def) lemma LeftDerivationFix_implies_ex_ladder: "LeftDerivationFix a i D j \ \ \ L. LeftDerivationLadder a D L \ \ ladder_last_j L = j \ ladder_last_n L = length D" apply (rule_tac x="[mk_deriv_fix i (length D) j]" in exI) apply (auto simp add: LeftDerivationLadder_def) apply (simp add: LeftDerivationFix_def) apply (simp add: is_ladder_def) apply (auto simp add: ladder_i_def ladder_j_def ladder_n_def ladder_\_def) apply (simp add: ladder_last_n_def ladder_n_def) using Derive LeftDerivationFix_def LeftDerivation_implies_Derivation apply blast apply (simp add: LeftDerivationIntros_def) apply (simp add: ladder_last_j_def ladder_j_def) apply (simp add: ladder_last_n_def ladder_n_def) done lemma trivP[case_names prems]: "P \ P" by blast lemma LeftDerivationLadder_ladder_n_bound: assumes "LeftDerivationLadder a D L b" assumes "index < length L" shows "ladder_n L index \ length D" using LeftDerivationLadder_def assms(1) assms(2) is_ladder_def by blast lemma LeftDerivationLadder_deriv_n_bound: assumes "LeftDerivationLadder a D L b" assumes "index < length L" shows "deriv_n (L ! index) \ length D" using LeftDerivationLadder_def assms(1) assms(2) is_ladder_def ladder_n_def by auto lemma ladder_n_simp1[simp]: "u < length L \ ladder_n (L@L') u = ladder_n L u" by (simp add: ladder_n_def) lemma ladder_n_simp2[simp]: "ladder_n (L@[d]) (length L) = deriv_n d" by (simp add: ladder_n_def) lemma ladder_j_simp1[simp]: "u < length L \ ladder_j (L@L') u = ladder_j L u" by (simp add: ladder_j_def) lemma ladder_j_simp2[simp]: "ladder_j (L@[d]) (length L) = deriv_j d" by (simp add: ladder_j_def) lemma ladder_i_simp1[simp]: "u < length L \ ladder_i (L@L') u = ladder_i L u" by (auto simp add: ladder_i_def) lemma ladder_ix_simp1[simp]: "u < length L \ ladder_ix (L@L') u = ladder_ix L u" by (auto simp add: ladder_ix_def) lemma ladder_ix_simp2[simp]: "L \ [] \ ladder_ix (L@[d]) (length L) = deriv_ix d" by (auto simp add: ladder_ix_def) lemma ladder_\_simp1[simp]: "u < length L \ ladder_\ a D (L@L') u = ladder_\ a D L u" by (simp add: ladder_\_def) lemma ladder_\_simp2[simp]: "u < length L \ is_ladder D L \ ladder_\ a (D@D') L u = ladder_\ a D L u" by (simp add: is_ladder_def ladder_\_def) lemma ladder_\_simp1[simp]: "u < length L \ ladder_\ a D (L@L') u = ladder_\ a D L u" by (simp add: ladder_\_def) lemma ladder_\_simp2[simp]: "u < length L \ is_ladder D L \ ladder_\ a (D@D') L u = ladder_\ a D L u" by (simp add: is_ladder_def ladder_\_def) lemma ladder_n_minus_1_bound: "is_ladder D L \ index \ 1 \ index < length L \ ladder_n L (index - Suc 0) < length D" by (metis (no_types, lifting) One_nat_def Suc_diff_1 Suc_le_lessD dual_order.strict_implies_order is_ladder_def le_neq_implies_less not_less) lemma LeftDerivationIntrosAt_ignore_appendix: assumes is_ladder: "is_ladder D L" assumes hyp: "LeftDerivationIntrosAt a D L index" assumes index_ge: "index \ 1" assumes index_less: "index < length L" shows "LeftDerivationIntrosAt a (D @ D') (L @ L') index" proof - have index_minus_1: "index - Suc 0 < length L" using index_less by arith have is_0: "ladder_n L index - length D = 0" using index_less is_ladder is_ladder_def by auto from index_ge index_less show ?thesis apply (simp add: LeftDerivationIntrosAt_def Let_def) apply (simp add: index_minus_1 is_ladder ladder_n_minus_1_bound is_0) using hyp apply (auto simp add: LeftDerivationIntrosAt_def Let_def) done qed lemma ladder_i_eq_last_j: "L \ [] \ ladder_i (L @ L') (length L) = ladder_last_j L" by (simp add: ladder_i_def ladder_last_j_def) lemma ladder_last_n_intro: "L \ [] \ ladder_n L (length L - Suc 0) = ladder_last_n L" by (simp add: ladder_last_n_def) lemma is_ladder_not_empty: "is_ladder D L \ L \ []" using is_ladder_def by blast lemma last_ladder_\: assumes is_ladder: "is_ladder D L" assumes ladder_last_n: "ladder_last_n L = length D" shows "ladder_\ a D L (length L - Suc 0) = Derive a D" proof - from is_ladder is_ladder_not_empty have "L \ []" by blast then show ?thesis by (simp add: ladder_\_def ladder_last_n_intro ladder_last_n) qed lemma ladder_\_full: assumes is_ladder: "is_ladder D L" assumes ladder_last_n: "ladder_last_n L = length D" shows "ladder_\ a (D @ D') (L @ L') (length L) = Derive a D" proof - from is_ladder have L_not_empty: "L \ []" by (simp add: is_ladder_def) with is_ladder ladder_last_n show ?thesis apply (simp add: ladder_\_def) apply (simp add: last_ladder_\) done qed lemma LeftDerivationIntro_implies_LeftDerivation: "LeftDerivationIntro \ i r ix D j \ \ LeftDerivation \ ((i,r)#D) \" using LeftDerivationFix_def LeftDerivationIntro_def by auto lemma LeftDerivationLadder_grow: "LeftDerivationLadder a D L \ \ ladder_last_j L = i \ LeftDerivationIntro \ i r ix E j \ \ LeftDerivationLadder a (D@[(i, r)]@E) (L@[mk_deriv_intro ix (Suc(length D + length E)) j]) \" proof (induct arbitrary: a D L \ i r ix E j \ rule: trivP) case prems { fix u :: nat assume "u < Suc (length L)" then have "u < length L \ u = length L" by arith then have "ladder_n (L @ [mk_deriv_intro ix (Suc (length D + length E)) j]) u \ Suc (length D + length E)" proof (induct rule: disjCases2) case 1 then show ?case apply simp by (meson LeftDerivationLadder_ladder_n_bound le_Suc_eq le_add1 le_trans prems(1)) next case 2 then show ?case by (simp add: ladder_n_def) qed } note ladder_n_ineqs = this { fix u :: nat fix v :: nat assume u_less_v: "u < v" assume "v < Suc (length L)" then have "v < length L \ v = length L" by arith then have "ladder_n (L @ [mk_deriv_intro ix (Suc (length D + length E)) j]) u < ladder_n (L @ [mk_deriv_intro ix (Suc (length D + length E)) j]) v" proof (induct rule: disjCases2) case 1 with u_less_v have u_bound: "u < length L" by arith show ?case using 1 u_bound apply simp using prems u_less_v LeftDerivationLadder_def is_ladder_def by auto next case 2 with u_less_v have u_bound: "u < length L" by arith have "deriv_n (L ! u) \ length D" using LeftDerivationLadder_deriv_n_bound prems(1) u_bound by blast then show ?case apply (simp add: u_bound) apply (simp add: ladder_n_def 2) done qed } note ladder_n_ineqs = ladder_n_ineqs this have is_ladder: "is_ladder (D @ (i, r) # E) (L @ [mk_deriv_intro ix (Suc (length D + length E)) j])" apply (auto simp add: is_ladder_def) using ladder_n_ineqs apply auto apply (simp add: ladder_last_n_def) done have is_ladder_L: "is_ladder D L" using LeftDerivationLadder_def prems.prems(1) by blast have ladder_last_n_eq_length: "ladder_last_n L = length D" using is_ladder_L is_ladder_def by blast have L_not_empty: "L \ []" using LeftDerivationLadder_def is_ladder_def prems(1) by blast { fix index :: nat assume index_ge: "Suc 0 \ index" assume "index < Suc (length L)" then have "index < length L \ index = length L" by arith then have "LeftDerivationIntrosAt a (D @ (i, r) # E) (L @ [mk_deriv_intro ix (Suc (length D + length E)) j]) index" proof (induct rule: disjCases2) case 1 then show ?case using LeftDerivationIntrosAt_ignore_appendix LeftDerivationIntros_def LeftDerivationLadder_def One_nat_def index_ge prems.prems(1) by presburger next case 2 have min_simp: "\ n E. min n (Suc (n + length E)) = n" by auto with 2 prems is_ladder_L ladder_last_n_eq_length show ?case apply (simp add: LeftDerivationIntrosAt_def) apply (simp add: L_not_empty ladder_i_eq_last_j ladder_last_n_intro) apply (simp add: ladder_\_full min_simp) apply (simp add: ladder_\_def) by (metis Derive LeftDerivationIntro_implies_LeftDerivation LeftDerivationLadder_def LeftDerivation_implies_Derivation LeftDerivation_implies_append) qed } then show ?case apply (auto simp add: LeftDerivationLadder_def) using prems apply (auto simp add: LeftDerivationLadder_def)[1] using LeftDerivationFix_def LeftDerivationIntro_def LeftDerivation_append apply auto[1] using is_ladder apply simp using L_not_empty apply simp using LeftDerivationLadder_def LeftDerivationLadder_ladder_n_bound ladder_\_def prems.prems(1) apply auto[1] apply (subst LeftDerivationIntros_def) apply auto done qed lemma LeftDerivationIntro_bounds_ij: "LeftDerivationIntro \ i r ix D j \ \ i < length \ \ j < length \" by (meson Derives1_bound LeftDerivationFix_def LeftDerivationIntro_def LeftDerives1_implies_Derives1) theorem LeftDerivationLadder_exists: "LeftDerivation a D \ \ is_sentence \ \ j < length \ \ \ L. LeftDerivationLadder a D L \ \ ladder_last_j L = j" proof (induct "length D" arbitrary: a D \ j rule: less_induct) case less from LeftDerivationFixOrIntro[OF less(2,3,4)] show ?case proof (induct rule: disjCases2) case 1 then obtain i where "LeftDerivationFix a i D j \" by blast show ?case using "1.hyps" LeftDerivationFix_implies_ex_ladder by blast next case 2 then obtain d \ ix where inductrule: "d < length D \ LeftDerivation a (take d D) \ \ LeftDerivationIntro \ (fst (D ! d)) (snd (D ! d)) ix (drop (Suc d) D) j \" by blast then have less_length_D: "length (take d D) < length D" and LeftDerivation_\: "LeftDerivation a (take d D) \" by auto have is_sentence_\: "is_sentence \" using LeftDerivationIntro_is_sentence inductrule by blast have "fst (D ! d) < length \" using LeftDerivationIntro_bounds_ij inductrule by blast from less(1)[OF less_length_D LeftDerivation_\ is_sentence_\, where j=" fst (D ! d)", OF this] obtain L where induct_Ladder: "LeftDerivationLadder a (take d D) L \" and induct_last: "ladder_last_j L = fst (D ! d)" by blast have induct_intro: "LeftDerivationIntro \ (fst (D ! d)) (snd (D ! d)) ix (drop (Suc d) D) j \" using inductrule by blast have "d < length D" using inductrule by blast then have simp_to_D: "take d D @ D ! d # drop (Suc d) D = D" using id_take_nth_drop by force from LeftDerivationLadder_grow[OF induct_Ladder induct_last induct_intro] simp_to_D show ?case apply auto apply (rule_tac x= "L @ [mk_deriv_intro ix (Suc (min (length D) d + (length D - Suc d))) j]" in exI) apply (simp add: ladder_last_j_def) done qed qed lemma LeftDerivationLadder_L_0: assumes "LeftDerivationLadder \ D L \" assumes "length L = 1" shows "\ i. LeftDerivationFix \ i D (ladder_last_j L) \" proof - have "is_ladder D L" using assms by (auto simp add: LeftDerivationLadder_def) then have ladder_n: "ladder_n L 0 = length D" by (simp add: assms(2) is_ladder_def ladder_last_n_def) show ?thesis apply (rule_tac x = "ladder_i L 0" in exI) using assms(1) apply (auto simp add: LeftDerivationLadder_def) by (metis Derive LeftDerivationFix_def LeftDerivation_implies_Derivation One_nat_def assms(2) diff_Suc_1 ladder_last_j_def ladder_n order_refl take_all) qed lemma LeftDerivationFix_splits_at_derives: assumes "LeftDerivationFix a i D j b" shows "\ U a1 a2 b1 b2. splits_at a i a1 U a2 \ splits_at b j b1 U b2 \ derives a1 b1 \ derives a2 b2" proof - note hyp = LeftDerivationFix_def[where \=a and \=b and D=D and i=i and j=j] from hyp obtain E F where EF: "D = E @ derivation_shift F 0 (Suc j) \ LeftDerivation (take i a) E (take j b) \ LeftDerivation (drop (Suc i) a) F (drop (Suc j) b)" using assms by blast show ?thesis apply (rule_tac x="a ! i" in exI) apply (rule_tac x="take i a" in exI) apply (rule_tac x="drop (Suc i) a" in exI) apply (rule_tac x="take j b" in exI) apply (rule_tac x="drop (Suc j) b" in exI) using Derivation_implies_derives LeftDerivation_implies_Derivation assms hyp splits_at_def by blast qed lemma LeftDerivation_append_suffix: "LeftDerivation a D b \ is_sentence c \ LeftDerivation (a@c) D (b@c)" proof (induct D arbitrary: a b c) case Nil then show ?case by auto next case (Cons d D) then show ?case apply auto apply (rule_tac x="x@c" in exI) apply auto using LeftDerives1_append_suffix by simp qed lemma LeftDerivation_impossible: "LeftDerivation a D b \ i < length a \ is_nonterminal (a ! i) \ derivation_ge D (Suc i) \ D = []" proof (induct D) case Nil then show ?case by auto next case (Cons d D) then have lm: "\ j. leftmost j a \ j \ i" by (metis Derives1_sentence1 LeftDerivation.simps(2) LeftDerives1_implies_Derives1 leftmost_exists leftmost_unique) from Cons show ?case apply auto apply (auto simp add: derivation_ge_def LeftDerives1_def) using lm[where j="fst d"] by arith qed lemma derivation_ge_shift: "derivation_ge (derivation_shift F 0 j) j" apply (induct F) apply (auto simp add: derivation_ge_def) done lemma LeftDerivationFix_splits_at_nonterminal: assumes "LeftDerivationFix a i D j b" assumes "is_nonterminal (a ! i)" shows "\ U a1 a2 b1. splits_at a i a1 U a2 \ splits_at b j b1 U a2 \ LeftDerivation a1 D b1" proof - note hyp = LeftDerivationFix_def[where \=a and \=b and D=D and i=i and j=j] from hyp obtain E F where EF: "D = E @ derivation_shift F 0 (Suc j) \ LeftDerivation (take i a) E (take j b) \ LeftDerivation (drop (Suc i) a) F (drop (Suc j) b)" using assms by blast have "\ \. LeftDerivation a E \ \ LeftDerivation \ (derivation_shift F 0 (Suc j)) b" using EF LeftDerivation_append assms(1) hyp by blast then obtain \ where \_intro: "LeftDerivation a E \ \ LeftDerivation \ (derivation_shift F 0 (Suc j)) b" by blast have "LeftDerivation ((take i a)@(drop i a)) E ((take j b)@(drop i a))" by (metis EF LeftDerivation_append_suffix append_take_drop_id assms(1) hyp is_sentence_concat) then have "LeftDerivation a E ((take j b)@(drop i a))" by simp then have \_decomposed: "\ = (take j b)@(drop i a)" using Derivation_unique_dest LeftDerivation_implies_Derivation \_intro by blast then have "\ ! j = a ! i" by (metis Cons_nth_drop_Suc assms(1) hyp length_take min.absorb2 nth_append_length order.strict_implies_order) then have is_nt: "is_nonterminal (\ ! j)" by (simp add: assms(2)) have index_j: "j < length \" using \_decomposed assms(1) hyp by auto have derivation: "LeftDerivation \ (derivation_shift F 0 (Suc j)) b" by (simp add: \_intro) from LeftDerivation_impossible[OF derivation index_j is_nt derivation_ge_shift] have F: "F = []" by (metis length_0_conv length_derivation_shift) then have \_is_b: "\ = b" using \_intro by auto show ?thesis apply (rule_tac x="a ! i" in exI) apply (rule_tac x="take i a" in exI) apply (rule_tac x="drop (Suc i) a" in exI) apply (rule_tac x="take j b" in exI) using EF F assms(1) hyp splits_at_def by auto qed lemma LeftDerivationIntro_implies_nonterminal: "LeftDerivationIntro \ i (snd e) ix E j \ \ is_nonterminal (\ ! i)" by (simp add: LeftDerivationIntro_def LeftDerives1_def leftmost_is_nonterminal) lemma LeftDerivationIntrosAt_implies_nonterminal: "LeftDerivationIntrosAt a D L index \ is_nonterminal((ladder_\ a D L index) ! (ladder_i L index))" by (meson LeftDerivationIntro_implies_nonterminal LeftDerivationIntrosAt_def) lemma LeftDerivationIntro_examine_rule: "LeftDerivationIntro \ i r ix D j \ \ splits_at \ i \1 M \2 \ \ \. M = fst r \ \ = snd r \ (M, \) \ \" by (metis Derives1_nonterminal Derives1_rule LeftDerivationIntro_def LeftDerives1_implies_Derives1 prod.collapse) lemma LeftDerivation_skip_prefixword_ex: assumes "LeftDerivation (u@v) D w" assumes "is_word u" shows "\ w'. w = u@w' \ LeftDerivation v (derivation_shift D (length u) 0) w'" by (metis LeftDerivation.simps(1) LeftDerivation_breakdown LeftDerivation_implies_Derivation LeftDerivation_skip_prefix append_eq_conv_conj assms(1) assms(2) is_word_Derivation is_word_Derivation_derivation_ge) definition ladder_cut :: "ladder \ nat \ ladder" where "ladder_cut L n = (let i = length L - 1 in L[i := (n, snd (L ! i))])" fun deriv_shift :: "nat \ nat \ deriv \ deriv" where "deriv_shift dn dj (n, j, i) = (n - dn, j - dj, i)" definition ladder_shift :: "ladder \ nat \ nat \ ladder" where "ladder_shift L dn dj = map (deriv_shift dn dj) L" lemma splits_at_append_suffix_prevails: assumes "splits_at (a@b) i u N v" assumes "i < length a" shows "\ v'. v = v'@b \ a=u@[N]@v'" proof - have "min (length a) (Suc i) = Suc i" using Suc_leI assms(2) min.absorb2 by blast then show ?thesis by (metis (no_types) append_assoc append_eq_conv_conj append_take_drop_id assms(1) hd_drop_conv_nth length_take splits_at_def take_hd_drop) qed lemma derivation_shift_right_left_cancel: "derivation_shift (derivation_shift D 0 r) r 0 = D" by (induct D, auto) lemma derivation_shift_left_right_cancel: assumes "derivation_ge D r" shows "derivation_shift (derivation_shift D r 0) 0 r = D" using assms derivation_ge_shift_simp derivation_shift_0_shift by auto lemma LeftDerivation_ge_take: assumes "derivation_ge D k" assumes "LeftDerivation a D b" assumes "D \ []" shows "take k a = take k b \ is_word (take k a)" proof - obtain d D' where d: "d#D' = D" using assms(3) list.exhaust by blast then have "\ x. LeftDerives1 a (fst d) (snd d) x \ LeftDerivation x D' b" using LeftDerivation.simps(2) assms(2) by blast then obtain x where x: "LeftDerives1 a (fst d) (snd d) x \ LeftDerivation x D' b" by blast have fst_d_k: "fst d \ k" using d assms(1) derivation_ge_cons by blast from x fst_d_k have is_word: "is_word (take k a)" by (metis LeftDerives1_def append_take_drop_id is_word_append leftmost_def min.absorb2 take_append take_take) have is_eq: "take k a = take k b" using Derivation_take LeftDerivation_implies_Derivation assms(1) assms(2) by blast show ?thesis using is_word is_eq by blast qed lemma LeftDerivationFix_splits_at_symbol: assumes "LeftDerivationFix a i D j b" shows "\ U a1 a2 b1 b2 n. splits_at a i a1 U a2 \ splits_at b j b1 U b2 \ n \ length D \ LeftDerivation a1 (take n D) b1 \ derivation_ge (drop n D) (Suc(length b1)) \ LeftDerivation a2 (derivation_shift (drop n D) (Suc(length b1)) 0) b2 \ (n = length D \ (n < length D \ is_word (b1@[U])))" proof - note hyp = LeftDerivationFix_def[where \=a and \=b and D=D and i=i and j=j] from hyp obtain E F where EF: "D = E @ derivation_shift F 0 (Suc j) \ LeftDerivation (take i a) E (take j b) \ LeftDerivation (drop (Suc i) a) F (drop (Suc j) b)" using assms by blast have "\ \. LeftDerivation a E \ \ LeftDerivation \ (derivation_shift F 0 (Suc j)) b" using EF LeftDerivation_append assms(1) hyp by blast then obtain \ where \_intro: "LeftDerivation a E \ \ LeftDerivation \ (derivation_shift F 0 (Suc j)) b" by blast have "LeftDerivation ((take i a)@(drop i a)) E ((take j b)@(drop i a))" by (metis EF LeftDerivation_append_suffix append_take_drop_id assms(1) hyp is_sentence_concat) then have "LeftDerivation a E ((take j b)@(drop i a))" by simp then have \_decomposed: "\ = (take j b)@(drop i a)" using Derivation_unique_dest LeftDerivation_implies_Derivation \_intro by blast have derivation: "LeftDerivation \ (derivation_shift F 0 (Suc j)) b" by (simp add: \_intro) have "\ n. n \ length D \ E = take n D" by (metis EF append_eq_conv_conj is_prefix_length is_prefix_take) then obtain n where n: "n \ length D \ E = take n D" by blast have F_def: "drop n D = derivation_shift F 0 (Suc j)" by (metis EF append_eq_conv_conj length_take min.absorb2 n) have min_j: "min (length b) j = j" using assms hyp by linarith have derivation_ge_Suc_j: "derivation_ge (drop n D) (Suc j)" using F_def derivation_ge_shift by simp have LeftDerivation_\_b: "LeftDerivation \ (drop n D) b" by (simp add: F_def \_intro) have is_word_Suc_j_b: "n \ length D \ is_word (take (Suc j) b)" by (metis EF F_def LeftDerivation_ge_take \_intro append_Nil2 derivation_ge_Suc_j length_take min.absorb2 n) have take_Suc_j_b_decompose: "take (Suc j) b = take j b @ [a ! i]" using assms hyp take_Suc_conv_app_nth by auto show ?thesis apply (rule_tac x="a ! i" in exI) apply (rule_tac x="take i a" in exI) apply (rule_tac x="drop (Suc i) a" in exI) apply (rule_tac x="take j b" in exI) apply (rule_tac x="drop (Suc j) b" in exI) apply (rule_tac x="n" in exI) apply (auto simp add: min_j) using assms hyp splits_at_def apply blast using assms hyp splits_at_def apply blast using n apply blast using EF n apply simp using F_def apply simp using derivation_ge_shift apply blast using F_def derivation_shift_right_left_cancel apply simp using EF apply blast using n apply arith using is_word_Suc_j_b take_Suc_j_b_decompose is_word_append apply simp+ done qed lemma LeftDerivation_breakdown': "LeftDerivation (u @ v) D w \ \n w1 w2. n \ length D \ w = w1 @ w2 \ LeftDerivation u (take n D) w1 \ derivation_ge (drop n D) (length w1) \ LeftDerivation v (derivation_shift (drop n D) (length w1) 0) w2" proof - assume hyp: "LeftDerivation (u @ v) D w" from LeftDerivation_breakdown[OF hyp] obtain n w1 w2 where breakdown: "w = w1 @ w2 \ LeftDerivation u (take n D) w1 \ derivation_ge (drop n D) (length w1) \ LeftDerivation v (derivation_shift (drop n D) (length w1) 0) w2" by blast obtain m where m: "m = min (length D) n" by blast have take_m: "take m D = take n D" using m is_prefix_take take_prefix by fastforce have drop_m: "drop m D = drop n D" by (metis append_eq_conv_conj append_take_drop_id length_take m) have m_bound: "m \ length D" by (simp add: m) show ?thesis apply (rule_tac x="m" in exI) apply (rule_tac x="w1" in exI) apply (rule_tac x="w2" in exI) using breakdown m_bound take_m drop_m by auto qed lemma LeftDerives1_append_replace_in_left: assumes ld1: "LeftDerives1 (\@\) i r \" assumes i_bound: "i < length \" shows "\ \'. \ = \'@\ \ LeftDerives1 \ i r \' \ i + length (snd r) \ length \'" proof - obtain \' where \': "\' = (take i \)@(snd r)@(drop (i+1) \)" by blast have fst_r: "fst r = \ ! i" proof - have "\ss n p ssa. \ LeftDerives1 ss n p ssa \ Derives1 ss n p ssa" using LeftDerives1_implies_Derives1 by blast then have "Derives1 (\ @ \) i r \" using ld1 by blast then show ?thesis using Derives1_nonterminal i_bound splits_at_def by auto qed have "Derives1 \ i r \'" using i_bound ld1 apply (auto simp add: \' Derives1_def) apply (rule_tac x="take i \" in exI) apply (rule_tac x="drop (i+1) \" in exI) apply (rule_tac x="fst r" in exI) apply auto apply (simp add: fst_r) using id_take_nth_drop apply blast using Derives1_sentence1 LeftDerives1_implies_Derives1 is_sentence_concat is_sentence_take apply blast apply (metis Derives1_sentence1 LeftDerives1_implies_Derives1 append_take_drop_id is_sentence_concat) using Derives1_rule LeftDerives1_implies_Derives1 by blast then have leftderives1_\_\': "LeftDerives1 \ i r \'" using LeftDerives1_def i_bound ld1 leftmost_cons_less by auto have i_bound_\': "i + length (snd r) \ length \'" using \' i_bound by (simp add: add_mono_thms_linordered_semiring(2) le_add1 less_or_eq_imp_le min.absorb2) have is_sentence_\: "is_sentence \" using Derives1_sentence1 LeftDerives1_implies_Derives1 is_sentence_concat ld1 by blast then have \: "\ = \'@\" using ld1 leftderives1_\_\' Derives1_append_suffix Derives1_unique_dest LeftDerives1_implies_Derives1 by blast show ?thesis apply (rule_tac x="\'" in exI) using \ i_bound_\' leftderives1_\_\' by blast qed lemma LeftDerivationIntro_propagate: assumes intro: "LeftDerivationIntro (\@\) i r ix D j \" assumes i_\: "i < length \" assumes non: "is_nonterminal (\ ! j)" shows "\ \. LeftDerivation \ ((i,r)#D) \ \ \ = \@\ \ j < length \" proof - from intro LeftDerivationIntro_def[where \="\@\" and i=i and r=r and ix=ix and D=D and j=j and \=$ obtain \ where ld_\: "LeftDerives1 (\ @ \) i r \" and ix: "ix < length (snd r) \ snd r ! ix = \ ! j" and \_fix: "LeftDerivationFix \ (i + ix) D j \" by blast from LeftDerives1_append_replace_in_left[OF ld_\ i_\] obtain \' where \': "\ = \' @ \ \ LeftDerives1 \ i r \' \ i + length (snd r) \ length \'" by blast have i_plus_ix_bound: "i + ix < length \'" using \' ix by linarith have ld_\: "LeftDerivationFix (\' @ \) (i + ix) D j \" using \_fix \' by simp then have non_i_ix: "is_nonterminal ((\' @ \) ! (i + ix))" by (simp add: LeftDerivationFix_def non) from LeftDerivationFix_splits_at_nonterminal[OF ld_\ non_i_ix] obtain U a1 a2 b1 where U: "splits_at (\' @ \) (i + ix) a1 U a2 \ splits_at \ j b1 U a2 \ LeftDerivation a1 D b1" by blast have "\ q. a2 = q@\ \ \' = a1 @ [U] @ q" using splits_at_append_suffix_prevails[OF _ i_plus_ix_bound, where b=\] U by blast then obtain q where q: "a2 = q@\ \ \' = a1 @ [U] @ q" by blast show ?thesis apply (rule_tac x="b1@[U]@q" in exI) apply auto apply (rule_tac x="\'" in exI) apply (metis LeftDerivationFix_def LeftDerivation_append_suffix U \' q append_Cons append_Nil is_sentence_concat ld_\) using U q splits_at_combine apply auto[1] using U splits_at_def by auto qed lemma LeftDerivationIntro_finish: assumes intro: "LeftDerivationIntro (\@\) i r ix D j \" assumes i_\: "i < length \" shows "\ k \ \'. k \ length D \ LeftDerivation \ ((i, r)#(take k D)) \ \ LeftDerivation (\ @ \) ((i, r)#(take k D)) (\ @ \) \ derivation_ge (drop k D) (length \) \ LeftDerivation \ (derivation_shift (drop k D) (length \) 0) \' \ \ = \ @ \' \ j < length \" proof - from intro LeftDerivationIntro_def[where \="\@\" and i=i and r=r and ix=ix and D=D and j=j and \=\] obtain \ where ld_\: "LeftDerives1 (\ @ \) i r \" and ix: "ix < length (snd r) \ snd r ! ix = \ ! j" and \_fix: "LeftDerivationFix \ (i + ix) D j \" by blast from LeftDerives1_append_replace_in_left[OF ld_\ i_\] obtain \' where \': "\ = \' @ \ \ LeftDerives1 \ i r \' \ i + length (snd r) \ length \'" by blast have i_plus_ix_bound: "i + ix < length \'" using \' ix by linarith have ld_\: "LeftDerivationFix (\' @ \) (i + ix) D j \" using \_fix \' by simp from LeftDerivationFix_splits_at_symbol[OF ld_\] obtain U a1 a2 b1 b2 n where U: "splits_at (\' @ \) (i + ix) a1 U a2 \ splits_at \ j b1 U b2 \ n \ length D \ LeftDerivation a1 (take n D) b1 \ derivation_ge (drop n D) (Suc (length b1)) \ LeftDerivation a2 (derivation_shift (drop n D) (Suc (length b1)) 0) b2 \ (n = length D \ n < length D \ is_word (b1 @ [U]))" by blast have n_bound: "n \ length D" using U by blast have "\ q. a2 = q@\ \ \' = a1 @ [U] @ q" using splits_at_append_suffix_prevails[OF _ i_plus_ix_bound, where b=\] U by blast then obtain q where q: "a2 = q@\ \ \' = a1 @ [U] @ q" by blast have j: "j = length b1" using U by (simp add: dual_order.strict_implies_order min.absorb2 splits_at_def) have "n = length D \ n < length D \ is_word (b1 @ [U])" using U by blast then show ?thesis proof (induct rule: disjCases2) case 1 from 1 have drop_n_D: "drop n D = []" by (simp add: U) then have "LeftDerivation a2 [] b2" using U by simp then have a2_eq_b2: "a2 = b2" by simp show ?case apply (rule_tac x="n" in exI) apply (rule_tac x="b1@[U]@q" in exI) apply (rule_tac x="\" in exI) apply auto apply (simp add: 1) apply (rule_tac x="\'" in exI) apply (metis LeftDerivationFix_is_sentence LeftDerivation_append_suffix U \' append_Cons append_Nil is_sentence_concat ld_\ q) apply (rule_tac x="\' @ \" in exI) apply (metis "1.hyps" LeftDerivationFix_def U \' a2_eq_b2 id_take_nth_drop ld_\ ld_\ q splits_at_def take_all) apply (simp add: drop_n_D)+ apply (metis U a2_eq_b2 id_take_nth_drop q splits_at_def) using j apply arith done next case 2 obtain E where E: "E = (derivation_shift (drop n D) (Suc (length b1)) 0)" by blast then have "LeftDerivation (q@\) E b2" using U q by simp from LeftDerivation_breakdown'[OF this] obtain n' w1 w2 where w1w2: "n' \ length E \ b2 = w1 @ w2 \ LeftDerivation q (take n' E) w1 \ derivation_ge (drop n' E) (length w1) \ LeftDerivation \ (derivation_shift (drop n' E) (length w1) 0) w2" by blast have length_E_D: "length E = length D - n" using E n_bound by simp have n_plus_n'_bound: "n + n' \ length D" using length_E_D w1w2 n_bound by arith have take_breakdown: "take (n + n') D = (take n D) @ (take n' (drop n D))" using take_add by blast have q_w1: "LeftDerivation q (take n' E) w1" using w1w2 by blast have isw: "is_word (b1 @ [U])" using 2 by blast have take_n': "take n' (drop n D) = derivation_shift (take n' E) 0 (Suc (length b1))" by (metis E U derivation_shift_left_right_cancel take_derivation_shift) have \'_derives_b1_U_w1: "LeftDerivation \' (take (n + n') D) (b1 @ U # w1)" apply (subst take_breakdown) apply (rule_tac LeftDerivation_implies_append[where b="b1@[U]@q"]) apply (metis LeftDerivationFix_is_sentence LeftDerivation_append_suffix U is_sentence_concat ld_\ q) apply (simp add: take_n') by (rule LeftDerivation_append_prefix[OF q_w1, where u = "b1@[U]", OF isw, simplified]) have dge: "derivation_ge (drop (n + n') D) (Suc (length b1 + length w1))" proof - have "derivation_ge (drop n' (drop n D)) (length b1 + 1 + length w1)" by (metis (no_types) E Suc_eq_plus1 U append_take_drop_id derivation_ge_append derivation_ge_shift_plus drop_derivation_shift w1w2) then show "derivation_ge (drop (n + n') D) (Suc (length b1 + length w1))" by (metis (no_types) Suc_eq_plus1 add.commute drop_drop semiring_normalization_rules(23)) qed show ?case apply (rule_tac x="n+n'" in exI) apply (rule_tac x="b1 @ [U] @ w1" in exI) apply (rule_tac x=w2 in exI) apply auto using n_plus_n'_bound apply simp apply (rule_tac x="\'" in exI) using \' \'_derives_b1_U_w1 apply blast apply (rule_tac x="\' @ \" in exI) apply (metis Cons_eq_appendI LeftDerivationFix_is_sentence LeftDerivation_append_suffix \' \'_derives_b1_U_w1 append_assoc is_sentence_concat ld_\ ld_\) apply (rule dge) apply (metis E Suc_eq_plus1 add.commute derivation_shift_0_shift drop_derivation_shift drop_drop w1w2) using U splits_at_combine w1w2 apply auto[1] by (simp add: j) qed qed lemma LeftDerivationLadder_propagate: "LeftDerivationLadder (\@\) D L \ \ ladder_i L 0 < length \ \ n = ladder_n L index \ index < length L \ if (index + 1 < length L) then (\ \. LeftDerivation \ (take n D) \ \ ladder_\ (\@\) D L index = \@\ \ ladder_j L index < length \) else (\ n' \ \'. (index = 0 \ ladder_prev_n L index < n') \ n' \ n \ LeftDerivation \ (take n' D) \ \ LeftDerivation (\@\) (take n' D) (\@\) \ derivation_ge (drop n' D) (length \) \ LeftDerivation \ (derivation_shift (drop n' D) (length \) 0) \' \ ladder_\ (\@\) D L index = \@\' \ ladder_j L index < length \)" proof (induct index arbitrary: n) case 0 have ldfix: "LeftDerivationFix (\@\) (ladder_i L 0) (take n D) (ladder_j L 0) (ladder_\ (\@\) D L 0)" using "0.prems"(1) "0.prems"(3) LeftDerivationLadder_def by blast from 0 have "1 < length L \ 1 = length L" by arith then show ?case proof (induct rule: disjCases2) case 1 have "LeftDerivationIntrosAt (\@\) D L 1" using "0.prems"(1) "1.hyps" LeftDerivationIntros_def LeftDerivationLadder_def by blast from LeftDerivationIntrosAt_implies_nonterminal[OF this] have "is_nonterminal (ladder_\ (\ @ \) D L 0 ! ladder_j L 0)" by (simp add: ladder_\_def ladder_i_def) with ldfix have "is_nonterminal ((\@\) ! (ladder_i L 0))" by (simp add: LeftDerivationFix_def) from LeftDerivationFix_splits_at_nonterminal[OF ldfix this] obtain U a1 a2 b where thesplit: "splits_at (\ @ \) (ladder_i L 0) a1 U a2 \ splits_at (ladder_\ (\ @ \) D L 0) (ladder_j L 0) b U a2 \ LeftDerivation a1 (take n D) b" by blast have "\ \'. a2 = \' @ \ \ \ = a1 @ [U] @ \'" using thesplit splits_at_append_suffix_prevails using "0.prems"(2) by blast then obtain \' where \': "a2 = \' @ \ \ \ = a1 @ ([U] @ \')" by blast obtain \ where \: "\ = b @ ([U] @ \')" by blast have "is_sentence \" using LeftDerivationFix_is_sentence is_sentence_concat ldfix by blast then have "is_sentence ([U] @ \')" using \' is_sentence_concat by blast with \' thesplit have "LeftDerivation (a1 @ ([U] @ \')) (take n D) (b @ ([U] @ \'))" using LeftDerivation_append_suffix by blast then have \_derives_\: "LeftDerivation \ (take n D) \" using \ \' by blast have \_append_\: "ladder_\ (\ @ \) D L 0 = \@\" by (metis \ \' append_assoc splits_at_combine thesplit) have ladder_j_bound: "ladder_j L 0 < length \" by (metis One_nat_def \ diff_add_inverse dual_order.strict_implies_order leD le_add1 length_Cons length_append length_take list.size(3) min.absorb2 neq0_conv splits_at_def thesplit zero_less_diff zero_less_one) show ?case using 1 apply simp apply (rule_tac x="\" in exI) by (auto simp add: \_derives_\ \_append_\ ladder_j_bound) next case 2 note case_2 = 2 have n_def: "n = length D" by (metis "0.prems"(1) "0.prems"(3) "2.hyps" LeftDerivationLadder_def One_nat_def diff_Suc_1 is_ladder_def ladder_last_n_intro) then have take_n_D: "take n D = D" by (simp add: eq_imp_le) from LeftDerivationFix_splits_at_symbol[OF ldfix] obtain U a1 a2 b1 b2 m where U: "splits_at (\ @ \) (ladder_i L 0) a1 U a2 \ splits_at (ladder_\ (\ @ \) D L 0) (ladder_j L 0) b1 U b2 \ m \ length (take n D) \ LeftDerivation a1 (take m (take n D)) b1 \ derivation_ge (drop m (take n D)) (Suc (length b1)) \ LeftDerivation a2 (derivation_shift (drop m (take n D)) (Suc (length b1)) 0) b2 \ (m = length (take n D) \ (m < length (take n D) \ is_word (b1 @ [U])))" by blast obtain D' where D': "D' = derivation_shift (drop m D) (Suc (length b1)) 0" by blast then have a2_derives_b2: "LeftDerivation a2 D' b2" using U take_n_D by auto from U have m_leq_n: "m \ n" by (simp add: "0.prems"(1) "0.prems"(3) "0.prems"(4) LeftDerivationLadder_def is_ladder_def min.absorb2) from U have "splits_at (\ @ \) (ladder_i L 0) a1 U a2" by blast from splits_at_append_suffix_prevails[OF this 0(2)] obtain v' where v': "a2 = v' @ \ \ \ = a1 @ [U] @ v'" by blast have a1_derives_b1: "LeftDerivation a1 (take m D) b1" using m_leq_n U by (metis "0.prems"(1) "0.prems"(3) "2.hyps" LeftDerivationLadder_def One_nat_def cancel_comm_monoid_add_class.diff_cancel is_ladder_def ladder_last_n_intro order_refl take_all) have "LeftDerivation (v' @ \) D' b2" using a2_derives_b2 v' by simp from LeftDerivation_breakdown'[OF this] obtain m' w1 w2 where w12: "b2 = w1 @ w2 \ m' \ length D' \ LeftDerivation v' (take m' D') w1 \ derivation_ge (drop m' D') (length w1) \ LeftDerivation \ (derivation_shift (drop m' D') (length w1) 0) w2" by blast have "length D' \ length D - m" by (simp add: D') then have "m' \ length D - m" using w12 dual_order.trans by blast - then have m_m'_leq_n: "m + m' \ n" using n_def m_leq_n le_diff_conv2 add.commute + then have m_m'_leq_n: "m + m' \ n" using n_def m_leq_n Nat.le_diff_conv2 add.commute by linarith obtain \ where \: "\ = b1 @ ([U] @ w1)" by blast have "is_sentence ([U] @ v')" using LeftDerivationFix_is_sentence is_sentence_concat ldfix v' by blast then have "LeftDerivation (a1 @ ([U] @ v')) (take m D) (b1 @ ([U] @ v'))" using LeftDerivation_append_suffix a1_derives_b1 by blast then have \_derives_pre_\: "LeftDerivation \ (take m D) (b1 @ ([U] @ v'))" using v' by blast have "m = n \ (m < n \ is_word (b1 @ [U]))" using U n_def[symmetric] take_n_D by simp then have pre_\_derives_\: "LeftDerivation (b1 @ ([U] @ v')) (take m' (drop m D)) \" proof (induct rule: disjCases2) case 1 then have "m' = 0" using m_m'_leq_n by arith then show ?case apply (simp add: \) using w12 by simp next case 2 then have is_word_prefix: "is_word (b1 @ [U])" by blast have take_drop_eq: "take m' (drop m D) = derivation_shift (take m' D') 0 (length (b1 @ [U]))" apply (simp add: D' take_derivation_shift) by (metis U derivation_shift_left_right_cancel take_derivation_shift take_n_D) have v'_derives_w1: "LeftDerivation v' (take m' D') w1" by (simp add: w12) with is_word_prefix have "LeftDerivation ((b1 @ [U]) @ v') (derivation_shift (take m' D') 0 (length (b1 @ [U]))) ((b1 @ [U]) @ w1)" using LeftDerivation_append_prefix by blast with take_drop_eq show ?case by (simp add: \) qed have "(take m D) @ (take m' (drop m D)) = (take (m + m') D)" by (simp add: take_add) then have \_derives_\: "LeftDerivation \ (take (m + m') D) \" using LeftDerivation_implies_append \_derives_pre_\ pre_\_derives_\ by fastforce have derivation_ge_drop_m_m': "derivation_ge (drop (m + m') D) (length \)" proof - have f1: "drop m' (drop m D) = drop (m + m') D" by (simp add: add.commute) have "derivation_ge (drop m' (drop m D)) (Suc (length b1))" by (metis (no_types) U append_take_drop_id derivation_ge_append take_n_D) then show "derivation_ge (drop (m + m') D) (length \)" using f1 by (metis (no_types) D' \ append_assoc derivation_ge_shift_plus drop_derivation_shift length_append length_append_singleton w12) qed have \_derives_w2: "LeftDerivation \ (derivation_shift (drop (m + m') D) (length \) 0) w2" proof - have "derivation_shift (drop m' D') (length w1) 0 = derivation_shift (drop (m + m') D) (length \) 0" by (simp add: D' \ add.commute derivation_shift_0_shift drop_derivation_shift) then show "LeftDerivation \ (derivation_shift (drop (m + m') D) (length \) 0) w2" using w12 by presburger qed have ladder_\_def: "ladder_\ (\ @ \) D L 0 = \ @ w2" using U \ splits_at_combine w12 by auto have ladder_j_bound: "ladder_j L 0 < length \" using U \ splits_at_def by auto show ?case using 2 apply simp apply (rule_tac x="m + m'" in exI) apply (auto simp add: m_m'_leq_n) apply (rule_tac x="\" in exI) apply (auto simp add: \_derives_\) using LeftDerivationFix_is_sentence LeftDerivation_append_suffix \_derives_\ is_sentence_concat ldfix apply blast using derivation_ge_drop_m_m' apply blast apply (rule_tac x="w2" in exI) apply auto using \_derives_w2 apply blast using ladder_\_def apply blast using ladder_j_bound apply blast done qed next case (Suc index) have step: "LeftDerivationIntrosAt (\@\) D L (Suc index)" by (metis LeftDerivationIntros_def LeftDerivationLadder_def Suc.prems(1) Suc.prems(4) Suc_eq_plus1_left le_add1) have index_plus_1_bound: "index + 1 < length L" using Suc.prems(4) by linarith then have index_bound: "index < length L" by arith obtain n' where n': "n' = ladder_n L index" by blast from Suc.hyps[OF Suc.prems(1) Suc.prems(2) n' index_bound] index_plus_1_bound have "\ \'. LeftDerivation \ (take n' D) \' \ ladder_\ (\@\) D L index = \'@\ \ ladder_j L index < length \'" by auto then obtain \' where \': "LeftDerivation \ (take n' D) \' \ ladder_\ (\@\) D L index = \'@\ \ ladder_j L index < length \'" by blast have Suc_index_bound: "Suc index < length L" using Suc.prems by auto have is_ladder: "is_ladder D L" using Suc.prems LeftDerivationLadder_def by auto have n_def: "n = ladder_n L (Suc index)" using Suc_index_bound n' by (simp add: Suc.prems(3)) with n' have n'_less_n: "n' < n" using is_ladder Suc_index_bound is_ladder_def lessI by blast have ladder_\_is_\: "ladder_\ (\@\) D L (Suc index) = ladder_\ (\@\) D L index" by (simp add: ladder_\_def) obtain i where i: "i = ladder_i L (Suc index)" by blast obtain e where e: "e = (D ! n')" by blast obtain E where E: "E = drop (Suc n') (take n D)" by blast obtain ix where ix: "ix = ladder_ix L (Suc index)" by blast obtain j where j: "j = ladder_j L (Suc index)" by blast obtain \ where \: "\ = ladder_\ (\@\) D L (Suc index)" by blast have intro: "LeftDerivationIntro (\'@\) i (snd e) ix E j \" by (metis E LeftDerivationIntrosAt_def \' \ ladder_\_is_\ diff_Suc_1 e i ix j local.step n' n_def) have is_eq_fst_e: "i = fst e" by (metis LeftDerivationIntrosAt_def diff_Suc_1 e i local.step n') have i_less_\': "i < length \'" using i \' ladder_i_def by simp have "(Suc index) + 1 < length L \ (Suc index) + 1 = length L" using Suc_index_bound by arith then show ?case proof (induct rule: disjCases2) case 1 from 1 have "LeftDerivationIntrosAt (\@\) D L (Suc (Suc index))" by (metis LeftDerivationIntros_def LeftDerivationLadder_def Suc.prems(1) Suc_eq_plus1 Suc_eq_plus1_left le_add1) from LeftDerivationIntrosAt_implies_nonterminal[OF this] have "is_nonterminal (ladder_\ (\ @ \) D L (Suc (Suc index)) ! ladder_i L (Suc (Suc index)))" by blast then have non_\_j: "is_nonterminal (\ ! j)" by (simp add: \ j ladder_\_def ladder_i_def) from LeftDerivationIntro_propagate[OF intro i_less_\' non_\_j] obtain \ where \: "LeftDerivation \' ((i, snd e) # E) \ \ \ = \ @ \ \ j < length \" by blast have \_\: "LeftDerivation \ ((take n' D)@((i, snd e) # E)) \" using \' \ LeftDerivation_implies_append by blast have i_e: "(i, snd e) = e" by (simp add: is_eq_fst_e) have take_n_D_e: "((take n' D)@(e # E)) = take n D" proof - (* automatically found *) obtain nn :: "(nat \ symbol \ symbol list) list \ (nat \ nat \ nat) list \ nat" and nna :: "(nat \ symbol \ symbol list) list \ (nat \ nat \ nat) list \ nat" and nnb :: "(nat \ symbol \ symbol list) list \ (nat \ nat \ nat) list \ nat" where f1: "(\ps psa. \ is_ladder ps psa \ psa \ [] \ (\n. \ n < length psa \ ladder_n psa n \ length ps) \ (\n na. (\ n < na \ \ na < length psa) \ ladder_n psa n < ladder_n psa na) \ ladder_last_n psa = length ps) \ (\ps psa. (psa = [] \ nn ps psa < length psa \ \ ladder_n psa (nn ps psa) \ length ps \ (nna ps psa < nnb ps psa \ nnb ps psa < length psa) \ \ ladder_n psa (nna ps psa) < ladder_n psa (nnb ps psa) \ ladder_last_n psa \ length ps) \ is_ladder ps psa)" using is_ladder_def by moura then have f2: "ladder_last_n L = length D" using is_ladder by blast have f3: "min (ladder_last_n L) n = n" using f1 by (metis (no_types) Suc_eq_plus1 index_plus_1_bound is_ladder min.absorb2 n_def) then have "take n' (take n D) @ take n D ! n' # E = take n D" using f2 by (metis E id_take_nth_drop length_take n'_less_n) then show ?thesis using f3 f2 by (metis (no_types) append_assoc append_eq_conv_conj dual_order.strict_implies_order e length_take min.absorb2 n'_less_n nth_append) qed from 1 show ?case apply auto apply (rule_tac x=\ in exI) apply auto using \_\ i_e take_n_D_e apply auto[1] using \ \ apply blast using \ j by blast next case 2 from LeftDerivationIntro_finish[OF intro i_less_\'] obtain k \ \' where kw\': "k \ length E \ LeftDerivation \' ((i, snd e) # take k E) \ \ LeftDerivation (\' @ \) ((i, snd e) # take k E) (\ @ \) \ derivation_ge (drop k E) (length \) \ LeftDerivation \ (derivation_shift (drop k E) (length \) 0) \' \ \ = \ @ \' \ j < length \" by blast have ladder_last_n_1: "ladder_last_n L = n" by (metis "2.hyps" Suc_eq_plus1 diff_Suc_1 ladder_last_n_def n_def) from is_ladder have ladder_last_n_2: "ladder_last_n L = length D" using is_ladder_def by blast from ladder_last_n_1 ladder_last_n_2 have n_eq_length_D: "n = length D" by blast have take_split: "take (Suc (n' + k)) D = (take n' D) @ ((i, snd e) # take k E)" apply (simp add: E n_eq_length_D) by (metis (no_types, lifting) Cons_eq_appendI add_Suc append_eq_appendI e is_eq_fst_e n'_less_n n_eq_length_D prod.collapse self_append_conv2 take_Suc_conv_app_nth take_add) have \_\: "LeftDerivation \ (take (Suc (n' + k)) D) \" apply (subst take_split) apply (rule LeftDerivation_implies_append[where b="\'"]) apply (simp add: \') using kw\' by blast have Suc_n'_k_bound: "Suc (n' + k) \ n" using E kw\' n'_less_n by auto[1] from 2 show ?case apply auto apply (rule_tac x="Suc (n' + k)" in exI) apply auto apply (simp add: ladder_prev_n_def n') using Suc_n'_k_bound apply blast apply (rule_tac x="\" in exI) apply auto using \_\ apply blast using \_\ LeftDerivationFix_def LeftDerivationLadder_def LeftDerivation_append_suffix Suc.prems(1) is_sentence_concat apply auto[1] apply (metis E add.commute add_Suc_right drop_drop kw\' n_eq_length_D nat_le_linear take_all) apply (rule_tac x="\'" in exI) apply auto apply (metis E LeftDerivationLadder_ladder_n_bound Suc.prems(1) Suc_index_bound add.commute add_Suc_right drop_drop kw\' n_def n_eq_length_D take_all) using \ kw\' apply blast using j kw\' by blast qed qed lemma ladder_i_of_cut_at_0: assumes L_non_empty: "L \ []" shows "ladder_i (ladder_cut L n) 0 = ladder_i L 0" proof - have "length L \ 0" using L_non_empty by auto then have "length L = 1 \ length L > 1" by arith then show ?thesis proof (induct rule: disjCases2) case 1 then show ?case apply (simp add: ladder_cut_def ladder_i_def deriv_i_def) by (simp add: assms hd_conv_nth) next case 2 then show ?case apply (simp add: ladder_cut_def ladder_i_def deriv_i_def) by (metis diff_is_0_eq hd_conv_nth leD list_update_nonempty nth_list_update_neq) qed qed lemma ladder_last_j_of_cut: assumes L_non_empty: "L \ []" shows "ladder_last_j (ladder_cut L n) = ladder_last_j L" proof - have length_L_nonzero: "length L \ 0" using L_non_empty by auto then have length_ladder_cut: "length (ladder_cut L n) = length L" by (metis ladder_cut_def length_list_update) show ?thesis apply (simp add: ladder_last_j_def length_ladder_cut) apply (simp add: ladder_cut_def ladder_j_def deriv_j_def) by (metis length_L_nonzero diff_less neq0_conv nth_list_update_eq snd_conv zero_less_Suc) qed lemma length_ladder_cut: assumes L_non_empty: "L \ []" shows "length (ladder_cut L n) = length L" by (metis ladder_cut_def length_list_update) lemma ladder_last_n_of_cut: assumes L_non_empty: "L \ []" shows "ladder_last_n (ladder_cut L n) = n" proof - show ?thesis apply (simp add: ladder_last_n_def length_ladder_cut[OF L_non_empty]) apply (simp add: ladder_n_def ladder_cut_def deriv_n_def) by (metis assms diff_Suc_less fst_conv length_greater_0_conv nth_list_update_eq) qed lemma ladder_n_of_cut: assumes L_non_empty: "L \ []" assumes "index < length L - 1" shows "ladder_n (ladder_cut L n) index = ladder_n L index" by (metis assms(2) ladder_cut_def ladder_n_def nat_neq_iff nth_list_update_neq) lemma ladder_n_prev_bound: assumes ladder: "is_ladder D L" assumes u_bound: "u < length L - 1" shows "ladder_n L u \ ladder_prev_n L (length L - 1)" proof - have "ladder_n L u \ ladder_n L (length L - 2)" proof - have "u < Suc (length L - 2)" using u_bound by linarith then show ?thesis by (metis (no_types) diff_Suc_less is_ladder_def ladder leI length_greater_0_conv not_less_eq numeral_2_eq_2 order.order_iff_strict) qed then show ?thesis by (metis One_nat_def Suc_diff_Suc diff_Suc_1 ladder_prev_n_def neq0_conv not_less0 numeral_2_eq_2 u_bound zero_less_diff) qed lemma ladder_n_last_is_length: assumes "is_ladder D L" shows "ladder_n L (length L - 1) = length D" using assms is_ladder_def ladder_last_n_intro by auto lemma derivation_ge_shift_implies_derivation_ge: assumes dge: "derivation_ge (derivation_shift F 0 j) k" shows "derivation_ge F (k - j)" proof - have "\ i r. (i, r) \ set (derivation_shift F 0 j) \ i \ k" using dge derivation_ge_def by auto { fix i :: nat fix r :: "symbol \ (symbol list)" assume ir: "(i, r) \ set F" then have "(i + j, r) \ set (derivation_shift F 0 j)" proof - have "(i + j, r) \ (\p. (fst p - 0 + j, snd p))  set F" by (metis (lifting) ir diff_zero image_eqI prod.collapse prod.inject) then show ?thesis by (simp add: derivation_shift_def) qed then have "i + j \ k" using dge derivation_ge_def by auto then have "i \ k - j" by auto } then show ?thesis using derivation_ge_def by auto qed lemma Derives1_bound': "Derives1 a i r b \ i \ length b" by (metis Derives1_bound Derives1_take append_Nil2 append_take_drop_id drop_eq_Nil dual_order.strict_implies_order length_take min.absorb2 nat_le_linear) lemma LeftDerivation_Derives1_last: assumes "LeftDerivation a D b" assumes "D \ []" shows "Derives1 (Derive a (take (length D - 1) D)) (fst (last D)) (snd (last D)) b" by (metis Derive LeftDerivation_Derive_take_LeftDerives1 LeftDerivation_implies_Derivation LeftDerives1_implies_Derives1 assms(1) assms(2) last_conv_nth le_refl length_0_conv take_all) lemma last_of_prefix_in_set: assumes "n < length E" assumes "D = E@F" shows "last E \ set (drop n D)" proof - have f1: "last (drop n E) = last E" by (simp add: assms(1)) have "drop n E \ []" by (metis (no_types) Cons_nth_drop_Suc assms(1) list.simps(3)) then show ?thesis using f1 by (metis (no_types) append.simps(2) append_butlast_last_id append_eq_conv_conj assms(2) drop_append in_set_dropD insertCI list.set(2)) qed lemma LeftDerivationFix_cut_appendix: assumes ldfix: "LeftDerivationFix (\@\) i D j (\@\')" assumes \_\: "LeftDerivation \ (take n D) \" assumes n_bound: "n \ length D" assumes dge: "derivation_ge (drop n D) (length \)" assumes i_in: "i < length \" assumes j_in: "j < length \" shows "LeftDerivationFix \ i (take n D) j \" proof - from LeftDerivationFix_def[where \="\@\" and i=i and D=D and j=j and \="\@\'"] obtain E F where EF: "is_sentence (\ @ \) \ is_sentence (\ @ \') \ LeftDerivation (\ @ \) D (\ @ \') \ i < length (\ @ \) \ j < length (\ @ \') \ (\ @ \) ! i = (\ @ \') ! j \ D = E @ derivation_shift F 0 (Suc j) \ LeftDerivation (take i (\ @ \)) E (take j (\ @ \')) \ LeftDerivation (drop (Suc i) (\ @ \)) F (drop (Suc j) (\ @ \'))" using ldfix by auto with i_in j_in have take_i_E_take_j: "LeftDerivation (take i \) E (take j \)" by (simp add: less_or_eq_imp_le) obtain m where m: "m = length E" by blast { assume n_less_m: "n < m" then have E_nonempty: "E \ []" using gr_implies_not0 list.size(3) m by auto have last_E_in_set: "last E \ set (drop n D)" using last_of_prefix_in_set n_less_m m EF by blast obtain k r where kr: "(k, r) = last E" by (metis old.prod.exhaust) have k_lower_bound: "k \ length \" using dge last_E_in_set kr by (metis derivation_ge_def fst_conv) have "\ \'. Derives1 \' k r (take j \)" using LeftDerivation_Derives1_last take_i_E_take_j by (metis E_nonempty kr fst_conv snd_conv) then have "k \ j" by (metis Derives1_bound' j_in length_take less_imp_le_nat min.absorb2) then have k_upper_bound: "k < length \" using j_in by arith from k_lower_bound k_upper_bound have "False" by arith } then have m_le_n: "m \ n" by arith have take_i_E_take_j: "LeftDerivation (take i \) E (take j \)" by (simp add: take_i_E_take_j) have "take n D = E @ (take (n - m) (derivation_shift F 0 (Suc j)))" using EF m m_le_n by auto then have take_n_D: "take n D = E @ (derivation_shift (take (n - m) F) 0 (Suc j))" using take_derivation_shift by auto obtain F' where F': "F' = derivation_shift (take (n - m) F) 0 (Suc j)" by blast have "LeftDerivation ((take i \)@(drop i \)) E ((take j \)@(drop i \))" using take_i_E_take_j by (metis EF LeftDerivation_append_suffix append_take_drop_id is_sentence_concat) then have "LeftDerivation \ E ((take j \)@(drop i \))" by simp with take_n_D have take_j_drop_i: "LeftDerivation ((take j \)@(drop i \)) F' \" using F' by (metis Derivation_unique_dest LeftDerivation_append LeftDerivation_implies_Derivation \_\) have F'_ge: "derivation_ge F' (Suc j)" using F' derivation_ge_shift by blast have drop_append: "drop i \ = [\!i] @ (drop (Suc i) \)" by (simp add: Cons_nth_drop_Suc i_in) have take_append: "take j \ @ [\!i] = take (Suc j) \" by (metis LeftDerivationFix_def i_in j_in ldfix nth_superfluous_append take_Suc_conv_app_nth) have take_drop_Suc: "(take j \)@(drop i \) = (take (Suc j) \)@(drop (Suc i) \)" by (simp add: drop_append take_append) with take_drop_Suc take_j_drop_i have "LeftDerivation ((take (Suc j) \)@(drop (Suc i) \)) F' \" by auto note helper = LeftDerivation_skip_prefix[OF this] have len_take: "length (take (Suc j) \) = Suc j" by (simp add: Suc_leI j_in min.absorb2) have F'_shift: "derivation_shift F' (Suc j) 0 = take (n - m) F" using F' derivation_shift_right_left_cancel by blast have LeftDerivation_drop: "LeftDerivation (drop (Suc i) \) (take (n - m) F) (drop (Suc j) \)" using helper len_take F'_shift F'_ge by auto show ?thesis apply (auto simp add: LeftDerivationFix_def) using LeftDerivationFix_is_sentence is_sentence_concat ldfix apply blast using LeftDerivationFix_is_sentence is_sentence_concat ldfix apply blast using \_\ apply blast using i_in apply blast using j_in apply blast using LeftDerivationFix_def i_in j_in ldfix apply auto[1] apply (rule_tac x=E in exI) apply (rule_tac x="take (n - m) F" in exI) apply auto using take_n_D apply blast using take_i_E_take_j apply blast using LeftDerivation_drop by blast qed lemma LeftDerivationFix_cut_appendix': assumes ldfix: "LeftDerivationFix (\@\) i D j (\@\')" assumes \_\: "LeftDerivation \ D \" assumes i_in: "i < length \" assumes j_in: "j < length \" shows "LeftDerivationFix \ i D j \" proof - obtain n where n: "n = length D" by blast have "LeftDerivationFix \ i (take n D) j \" apply (rule_tac LeftDerivationFix_cut_appendix) apply (rule ldfix) using \_\ n apply auto[1] using n apply auto[1] using n apply auto[1] using i_in apply blast using j_in apply blast done then show ?thesis using n by auto qed lemma LeftDerivationIntro_cut_appendix: assumes ldfix: "LeftDerivationIntro (\@\) i r ix D j (\@\')" assumes \_\: "LeftDerivation \ ((i,r)#(take n D)) \" assumes n_bound: "n \ length D" assumes dge: "derivation_ge (drop n D) (length \)" assumes i_in: "i < length \" assumes j_in: "j < length \" shows "LeftDerivationIntro \ i r ix (take n D) j \" proof - from LeftDerivationIntro_def[where \="\@\" and i=i and r=r and ix=ix and D=D and j=j and \="\@\'"] obtain \ where \: "LeftDerives1 (\ @ \) i r \ \ ix < length (snd r) \ snd r ! ix = (\ @ \') ! j \ LeftDerivationFix \ (i + ix) D j (\ @ \')" using ldfix by blast then have "\ \'. \ = \' @ \ \ i + length (snd r) \ length \'" using i_in using LeftDerives1_append_replace_in_left by blast then obtain \' where \': "\ = \' @ \ \ i + length (snd r) \ length \'" by blast have \_\': "LeftDerives1 \ i r \'" using \' \ using LeftDerives1_skip_suffix i_in by blast from \_\ obtain u where u: "LeftDerives1 \ i r u \ LeftDerivation u (take n D) \" by auto with \_\' have "u = \'" using Derives1_unique_dest LeftDerives1_implies_Derives1 by blast with u have \'_\: "LeftDerivation \' (take n D) \" by auto have ldfix_append: "LeftDerivationFix (\' @ \) (i + ix) D j (\ @ \')" using \' \ by blast have i_plus_ix_bound: "i + ix < length \'" using \ \' using add_lessD1 le_add_diff_inverse less_asym' linorder_neqE_nat nat_add_left_cancel_less by linarith from LeftDerivationFix_cut_appendix[OF ldfix_append \'_\ n_bound dge i_plus_ix_bound j_in] have ldfix: "LeftDerivationFix \' (i + ix) (take n D) j \" . show ?thesis apply (simp add: LeftDerivationIntro_def) apply (rule_tac x="\'" in exI) apply auto using \_\' apply blast using \ apply blast apply (simp add: \ j_in) using ldfix by blast qed lemma LeftDerivationIntro_cut_appendix': assumes ldfix: "LeftDerivationIntro (\@\) i r ix D j (\@\')" assumes \_\: "LeftDerivation \ ((i,r)#D) \" assumes i_in: "i < length \" assumes j_in: "j < length \" shows "LeftDerivationIntro \ i r ix D j \" proof - obtain n where n: "n = length D" by blast have "LeftDerivationIntro \ i r ix (take n D) j \" apply (rule_tac LeftDerivationIntro_cut_appendix) apply (rule ldfix) using \_\ n apply auto[1] using n apply auto[1] using n apply auto[1] using i_in apply blast using j_in apply blast done then show ?thesis using n by auto qed lemma ladder_n_monotone: "is_ladder D L \ u \ v \ v < length L \ ladder_n L u \ ladder_n L v" by (metis is_ladder_def le_neq_implies_less linear not_less) lemma ladder_i_cut: assumes index_bound: "index < length L" shows "ladder_i (ladder_cut L n) index = ladder_i L index" proof - have "index = 0 \ index > 0" by arith then show ?thesis proof (induct rule: disjCases2) case 1 with index_bound have "L \ []" by (simp add: less_numeral_extra(3)) then show ?case using 1 by (simp add: ladder_i_of_cut_at_0) next case 2 then show ?case apply (auto simp add: ladder_i_def ladder_cut_def ladder_j_def deriv_j_def Let_def) using index_bound by auto qed qed lemma ladder_j_cut: assumes index_bound: "index < length L" shows "ladder_j (ladder_cut L n) index = ladder_j L index" by (metis gr_implies_not0 index_bound ladder_cut_def ladder_j_def ladder_last_j_def ladder_last_j_of_cut length_ladder_cut list.size(3) nth_list_update_neq) lemma ladder_ix_cut: assumes index_lower_bound: "index > 0" assumes index_upper_bound: "index < length L" shows "ladder_ix (ladder_cut L n) index = ladder_ix L index" proof - show ?thesis using index_lower_bound apply (simp add: ladder_ix_def deriv_ix_def) by (metis index_upper_bound ladder_cut_def nth_list_update_eq nth_list_update_neq snd_conv) qed lemma LeftDerivation_from_in_between: assumes \_\: "LeftDerivation \ (take u D) \" assumes \_\: "LeftDerivation \ (take v D) \" assumes u_le_v: "u \ v" shows "LeftDerivation \ (drop u (take v D)) \" proof - have take_split: "take v D = take u D @ (drop u (take v D))" by (metis u_le_v add_diff_cancel_left' drop_take le_Suc_ex take_add) then show ?thesis using \_\ \_\ by (metis (no_types, lifting) Derivation_unique_dest LeftDerivation_append LeftDerivation_implies_Derivation) qed lemma LeftDerivationLadder_cut_appendix_helper: assumes LDLadder: "LeftDerivationLadder (\@\) D L \" assumes ladder_i_in_\: "ladder_i L 0 < length \" shows "\ E F \1 \2 L'. D = E@F \ \ = \1 @ \2 \ LeftDerivationLadder \ E L' \1 \ derivation_ge F (length \1) \ LeftDerivation \ (derivation_shift F (length \1) 0) \2 \ L' = ladder_cut L (length E)" proof - have is_ladder_D_L: "is_ladder D L" using LDLadder LeftDerivationLadder_def by blast obtain n where n: "n = ladder_last_n L" by blast then have n_eq_ladder_n: "n = ladder_n L (length L - 1)" using ladder_last_n_def by blast have length_L_nonzero: "length L > 0" using LeftDerivationLadder_def assms(1) is_ladder_def by blast from LeftDerivationLadder_propagate[OF LDLadder ladder_i_in_\ n_eq_ladder_n] obtain n' \ \' where finish: "(length L - 1 = 0 \ ladder_prev_n L (length L - 1) < n') \ n' \ n \ LeftDerivation \ (take n' D) \ \ LeftDerivation (\ @ \) (take n' D) (\ @ \) \ derivation_ge (drop n' D) (length \) \ LeftDerivation \ (derivation_shift (drop n' D) (length \) 0) \' \ ladder_\ (\ @ \) D L (length L - 1) = \ @ \' \ ladder_j L (length L - 1) < length \" using length_L_nonzero by auto obtain E where E: "E = take n' D" by blast obtain F where F: "F = drop n' D" by blast obtain L' where L': "L' = ladder_cut L (length E)" by blast have \_ladder: "\ = ladder_\ (\ @ \) D L (length L - 1)" by (metis Derive LDLadder LeftDerivationLadder_def LeftDerivation_implies_Derivation append_Nil2 append_take_drop_id drop_eq_Nil is_ladder_def ladder_\_def le_refl n n_eq_ladder_n) then have \: "\ = \ @ \'" using finish by auto have "is_sentence (\@\)" using LDLadder LeftDerivationFix_is_sentence LeftDerivationLadder_def by blast then have is_sentence_\: "is_sentence \" using is_sentence_concat by blast have "is_sentence \" using Derivation_implies_derives LDLadder LeftDerivationFix_is_sentence LeftDerivationLadder_def LeftDerivation_implies_Derivation derives_is_sentence by blast then have is_sentence_\: "is_sentence \" using \ is_sentence_concat by blast have length_L': "length L' = length L" by (metis L' ladder_cut_def length_list_update) have ladder_last_n_L': "ladder_last_n L' = length E" using L' ladder_last_n_of_cut length_L_nonzero by blast have length_D_eq_n: "length D = n" using LDLadder LeftDerivationLadder_def is_ladder_def n by auto then have length_E_eq_n': "length E = n'" by (simp add: E finish min.absorb2) { fix u :: nat assume "u < length L'" then have "u < length L' - 1 \ u = length L' - 1" by arith then have "ladder_n L' u \ length E" proof (induct rule: disjCases2) case 1 have u_bound: "u < length L - 1" using 1 by (simp add: length_L') then have L'_eq_L: "ladder_n L' u = ladder_n L u" using L' ladder_n_of_cut length_L_nonzero length_greater_0_conv by blast from u_bound have "ladder_n L u \ ladder_prev_n L (length L - 1)" using ladder_n_prev_bound LeftDerivationLadder_def assms(1) by blast then show ?case using L'_eq_L finish length_E_eq_n' u_bound by linarith next case 2 then have "ladder_n L' u = length E" using ladder_last_n_L' ladder_last_n_def by auto then show ?case by auto qed } note ladder_n_bound = this { fix u :: nat fix v :: nat assume u_less_v: "u < v" assume v_bound: "v < length L'" have "v < length L' - 1 \ v = length L' - 1" using v_bound by arith then have "ladder_n L' u < ladder_n L' v" proof (induct rule: disjCases2) case 1 show ?case using "1.hyps" L' LeftDerivationLadder_def assms(1) is_ladder_def ladder_n_of_cut length_L' u_less_v by auto next case 2 note v_def = 2 have "v = 0 \ v \ 0" by arith then show ?case proof (induct rule: disjCases2) case 1 then show ?case using u_less_v by auto next case 2 then have "ladder_prev_n L (length L - 1) < n'" using finish v_def length_L' by linarith then show ?case by (metis (no_types, lifting) L' LeftDerivationLadder_def assms(1) ladder_last_n_L' ladder_last_n_def ladder_n_of_cut ladder_n_prev_bound le_neq_implies_less length_E_eq_n' length_L' length_greater_0_conv less_trans u_less_v v_def) qed qed } note ladder_n_pairwise_bound = this have is_ladder_E_L': "is_ladder E L'" apply (auto simp add: is_ladder_def ladder_last_n_L') using length_L_nonzero length_L' apply simp using ladder_n_bound apply blast using ladder_n_pairwise_bound by blast { fix index :: nat assume index_bound: "index + 1 < length L" then have index_le: "index < length L" by arith from index_bound have len_L_minus_1: "length L - 1 \ 0" by arith obtain m where m: "m = ladder_n L index" by blast from LeftDerivationLadder_propagate[OF LDLadder ladder_i_in_\ m index_le] obtain \ where \: "LeftDerivation \ (take m D) \ \ ladder_\ (\ @ \) D L index = \ @ \ \ ladder_j L index < length \" using index_bound by auto have L'_Derive: "ladder_\ \ E L' index = Derive \ (take (ladder_n L' index) E)" by (simp add: ladder_\_def) have ladder_n_L'_eq_L: "ladder_n L' index = ladder_n L index" using L' index_bound ladder_n_of_cut length_L_nonzero by auto have "ladder_prev_n L (length L - 1) < n'" using finish len_L_minus_1 by blast then have n'_is_upper_bound: "ladder_n L (length L - 2) < n'" using index_bound by (metis diff_diff_left ladder_prev_n_def len_L_minus_1 one_add_one) have index_upper_bound: "index \ length L - 2" using index_bound by linarith have ladder_n_upper_bound: "ladder_n L index \ ladder_n L (length L - 2)" apply (rule_tac ladder_n_monotone) apply (rule_tac is_ladder_D_L) apply (rule index_upper_bound) using length_L_nonzero by linarith with n'_is_upper_bound have m_le_n': "m \ n'" using dual_order.strict_implies_order le_less_trans m by linarith then have "take m E = take m D" by (metis E le_take_same length_E_eq_n' order_refl take_all) then have take_helper: "(take (ladder_n L' index) E) = take m D" by (simp add: ladder_n_L'_eq_L m) then have Derive_eq_\: "Derive \ (take (ladder_n L' index) E) = \" by (simp add: Derive LeftDerivation_implies_Derivation \) then have t1: "ladder_\ (\@\) D L index = (ladder_\ \ E L' index) @ \" by (simp add: L'_Derive \) have \_eq: "\ = ladder_\ \ E L' index" by (simp add: Derive_eq_\ L'_Derive) then have t2: "LeftDerivation \ (take (ladder_n L index) D) (ladder_\ \ E L' index)" using \ m by blast have t3: "(take (ladder_n L' index) E) = take (ladder_n L index) D" by (simp add: m take_helper) have t4: "ladder_j L index < length (ladder_\ \ E L' index)" using \ \_eq by blast have t5: "E ! (ladder_n L' index) = D ! (ladder_n L index)" using E ladder_n_L'_eq_L ladder_n_upper_bound n'_is_upper_bound by auto note t = t1 t2 t3 t4 t5 } note ladder_early_stage = this { fix index :: nat assume index_bound: "index < length L" have i: "ladder_i L' index = ladder_i L index" using L' ladder_i_cut by (simp add: index_bound) have j: "ladder_j L' index = ladder_j L index" using L' ladder_j_cut by (simp add: index_bound) have ix: "index > 0 \ ladder_ix L' index = ladder_ix L index" using L' ladder_ix_cut by (simp add: index_bound) have \: "ladder_\ (\@\) D L index = (ladder_\ \ E L' index) @ \" by (simp add: index_bound ladder_\_def ladder_early_stage(1)) have i_bound: "index > 0 \ ladder_i L' index < length (ladder_\ \ E L' index)" using i index_bound ladder_\_def ladder_early_stage(4) ladder_i_def by auto note ij = i j ix \ i_bound } note ladder_every_stage = this { fix u :: nat fix v :: nat assume u_le_v: "u \ v" assume v_bound: "v < length L" have "ladder_n L u \ ladder_n L v" using is_ladder_D_L ladder_n_monotone u_le_v v_bound by blast } note ladder_L_n_pairwise_le = this { fix index :: nat assume index_lower_bound: "index > 0" assume index_upper_bound: "index + 1 < length L" note derivation = ladder_early_stage(2) have derivation1: "LeftDerivation \ (take (ladder_n L (index - Suc 0)) D) (ladder_\ \ E L' (index - Suc 0))" using derivation[of "index - Suc 0"] index_lower_bound index_upper_bound using One_nat_def Suc_diff_1 Suc_eq_plus1 le_less_trans lessI less_or_eq_imp_le by linarith have derivation2: "LeftDerivation \ (take (ladder_n L index) D) (ladder_\ \ E L' index)" using derivation[of index] index_upper_bound by blast have ladder_\_is_$symmetric]: "ladder_\ \ E L' (index - Suc 0) = ladder_\ \ E L' index" using index_lower_bound ladder_\_def by auto have ladder_n_le: "ladder_n L (index - Suc 0) \ ladder_n L index" apply (rule_tac ladder_L_n_pairwise_le) apply arith using index_upper_bound by arith from LeftDerivation_from_in_between[OF derivation1 derivation2 ladder_n_le] ladder_\_is_\ have "LeftDerivation (ladder_\ \ E L' index) (drop (ladder_n L' (index - Suc 0)) (take (ladder_n L' index) E)) (ladder_\ \ E L' index)" by (metis L' Suc_leI add_lessD1 index_lower_bound index_upper_bound ladder_early_stage(3) ladder_n_of_cut le_add_diff_inverse2 length_L_nonzero length_greater_0_conv less_diff_conv) } note LeftDerivation_delta_early = this have LeftDerivationFix_\_0: "LeftDerivationFix \ (ladder_i L' 0) (take (ladder_n L' 0) E) (ladder_j L' 0) (ladder_\ \ E L' 0)" proof - have ldfix: "LeftDerivationFix (\@\) (ladder_i L 0) (take (ladder_n L 0) D) (ladder_j L 0) (ladder_\ (\@\) D L 0)" using LDLadder LeftDerivationLadder_def by blast have ladder_i_L': "ladder_i L' 0 = ladder_i L 0" using L' ladder_i_of_cut_at_0 length_L_nonzero by blast have ladder_j_L': "ladder_j L' 0 = ladder_j L 0" by (metis L' ladder_cut_def ladder_j_def ladder_last_j_def ladder_last_j_of_cut length_L' length_greater_0_conv nth_list_update_neq) have "length L = 1 \ length L > 1" using length_L_nonzero by linarith then show ?thesis proof (induct rule: disjCases2) case 1 from 1 have ladder_n_L'_0: "ladder_n L' 0 = n'" using diff_is_0_eq' ladder_last_n_L' ladder_last_n_def length_E_eq_n' length_L' less_or_eq_imp_le by auto have take_n'_E: "take n' E = E" by (simp add: length_E_eq_n') from ladder_n_L'_0 take_n'_E have take_ladder_n_L': "take (ladder_n L' 0) E = E" by auto have "ladder_n L 0 = length D" by (simp add: "1.hyps" length_D_eq_n n_eq_ladder_n) then have take_ladder_n_L_0: "take (ladder_n L 0) D = D" by simp have ladder_\_\: "ladder_\ \ E L' 0 = \" apply (simp add: ladder_\_def take_ladder_n_L') by (simp add: Derive E LeftDerivation_implies_Derivation finish) have ladder_j_in_\: "ladder_j L 0 < length \" using finish "1.hyps" by auto have ldfix_1: "LeftDerivationFix (\@\) (ladder_i L 0) D (ladder_j L 0) (\@\')" using "1.hyps" \ \_ladder ldfix take_ladder_n_L_0 by auto then have "LeftDerivationFix \ (ladder_i L 0) E (ladder_j L 0) \" by (simp add: E LeftDerivationFix_cut_appendix finish ladder_i_in_\ ladder_j_in_\ length_D_eq_n) then show ?case by (simp add: ladder_i_L' ladder_j_L' take_ladder_n_L' ladder_\_\) next case 2 have h: "0 + 1 < length L" using "2.hyps" by auto note stage = ladder_early_stage[of 0, OF h] have ldfix0: "LeftDerivationFix (\@\) (ladder_i L 0) (take (ladder_n L 0) D) (ladder_j L 0) ((ladder_\ \ E L' 0) @ \)" using ladder_i_L' ladder_j_L' ldfix stage(1) stage(3) by auto from LeftDerivationFix_cut_appendix'[OF ldfix0 stage(2) ladder_i_in_\ stage(4)] show ?case by (simp add: ladder_i_L' ladder_j_L' stage(3)) qed qed { fix index :: nat assume index_bounds: "1 \ index \ index + 1 < length L" have introsAt_appendix: "LeftDerivationIntrosAt (\@\) D L index" using LDLadder LeftDerivationIntros_def LeftDerivationLadder_def add_lessD1 index_bounds by blast have index_plus_1_upper_bound: "index + 1 < length L" using index_bounds by arith note early_stage = ladder_early_stage[of index, OF index_plus_1_upper_bound] have ladder_i_L_index_eq_fst: "ladder_i L index = fst (D ! ladder_n L (index - Suc 0))" using introsAt_appendix LeftDerivationIntrosAt_def index_bounds by (metis One_nat_def) have E_at_D_at: "(E ! ladder_n L' (index - Suc 0)) = (D ! ladder_n L (index - Suc 0))" using ladder_early_stage[of "index - Suc 0"] by (metis One_nat_def add_lessD1 index_bounds le_add_diff_inverse2) then have ladder_i_L'_index_eq_fst: "ladder_i L' index = fst (E ! ladder_n L' (index - Suc 0))" using index_bounds ladder_i_L_index_eq_fst ladder_every_stage(1) le_add1 le_less_trans by auto have same_derivation: "(drop (Suc (ladder_n L' (index - Suc 0))) (take (ladder_n L' index) E)) = (drop (Suc (ladder_n L (index - Suc 0))) (take (ladder_n L index) D))" using L' early_stage(3) index_bounds ladder_n_of_cut length_L_nonzero by auto have deriv_split: "(drop (ladder_n L' (index - Suc 0)) (take (ladder_n L' index) E)) = ((ladder_i L' index, snd (E ! ladder_n L' (index - Suc 0))) # drop (Suc (ladder_n L' (index - Suc 0))) (take (ladder_n L' index) E))" by (metis Cons_nth_drop_Suc One_nat_def Suc_le_lessD add_lessD1 diff_Suc_less index_bounds ladder_i_L'_index_eq_fst ladder_n_bound ladder_n_pairwise_bound length_L' length_take min.absorb2 nth_take prod.collapse) have "LeftDerivationIntrosAt \ E L' index" apply (auto simp add: LeftDerivationIntrosAt_def Let_def) using ladder_i_L'_index_eq_fst apply blast apply (rule_tac LeftDerivationIntro_cut_appendix'[where \=\ and \' =$) apply (metis E_at_D_at LeftDerivationIntrosAt_def One_nat_def Suc_le_lessD add_lessD1 early_stage(1) index_bounds introsAt_appendix ladder_every_stage(2) ladder_every_stage(3) ladder_every_stage(4) ladder_i_L'_index_eq_fst same_derivation) defer 1 using index_bounds ladder_every_stage(5) apply auto[1] using early_stage(4) index_bounds ladder_every_stage(2) apply auto[1] using LeftDerivation_delta_early deriv_split by (metis One_nat_def Suc_le_eq index_bounds) } note LeftDerivationIntrosAt_early = this { fix index :: nat assume index_bounds: "1 \ index \ index + 1 = length L" have introsAt_appendix: "LeftDerivationIntrosAt (\@\) D L index" using LDLadder LeftDerivationIntros_def LeftDerivationLadder_def add_lessD1 index_bounds by (metis Suc_eq_plus1 not_less_eq) have ladder_i_L_index_eq_fst: "ladder_i L index = fst (D ! ladder_n L (index - Suc 0))" using introsAt_appendix LeftDerivationIntrosAt_def index_bounds by (metis One_nat_def) have E_at_D_at: "(E ! ladder_n L' (index - Suc 0)) = (D ! ladder_n L (index - Suc 0))" using ladder_early_stage[of "index - Suc 0"] by (metis One_nat_def Suc_eq_plus1 index_bounds le_add_diff_inverse2 lessI) then have ladder_i_L'_index_eq_fst: "ladder_i L' index = fst (E ! ladder_n L' (index - Suc 0))" using index_bounds ladder_i_L_index_eq_fst ladder_every_stage(1) le_add1 le_less_trans by auto obtain D' where D': "D' = (drop (Suc (ladder_n L (index - Suc 0))) (take (ladder_n L index) D))" by blast obtain k where k: "k = (ladder_n L' index) - (Suc (ladder_n L' (index - Suc 0)))" by blast have ladder_n_L'_index: "ladder_n L' index = length E" by (metis diff_add_inverse2 index_bounds ladder_last_n_L' ladder_last_n_def length_L') have take_is_E: "take (ladder_n L' index) E = E" by (simp add: ladder_n_L'_index) have ladder_n_L_index: "ladder_n L index = length D" by (metis diff_add_inverse2 index_bounds length_D_eq_n n_eq_ladder_n) have take_is_D: "take (ladder_n L index) D = D" by (simp add: ladder_n_L_index) have write_as_take_k_D': "(drop (Suc (ladder_n L' (index - Suc 0))) E) = take k D'" using take_is_D by (metis D' E L' One_nat_def Suc_le_lessD add_diff_cancel_right' diff_Suc_less drop_take index_bounds k ladder_n_L'_index ladder_n_of_cut length_E_eq_n' length_L_nonzero length_greater_0_conv) have k_bound: "k \ length D'" by (metis le_iff_add append_take_drop_id k ladder_n_L'_index length_append length_drop write_as_take_k_D') have D'_alt: "D' = drop (Suc (ladder_n L (index - Suc 0))) D" by (simp add: D' take_is_D) have "LeftDerivationIntrosAt \ E L' index" apply (auto simp add: LeftDerivationIntrosAt_def Let_def) using ladder_i_L'_index_eq_fst apply blast apply (subst take_is_E) apply (subst write_as_take_k_D') apply (rule_tac LeftDerivationIntro_cut_appendix[where \=\ and \' = \']) apply (metis D' Derive E E_at_D_at LeftDerivationIntrosAt_def LeftDerivation_implies_Derivation One_nat_def Suc_le_lessD add_diff_cancel_right' diff_Suc_less finish index_bounds introsAt_appendix ladder_\_def ladder_every_stage(2) ladder_every_stage(3) ladder_every_stage(4) ladder_i_L'_index_eq_fst length_L_nonzero take_is_E) apply (metis Cons_nth_drop_Suc E L' LeftDerivation_from_in_between LeftDerivation_take_derive One_nat_def Suc_le_lessD add_diff_cancel_right' diff_Suc_less finish index_bounds ladder_\_def ladder_\_def ladder_i_L'_index_eq_fst ladder_n_L'_index ladder_n_of_cut ladder_prev_n_def length_E_eq_n' length_L_nonzero less_imp_le_nat less_numeral_extra(3) list.size(3) prod.collapse take_is_E write_as_take_k_D') using k_bound apply blast using D'_alt apply (metis (no_types, lifting) Derive E L' LeftDerivation_implies_Derivation One_nat_def Suc_leI Suc_le_lessD add_diff_cancel_right' diff_Suc_less drop_drop finish index_bounds k ladder_\_def ladder_n_L'_index ladder_n_of_cut ladder_prev_n_def le_add_diff_inverse2 length_E_eq_n' length_L_nonzero length_greater_0_conv less_not_refl2 take_is_E) using index_bounds ladder_every_stage(5) apply auto[1] by (metis Derive E LeftDerivation_implies_Derivation One_nat_def add_diff_cancel_right' diff_Suc_less finish index_bounds ladder_\_def ladder_every_stage(2) length_L_nonzero take_is_E) } note LeftDerivationIntrosAt_last = this have ladder_E_L': "LeftDerivationLadder \ E L' \" apply (auto simp add: LeftDerivationLadder_def) using finish E apply blast using is_ladder_E_L' apply blast using LeftDerivationFix_\_0 apply blast using LeftDerivationIntros_def LeftDerivationIntrosAt_early LeftDerivationIntrosAt_last by (metis Suc_eq_plus1 Suc_leI le_neq_implies_less length_L') show ?thesis apply (rule_tac x=E in exI) apply (rule_tac x=F in exI) apply (rule_tac x=\ in exI) apply (rule_tac x=\' in exI) apply (rule_tac x=L' in exI) apply auto using E F apply simp apply (rule \) using ladder_E_L' apply blast using F finish apply blast using F finish apply blast by (rule L') qed theorem LeftDerivationLadder_cut_appendix: assumes LDLadder: "LeftDerivationLadder (\@\) D L \" assumes ladder_i_in_\: "ladder_i L 0 < length \" shows "\ E F \1 \2 L'. D = E@F \ \ = \1 @ \2 \ LeftDerivationLadder \ E L' \1 \ derivation_ge F (length \1) \ LeftDerivation \ (derivation_shift F (length \1) 0) \2 \ length L' = length L \ ladder_i L' 0 = ladder_i L 0 \ ladder_last_j L' = ladder_last_j L" proof - from LeftDerivationLadder_cut_appendix_helper[OF LDLadder ladder_i_in_\] obtain E F \1 \2 L' where helper: "D = E @ F \ \ = \1 @ \2 \ LeftDerivationLadder \ E L' \1 \ derivation_ge F (length \1) \ LeftDerivation \ (derivation_shift F (length \1) 0) \2 \ L' = ladder_cut L (length E)" by blast show ?thesis apply (rule_tac x=E in exI) apply (rule_tac x=F in exI) apply (rule_tac x=\1 in exI) apply (rule_tac x=\2 in exI) apply (rule_tac x=L' in exI) using helper LDLadder LeftDerivationLadder_def is_ladder_def ladder_i_of_cut_at_0 ladder_last_j_of_cut length_ladder_cut by force qed definition ladder_stepdown_diff :: "ladder \ nat" where "ladder_stepdown_diff L = Suc (ladder_n L 0)" definition ladder_stepdown_\_0 :: "sentence \ derivation \ ladder \ sentence" where "ladder_stepdown_\_0 a D L = Derive a (take (ladder_stepdown_diff L) D)" lemma LeftDerivationIntro_LeftDerives1: assumes "LeftDerivationIntro \ i r ix D j \" assumes "splits_at \ i a1 A a2" shows "LeftDerives1 \ i r (a1@(snd r)@a2)" by (metis LeftDerivationIntro_def LeftDerivationIntro_examine_rule LeftDerivationIntro_is_sentence LeftDerives1_def assms(1) assms(2) prod.collapse splits_at_implies_Derives1) lemma LeftDerives1_Derive: assumes "LeftDerives1 \ i r \" shows "Derive \ [(i, r)] = \" by (metis Derive LeftDerivation.simps(1) LeftDerivation_LeftDerives1 LeftDerivation_implies_Derivation append_Nil assms) lemma ladder_stepdown_\_0_altdef: assumes ladder: "LeftDerivationLadder \ D L \" assumes length_L: "length L > 1" assumes split: "splits_at (ladder_\ \ D L 1) (ladder_i L 1) a1 A a2" shows "ladder_stepdown_\_0 \ D L = a1 @ (snd (snd (D ! (ladder_n L 0)))) @ a2" proof - have 1: "ladder_\ \ D L 1 = Derive \ (take (ladder_n L 0) D)" by (simp add: ladder_\_def ladder_\_def) obtain rule where rule: "rule = snd (D ! (ladder_n L 0))" by blast have "\ E \. LeftDerivationIntro (ladder_\ \ D L 1) (ladder_i L 1) rule (ladder_ix L 1) E (ladder_j L 1) \" by (metis LeftDerivationIntrosAt_def LeftDerivationIntros_def LeftDerivationLadder_def One_nat_def diff_Suc_1 ladder length_L order_refl rule) then obtain E \ where intro: "LeftDerivationIntro (ladder_\ \ D L 1) (ladder_i L 1) rule (ladder_ix L 1) E (ladder_j L 1) \" by blast then have 2: "LeftDerives1 (ladder_\ \ D L 1) (ladder_i L 1) rule (a1@(snd rule)@a2)" using LeftDerivationIntro_LeftDerives1 split by blast have fst_D: "fst (D ! (ladder_n L 0)) = ladder_i L 1" by (metis LeftDerivationIntrosAt_def LeftDerivationIntros_def LeftDerivationLadder_def One_nat_def diff_Suc_1 ladder le_numeral_extra(4) length_L) have derive_derive: "Derive \ (take (Suc (ladder_n L 0)) D) = Derive (Derive \ (take (ladder_n L 0) D)) [D ! (ladder_n L 0)]" proof - have f1: "Derivation \ (take (Suc (ladder_n L 0)) D) (Derive \ (take (Suc (ladder_n L 0)) D))" using Derivation_take_derive LeftDerivationLadder_def LeftDerivation_implies_Derivation ladder by blast have f2: "length L - 1 < length L" using length_L by linarith have "0 < length L - 1" using length_L by linarith then have f3: "take (Suc (ladder_n L 0)) D = take (ladder_n L 0) D @ [D ! ladder_n L 0]" using f2 by (metis (full_types) LeftDerivationLadder_def is_ladder_def ladder ladder_last_n_def take_Suc_conv_app_nth) obtain sss :: "symbol list \ (nat \ symbol \ symbol list) list \ (nat \ symbol \ symbol list) list \ symbol list \ symbol list" where "\x0 x1 x2 x3. (\v4. Derivation x3 x2 v4 \ Derivation v4 x1 x0) = (Derivation x3 x2 (sss x0 x1 x2 x3) \ Derivation (sss x0 x1 x2 x3) x1 x0)" by moura then show ?thesis using f3 f1 Derivation_append Derive by auto qed then have 3: "ladder_stepdown_\_0 \ D L = Derive (ladder_\ \ D L 1) [D ! (ladder_n L 0)]" using 1 by (simp add: ladder_stepdown_\_0_def ladder_stepdown_diff_def) have 4: "D ! (ladder_n L 0) = (ladder_i L 1, rule)" using rule fst_D by (metis prod.collapse) then show ?thesis using 2 3 4 LeftDerives1_Derive snd_conv by auto qed lemma ladder_i_0_bound: assumes ld: "LeftDerivationLadder \ D L \" shows "ladder_i L 0 < length \" proof - have "LeftDerivationFix \ (ladder_i L 0) (take (ladder_n L 0) D) (ladder_j L 0) (ladder_\ \ D L 0)" using ld LeftDerivationLadder_def by simp then show ?thesis using LeftDerivationFix_def by simp qed lemma ladder_j_bound: assumes ld: "LeftDerivationLadder \ D L \" assumes index_bound: "index < length L" shows "ladder_j L index < length (ladder_\ \ D L index)" proof - have ld': "LeftDerivationLadder (\@[]) D L \" using ld by simp have ladder_i_0: "ladder_i L 0 < length \" using ladder_i_0_bound ld by auto obtain n where n: "n = ladder_n L index" by blast note propagate = LeftDerivationLadder_propagate[OF ld' ladder_i_0 n index_bound] from index_bound have "index + 1 < length L \ index + 1 = length L" by arith then show ?thesis proof (induct rule: disjCases2) case 1 then have "\\. LeftDerivation \ (take n D) \ \ ladder_\ (\ @ []) D L index = \ @ [] \ ladder_j L index < length \" using propagate by auto then show ?case by auto next case 2 then have " \n' \ \'. (index = 0 \ ladder_prev_n L index < n') \ n' \ n \ LeftDerivation \ (take n' D) \ \ LeftDerivation (\ @ []) (take n' D) (\ @ []) \ derivation_ge (drop n' D) (length \) \ LeftDerivation [] (derivation_shift (drop n' D) (length \) 0) \' \ ladder_\ (\ @ []) D L index = \ @ \' \ ladder_j L index < length \" using propagate by auto then show ?case by auto qed qed lemma ladder_last_j_bound: assumes ld: "LeftDerivationLadder \ D L \" shows "ladder_last_j L < length \" proof - have "length L - 1 < length L" using LeftDerivationLadder_def assms is_ladder_def by auto from ladder_j_bound[OF ld this] show ?thesis by (metis Derive LeftDerivationLadder_def LeftDerivation_implies_Derivation One_nat_def is_ladder_def ladder_last_j_def last_ladder_\ ld) qed fun ladder_shift_n :: "nat \ ladder \ ladder" where "ladder_shift_n N [] = []" | "ladder_shift_n N ((n, j, i)#L) = ((n - N, j, i)#(ladder_shift_n N L))" fun ladder_stepdown :: "ladder \ ladder" where "ladder_stepdown [] = undefined" | "ladder_stepdown [v] = undefined" | "ladder_stepdown ((n0, j0, i0)#(n1, j1, ix1)#L) = (n1 - Suc n0, j1, j0 + ix1) # (ladder_shift_n (Suc n0) L)" lemma ladder_shift_n_length: "length (ladder_shift_n N L) = length L" by (induct L, auto) lemma ladder_stepdown_prepare: assumes "length L > 1" shows "L = (ladder_n L 0, ladder_j L 0, ladder_i L 0)# (ladder_n L 1, ladder_j L 1, ladder_ix L 1)#(drop 2 L)" proof - have "\ n0 j0 i0 n1 j1 ix1 L'. L = ((n0, j0, i0)#(n1, j1, ix1)#L')" by (metis One_nat_def Suc_eq_plus1 assms ladder_stepdown.cases less_not_refl list.size(3) list.size(4) not_less0) then obtain n0 j0 i0 n1 j1 ix1 L' where L': "L = ((n0, j0, i0)#(n1, j1, ix1)#L')" by blast have n0: "n0 = ladder_n L 0" using L' by (auto simp add: ladder_n_def deriv_n_def) show ?thesis using L' by (auto simp add: ladder_n_def deriv_n_def ladder_j_def deriv_j_def ladder_i_def deriv_i_def ladder_ix_def deriv_ix_def) qed lemma ladder_stepdown_length: assumes "length L > 1" shows "length (ladder_stepdown L) = length L - 1" apply (subst ladder_stepdown_prepare[OF assms(1)]) apply (simp add: ladder_shift_n_length) using assms apply arith done lemma ladder_stepdown_i_0: assumes "length L > 1" shows "ladder_i (ladder_stepdown L) 0 = ladder_i L 1 + ladder_ix L 1" using ladder_stepdown_prepare[OF assms] ladder_i_def ladder_j_def deriv_j_def by (metis One_nat_def deriv_i_def diff_Suc_1 ladder_stepdown.simps(3) list.sel(1) snd_conv zero_neq_one) lemma ladder_shift_n_cons: "ladder_shift_n N (x#L) = (fst x - N, snd x)#(ladder_shift_n N L)" apply (induct L) by (cases x, simp)+ lemma ladder_shift_n_drop: "ladder_shift_n N (drop n L) = drop n (ladder_shift_n N L)" proof (induct L arbitrary: n) case Nil then show ?case by simp next case (Cons x L) show ?case proof (cases n) case 0 then show ?thesis by simp next case (Suc n) then show ?thesis by (simp add: ladder_shift_n_cons Cons) qed qed lemma drop_2_shift: assumes "index > 0" assumes "length L > 1" shows "drop 2 L ! (index - Suc 0) = L ! Suc index" proof - define l1 l2 and L' where "l1 = L ! 0" "l2 = L ! 1" and "L' = drop 2 L" with \length L > 1\ have "L = l1 # l2 # L'" by (cases L) (auto simp add: neq_Nil_conv) with \index > 0\ show ?thesis by simp qed lemma ladder_shift_n_at: "index < length L \ (ladder_shift_n N L) ! index = (fst (L ! index) - N, snd (L ! index))" proof (induct L arbitrary: index) case Nil then show ?case by auto next case (Cons x L) show ?case apply (simp add: ladder_shift_n_cons) apply (cases index) apply (auto) apply (rule_tac Cons(1)) using Cons(2) by auto qed lemma ladder_stepdown_j: assumes length_L_greater_1: "length L > 1" assumes L': "L' = ladder_stepdown L" assumes index_bound: "index < length L'" shows "ladder_j L' index = ladder_j L (Suc index)" proof - note L_prepare = ladder_stepdown_prepare[OF length_L_greater_1] have ladder_stepdown_L_def: "ladder_stepdown L = ((ladder_n L (Suc 0) - Suc (ladder_n L 0), ladder_j L (Suc 0), ladder_j L 0 + ladder_ix L (Suc 0)) # ladder_shift_n (Suc (ladder_n L 0)) (drop 2 L))" by (subst L_prepare, simp) have "index = 0 \ index > 0" by arith then show "ladder_j L' index = ladder_j L (Suc index)" proof (induct rule: disjCases2) case 1 show ?case by (simp add: L' ladder_stepdown_L_def 1 ladder_j_def deriv_j_def) next case 2 have index_bound': "Suc index < length L" using index_bound L' ladder_stepdown_length length_L_greater_1 by auto show ?case apply (simp add: L' ladder_stepdown_L_def 2 ladder_j_def ladder_shift_n_drop drop_2_shift) apply (subst drop_2_shift) apply (simp add: 2) using length_L_greater_1 apply (simp add: ladder_shift_n_length) apply (simp add: deriv_j_def) apply (simp add: ladder_shift_n_at[OF index_bound']) done qed qed lemma ladder_stepdown_last_j: assumes length_L_greater_1: "length L > 1" shows "ladder_last_j (ladder_stepdown L) = ladder_last_j L" using ladder_stepdown_j Suc_diff_Suc diff_Suc_1 ladder_last_j_def ladder_stepdown_length length_L_greater_1 lessI by auto lemma ladder_stepdown_n: assumes length_L_greater_1: "length L > 1" assumes L': "L' = ladder_stepdown L" assumes index_bound: "index < length L'" shows "ladder_n L' index = ladder_n L (Suc index) - ladder_stepdown_diff L" proof - note L_prepare = ladder_stepdown_prepare[OF length_L_greater_1] have ladder_stepdown_L_def: "ladder_stepdown L = ((ladder_n L (Suc 0) - Suc (ladder_n L 0), ladder_j L (Suc 0), ladder_j L 0 + ladder_ix L (Suc 0)) # ladder_shift_n (Suc (ladder_n L 0)) (drop 2 L))" by (subst L_prepare, simp) have "index = 0 \ index > 0" by arith then show "ladder_n L' index = ladder_n L (Suc index) - ladder_stepdown_diff L" proof (induct rule: disjCases2) case 1 show ?case by (simp add: L' ladder_stepdown_L_def 1 ladder_n_def deriv_n_def ladder_stepdown_diff_def) next case 2 have index_bound': "Suc index < length L" using index_bound L' ladder_stepdown_length length_L_greater_1 by auto show ?case apply (simp add: L' ladder_stepdown_L_def 2 ladder_n_def ladder_shift_n_drop drop_2_shift ladder_stepdown_diff_def) apply (subst drop_2_shift) apply (simp add: 2) using length_L_greater_1 apply (simp add: ladder_shift_n_length) apply (simp add: deriv_n_def) apply (simp add: ladder_shift_n_at[OF index_bound']) done qed qed lemma ladder_stepdown_ix: assumes length_L_greater_1: "length L > 1" assumes L': "L' = ladder_stepdown L" assumes index_lower_bound: "0 < index" assumes index_upper_bound: "index < length L'" shows "ladder_ix L' index = ladder_ix L (Suc index)" proof - note L_prepare = ladder_stepdown_prepare[OF length_L_greater_1] have ladder_stepdown_L_def: "ladder_stepdown L = ((ladder_n L (Suc 0) - Suc (ladder_n L 0), ladder_j L (Suc 0), ladder_j L 0 + ladder_ix L (Suc 0)) # ladder_shift_n (Suc (ladder_n L 0)) (drop 2 L))" by (subst L_prepare, simp) have index_bound': "Suc index < length L" using index_upper_bound L' ladder_stepdown_length length_L_greater_1 by auto show ?thesis apply (simp add: L' ladder_stepdown_L_def index_lower_bound ladder_ix_def ladder_shift_n_drop) apply (subst drop_2_shift) apply (simp add: index_lower_bound) using length_L_greater_1 apply (simp add: ladder_shift_n_length) apply (simp add: deriv_ix_def) apply (simp add: ladder_shift_n_at[OF index_bound']) using index_lower_bound by arith qed lemma Derive_Derive: assumes "Derivation \ (D@E) \" shows "Derive (Derive \ D) E = Derive \ (D@E)" using Derivation_append Derive assms by fastforce lemma drop_at_shift: assumes "n \ index" assumes "index < length D" shows "drop n D ! (index - n) = D ! index" using assms(1) assms(2) by auto theorem LeftDerivationLadder_stepdown: assumes ldl: "LeftDerivationLadder \ D L \" assumes length_L: "length L > 1" shows "\ L'. LeftDerivationLadder (ladder_stepdown_\_0 \ D L) (drop (ladder_stepdown_diff L) D) L' \ \ length L' = length L - 1 \ ladder_i L' 0 = ladder_i L 1 + ladder_ix L 1 \ ladder_last_j L' = ladder_last_j L" proof - obtain L' where L': "L' = ladder_stepdown L" by blast have ldl1: "LeftDerivation (ladder_stepdown_\_0 \ D L) (drop (ladder_stepdown_diff L) D) \" proof - have D_split: "D = (take (ladder_stepdown_diff L) D) @ (drop (ladder_stepdown_diff L) D)" by simp show ?thesis using D_split ldl proof - obtain sss :: "symbol list \ (nat \ symbol \ symbol list) list \ (nat \ symbol \ symbol list) list \ symbol list \ symbol list" where "\x0 x1 x2 x3. (\v4. LeftDerivation x3 x2 v4 \ LeftDerivation v4 x1 x0) = (LeftDerivation x3 x2 (sss x0 x1 x2 x3) \ LeftDerivation (sss x0 x1 x2 x3) x1 x0)" by moura then have "(\ LeftDerivation \ (take (ladder_stepdown_diff L) D @ drop (ladder_stepdown_diff L) D) \ \ LeftDerivation \ (take (ladder_stepdown_diff L) D) (sss \ (drop (ladder_stepdown_diff L) D) (take (ladder_stepdown_diff L) D) \) \ LeftDerivation (sss \ (drop (ladder_stepdown_diff L) D) (take (ladder_stepdown_diff L) D) \) (drop (ladder_stepdown_diff L) D) \) \ (LeftDerivation \ (take (ladder_stepdown_diff L) D @ drop (ladder_stepdown_diff L) D) \ \ (\ss. \ LeftDerivation \ (take (ladder_stepdown_diff L) D) ss \ \ LeftDerivation ss (drop (ladder_stepdown_diff L) D) \))" using LeftDerivation_append by blast then show ?thesis by (metis (no_types) D_split Derivation_take_derive Derivation_unique_dest LeftDerivationLadder_def LeftDerivation_implies_Derivation ladder_stepdown_\_0_def ldl) qed qed have L'_nonempty: "L' \ []" using L' ladder_stepdown_length length_L by fastforce { fix u :: nat assume u': "u < length L'" then have Suc_u: "Suc u < length L" using L' ladder_stepdown_length length_L by auto have "ladder_n L (Suc u) \ length D" using ldl Suc_u by (simp add: LeftDerivationLadder_ladder_n_bound) then have "ladder_n L' u \ length D - ladder_stepdown_diff L" apply (subst ladder_stepdown_n[OF length_L L' u']) by auto } note is_ladder_prop1 = this { fix u :: nat fix v :: nat assume u_less_v: "u < v" assume v_L': "v < length L'" from u_less_v v_L' have u_L': "u < length L'" by arith have "ladder_n L (Suc u) < ladder_n L (Suc v)" using ldl by (metis (no_types, lifting) L' LeftDerivationLadder_def One_nat_def Suc_diff_1 Suc_lessD Suc_mono is_ladder_def ladder_stepdown_length length_L u_less_v v_L') then have "ladder_n L' u < ladder_n L' v" apply (simp add: ladder_stepdown_n[OF length_L L'] u_L' v_L') by (metis (no_types, lifting) L' LeftDerivationLadder_def Suc_eq_plus1 Suc_leI diff_less_mono is_ladder_def ladder_stepdown_diff_def ladder_stepdown_length ldl length_L less_diff_conv u_L' zero_less_Suc) } note is_ladder_prop2 = this have is_ladder_L': "is_ladder (drop (ladder_stepdown_diff L) D) L'" apply (auto simp add: is_ladder_def) using L'_nonempty apply blast using is_ladder_prop1 apply blast using is_ladder_prop2 apply blast using ladder_last_n_def ladder_stepdown_n L' LeftDerivationLadder_def Suc_diff_Suc diff_Suc_1 ladder_n_last_is_length ladder_stepdown_length ldl length_L lessI by auto have ldfix: "LeftDerivationFix (ladder_stepdown_\_0 \ D L) (ladder_i L' 0) (take (ladder_n L' 0) (drop (ladder_stepdown_diff L) D)) (ladder_j L' 0) (ladder_\ (ladder_stepdown_\_0 \ D L) (drop (ladder_stepdown_diff L) D) L' 0)" proof - have introsAt_L_1: "LeftDerivationIntrosAt \ D L 1" using LeftDerivationIntros_def LeftDerivationLadder_def ldl length_L by blast thm LeftDerivationIntrosAt_def obtain n where n: "n = ladder_n L 0" by blast obtain m where m: "m = ladder_n L 1" by blast have "LeftDerivationIntro (ladder_\ \ D L 1) (ladder_i L 1) (snd (D ! n)) (ladder_ix L 1) (drop (Suc n) (take m D)) (ladder_j L 1) (ladder_\ \ D L 1)" using n m introsAt_L_1 by (metis LeftDerivationIntrosAt_def One_nat_def diff_Suc_1) from iffD1[OF LeftDerivationIntro_def this] obtain \ where \: "LeftDerives1 (ladder_\ \ D L 1) (ladder_i L 1) (snd (D ! n)) \ \ ladder_ix L 1 < length (snd (snd (D ! n))) \ snd (snd (D ! n)) ! ladder_ix L 1 = ladder_\ \ D L 1 ! ladder_j L 1 \ LeftDerivationFix \ (ladder_i L 1 + ladder_ix L 1) (drop (Suc n) (take m D)) (ladder_j L 1) (ladder_\ \ D L 1)" by blast have "\ = Derive (ladder_\ \ D L 1) [D ! n]" by (metis (no_types, hide_lams) LeftDerivationIntrosAt_def LeftDerives1_Derive \ cancel_comm_monoid_add_class.diff_cancel introsAt_L_1 n prod.collapse) then have \_def: "\ = ladder_stepdown_\_0 \ D L" proof - obtain sss :: "nat \ symbol list \ symbol list" and ss :: "nat \ symbol list \ symbol" and sssa :: "nat \ symbol list \ symbol list" where "\x2 x3. (\v4 v5 v6. splits_at x3 x2 v4 v5 v6) = splits_at x3 x2 (sss x2 x3) (ss x2 x3) (sssa x2 x3)" by moura then have f1: "\ssa n p ssb. \ Derives1 ssa n p ssb \ splits_at ssa n (sss n ssa) (ss n ssa) (sssa n ssa)" using splits_at_ex by presburger then have "\ = sss (ladder_i L 1) (ladder_\ \ D L 1) @ snd (snd (D ! n)) @ sssa (ladder_i L 1) (ladder_\ \ D L 1)" by (meson LeftDerives1_implies_Derives1 \ splits_at_combine_dest) then show ?thesis using f1 by (metis (no_types) LeftDerives1_implies_Derives1 \ ladder_stepdown_\_0_altdef ldl length_L n) qed have ladder_i_L'_0: "ladder_i L' 0 = ladder_i L 1 + ladder_ix L 1" using L' ladder_stepdown_i_0 length_L by blast have derivation_eq: "(take (ladder_n L' 0) (drop (ladder_stepdown_diff L) D)) = (drop (Suc n) (take m D))" using n m by (metis L' L'_nonempty One_nat_def drop_take ladder_stepdown_diff_def ladder_stepdown_n length_L length_greater_0_conv) have ladder_j_L'_0: "ladder_j L' 0 = ladder_j L 1" using L' L'_nonempty ladder_stepdown_j length_L by auto have ladder_\: "(ladder_\ (ladder_stepdown_\_0 \ D L) (drop (ladder_stepdown_diff L) D) L' 0) = ladder_\ \ D L 1" by (metis Derivation_take_derive Derivation_unique_dest LeftDerivationFix_def LeftDerivation_implies_Derivation \ \_def derivation_eq ladder_\_def ldl1) from \_def \ ladder_i_L'_0 derivation_eq ladder_j_L'_0 ladder_\ show ?thesis by auto qed { fix index :: nat assume index_lower_bound: "Suc 0 \ index" assume index_upper_bound: "index < length L'" then have Suc_index_upper_bound: "Suc index < length L" using L' Suc_diff_Suc Suc_less_eq diff_Suc_1 ladder_stepdown_length length_L less_Suc_eq by auto then have intros_at_Suc_index: "LeftDerivationIntrosAt \ D L (Suc index)" by (metis LeftDerivationIntros_def LeftDerivationLadder_def Suc_eq_plus1_left ldl le_add1) from iffD1[OF LeftDerivationIntrosAt_def this] have ldintro: "let \' = ladder_\ \ D L (Suc index); i = ladder_i L (Suc index); j = ladder_j L (Suc index); ix = ladder_ix L (Suc index); \ = ladder_\ \ D L (Suc index); n = ladder_n L (Suc index - 1); m = ladder_n L (Suc index); e = D ! n; E = drop (Suc n) (take m D) in i = fst e \ LeftDerivationIntro \' i (snd e) ix E j \" by blast have index_minus_Suc_0_bound: "index - Suc 0 < length L'" by (simp add: index_upper_bound less_imp_diff_less) note helpers = length_L L' index_minus_Suc_0_bound have ladder_i_L'_index: "ladder_i L' index = fst (drop (ladder_stepdown_diff L) D ! ladder_n L' (index - Suc 0))" apply (auto simp add: ladder_i_def) using index_lower_bound apply arith apply (simp add: ladder_stepdown_n[OF helpers] ladder_stepdown_j[OF helpers]) apply (subst drop_at_shift) using LeftDerivationLadder_def Suc_index_upper_bound Suc_leI Suc_lessD is_ladder_def ladder_stepdown_diff_def ldl apply presburger apply (metis LeftDerivationLadder_def One_nat_def Suc_eq_plus1 Suc_index_upper_bound add.commute add_diff_cancel_right' ladder_n_minus_1_bound ldl le_add1) by (metis LeftDerivationIntrosAt_def intros_at_Suc_index diff_Suc_1 ladder_i_def nat.simps(3)) have intro_at_index: "LeftDerivationIntro (ladder_\ (ladder_stepdown_\_0 \ D L) (drop (ladder_stepdown_diff L) D) L' index) (ladder_i L' index) (snd (drop (ladder_stepdown_diff L) D ! ladder_n L' (index - Suc 0))) (ladder_ix L' index) (drop (Suc (ladder_n L' (index - Suc 0))) (take (ladder_n L' index) (drop (ladder_stepdown_diff L) D))) (ladder_j L' index) (ladder_\ (ladder_stepdown_\_0 \ D L) (drop (ladder_stepdown_diff L) D) L' index)" proof - have arg1: "(ladder_\ (ladder_stepdown_\_0 \ D L) (drop (ladder_stepdown_diff L) D) L' index) = ladder_\ \ D L (Suc index)" apply (auto simp add: ladder_\_def ladder_\_def) using index_lower_bound apply arith apply (simp add: ladder_stepdown_n[OF helpers] ladder_stepdown_\_0_def) apply (subst Derive_Derive[where \="ladder_\ \ D L index"]) apply (metis (no_types, lifting) Derivation_take_derive LeftDerivationLadder_def LeftDerivation_implies_Derivation Suc_index_upper_bound Suc_leI Suc_lessD add.commute is_ladder_def ladder_\_def ladder_stepdown_diff_def ldl le_add_diff_inverse2 take_add) by (metis LeftDerivationLadder_def Suc_index_upper_bound Suc_leI Suc_lessD add.commute is_ladder_def ladder_stepdown_diff_def ldl le_add_diff_inverse2 take_add) have arg2: "ladder_i L' index = ladder_i L (Suc index)" using L' index_lower_bound index_minus_Suc_0_bound ladder_i_def ladder_stepdown_j length_L by auto obtain n where n: "n = ladder_n L (Suc index - 1)" by blast have arg3: "(snd (drop (ladder_stepdown_diff L) D ! ladder_n L' (index - Suc 0))) = snd (D ! n)" apply (simp add: ladder_stepdown_n[OF helpers] index_lower_bound) apply (subst drop_at_shift) using index_lower_bound apply (metis (no_types, hide_lams) L' LeftDerivationLadder_def One_nat_def Suc_eq_plus1 add.commute diff_Suc_1 index_upper_bound is_ladder_def ladder_stepdown_diff_def ladder_stepdown_length ldl le_add_diff_inverse2 length_L less_or_eq_imp_le n nat.simps(3) neq0_conv not_less not_less_eq_eq) using index_lower_bound apply (metis LeftDerivationLadder_def One_nat_def Suc_index_upper_bound Suc_le_lessD Suc_pred diff_Suc_1 ladder_n_minus_1_bound ldl le_imp_less_Suc less_imp_le) using index_lower_bound n by (simp add: Suc_diff_le) have arg4: "ladder_ix L' index = ladder_ix L (Suc index)" using ladder_stepdown_ix L' Suc_le_lessD index_lower_bound index_upper_bound length_L by auto obtain m where m: "m = ladder_n L (Suc index)" by blast have Suc_index_Suc: "Suc (index - Suc 0) = index" using index_lower_bound by arith have arg5: "(drop (Suc (ladder_n L' (index - Suc 0))) (take (ladder_n L' index) (drop (ladder_stepdown_diff L) D))) = drop (Suc n) (take m D)" apply (simp add: ladder_stepdown_n[OF helpers] ladder_stepdown_n[OF length_L L' index_upper_bound] n m Suc_index_Suc) by (metis (no_types, lifting) LeftDerivationLadder_def Suc_eq_plus1_left Suc_index_upper_bound Suc_leI Suc_le_lessD Suc_lessD drop_drop drop_take index_lower_bound is_ladder_def ladder_stepdown_diff_def ldl le_add_diff_inverse2) have arg6: "ladder_j L' index = ladder_j L (Suc index)" using L' index_upper_bound ladder_stepdown_j length_L by blast have arg7: "(ladder_\ (ladder_stepdown_\_0 \ D L) (drop (ladder_stepdown_diff L) D) L' index) = ladder_\ \ D L (Suc index)" apply (simp add: ladder_\_def) apply (simp add: ladder_stepdown_n[OF length_L L' index_upper_bound] ladder_stepdown_\_0_def) apply (subst Derive_Derive[where \="ladder_\ \ D L (Suc index)"]) apply (metis (no_types, lifting) L' LeftDerivationLadder_def LeftDerivation_implies_Derivation LeftDerivation_take_derive Suc_le_lessD add_diff_inverse_nat diff_is_0_eq index_lower_bound index_upper_bound is_ladder_L' is_ladder_def ladder_\_def ladder_stepdown_n ldl le_0_eq length_L less_numeral_extra(3) less_or_eq_imp_le take_add) by (metis (no_types, lifting) L' One_nat_def add_diff_inverse_nat diff_is_0_eq index_lower_bound index_upper_bound is_ladder_L' is_ladder_def ladder_stepdown_n le_0_eq le_neq_implies_less length_L less_numeral_extra(3) less_or_eq_imp_le take_add zero_less_one) from ldintro arg1 arg2 arg3 arg4 arg5 arg6 arg7 show ?thesis by (metis m n) qed have "LeftDerivationIntrosAt (ladder_stepdown_\_0 \ D L) (drop (ladder_stepdown_diff L) D) L' index" apply (auto simp add: LeftDerivationIntrosAt_def Let_def) using ladder_i_L'_index apply blast using intro_at_index by blast } note introsAt = this show ?thesis apply (rule_tac x="L'" in exI) apply auto defer 1 using L' ladder_stepdown_length length_L apply auto[1] using ladder_stepdown_i_0 length_L L' apply auto[1] using ladder_stepdown_last_j L' length_L apply auto[1] apply (auto simp add: LeftDerivationLadder_def) using ldl1 apply blast using is_ladder_L' apply blast using ldfix apply blast apply (auto simp add: LeftDerivationIntros_def) apply (simp add: introsAt) done qed fun ladder_shift_j :: "nat \ ladder \ ladder" where "ladder_shift_j d [] = []" | "ladder_shift_j d ((n, j, i)#L) = ((n, j - d, i)#(ladder_shift_j d L))" definition ladder_cut_prefix :: "nat \ ladder \ ladder" where "ladder_cut_prefix d L = (ladder_shift_j d L)[0 := (ladder_n L 0, ladder_j L 0 - d, ladder_i L 0 - d)]" lemma ladder_shift_j_length: "length (ladder_shift_j d L) = length L" by (induct L, auto) lemma ladder_cut_prefix_length: shows "length (ladder_cut_prefix d L) = length L" apply (simp add: ladder_cut_prefix_def) apply (simp add: ladder_shift_j_length) done lemma ladder_shift_j_cons: "ladder_shift_j d (x#L) = (fst x, fst (snd x) - d, snd(snd x))# (ladder_shift_j d L)" apply (induct L) by (cases x, simp)+ lemma deriv_j_ladder_shift_j: "index < length L \ deriv_j (ladder_shift_j d L ! index) = deriv_j (L ! index) - d" proof (induct L arbitrary: index) case Nil then show ?case by auto next case (Cons x L) show ?case apply (subst ladder_shift_j_cons) apply (cases index) using Cons by (auto simp add: deriv_j_def) qed lemma deriv_n_ladder_shift_j: "index < length L \ deriv_n (ladder_shift_j d L ! index) = deriv_n (L ! index)" proof (induct L arbitrary: index) case Nil then show ?case by auto next case (Cons x L) show ?case apply (subst ladder_shift_j_cons) apply (cases index) using Cons by (auto simp add: deriv_n_def) qed lemma deriv_ix_ladder_shift_j: "index < length L \ deriv_ix (ladder_shift_j d L ! index) = deriv_ix (L ! index)" proof (induct L arbitrary: index) case Nil then show ?case by auto next case (Cons x L) show ?case apply (subst ladder_shift_j_cons) apply (cases index) using Cons by (auto simp add: deriv_ix_def) qed lemma ladder_cut_prefix_j: assumes index_bound: "index < length L" assumes length_L: "length L > 0" shows "ladder_j (ladder_cut_prefix d L) index = ladder_j L index - d" apply (simp add: ladder_j_def ladder_cut_prefix_def) apply (cases index) apply (auto simp add: length_L) apply (subst nth_list_update_eq) apply (simp only: ladder_shift_j_length length_L) apply (simp add: deriv_j_def) apply (subst deriv_j_ladder_shift_j) using index_bound apply arith by blast lemma hd_0_subst: "length L > 0 \ hd (L [0 := x]) = x" using hd_conv_nth by (simp add: upd_conv_take_nth_drop) lemma ladder_cut_prefix_i: assumes index_bound: "index < length L" assumes length_L: "length L > 0" shows "ladder_i (ladder_cut_prefix d L) index = ladder_i L index - d" apply (simp add: ladder_i_def ladder_cut_prefix_def) apply (cases index) apply auto[1] apply (subst hd_0_subst) using length_L ladder_shift_j_length apply metis apply (auto simp add: deriv_i_def) apply (case_tac nat) apply (simp add: ladder_j_def deriv_j_def) apply auto apply (subst nth_list_update_eq) using length_L ladder_shift_j_length apply auto[1] apply simp apply (simp add: ladder_j_def) apply (subst deriv_j_ladder_shift_j) using index_bound apply arith apply simp done lemma ladder_cut_prefix_n: assumes index_bound: "index < length L" assumes length_L: "length L > 0" shows "ladder_n (ladder_cut_prefix d L) index = ladder_n L index" apply (simp add: ladder_cut_prefix_def) apply (cases index) apply (auto simp add: ladder_n_def) apply (subst nth_list_update_eq) apply (simp add: ladder_shift_j_length) using length_L apply blast apply (simp add: deriv_n_def ) apply (rule_tac deriv_n_ladder_shift_j) using index_bound by arith lemma ladder_cut_prefix_ix: assumes index_bound: "index < length L" assumes length_L: "length L > 0" shows "ladder_ix (ladder_cut_prefix d L) index = ladder_ix L index" apply (simp add: ladder_cut_prefix_def) apply (cases index) apply (auto simp add: ladder_ix_def) apply (rule_tac deriv_ix_ladder_shift_j) using index_bound by arith lemma LeftDerivationFix_derivation_ge_is_nonterminal: assumes ldfix: "LeftDerivationFix \ i D j \" assumes derivation_ge_d: "derivation_ge D d" assumes is_nonterminal: "is_nonterminal (\ ! j)" shows "(D = [] \ \ = \ \ i = j) \ (i > d \ j \ d)" proof - have "is_nonterminal (\ ! i)" using ldfix is_nonterminal by (simp add: LeftDerivationFix_def) from LeftDerivationFix_splits_at_nonterminal[OF ldfix this] obtain U a1 a2 b1 where U: "splits_at \ i a1 U a2 \ splits_at \ j b1 U a2 \ LeftDerivation a1 D b1" by blast have "D = [] \ D \ []" by auto then show ?thesis proof (induct rule: disjCases2) case 1 then have "a1 = b1" using U by auto then have i_eq_j: "i = j" using U by (metis dual_order.strict_implies_order length_take min.absorb2 splits_at_def) from 1 have "\ = \" using ldfix LeftDerivationFix_def by auto with 1 i_eq_j show ?case by blast next case 2 have "\ a1'. LeftDerives1 a1 (fst (hd D)) (snd (hd D)) a1'" using U 2 by (metis LeftDerivation.elims(2) list.sel(1)) then obtain a1' where a1': "LeftDerives1 a1 (fst (hd D)) (snd (hd D)) a1'" by blast then have "(fst (hd D)) < length a1" using Derives1_bound LeftDerives1_implies_Derives1 by blast then have fst_less_i: "(fst (hd D)) < i" using U by (simp add: leD min.absorb2 nat_le_linear splits_at_def) have d_le_fst: "d \ fst (hd D)" using derivation_ge_d 2 by (simp add: derivation_ge_def) with fst_less_i have d_less_i: "d < i" using le_less_trans by blast have "\ b1'. LeftDerives1 b1' (fst (last D)) (snd (last D)) b1" using U 2 by (metis Derive LeftDerivation_Derive_take_LeftDerives1 LeftDerivation_implies_Derivation last_conv_nth length_0_conv order_refl take_all) then obtain b1' where b1': "LeftDerives1 b1' (fst (last D)) (snd (last D)) b1" by blast then have "fst (last D) \ length b1" using Derives1_bound' LeftDerives1_implies_Derives1 by blast then have fst_le_j: "fst (last D) \ j" using U splits_at_def by auto have "d \ fst (last D)" using derivation_ge_d 2 using derivation_ge_def last_in_set by blast with fst_le_j have "d \ j" using order.trans by blast with d_less_i show ?thesis by auto qed qed lemma LeftDerivationFix_derivation_ge: assumes ldfix: "LeftDerivationFix \ i D j \" assumes derivation_ge_d: "derivation_ge D d" shows "i = j \ (i > d \ j \ d)" proof - from LeftDerivationFix_splits_at_symbol[OF ldfix] obtain U a1 a2 b1 b2 n where U: "splits_at \ i a1 U a2 \ splits_at \ j b1 U b2 \ n \ length D \ LeftDerivation a1 (take n D) b1 \ derivation_ge (drop n D) (Suc (length b1)) \ LeftDerivation a2 (derivation_shift (drop n D) (Suc (length b1)) 0) b2 \ (n = length D \ n < length D \ is_word (b1 @ [U]))" by blast have "n = 0 \ n > 0" by auto then show ?thesis proof (induct rule: disjCases2) case 1 then have "a1 = b1" using U by auto then have i_eq_j: "i = j" using U by (metis dual_order.strict_implies_order length_take min.absorb2 splits_at_def) then show ?case by blast next case 2 obtain E where E: "E = take n D" by blast have E_nonempty: "E \ []" using E 2 using U less_nat_zero_code list.size(3) take_eq_Nil by auto have "\ a1'. LeftDerives1 a1 (fst (hd E)) (snd (hd E)) a1'" using U E E_nonempty by (metis LeftDerivation.simps(2) list.exhaust list.sel(1)) then obtain a1' where a1': "LeftDerives1 a1 (fst (hd E)) (snd (hd E)) a1'" by blast then have "(fst (hd E)) < length a1" using Derives1_bound LeftDerives1_implies_Derives1 by blast then have fst_less_i: "(fst (hd E)) < i" using U by (simp add: leD min.absorb2 nat_le_linear splits_at_def) have d_le_fst: "d \ fst (hd E)" using derivation_ge_d E_nonempty E by (simp add: LeftDerivation.elims(2) U derivation_ge_def hd_conv_nth) with fst_less_i have d_less_i: "d < i" using le_less_trans by blast have "\ b1'. LeftDerives1 b1' (fst (last E)) (snd (last E)) b1" using E_nonempty U E by (metis LeftDerivation_append1 append_butlast_last_id prod.collapse) then obtain b1' where b1': "LeftDerives1 b1' (fst (last E)) (snd (last E)) b1" by blast then have "fst (last E) \ length b1" using Derives1_bound' LeftDerives1_implies_Derives1 by blast then have fst_le_j: "fst (last E) \ j" using U splits_at_def by auto have "d \ fst (last E)" using derivation_ge_d E_nonempty E using derivation_ge_d last_in_set by (metis derivation_ge_def set_take_subset subsetCE) with fst_le_j have "d \ j" using order.trans by blast with d_less_i show ?thesis by auto qed qed lemma LeftDerivationIntro_derivation_ge: assumes ldintro: "LeftDerivationIntro \ i r ix D j \" assumes i_ge_d: "i \ d" assumes derivation_ge_d: "derivation_ge D d" shows "j \ d" proof - from iffD1[OF LeftDerivationIntro_def ldintro] obtain \ where \: "LeftDerives1 \ i r \ \ ix < length (snd r) \ snd r ! ix = \ ! j \ LeftDerivationFix \ (i + ix) D j \" by blast then have "(i + ix = j) \ (i + ix > d \ j \ d)" using LeftDerivationFix_derivation_ge derivation_ge_d by blast then show ?thesis proof (induct rule: disjCases2) case 1 then show ?case using i_ge_d trans_le_add1 by blast next case 2 then show ?case by simp qed qed lemma derivation_ge_LeftDerivationLadder: assumes derivation_ge_d: "derivation_ge D d" assumes ladder: "LeftDerivationLadder \ D L \" assumes ladder_i_0: "ladder_i L 0 \ d" shows "index < length L \ ladder_i L index \ d \ ladder_j L index \ d" proof (induct index) case 0 from iffD1[OF LeftDerivationLadder_def ladder] have ldfix: "LeftDerivationFix \ (ladder_i L 0) (take (ladder_n L 0) D) (ladder_j L 0) (ladder_\ \ D L 0)" by blast have "derivation_ge (take (ladder_n L 0) D) d" using derivation_ge_d by (metis append_take_drop_id derivation_ge_append) from ladder_i_0 derivation_ge_d LeftDerivationFix_derivation_ge[OF ldfix this] show ?case by linarith next case (Suc n) have ladder_i_Suc: "ladder_i L (Suc n) \ d" apply (auto simp add: ladder_i_def) using Suc by auto from iffD1[OF LeftDerivationLadder_def ladder] have "LeftDerivationIntros \ D L" by blast then have "LeftDerivationIntrosAt \ D L (Suc n)" using Suc.prems by (metis LeftDerivationIntros_def Suc_eq_plus1_left le_add1) from iffD1[OF LeftDerivationIntrosAt_def this] show ?case using ladder_i_Suc LeftDerivationIntro_derivation_ge by (metis append_take_drop_id derivation_ge_append derivation_ge_d) qed lemma derivation_shift_append: "derivation_shift (A@B) left right = (derivation_shift A left right) @ (derivation_shift B left right)" by (induct A, simp+) lemma derivation_shift_right_left_subtract: "right \ left \ derivation_shift (derivation_shift L 0 right) left 0 = derivation_shift L 0 (right - left)" by (induct L, simp+) lemma LeftDerivationFix_cut_prefix: assumes "LeftDerivationFix (\@\) i D j \" assumes "derivation_ge D (length \)" assumes "i \ length \" assumes is_word_\: "is_word \" shows "\ \'. \ = \ @ \' \ LeftDerivationFix \ (i - length \) (derivation_shift D (length \) 0) (j - length \) \'" proof - have j_ge_d: "j \ length \" using assms(3) LeftDerivationFix_derivation_ge[OF assms(1) assms(2)] by arith obtain \' where \': "\' = drop (length \) \" by blast from iffD1[OF LeftDerivationFix_def assms(1)] obtain E F where EF: "is_sentence (\ @ \) \ is_sentence \ \ LeftDerivation (\ @ \) D \ \ i < length (\ @ \) \ j < length \ \ (\ @ \) ! i = \ ! j \ D = E @ derivation_shift F 0 (Suc j) \ LeftDerivation (take i (\ @ \)) E (take j \) \ LeftDerivation (drop (Suc i) (\ @ \)) F (drop (Suc j) \)" by blast then have "LeftDerivation (\ @ \) D \" by blast from LeftDerivation_skip_prefixword_ex[OF this is_word_\] obtain \' where \': "\ = \ @ \' \ LeftDerivation \ (derivation_shift D (length \) 0) \'" by blast have ldf1: "is_sentence \" using EF is_sentence_concat by blast have ldf2: "is_sentence \'" using EF \' is_sentence_concat by blast have ldf3: "i - length \ < length \" by (metis EF append_Nil assms(3) drop_append drop_eq_Nil not_le) have ldf4: "j - length \ < length \'" by (metis EF append_Nil j_ge_d \' drop_append drop_eq_Nil not_le) have ldf5: "\ ! (i - length \) = \' ! (j - length \)" by (metis \' EF assms(3) j_ge_d leD nth_append) have D_split: "D = E @ derivation_shift F 0 (Suc j)" using EF by blast show ?thesis apply (rule_tac x=\' in exI) apply (auto simp add: \') apply (auto simp add: LeftDerivationFix_def) using ldf1 apply blast using ldf2 apply blast using \' apply blast using ldf3 apply blast using ldf4 apply blast using ldf5 apply blast apply (rule_tac x="derivation_shift E (length \) 0" in exI) apply (rule_tac x="F" in exI) apply auto apply (subst D_split) apply (simp add: derivation_shift_append) apply (subst derivation_shift_right_left_subtract) apply (simp add: j_ge_d le_Suc_eq) using j_ge_d apply (simp add: Suc_diff_le) apply (metis EF LeftDerivation_implies_Derivation LeftDerivation_skip_prefix \' append_eq_conv_conj assms(3) drop_take is_word_Derivation_derivation_ge is_word_\ take_all take_append) using EF Suc_diff_le \' assms(3) j_ge_d by auto qed lemma LeftDerives1_propagate_prefix: "LeftDerives1 (\ @ \) i r \ \ i \ length \ \ is_prefix \ \" proof - assume a1: "LeftDerives1 (\ @ \) i r \" assume a2: "length \ \ i" have f3: "take i (\ @ \) = take i \" using a1 Derives1_take LeftDerives1_implies_Derives1 by blast then have f4: "length (take i \) = i" using a1 by (metis (no_types) Derives1_bound LeftDerives1_implies_Derives1 dual_order.strict_implies_order length_take min.absorb2) have "take (length \) (take i \) = \" using f3 a2 by (simp add: append_eq_conv_conj) then show ?thesis using f4 a2 by (metis (no_types) append_Nil2 append_eq_conv_conj diff_is_0_eq' is_prefix_take take_0 take_append) qed lemma LeftDerivationIntro_cut_prefix: assumes "LeftDerivationIntro (\@\) i r ix D j \" assumes "derivation_ge D (length \)" assumes "i \ length \" assumes is_word_\: "is_word \" shows "\ \'. \ = \ @ \' \ LeftDerivationIntro \ (i - length \) r ix (derivation_shift D (length \) 0) (j - length \) \'" proof - from iffD1[OF LeftDerivationIntro_def assms(1)] obtain \ where \: "LeftDerives1 (\ @ \) i r \ \ ix < length (snd r) \ snd r ! ix = \ ! j \ LeftDerivationFix \ (i + ix) D j \" by blast have "\ \'. \ = \ @ \'" using LeftDerives1_propagate_prefix \ assms(3) by (metis append_dropped_prefix) then obtain \' where \': "\ = \ @ \'" by blast with \ have "LeftDerives1 (\ @ \) i r (\ @ \')" by simp from LeftDerives1_skip_prefix[OF assms(3) this] have \_\': "LeftDerives1 \ (i - length \) r \'" by blast have ldfix: "LeftDerivationFix (\ @ \') (i + ix) D j \" using \ \' by auto have \_le_i_plus_ix: "length \ \ i + ix" using assms(3) by arith from LeftDerivationFix_cut_prefix[OF ldfix assms(2) \_le_i_plus_ix assms(4)] obtain \' where \': "\ = \ @ \' \ LeftDerivationFix \' (i + ix - length \) (derivation_shift D (length \) 0) (j - length \) \'" by blast have same_symbol: "\ ! j = \' ! (j - length \)" by (metis LeftDerivationFix_def \ \' \_le_i_plus_ix \' leD nth_append) have \'_\': "LeftDerivationFix \' (i - length \ + ix) (derivation_shift D (length \) 0) (j - length \) \'" by (simp add: \' assms(3)) show ?thesis apply (simp add: LeftDerivationIntro_def) apply (rule_tac x=\' in exI) apply (auto simp add: \') apply (rule_tac x=\' in exI) by (auto simp add: \ \_\' same_symbol \'_\') qed lemma LeftDerivationLadder_implies_LeftDerivation_at_index: assumes "LeftDerivationLadder \ D L \" assumes "index < length L" shows "LeftDerivation \ (take (ladder_n L index) D) (ladder_\ \ D L index)" using LeftDerivationLadder_def LeftDerivation_take_derive assms(1) ladder_\_def by auto lemma LeftDerivationLadder_cut_prefix_propagate: assumes ladder: "LeftDerivationLadder (\@\) D L \" assumes is_word_\: "is_word \" assumes derivation_ge_\: "derivation_ge D (length \)" assumes ladder_i_0: "ladder_i L 0 \ length \" assumes L': "L' = ladder_cut_prefix (length \) L" assumes D': "D' = derivation_shift D (length \) 0" shows "index < length L \ LeftDerivation \ (take (ladder_n L' index) D') (ladder_\ \ D' L' index) \ ladder_\ (\@\) D L index = \@(ladder_\ \ D' L' index) \ ladder_\ (\@\) D L index = \@(ladder_\ \ D' L' index)" proof (induct index) case 0 have ladder_\: "ladder_\ (\@\) D L 0 = \@(ladder_\ \ D' L' 0)" by (simp add: ladder_\_def) have ldfix: "LeftDerivationFix (\@\) (ladder_i L 0) (take (ladder_n L 0) D) (ladder_j L 0) (ladder_\ (\@\) D L 0)" using ladder LeftDerivationLadder_def by blast have dge_take: "derivation_ge (take (ladder_n L 0) D) (length \)" using derivation_ge_\ by (metis append_take_drop_id derivation_ge_append) from LeftDerivationFix_cut_prefix[OF ldfix dge_take ladder_i_0 is_word_\] obtain \' where \': "ladder_\ (\ @ \) D L 0 = \ @ \' \ LeftDerivationFix \ (ladder_i L 0 - length \) (derivation_shift (take (ladder_n L 0) D) (length \) 0) (ladder_j L 0 - length \) \'" by blast have ladder_\: "ladder_\ (\@\) D L 0 = \@(ladder_\ \ D' L' 0)" using \' by (metis "0.prems" D' Derive L' LeftDerivationFix_def LeftDerivation_implies_Derivation ladder_\_def ladder_cut_prefix_n take_derivation_shift) have "LeftDerivation \ (take (ladder_n L' 0) D') (ladder_\ \ D' L' 0)" proof - have "LeftDerivation (\@\) (take (ladder_n L 0) D) (ladder_\ (\@\) D L 0)" using LeftDerivationLadder_implies_LeftDerivation_at_index ladder "0.prems" by blast then show ?thesis by (metis D' LeftDerivationLadder_def LeftDerivation_skip_prefix LeftDerivation_take_derive derivation_ge_\ ladder ladder_\_def) qed then show ?case using ladder_\ ladder_\ by auto next case (Suc index) have index_less_L: "index < length L" using Suc(2) by arith then have induct: "ladder_\ (\@\) D L index = \@(ladder_\ \ D' L' index)" using Suc by blast then have ladder_\: "ladder_\ (\@\) D L (Suc index) = \@(ladder_\ \ D' L' (Suc index))" by (simp add: ladder_\_def) have introsAt: "LeftDerivationIntrosAt (\@\) D L (Suc index)" using Suc(2) ladder by (metis LeftDerivationIntros_def LeftDerivationLadder_def Suc_eq_plus1_left le_add1) obtain n m e E where n: "n = ladder_n L (Suc index - 1)" and m: "m = ladder_n L (Suc index)" and e: "e = D ! n" and E: "E = drop (Suc n) (take m D)" by blast from iffD1[OF LeftDerivationIntrosAt_def introsAt] have "LeftDerivationIntro (ladder_\ (\ @ \) D L (Suc index)) (ladder_i L (Suc index)) (snd e) (ladder_ix L (Suc index)) E (ladder_j L (Suc index)) (ladder_\ (\ @ \) D L (Suc index))" using n m e E Let_def by meson then have ldintro: "LeftDerivationIntro (\@(ladder_\ \ D' L' (Suc index))) (ladder_i L (Suc index)) (snd e) (ladder_ix L (Suc index)) E (ladder_j L (Suc index)) (ladder_\ (\ @ \) D L (Suc index))" by (simp add: ladder_\) have dge_E_\: "derivation_ge E (length \)" apply (simp add: E) using derivation_ge_\ by (metis append_take_drop_id derivation_ge_append) have ladder_i_Suc: "length \ \ ladder_i L (Suc index)" using Suc.prems derivation_ge_LeftDerivationLadder derivation_ge_\ ladder ladder_i_0 by blast from LeftDerivationIntro_cut_prefix[OF ldintro dge_E_\ ladder_i_Suc is_word_\] obtain \' where \': "ladder_\ (\ @ \) D L (Suc index) = \ @ \' \ LeftDerivationIntro (ladder_\ \ D' L' (Suc index)) (ladder_i L (Suc index) - length \) (snd e) (ladder_ix L (Suc index)) (derivation_shift E (length \) 0) (ladder_j L (Suc index) - length \) \'" by blast then have "LeftDerivation (ladder_\ \ D' L' (Suc index)) ((ladder_i L (Suc index) - length \, snd e) # (derivation_shift E (length \) 0)) \'" using LeftDerivationIntro_implies_LeftDerivation by blast then have "LeftDerivation (ladder_\ \ D' L' index) ((ladder_i L (Suc index) - length \, snd e) # (derivation_shift E (length \) 0)) \'" by (auto simp add: ladder_\_def) have ld: "LeftDerivation \ (take (ladder_n L' (Suc index)) D') (ladder_\ \ D' L' (Suc index))" proof - have "LeftDerivation (\@\) (take (ladder_n L (Suc index)) D) (ladder_\ (\@\) D L (Suc index))" using LeftDerivationLadder_implies_LeftDerivation_at_index ladder Suc.prems by blast then show ?thesis by (metis D' LeftDerivationLadder_def LeftDerivation_skip_prefix LeftDerivation_take_derive derivation_ge_\ ladder ladder_\_def) qed then show ?case using \' D' Derive L' LeftDerivationIntro_def n m e E ld LeftDerivation_implies_Derivation ladder_\_def ladder_cut_prefix_n take_derivation_shift by (metis (no_types, lifting) LeftDerivationLadder_implies_LeftDerivation_at_index LeftDerivation_skip_prefixword_ex Suc.prems Suc_leI index_less_L is_word_\ ladder ladder_\ le_0_eq neq0_conv) qed theorem LeftDerivationLadder_cut_prefix: assumes ladder: "LeftDerivationLadder (\@\) D L \" assumes is_word_\: "is_word \" assumes ladder_i_0: "ladder_i L 0 \ length \" shows "\ D' L' \'. \ = \ @ \' \ LeftDerivationLadder \ D' L' \' \ D' = derivation_shift D (length \) 0 \ length L' = length L \ ladder_i L' 0 + length \ = ladder_i L 0 \ ladder_last_j L' + length \ = ladder_last_j L" proof - obtain D' where D': "D' = derivation_shift D (length \) 0" by blast obtain L' where L': "L' = ladder_cut_prefix (length \) L" by blast obtain \' where \': "\' = drop (length \) \" by blast have ladder_last_j_upper_bound: "ladder_last_j L < length \" using ladder using ladder_last_j_bound by blast have derivation_ge_\: "derivation_ge D (length \)" using is_word_\ LeftDerivationLadder_def LeftDerivation_implies_Derivation is_word_Derivation_derivation_ge ladder by blast note derivation_ge_ladder = derivation_ge_LeftDerivationLadder[OF derivation_ge_\ ladder ladder_i_0] have ladder_last_j_lower_bound: "ladder_last_j L \ length \" using LeftDerivationLadder_def derivation_ge_ladder is_ladder_def ladder ladder_last_j_def by auto from ladder_last_j_upper_bound ladder_last_j_lower_bound have \_less_\: "length \ < length \" by arith then have \_def: "\ = \ @ \'" by (metis LeftDerivation.simps(1) LeftDerivationLadder_def LeftDerivation_ge_take \' append_eq_conv_conj derivation_ge_\ ladder) have length_L_nonzero: "length L \ 0" using LeftDerivationLadder_def is_ladder_def ladder by auto have ladder_i_L'_thm: "\ index. index < length L \ ladder_i L' index + length \ = ladder_i L index" apply (simp add: L') apply (subst ladder_cut_prefix_i) apply simp using length_L_nonzero apply blast using derivation_ge_ladder by auto have ladder_j_L'_thm: "\ index. index < length L \ ladder_j L' index + length \ = ladder_j L index" apply (simp add: L') apply (subst ladder_cut_prefix_j) using LeftDerivationLadder_def is_ladder_def ladder apply blast using LeftDerivationLadder_def is_ladder_def ladder apply blast using derivation_ge_ladder by auto have length_L': "length L' = length L" using L' ladder_cut_prefix_length by simp have \_\': "LeftDerivation \ D' \'" using D' LeftDerivationLadder_def LeftDerivation_skip_prefix \' derivation_ge_\ ladder by blast have length_D': "length D' = length D" by (simp add: D') have is_ladder_D_L: "is_ladder D L" using LeftDerivationLadder_def ladder by blast { fix u :: nat assume u_bound_L': "u < length L'" have u_bound_L: "u < length L" using length_L' using u_bound_L' by simp have "ladder_n L' u \ length D'" apply (simp add: length_D' L') apply (subst ladder_cut_prefix_n) apply (simp add: u_bound_L) using length_L_nonzero apply arith using u_bound_L is_ladder_D_L by (simp add: is_ladder_def) } note is_ladder_1 = this { fix u :: nat fix v :: nat assume u_less_v: "u < v" assume v_bound_L': "v < length L'" then have v_bound_L: "v < length L" by (simp add: length_L') with u_less_v have u_bound_L: "u < length L" by arith have "ladder_n L' u < ladder_n L' v" apply (simp add: L') apply (subst ladder_cut_prefix_n) using u_bound_L apply blast using length_L_nonzero apply blast apply (subst ladder_cut_prefix_n) using v_bound_L apply blast using length_L_nonzero apply blast using u_less_v v_bound_L is_ladder_D_L by (simp add: is_ladder_def) } note is_ladder_2 = this have is_ladder_3: "ladder_last_n L' = length D'" apply (simp add: length_D' ladder_last_n_def L') apply (subst ladder_cut_prefix_n) apply (simp add: ladder_cut_prefix_length) using length_L_nonzero apply auto[1] using length_L_nonzero apply blast apply (simp add: ladder_cut_prefix_length) using is_ladder_D_L by (simp add: is_ladder_def ladder_last_n_def) have is_ladder_4: "LeftDerivationFix \ (ladder_i L' 0) (take (ladder_n L' 0) D') (ladder_j L' 0) (ladder_\ \ D' L' 0)" proof - have ldfix: "LeftDerivationFix (\@\) (ladder_i L 0) (take (ladder_n L 0) D) (ladder_j L 0) (ladder_\ (\@\) D L 0)" using ladder LeftDerivationLadder_def by blast have dge: "derivation_ge (take (ladder_n L 0) D) (length \)" using derivation_ge_\ by (metis append_take_drop_id derivation_ge_append) from LeftDerivationFix_cut_prefix[OF ldfix dge ladder_i_0 is_word_\] obtain \' where \': "ladder_\ (\ @ \) D L 0 = \ @ \' \ LeftDerivationFix \ (ladder_i L 0 - length \) (derivation_shift (take (ladder_n L 0) D) (length \) 0) (ladder_j L 0 - length \) \'" by blast then show ?thesis using LeftDerivationLadder_cut_prefix_propagate D' L' append_eq_conv_conj derivation_ge_\ is_word_\ ladder ladder_cut_prefix_i ladder_cut_prefix_j ladder_cut_prefix_n ladder_i_0 length_0_conv length_L_nonzero length_greater_0_conv take_derivation_shift by auto qed { fix index :: nat assume index_lower_bound: "Suc 0 \ index" assume index_upper_bound: "index < length L'" have introsAt: "LeftDerivationIntrosAt (\@\) D L index" by (metis LeftDerivationIntros_def LeftDerivationLadder_def One_nat_def index_lower_bound index_upper_bound ladder length_L') then have ladder_i_L: "ladder_i L index = fst (D ! ladder_n L (index - Suc 0))" by (metis LeftDerivationIntrosAt_def One_nat_def \LeftDerivationIntrosAt (\ @ \) D L index\) have ladder_i_L'_as_L: "ladder_i L' index = ladder_i L index - (length \)" using ladder_cut_prefix_i L' index_upper_bound is_ladder_D_L is_ladder_not_empty length_L' length_greater_0_conv by auto have length_L_gr_0: "length L > 0" using length_L' length_L_nonzero by arith have index_Suc_upper_bound_L: "index - Suc 0 < length L" using index_upper_bound length_L' by arith have "fst (D' ! ladder_n L' (index - Suc 0)) = fst (D ! ladder_n L (index - Suc 0)) - (length \)" apply (subst D', subst L') apply (subst ladder_cut_prefix_n[OF index_Suc_upper_bound_L length_L_gr_0]) apply (simp add: derivation_shift_def) using index_lower_bound index_upper_bound is_ladder_D_L ladder_n_minus_1_bound length_L' by auto then have ladder_i_L': "ladder_i L' index = fst (D' ! ladder_n L' (index - Suc 0))" using ladder_i_L ladder_i_L'_as_L by auto have "LeftDerivationIntro (ladder_\ \ D' L' index) (ladder_i L' index) (snd (D' ! ladder_n L' (index - Suc 0))) (ladder_ix L' index) (drop (Suc (ladder_n L' (index - Suc 0))) (take (ladder_n L' index) D')) (ladder_j L' index) (ladder_\ \ D' L' index)" proof - have "LeftDerivationIntro (ladder_\ (\@\) D L index) (ladder_i L index) (snd (D ! ladder_n L (index - Suc 0))) (ladder_ix L index) (drop (Suc (ladder_n L (index - Suc 0))) (take (ladder_n L index) D)) (ladder_j L index) (ladder_\ (\@\) D L index)" using introsAt by (metis LeftDerivationIntrosAt_def One_nat_def) then have ldintro: "LeftDerivationIntro (\@(ladder_\ \ D' L' index)) (ladder_i L index) (snd (D ! ladder_n L (index - Suc 0))) (ladder_ix L index) (drop (Suc (ladder_n L (index - Suc 0))) (take (ladder_n L index) D)) (ladder_j L index) (ladder_\ (\@\) D L index)" using D' L' LeftDerivationLadder_cut_prefix_propagate derivation_ge_\ index_upper_bound is_word_\ ladder ladder_i_0 length_L' by auto have dge: "derivation_ge (drop (Suc (ladder_n L (index - Suc 0))) (take (ladder_n L index) D)) (length \)" using derivation_ge_\ by (metis append_take_drop_id derivation_ge_append) have \_le_i_L: "length \ \ ladder_i L index" using derivation_ge_ladder index_upper_bound length_L' by auto from LeftDerivationIntro_cut_prefix[OF ldintro dge \_le_i_L is_word_\] obtain \' where \': "ladder_\ (\ @ \) D L index = \ @ \' \ LeftDerivationIntro (ladder_\ \ D' L' index) (ladder_i L index - length \) (snd (D ! ladder_n L (index - Suc 0))) (ladder_ix L index) (derivation_shift (drop (Suc (ladder_n L (index - Suc 0))) (take (ladder_n L index) D)) (length \) 0) (ladder_j L index - length \) \'" by blast have h1: "ladder_i L' index = ladder_i L index - length \" using L' ladder_cut_prefix_i ladder_i_L'_as_L by blast have h2: "(snd (D' ! ladder_n L' (index - Suc 0))) = (snd (D ! ladder_n L (index - Suc 0)))" apply (subst L', subst ladder_cut_prefix_n) apply (simp add: index_Suc_upper_bound_L) using length_L_gr_0 apply auto[1] apply (subst D') apply (simp add: derivation_shift_def) using index_lower_bound index_upper_bound is_ladder_D_L ladder_n_minus_1_bound length_L' by auto have h3: "ladder_ix L' index = ladder_ix L index" using ladder_cut_prefix_ix L' index_upper_bound length_L' length_L_gr_0 by auto have h4: "(drop (Suc (ladder_n L' (index - Suc 0))) (take (ladder_n L' index) D')) = (derivation_shift (drop (Suc (ladder_n L (index - Suc 0))) (take (ladder_n L index) D)) (length \) 0)" apply (subst D') apply (subst L')+ apply (subst ladder_cut_prefix_n, simp add: index_Suc_upper_bound_L) using length_L_gr_0 apply blast apply (subst ladder_cut_prefix_n) using index_upper_bound length_L' apply arith using length_L_gr_0 apply blast apply (simp add: derivation_shift_def) by (simp add: drop_map take_map) have h5: "ladder_j L' index = ladder_j L index - length \" using ladder_cut_prefix_j L' index_upper_bound length_L' length_L_gr_0 by auto have h6: "ladder_\ \ D' L' index = \'" using D' L' LeftDerivationLadder_cut_prefix_propagate \' derivation_ge_\ index_upper_bound is_word_\ ladder ladder_i_0 length_L' by auto show ?thesis using h1 h2 h3 h4 h5 h6 \' by simp qed then have "LeftDerivationIntrosAt \ D' L' index" apply (auto simp add: LeftDerivationIntrosAt_def Let_def) using ladder_i_L' by blast } note is_ladder_5 = this show ?thesis apply (rule_tac x="D'" in exI) apply (rule_tac x="L'" in exI) apply (rule_tac x="\'" in exI) apply auto using \_def apply blast defer 1 using D' apply blast using L' ladder_cut_prefix_length apply auto[1] apply (subst ladder_i_L'_thm) using LeftDerivationLadder_def is_ladder_def ladder apply blast apply simp apply (simp add: ladder_last_j_def) apply (subst ladder_j_L'_thm) apply (simp add: length_L') using length_L_nonzero apply arith apply (simp add: length_L') apply (auto simp add: LeftDerivationLadder_def) using \_\' apply blast apply (auto simp add: is_ladder_def) using length_L_nonzero length_L' apply auto[1] using is_ladder_1 apply blast using is_ladder_2 apply blast using is_ladder_3 apply blast using is_ladder_4 apply blast by (auto simp add: LeftDerivationIntros_def is_ladder_5) qed end end diff --git a/thys/LocalLexing/TheoremD10.thy b/thys/LocalLexing/TheoremD10.thy --- a/thys/LocalLexing/TheoremD10.thy +++ b/thys/LocalLexing/TheoremD10.thy @@ -1,540 +1,540 @@ theory TheoremD10 imports TheoremD9 Ladder begin context LocalLexing begin lemma \

_wellformed: "p \ \

k u \ wellformed_tokens p" using \

.simps(3) \_def prefixes_are_paths by blast lemma thmD10_ladder: "p \ \ \ charslength p = k \ X \ T \ T \ \ k \ (N, \@\) \ \ \ r \ length p \ leftderives [\] ((terminals (take r p))@[N]@\) \ LeftDerivationLadder \ D L (terminals ((drop r p)@[X])) \ ladder_last_j L = length (drop r p) \ k' = k + length (chars_of_token X) \ x = Item (N, \@\) (length \) (charslength (take r p)) k' \ I = items_le k' (\ k' {} (Scan T k (Gen (Prefixes p)))) \ x \ I" proof (induct "length L" arbitrary: N \ \ r \ D L x rule: less_induct) case less have item_origin_x_def: "item_origin x = (charslength (take r p))" by (simp add: less.prems(11)) then have x_k: "item_origin x \ k" using charslength.simps is_prefix_chars is_prefix_length is_prefix_take less.prems(2) by force have item_end_x_def: "item_end x = k'" by (simp add: less.prems(11)) have item_dot_x_def: "item_dot x = length \" by (simp add: less.prems(11)) have k'_upperbound: "k' \ length Doc" using \_token_length less.prems(10) less.prems(3) less.prems(4) by blast note item_def = less.prems(11) note k' = less.prems(10) note rule_dom = less.prems(5) note p_charslength = less.prems(2) note p_dom = less.prems(1) note r = less.prems(6) note leftderives_start = less.prems(7) note X_dom = less.prems(3) have wellformed_x: "wellformed_item x" apply (auto simp add: wellformed_item_def item_def rule_dom p_charslength) apply (subst k') apply (subst charslength.simps[symmetric]) apply (subst p_charslength[symmetric]) using item_origin_x_def p_charslength x_k apply linarith apply (rule k'_upperbound) done have leftderives_\: "leftderives \ (terminals ((drop r p)@[X]))" using LeftDerivationLadder_def LeftDerivation_implies_leftderives less.prems(8) by blast have is_sentence_drop_pX: "is_sentence (drop r (terminals p) @ [terminal_of_token X])" by (metis derives_is_sentence is_sentence_concat leftderives_\ leftderives_implies_derives rule_\_type rule_dom terminals_append terminals_drop terminals_singleton) have snd_item_rule_x: "snd (item_rule x) = \@\" by (simp add: item_def) from less have "is_ladder D L" using LeftDerivationLadder_def by blast then have "length L \ 0" by (simp add: is_ladder_not_empty) then have "length L = 1 \ length L > 1" by arith then show ?case proof (induct rule: disjCases2) case 1 have "\ i. LeftDerivationFix \ i D (length (drop r p)) (terminals ((drop r p)@[X]))" using "1.hyps" LeftDerivationLadder_L_0 less.prems(8) less.prems(9) by fastforce then obtain i where LDF: "LeftDerivationFix \ i D (length (drop r p)) (terminals ((drop r p)@[X]))" by blast from LeftDerivationFix_splits_at_derives[OF this] obtain U a1 a2 b1 b2 where decompose: "splits_at \ i a1 U a2 \ splits_at (terminals (drop r p @ [X])) (length (drop r p)) b1 U b2 \ derives a1 b1 \ derives a2 b2" by blast then have b1: "b1 = terminals (drop r p)" by (simp add: append_eq_conv_conj splits_at_def) with decompose have U: "U = fst X" by (metis length_terminals nth_append_length splits_at_def terminal_of_token_def terminals_append terminals_singleton) from decompose b1 U have b2: "b2 = []" by (simp add: splits_at_combine splits_at_def) have D: "LeftDerivation \ D (terminals ((drop r p)@[X]))" using LDF LeftDerivationLadder_def less.prems(8) by blast let ?y = "Item (item_rule x) (length a1) (item_origin x) k" have wellformed_y: "wellformed_item ?y" using wellformed_x apply (auto simp add: wellformed_item_def x_k) using k' k'_upperbound apply arith apply (simp add: item_rhs_def snd_item_rule_x) using decompose splits_at_def by (simp add: is_prefix_length trans_le_add1) have y_nonterminal: "item_nonterminal ?y = N" by (simp add: item_def item_nonterminal_def) have item_\_y: "item_\ ?y = a1" by (metis append_assoc append_eq_conv_conj append_take_drop_id decompose item.sel(1) item.sel(2) item_\_def item_rhs_def snd_item_rule_x splits_at_def) have pvalid_y: "pvalid p ?y" apply (auto simp add: pvalid_def) using p_dom \_wellformed apply blast using wellformed_y apply auto[1] apply (rule_tac x=r in exI) apply (auto simp add: r) using p_charslength apply simp using item_def apply simp apply (rule_tac x=\ in exI) using y_nonterminal apply simp using is_derivation_def leftderives_start apply auto[1] apply (simp add: item_\_y) using b1 decompose by auto let ?z = "inc_item ?y k'" have item_rhs_y: "item_rhs ?y = \@\" by (simp add: item_def item_rhs_def) have split_\: "\ = a1@[U]@a2" using decompose splits_at_combine by blast have next_symbol_y: "next_symbol ?y = Some(fst X)" by (auto simp add: next_symbol_def is_complete_def item_rhs_y split_\ U) have z_in_Scan_y: "?z \ Scan T k {?y}" apply (simp add: Scan_def) apply (rule disjI2) apply (rule_tac x="?y" in exI) apply (rule_tac x="fst X" in exI) apply (rule_tac x="snd X" in exI) apply (auto simp add: bin_def X_dom) using k' chars_of_token_def apply simp using next_symbol_y apply simp done from pvalid_y have "?y \ Gen(Prefixes p)" apply (simp add: Gen_def) apply (rule_tac x=p in exI) by (auto simp add: paths_le_def p_dom) then have "Scan T k {?y} \ Scan T k (Gen(Prefixes p))" apply (rule_tac monoD[OF mono_Scan]) apply blast done with z_in_Scan_y have z_in_Scan_Gen: "?z \ Scan T k (Gen(Prefixes p))" using rev_subsetD by blast have wellformed_z: "wellformed_item ?z" using k' k'_upperbound next_symbol_y wellformed_inc_item wellformed_y by auto have item_\_z: "item_\ ?z = a2@\" apply (simp add: item_\_def) apply (simp add: item_rhs_y split_\) done have item_end_z: "item_end ?z = k'" by simp have x_via_z: "x = inc_dot (length a2) ?z" by (simp add: inc_dot_def less.prems(11) split_\) have x_in_z: "x \ \ k' {} {?z}" apply (subst x_via_z) apply (rule_tac thmD6[OF wellformed_z item_\_z item_end_z]) using decompose b2 by blast have "\ k' {} {?z} \ \ k' {} (Scan T k (Gen(Prefixes p)))" apply (rule_tac monoD[OF mono_\]) using z_in_Scan_Gen using empty_subsetI insert_subset by blast then have x_in_Scan_Gen: "x \ \ k' {} (Scan T k (Gen(Prefixes p)))" using x_in_z by blast have "item_end x = k'" by (simp add: item_end_x_def) with x_in_Scan_Gen show ?case using items_le_def less.prems(12) mem_Collect_eq nat_le_linear by blast next case 2 obtain i where i: "i = ladder_i L 0" by blast obtain i' where i': "i' = ladder_j L 0" by blast obtain \' where \': "\' = ladder_\ \ D L 0" by blast obtain n where n: "n = ladder_n L 0" by blast have ldfix: "LeftDerivationFix \ i (take n D) i' \'" using LeftDerivationLadder_def \' i i' n less.prems(8) by blast have \'_alt: "\' = ladder_\ \ D L 1" using 2 by (simp add: \' ladder_\_def) have i'_alt: "i' = ladder_i L 1" using 2 by (simp add: i' ladder_i_def) obtain e where e: "e = D ! n" by blast obtain ix where ix: "ix = ladder_ix L 1" by blast obtain m where m: "m = ladder_n L 1" by blast obtain E where E: "E = drop (Suc n) (take m D)" by blast have ldintro: "LeftDerivationIntro \' i' (snd e) ix E (ladder_j L 1) (ladder_\ \ D L 1)" by (metis "2.hyps" LeftDerivationIntrosAt_def LeftDerivationIntros_def LeftDerivationLadder_def One_nat_def \'_alt E diff_Suc_1 e i'_alt ix leI less.prems(8) m n not_less_eq zero_less_one) have is_nonterminal_\'_at_i': "is_nonterminal (\' ! i')" using LeftDerivationIntro_implies_nonterminal ldintro by blast then have is_nonterminal_\_at_i: "is_nonterminal (\ ! i)" using LeftDerivationFix_def ldfix by auto then have "\ A a1 a2 a1'. splits_at \ i a1 A a2 \ splits_at \' i' a1' A a2 \ LeftDerivation a1 (take n D) a1'" using LeftDerivationFix_splits_at_nonterminal ldfix by auto then obtain A a1 a2 a1' where A: "splits_at \ i a1 A a2 \ splits_at \' i' a1' A a2 \ LeftDerivation a1 (take n D) a1'" by blast have A_def: "A = \' ! i'" using A splits_at_def by blast have is_nonterminal_A: "is_nonterminal A" using A_def is_nonterminal_\'_at_i' by blast have "\ rule. e = (i', rule)" by (metis e "2.hyps" LeftDerivationIntrosAt_def LeftDerivationIntros_def LeftDerivationLadder_def One_nat_def Suc_leI diff_Suc_1 i'_alt less.prems(8) n prod.collapse zero_less_one) then obtain rule where rule: "e = (i', rule)" by blast obtain w where w: "w = snd rule" by blast obtain \'' where \'': "\'' = a1' @ w @ a2" by blast have \'_\'': "LeftDerives1 \' i' rule \''" by (metis A w LeftDerivationFix_is_sentence LeftDerivationIntro_def LeftDerivationIntro_examine_rule LeftDerives1_def \'' ldfix ldintro prod.collapse rule snd_conv splits_at_implies_Derives1) then have is_word_a1': "is_word a1'" using LeftDerives1_splits_at_is_word A by blast have A_eq_fst_rule: "A = fst rule" using A LeftDerivationIntro_examine_rule ldintro rule by fastforce have ix_bound: "ix < length w" using ix w rule ldintro LeftDerivationIntro_def snd_conv by auto then have "\ w1 W w2. splits_at w ix w1 W w2" using splits_at_def by blast then obtain w1 W w2 where W: "splits_at w ix w1 W w2" by blast have a1'_w_a2: "a1'@w@a2 = ladder_stepdown_\_0 \ D L" using ladder_stepdown_\_0_altdef "2.hyps" A \'_alt e i'_alt less.prems(8) n rule snd_conv w by force from LeftDerivationLadder_stepdown[OF less.prems(8) 2] obtain L' where L': "LeftDerivationLadder (a1'@(w@a2)) (drop (ladder_stepdown_diff L) D) L' (terminals (drop r p @ [X])) \ length L' = length L - 1 \ ladder_i L' 0 = ladder_i L 1 + ladder_ix L 1 \ ladder_last_j L' = ladder_last_j L" using a1'_w_a2 by auto have ladder_i_L'_0: "ladder_i L' 0 = i' + ix" using L' i'_alt ix by auto have ladder_last_j_L': "ladder_last_j L' = length (drop r p)" using L' less.prems by auto from L' have this1: "LeftDerivationLadder (a1'@(w@a2)) (drop (ladder_stepdown_diff L) D) L' (terminals (drop r p @ [X]))" by blast have this2: "length a1' \ ladder_i L' 0" using A ladder_i_L'_0 splits_at_def by auto from LeftDerivationLadder_cut_prefix[OF this1 is_word_a1' this2] obtain D' L'' \' where L'': "terminals (drop r p @ [X]) = a1' @ \' \ LeftDerivationLadder (w @ a2) D' L'' \' \ D' = derivation_shift (drop (ladder_stepdown_diff L) D) (length a1') 0 \ length L'' = length L' \ ladder_i L'' 0 + length a1' = ladder_i L' 0 \ ladder_last_j L'' + length a1' = ladder_last_j L'" by blast have length_a1'_bound: "length a1' \ length (drop r p)" using L'' ladder_last_j_L' by linarith then have is_prefix_a1'_drop_r_p: "is_prefix a1' (terminals (drop r p))" proof - have f1: "\ss ssa ssb. \ is_prefix (ss::symbol list) (ssa @ ssb) \ is_prefix ss ssa \ (\ssc. ssc \ [] \ is_prefix ssc ssb \ ss = ssa @ ssc)" by (simp add: is_prefix_of_append) have f2: "\ss ssa. is_prefix ((ss::symbol list) @ ssa) ss \ \ is_prefix ssa []" by (metis (no_types) append_Nil2 is_prefix_cancel) have f3: "\ss. is_prefix ss [] \ \ is_prefix (terminals (drop r p) @ ss) a1'" by (metis (no_types) drop_eq_Nil is_prefix_append length_a1'_bound length_terminals) have "is_prefix a1' (a1' @ \') \ is_prefix a1' a1'" by (metis (no_types) append_Nil2 is_prefix_cancel is_prefix_empty) then show ?thesis using f3 f2 f1 by (metis L'' terminals_append) qed obtain r' where r': "r' = r + i'" by blast have length_a1'_eq_i': "length a1' = i'" using A less_or_eq_imp_le min.absorb2 splits_at_def by auto have a1'_r': "r \ r' \ r' \ length p \ terminals (drop r p) = a1' @ (terminals (drop r' p))" using is_prefix_a1'_drop_r_p r' proof - have "\ q. terminals (drop r p) = a1' @ q" using is_prefix_a1'_drop_r_p by (metis is_prefix_unsplit) then obtain q where q: "terminals (drop r p) = a1' @ q" by blast have "q = drop i' (terminals (drop r p))" using length_a1'_eq_i' q by (simp add: append_eq_conv_conj) then have "q = terminals (drop i' (drop r p))" by simp then have "q = terminals (drop r' p)" by (simp add: r' add.commute) with q show ?thesis using add.commute diff_add_inverse le_Suc_ex le_add1 le_diff_conv length_a1'_bound length_a1'_eq_i' length_drop r r' by auto qed have ladder_i_L'': "ladder_i L'' 0 = ix" using L'' ladder_i_L'_0 length_a1'_eq_i' add.commute add_left_cancel by linarith have L''_ladder: "LeftDerivationLadder (w @ a2) D' L'' \'" using L'' by blast have "ladder_i L'' 0 < length w" using ladder_i_L'' ix_bound by blast from LeftDerivationLadder_cut_appendix[OF L''_ladder this] obtain E' F' \1' \2' L''' where L''': "D' = E' @ F' \ \' = \1' @ \2' \ LeftDerivationLadder w E' L''' \1' \ derivation_ge F' (length \1') \ LeftDerivation a2 (derivation_shift F' (length \1') 0) \2' \ length L''' = length L'' \ ladder_i L''' 0 = ladder_i L'' 0 \ ladder_last_j L''' = ladder_last_j L''" by blast obtain z where z: "z = Item (A, w) (length w) (charslength (take r' p)) k'" by blast have z1: "length L''' < length L" using "2.hyps" L' L'' L''' by linarith have z2: "p \ \" by (simp add: p_dom) have z3: "charslength p = k" using p_charslength by auto have z4: "X \ T" by (simp add: X_dom) have z5: "T \ \ k" by (simp add: less.prems(4)) have "rule \ \" using Derives1_rule LeftDerives1_implies_Derives1 \'_\'' by blast then have z6: "(A, w @ []) \ \" using w A_eq_fst_rule by auto have z7: "r' \ length p" using a1'_r' by linarith have "leftderives [\] ((terminals (take r p))@[N]@\)" using leftderives_start by blast then have "leftderives [\] ((terminals (take r p))@(\@\)@\)" by (metis \_wellformed is_derivation_def is_derivation_is_sentence is_sentence_concat is_word_terminals_take leftderives_implies_derives leftderives_rule_step p_dom rule_dom) then have "leftderives [\] ((terminals (take r p))@a1@([A]@a2@\)@\)" using A splits_at_combine append_assoc by fastforce then have z8_helper: "leftderives [\] ((terminals (take r p))@a1'@([A]@a2@\)@\)" by (meson A LeftDerivation_implies_leftderives \_wellformed is_derivation_def is_derivation_is_sentence is_sentence_concat is_word_terminals_take leftderives_implies_derives leftderives_trans_step p_dom) have join_terminals: "(terminals (take r p))@a1' = terminals (take r' p)" by (metis is_prefix_a1'_drop_r_p length_a1'_eq_i' r' take_add take_prefix terminals_drop terminals_take) from z8_helper join_terminals have z8: "leftderives [\] (terminals (take r' p) @ [A] @ a2 @ \ @ \)" by (metis append_assoc) have \'_altdef: "\' = terminals (drop r' p @ [X])" using L'' a1'_r' by auto have "ladder_last_j L''' + length a1' = length (drop r p)" using L'' L''' ladder_last_j_L' by linarith then have ladder_last_j_L'''_\': "ladder_last_j L''' = length \' - 1" by (simp add: \'_altdef length_a1'_eq_i' r') then have "length \' - 1 < length \1'" using L''' ladder_last_j_bound by fastforce then have "length \1' + length \2' - 1 < length \1'" using L''' by simp then have "length \2' = 0" by arith then have \2': "\2' = []" by simp then have \1': "\1' = terminals (drop r' p @ [X])" using \'_altdef L''' by auto then have z9: "LeftDerivationLadder w E' L''' (terminals (drop r' p @ [X]))" using L''' by blast have z10: "ladder_last_j L''' = length (drop r' p)" using \'_altdef ladder_last_j_L'''_\' by auto note z11 = k' have z12: "z = Item (A, w @ []) (length w) (charslength (take r' p)) k'" using z by simp note z13 = less.prems(12) note induct = less.hyps(1)[of L''' A w "[]" r' "a2@\@\" E' z] note z_in_I = induct[OF z1 z2 z3 z4 z5 z6 z7 z8 z9 z10 z11 z12 z13] have a2_derives_empty: "derives a2 []" using L''' \2' using LeftDerivation_implies_leftderives leftderives_implies_derives by blast obtain x1 where x1: "x1 = Item (N, \@\) (length a1) (charslength (take r p)) (charslength (take r' p))" by blast obtain q where q: "q = take r' p" by blast then have is_prefix_q_p: "is_prefix q p" by simp then have q_in_Prefixes: "q \ Prefixes p" using Prefixes_is_prefix by blast then have wellformed_q: "wellformed_tokens q" using p_dom is_prefix_q_p prefixes_are_paths' \_wellformed by blast have item_rule_x1: "item_rule x1 = (N, \@\)" using x1 by simp have is_prefix_r_r': "is_prefix (take r p) (take r' p)" by (metis append_eq_conv_conj is_prefix_take r' take_add) then have charslength_le_r_r': "charslength (take r p) \ charslength (take r' p)" using charslength_of_prefix by blast have "is_prefix (take r' p) p" by auto then have charslength_r'_p: "charslength (take r' p) \ charslength p" using charslength_of_prefix by blast have "charslength p \ length Doc" using less.prems(1) add_leE k' k'_upperbound z3 by blast with charslength_r'_p have charslength_r'_Doc: "charslength (take r' p) \ length Doc" by arith have \_decompose: "\ = a1 @ [A] @ a2" using A splits_at_combine by blast have wellformed_x1: "wellformed_item x1" apply (auto simp add: wellformed_item_def) using item_rule_x1 less.prems apply auto[1] using charslength_le_r_r' x1 apply auto[1] using charslength_r'_Doc x1 apply auto[1] using x1 \_decompose by simp have item_nonterminal_x1: "item_nonterminal x1 = N" by (simp add: x1 item_nonterminal_def) have r_q_p: "take r (terminals q) = terminals (take r p)" by (metis q is_prefix_r_r' length_take min.absorb2 r take_prefix terminals_take) have item_\_x1: "item_\ x1 = a1" by (simp add: \_decompose item_\_def x1) have a1': "a1' = drop r (terminals q)" by (metis append_eq_conv_conj join_terminals length_take length_terminals min.absorb2 q r) have pvalid_q_x1: "pvalid q x1" apply (simp add: pvalid_def wellformed_q wellformed_x1 item_nonterminal_x1) apply (rule_tac x=r in exI) apply auto apply (simp add: a1'_r' min.absorb2 q) apply (simp add: q x1) apply (simp add: q x1 r') using r_q_p less.prems(7) append_Cons is_leftderivation_def leftderivation_implies_derivation apply fastforce apply (simp add: item_\_x1) using a1' A LeftDerivation_implies_leftderives leftderives_implies_derives by blast have item_end_x1_le_k': "item_end x1 \ k'" using charslength_r'_p apply (simp add: x1) using less.prems by auto have x1_in_I: "x1 \ I" apply (subst less.prems(12)) apply (auto simp add: items_le_def item_end_x1_le_k') apply (rule \_apply_setmonotone) apply (rule Scan_apply_setmonotone) apply (simp add: Gen_def) apply (rule_tac x=q in exI) by (simp add: pvalid_q_x1 paths_le_def q_in_Prefixes) obtain x2 where x2: "x2 = inc_item x1 k'" by blast have x1_in_bin: "x1 \ bin I (item_origin z)" using bin_def x1 x1_in_I z12 by auto have x2_in_Complete: "x2 \ Complete k' I" apply (simp add: Complete_def) apply (rule disjI2) apply (rule_tac x=x1 in exI) apply (simp add: x2) apply (rule_tac x=z in exI) apply auto using x1_in_bin apply blast using bin_def z12 z_in_I apply auto[1] apply (simp add: is_complete_def z12) by (simp add: \_decompose is_complete_def item_nonterminal_def next_symbol_def x1 z12) have wf_I': "wellformed_items (\ k' {} (Scan T k (Gen (Prefixes p))))" by (simp add: wellformed_items_Gen wellformed_items_Scan wellformed_items_\ z5) from items_le_Complete[OF this] x2_in_Complete have x2_in_I: "x2 \ I" by (metis Complete_\_fix z13) have "wellformed_items I" using wf_I' items_le_is_filter wellformed_items_def z13 by auto with x2_in_I have wellformed_x2: "wellformed_item x2" by (simp add: wellformed_items_def) have item_dot_x2: "item_dot x2 = Suc (length a1)" by (simp add: x2 x1) have item_\_x2: "item_\ x2 = a2 @ \" apply (simp add: item_\_def item_dot_x2) apply (simp add: item_rhs_def x2 x1 \_decompose) done have item_end_x2: "item_end x2 = k'" by (simp add: x2) note inc_dot_x2_by_a2 = thmD6[OF wellformed_x2 item_\_x2 item_end_x2 a2_derives_empty] have "x = inc_dot (length a2) x2" by (simp add: \_decompose inc_dot_def less.prems(11) x1 x2) with inc_dot_x2_by_a2 have "x \ \ k' {} {x2}" by auto then have "x \ \ k' {} I" using x2_in_I by (meson contra_subsetD empty_subsetI insert_subset monoD mono_\) then show "x \ I" by (metis (no_types, lifting) \_subset_elem_trans dual_order.refl item_end_x_def items_le_def items_le_is_filter mem_Collect_eq z13) qed qed theorem thmD10: assumes p_dom: "p \ \" assumes p_charslength: "charslength p = k" assumes X_dom: "X \ T" assumes T_dom: "T \ \ k" assumes rule_dom: "(N, \@\) \ \" assumes r: "r \ length p" assumes leftderives_start: "leftderives [\] ((terminals (take r p))@[N]@\)" assumes leftderives_\: "leftderives \ (terminals ((drop r p)@[X]))" assumes k': "k' = k + length (chars_of_token X)" assumes item_def: "x = Item (N, \@\) (length \) (charslength (take r p)) k'" assumes I: "I = items_le k' (\ k' {} (Scan T k (Gen (Prefixes p))))" shows "x \ I" proof - have "\ D. LeftDerivation \ D (terminals ((drop r p)@[X]))" using leftderives_\ leftderives_implies_LeftDerivation by blast then obtain D where D: "LeftDerivation \ D (terminals ((drop r p)@[X]))" by blast have is_sentence: "is_sentence (terminals (drop r p @ [X]))" using derives_is_sentence is_sentence_concat leftderives_\ leftderives_implies_derives rule_\_type rule_dom by blast have "\ L. LeftDerivationLadder \ D L (terminals ((drop r p)@[X])) \ ladder_last_j L = length (drop r p)" apply (rule LeftDerivationLadder_exists) apply (rule D) apply (rule is_sentence) by auto then obtain L where L: "LeftDerivationLadder \ D L (terminals ((drop r p)@[X]))" and L_ladder_last_j: "ladder_last_j L = length (drop r p)" by blast from thmD10_ladder[OF assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) assms(7) L L_ladder_last_j k' item_def I] show ?thesis . qed end end diff --git a/thys/Nat-Interval-Logic/IL_IntervalOperators.thy b/thys/Nat-Interval-Logic/IL_IntervalOperators.thy --- a/thys/Nat-Interval-Logic/IL_IntervalOperators.thy +++ b/thys/Nat-Interval-Logic/IL_IntervalOperators.thy @@ -1,3428 +1,3428 @@ (* Title: IL_IntOperator.thy Date: Jan 2007 Author: David Trachtenherz *) section \Arithmetic operators on natural intervals\ theory IL_IntervalOperators imports IL_Interval begin subsection \Arithmetic operations with intervals\ subsubsection \Addition of and multiplication by constants\ definition iT_Plus :: "iT \ Time \ iT" (infixl "\" 55) where "I \ k \ (\n.(n + k))  I" definition iT_Mult :: "iT \ Time \ iT" (infixl "\" 55) where iT_Mult_def : "I \ k \ (\n.(n * k))  I" (*<*) (* Some examples *) (* lemma "[\10]\5 = {5..15}" apply (simp only: iIN_0_iTILL_conv[symmetric]) apply (simp add: iT_defs) apply (simp add: iT_Plus_def) apply (simp add: image_add_atLeastAtMost) done lemma "[1\,2] = {1,2,3}" apply (simp add: iIN_def) apply fastforce done lemma "[1\,2]\2 = {2,4,6}" apply (simp add: iT_Mult_def iIN_def) apply auto done lemma "[10\]\k = {x*k | x. 10 \ x}" apply (simp add: iFROM_def iT_Mult_def) by blast lemma "[\4] \ 10 = {0, 10, 20, 30, 40}" apply (simp add: iT_Mult_def iTILL_def) by auto lemma "[\4] \ 10 \ 2 = {2, 12, 22, 32, 42}" apply (simp add: iT_Plus_def iT_Mult_def iTILL_def) by auto *) (*>*) lemma iT_Plus_image_conv: "I \ k = (\n.(n + k))  I" by (simp add: iT_Plus_def) lemma iT_Mult_image_conv: "I \ k = (\n.(n * k))  I" by (simp add: iT_Mult_def) lemma iT_Plus_empty: "{} \ k = {}" by (simp add: iT_Plus_def) lemma iT_Mult_empty: "{} \ k = {}" by (simp add: iT_Mult_def) lemma iT_Plus_not_empty: "I \ {} \ I \ k \ {}" by (simp add: iT_Plus_def) lemma iT_Mult_not_empty: "I \ {} \ I \ k \ {}" by (simp add: iT_Mult_def) lemma iT_Plus_empty_iff: "(I \ k = {}) = (I = {})" by (simp add: iT_Plus_def) lemma iT_Mult_empty_iff: "(I \ k = {}) = (I = {})" by (simp add: iT_Mult_def) lemma iT_Plus_mono: "A \ B \ A \ k \ B \ k" by (simp add: iT_Plus_def image_mono) lemma iT_Mult_mono: "A \ B \ A \ k \ B \ k" by (simp add: iT_Mult_def image_mono) lemma iT_Mult_0: "I \ {} \ I \ 0 = [\0]" by (fastforce simp add: iTILL_def iT_Mult_def) corollary iT_Mult_0_if: "I \ 0 = (if I = {} then {} else [\0])" by (simp add: iT_Mult_empty iT_Mult_0) lemma iT_Plus_mem_iff: "x \ (I \ k) = (k \ x \ (x - k) \ I)" apply (simp add: iT_Plus_def image_iff) apply (rule iffI) apply fastforce apply (rule_tac x="x - k" in bexI, simp+) done lemma iT_Plus_mem_iff2: "x + k \ (I \ k) = (x \ I)" by (simp add: iT_Plus_def image_iff) lemma iT_Mult_mem_iff_0: "x \ (I \ 0) = (I \ {} \ x = 0)" apply (case_tac "I = {}") apply (simp add: iT_Mult_empty) apply (simp add: iT_Mult_0 iT_iff) done -lemma iT_Mult_mem_iff: " +lemma iT_Mult_mem_iff: " 0 < k \ x \ (I \ k) = (x mod k = 0 \ x div k \ I)" by (fastforce simp: iT_Mult_def image_iff) lemma iT_Mult_mem_iff2: "0 < k \ x * k \ (I \ k) = (x \ I)" by (simp add: iT_Mult_def image_iff) lemma iT_Plus_singleton: "{a} \ k = {a + k}" by (simp add: iT_Plus_def) lemma iT_Mult_singleton: "{a} \ k = {a * k}" by (simp add: iT_Mult_def) lemma iT_Plus_Un: "(A \ B) \ k = (A \ k) \ (B \ k)" by (simp add: iT_Plus_def image_Un) lemma iT_Mult_Un: "(A \ B) \ k = (A \ k) \ (B \ k)" by (simp add: iT_Mult_def image_Un) lemma iT_Plus_Int: "(A \ B) \ k = (A \ k) \ (B \ k)" by (simp add: iT_Plus_def image_Int) lemma iT_Mult_Int: "0 < k \ (A \ B) \ k = (A \ k) \ (B \ k)" by (simp add: iT_Mult_def image_Int mult_right_inj) lemma iT_Plus_image: "f  I \ n = (\x. f x + n)  I" by (fastforce simp: iT_Plus_def) lemma iT_Mult_image: "f  I \ n = (\x. f x * n)  I" by (fastforce simp: iT_Mult_def) lemma iT_Plus_commute: "I \ a \ b = I \ b \ a" by (fastforce simp: iT_Plus_def) lemma iT_Mult_commute: "I \ a \ b = I \ b \ a" by (fastforce simp: iT_Mult_def) lemma iT_Plus_assoc:"I \ a \ b = I \ (a + b)" by (fastforce simp: iT_Plus_def) lemma iT_Mult_assoc:"I \ a \ b = I \ (a * b)" by (fastforce simp: iT_Mult_def) lemma iT_Plus_Mult_distrib: "I \ n \ m = I \ m \ n * m" by (simp add: iT_Plus_def iT_Mult_def image_image add_mult_distrib) (*<*) -lemma "i \ n1 \ n2 \ n3 \ n4 \ n5 \ n6 \ n7 = +lemma "i \ n1 \ n2 \ n3 \ n4 \ n5 \ n6 \ n7 = i \ n1 * n2 * n3 * n4 * n5 * n6 * n7" by (simp add: iT_Mult_assoc) lemma "i \ n1 \ n2 \ n3 \ n4 \ n5 = i \ n1 + n2 + n3 + n4 + n5" by (simp add: iT_Plus_assoc) lemma "i \ n1 \ m \ n2 = i \ m \ n1 * m + n2" by (simp add: iT_Plus_assoc iT_Plus_Mult_distrib) lemma "i \ n1 \ m1 \ m2 \ n2 = i \ m1 * m2 \ n1 * m1 * m2 + n2" by (simp add: iT_Plus_assoc iT_Mult_assoc iT_Plus_Mult_distrib) lemma "n \ I \ k \ k \ n" by (clarsimp simp add: iT_Plus_def) (*>*) lemma iT_Plus_finite_iff: "finite (I \ k) = finite I" by (simp add: iT_Plus_def inj_on_finite_image_iff) lemma iT_Mult_0_finite: "finite (I \ 0)" by (simp add: iT_Mult_0_if iTILL_0) lemma iT_Mult_finite_iff: "0 < k \ finite (I \ k) = finite I" by (simp add: iT_Mult_def inj_on_finite_image_iff[OF inj_imp_inj_on] mult_right_inj) lemma iT_Plus_Min: "I \ {} \ iMin (I \ k) = iMin I + k" by (simp add: iT_Plus_def iMin_mono2 mono_def) lemma iT_Mult_Min: "I \ {} \ iMin (I \ k) = iMin I * k" by (simp add: iT_Mult_def iMin_mono2 mono_def) lemma iT_Plus_Max: "\ finite I; I \ {} \ \ Max (I \ k) = Max I + k" by (simp add: iT_Plus_def Max_mono2 mono_def) lemma iT_Mult_Max: "\ finite I; I \ {} \ \ Max (I \ k) = Max I * k" by (simp add: iT_Mult_def Max_mono2 mono_def) -corollary +corollary iMOD_mult_0: "[r, mod m] \ 0 = [\0]" and iMODb_mult_0: "[r, mod m, c] \ 0 = [\0]" and iFROM_mult_0: "[n\] \ 0 = [\0]" and iIN_mult_0: "[n\,d] \ 0 = [\0]" and iTILL_mult_0: "[\n] \ 0 = [\0]" by (simp add: iT_not_empty iT_Mult_0)+ lemmas iT_mult_0 = iTILL_mult_0 iFROM_mult_0 iIN_mult_0 iMOD_mult_0 iMODb_mult_0 lemma iT_Plus_0: "I \ 0 = I" by (simp add: iT_Plus_def) lemma iT_Mult_1: "I \ Suc 0 = I" by (simp add: iT_Mult_def) -corollary +corollary iFROM_add_Min: "iMin ([n\] \ k) = n + k" and iIN_add_Min: "iMin ([n\,d] \ k) = n + k" and iTILL_add_Min: "iMin ([\n] \ k) = k" and iMOD_add_Min: "iMin ([r, mod m] \ k) = r + k" and iMODb_add_Min: "iMin ([r, mod m, c] \ k) = r + k" by (simp add: iT_not_empty iT_Plus_Min iT_Min)+ -corollary +corollary iFROM_mult_Min: "iMin ([n\] \ k) = n * k" and iIN_mult_Min: "iMin ([n\,d] \ k) = n * k" and iTILL_mult_Min: "iMin ([\n] \ k) = 0" and iMOD_mult_Min: "iMin ([r, mod m] \ k) = r * k" and iMODb_mult_Min: "iMin ([r, mod m, c] \ k) = r * k" by (simp add: iT_not_empty iT_Mult_Min iT_Min)+ -lemmas iT_add_Min = +lemmas iT_add_Min = iIN_add_Min iTILL_add_Min iFROM_add_Min iMOD_add_Min iMODb_add_Min -lemmas iT_mult_Min = +lemmas iT_mult_Min = iIN_mult_Min iTILL_mult_Min iFROM_mult_Min iMOD_mult_Min iMODb_mult_Min lemma iFROM_add: "[n\] \ k = [n+k\]" by (simp add: iFROM_def iT_Plus_def image_add_atLeast) lemma iIN_add: "[n\,d] \ k = [n+k\,d]" by (fastforce simp add: iIN_def iT_Plus_def) lemma iTILL_add: "[\i] \ k = [k\,i]" by (simp add: iIN_0_iTILL_conv[symmetric] iIN_add) lemma iMOD_add: "[r, mod m] \ k = [r + k, mod m]" apply (clarsimp simp: set_eq_iff iMOD_def iT_Plus_def image_iff) apply (rule iffI) apply (clarsimp simp: mod_add) apply (rule_tac x="x - k" in exI) apply clarsimp apply (simp add: mod_sub_add) done lemma iMODb_add: "[r, mod m, c] \ k = [r + k, mod m, c]" by (simp add: iMODb_iMOD_iIN_conv iT_Plus_Int iMOD_add iIN_add) lemmas iT_add = - iMOD_add + iMOD_add iMODb_add iFROM_add iIN_add iTILL_add iT_Plus_singleton lemma iFROM_mult: "[n\] \ k = [ n * k, mod k ]" apply (case_tac "k = 0") apply (simp add: iMOD_0 iT_mult_0 iIN_0 iTILL_0) apply (clarsimp simp: set_eq_iff iT_Mult_mem_iff iT_iff) apply (rule conj_cong, simp) apply (rule iffI) apply (drule mult_le_mono1[of _ _ k]) apply (rule order_trans, assumption) apply (simp add: div_mult_cancel) apply (drule div_le_mono[of _ _ k]) apply simp done lemma iIN_mult: "[n\,d] \ k = [ n * k, mod k, d ]" apply (case_tac "k = 0") apply (simp add: iMODb_mod_0 iT_mult_0 iIN_0 iTILL_0) apply (clarsimp simp: set_eq_iff iT_Mult_mem_iff iT_iff) apply (rule conj_cong, simp) apply (rule iffI) apply (elim conjE) apply (drule mult_le_mono1[of _ _ k], drule mult_le_mono1[of _ _ k]) apply (rule conjI) apply (rule order_trans, assumption) apply (simp add: div_mult_cancel) apply (simp add: div_mult_cancel add_mult_distrib mult.commute[of k]) apply (erule conjE) apply (drule div_le_mono[of _ _ k], drule div_le_mono[of _ _ k]) apply simp done lemma iTILL_mult: "[\n] \ k = [ 0, mod k, n ]" by (simp add: iIN_0_iTILL_conv[symmetric] iIN_mult) lemma iMOD_mult: "[r, mod m ] \ k = [ r * k, mod m * k ]" apply (case_tac "k = 0") apply (simp add: iMOD_0 iT_mult_0 iIN_0 iTILL_0) apply (clarsimp simp: set_eq_iff iT_Mult_mem_iff iT_iff) apply (subst mult.commute[of m k]) apply (simp add: mod_mult2_eq) apply (rule iffI) apply (elim conjE) apply (drule mult_le_mono1[of _ _ k]) apply (simp add: div_mult_cancel) apply (elim conjE) apply (subgoal_tac "x mod k = 0") prefer 2 apply (drule_tac arg_cong[where f="\x. x mod k"]) apply (simp add: mult.commute[of k]) apply (drule div_le_mono[of _ _ k]) apply simp done lemma iMODb_mult: " [r, mod m, c ] \ k = [ r * k, mod m * k, c ]" apply (case_tac "k = 0") apply (simp add: iMODb_mod_0 iT_mult_0 iIN_0 iTILL_0) apply (subst iMODb_iMOD_iTILL_conv) apply (simp add: iT_Mult_Int iMOD_mult iTILL_mult iMODb_iMOD_iTILL_conv) apply (subst Int_assoc[symmetric]) apply (subst Int_absorb2) apply (simp add: iMOD_subset) apply (simp add: iMOD_iTILL_iMODb_conv add_mult_distrib2) done lemmas iT_mult = iTILL_mult iFROM_mult iIN_mult iMOD_mult iMODb_mult iT_Mult_singleton subsubsection \Some conversions between intervals using constant addition and multiplication\ lemma iFROM_conv: "[n\] = UNIV \ n" by (simp add: iFROM_0[symmetric] iFROM_add) lemma iIN_conv: "[n\,d] = [\d] \ n" by (simp add: iTILL_add) lemma iMOD_conv: "[r, mod m] = [0\] \ m \ r" apply (case_tac "m = 0") apply (simp add: iMOD_0 iT_mult_0 iTILL_add) apply (simp add: iFROM_mult iMOD_add) done -lemma iMODb_conv: "[r, mod m, c] = [\c] \ m \ r" +lemma iMODb_conv: "[r, mod m, c] = [\c] \ m \ r" apply (case_tac "m = 0") apply (simp add: iMODb_mod_0 iT_mult_0 iTILL_add) apply (simp add: iTILL_mult iMODb_add) done text \Some examples showing the utility of iMODb\_conv\ lemma "[12, mod 10, 4] = {12, 22, 32, 42, 52}" apply (simp add: iT_defs) apply safe defer 1 apply simp+ txt \The direct proof without iMODb\_conv fails\ oops lemma "[12, mod 10, 4] = {12, 22, 32, 42, 52}" apply (simp only: iMODb_conv) apply (simp add: iT_defs iT_Mult_def iT_Plus_def) apply safe apply simp+ done lemma "[12, mod 10, 4] = {12, 22, 32, 42, 52}" apply (simp only: iMODb_conv) apply (simp add: iT_defs iT_Mult_def iT_Plus_def) apply (simp add: atMost_def) apply safe apply simp+ done lemma "[r, mod m, 4] = {r, r+m, r+2*m, r+3*m, r+4*m}" apply (simp only: iMODb_conv) apply (simp add: iT_defs iT_Mult_def iT_Plus_def atMost_def) apply (simp add: image_Collect) apply safe apply fastforce+ done lemma "[2, mod 10, 4] = {2, 12, 22, 32, 42}" apply (simp only: iMODb_conv) apply (simp add: iT_defs iT_Plus_def iT_Mult_def) apply fastforce done subsubsection \Subtraction of constants\ definition iT_Plus_neg :: "iT \ Time \ iT" (infixl "\-" 55) where "I \- k \ {x. x + k \ I}" lemma iT_Plus_neg_mem_iff: "(x \ I \- k) = (x + k \ I)" by (simp add: iT_Plus_neg_def) lemma iT_Plus_neg_mem_iff2: "k \ x \ (x - k \ I \- k) = (x \ I)" by (simp add: iT_Plus_neg_def) lemma iT_Plus_neg_image_conv: "I \- k = (\n.(n - k))  (I \\ k)" apply (simp add: iT_Plus_neg_def cut_ge_def, safe) apply (rule_tac x="x+k" in image_eqI) apply simp+ done lemma iT_Plus_neg_cut_eq: "t \ k \ (I \\ t) \- k = I \- k" by (simp add: set_eq_iff iT_Plus_neg_mem_iff cut_ge_mem_iff) lemma iT_Plus_neg_mono: "A \ B \ A \- k \ B \- k" by (simp add: iT_Plus_neg_def subset_iff) lemma iT_Plus_neg_empty: "{} \- k = {}" by (simp add: iT_Plus_neg_def) lemma iT_Plus_neg_Max_less_empty: " \ finite I; Max I < k \ \ I \- k = {}" by (simp add: iT_Plus_neg_image_conv cut_ge_Max_empty) lemma iT_Plus_neg_not_empty_iff: "(I \- k \ {}) = (\x\I. k \ x)" by (simp add: iT_Plus_neg_image_conv cut_ge_not_empty_iff) lemma iT_Plus_neg_empty_iff: " (I \- k = {}) = (I = {} \ (finite I \ Max I < k))" apply (case_tac "I = {}") apply (simp add: iT_Plus_neg_empty) apply (simp add: iT_Plus_neg_image_conv) apply (case_tac "infinite I") apply (simp add: nat_cut_ge_infinite_not_empty) apply (simp add: cut_ge_empty_iff) done lemma iT_Plus_neg_assoc: "(I \- a) \- b = I \- (a + b)" apply (simp add: iT_Plus_neg_def) apply (simp add: add.assoc add.commute[of b]) done lemma iT_Plus_neg_commute: "I \- a \- b = I \- b \- a" by (simp add: iT_Plus_neg_assoc add.commute[of b]) lemma iT_Plus_neg_0: "I \- 0 = I" by (simp add: iT_Plus_neg_image_conv cut_ge_0_all) lemma iT_Plus_Plus_neg_assoc: "b \ a \ I \ a \- b = I \ (a - b)" apply (simp add: iT_Plus_neg_image_conv) apply (clarsimp simp add: set_eq_iff image_iff Bex_def cut_ge_mem_iff iT_Plus_mem_iff) apply (rule iffI) apply fastforce apply (rule_tac x="x + b" in exI) apply (simp add: le_diff_conv) done lemma iT_Plus_Plus_neg_assoc2: "a \ b \ I \ a \- b = I \- (b - a)" apply (simp add: iT_Plus_neg_image_conv) apply (clarsimp simp add: set_eq_iff image_iff Bex_def cut_ge_mem_iff iT_Plus_mem_iff) apply (rule iffI) apply fastforce apply (clarify, rename_tac x') apply (rule_tac x="x' + a" in exI) apply simp done lemma iT_Plus_neg_Plus_le_cut_eq: " a \ b \ (I \- a) \ b = (I \\ a) \ (b - a)" apply (simp add: iT_Plus_neg_image_conv) apply (clarsimp simp add: set_eq_iff image_iff Bex_def cut_ge_mem_iff iT_Plus_mem_iff) apply (rule iffI) apply (clarify, rename_tac x') apply (subgoal_tac "x' = x + a - b") prefer 2 apply simp apply (simp add: le_imp_diff_le le_add_diff) -apply fastforce +apply fastforce done corollary iT_Plus_neg_Plus_le_Min_eq: " \ a \ b; a \ iMin I \ \ (I \- a) \ b = I \ (b - a)" by (simp add: iT_Plus_neg_Plus_le_cut_eq cut_ge_Min_all) lemma iT_Plus_neg_Plus_ge_cut_eq: " b \ a \ (I \- a) \ b = (I \\ a) \- (a - b)" apply (simp add: iT_Plus_neg_image_conv iT_Plus_def cut_cut_ge max_eqL) apply (subst image_comp) apply (rule image_cong, simp) apply (simp add: cut_ge_mem_iff) done corollary iT_Plus_neg_Plus_ge_Min_eq: " \ b \ a; a \ iMin I \ \ (I \- a) \ b = I \- (a - b)" by (simp add: iT_Plus_neg_Plus_ge_cut_eq cut_ge_Min_all) lemma iT_Plus_neg_Mult_distrib: " 0 < m \ I \- n \ m = I \ m \- n * m" apply (clarsimp simp: set_eq_iff iT_Plus_neg_image_conv image_iff iT_Plus_def iT_Mult_def Bex_def cut_ge_mem_iff) apply (rule iffI) apply (clarsimp, rename_tac x') apply (rule_tac x="x' * m" in exI) apply (simp add: diff_mult_distrib) apply (clarsimp, rename_tac x') apply (rule_tac x="x' - n" in exI) apply (simp add: diff_mult_distrib) apply fastforce done lemma iT_Plus_neg_Plus_le_inverse: "k \ iMin I \ I \- k \ k = I" by (simp add: iT_Plus_neg_Plus_le_Min_eq iT_Plus_0) lemma iT_Plus_neg_Plus_inverse: "I \- k \ k = I \\ k" by (simp add: iT_Plus_neg_Plus_ge_cut_eq iT_Plus_neg_0) lemma iT_Plus_Plus_neg_inverse: "I \ k \- k = I" by (simp add: iT_Plus_Plus_neg_assoc iT_Plus_0) lemma iT_Plus_neg_Un: "(A \ B) \- k = (A \- k) \ (B \- k)" by (fastforce simp: iT_Plus_neg_def) lemma iT_Plus_neg_Int: "(A \ B) \- k = (A \- k) \ (B \- k)" by (fastforce simp: iT_Plus_neg_def) lemma iT_Plus_neg_Max_singleton: "\ finite I; I \ {} \ \ I \- Max I= {0}" apply (rule set_eqI) apply (simp add: iT_Plus_neg_def) apply (case_tac "x = 0") apply simp apply fastforce done lemma iT_Plus_neg_singleton: "{a} \- k = (if k \ a then {a - k} else {})" by (force simp add: set_eq_iff iT_Plus_neg_mem_iff singleton_iff) corollary iT_Plus_neg_singleton1: "k \ a \ {a} \- k = {a-k}" by (simp add: iT_Plus_neg_singleton) corollary iT_Plus_neg_singleton2: "a < k \ {a} \- k= {}" by (simp add: iT_Plus_neg_singleton) lemma iT_Plus_neg_finite_iff: "finite (I \- k) = finite I" apply (simp add: iT_Plus_neg_image_conv) apply (subst inj_on_finite_image_iff) apply (metis cut_geE inj_on_diff_nat) apply (simp add: nat_cut_ge_finite_iff) done lemma iT_Plus_neg_Min: " I \- k \ {} \ iMin (I \- k) = iMin (I \\ k) - k" apply (simp add: iT_Plus_neg_image_conv) apply (simp add: iMin_mono2 monoI) done lemma iT_Plus_neg_Max: " \ finite I; I \- k \ {} \ \ Max (I \- k) = Max I - k" apply (simp add: iT_Plus_neg_image_conv) apply (simp add: Max_mono2 monoI cut_ge_finite cut_ge_Max_eq) done text \Subtractions of constants from intervals\ lemma iFROM_add_neg: "[n\] \- k = [n - k\]" by (fastforce simp: set_eq_iff iT_Plus_neg_mem_iff) lemma iTILL_add_neg: "[\n] \- k = (if k \ n then [\n - k] else {})" by (force simp add: set_eq_iff iT_Plus_neg_mem_iff iT_iff) lemma iTILL_add_neg1: "k \ n \ [\n] \- k = [\n-k]" by (simp add: iTILL_add_neg) lemma iTILL_add_neg2: "n < k \ [\n] \- k = {}" by (simp add: iTILL_add_neg) lemma iIN_add_neg: " [n\,d] \- k = ( - if k \ n then [n - k\,d] + if k \ n then [n - k\,d] else if k \ n + d then [\n + d - k] else {})" by (simp add: iIN_iFROM_iTILL_conv iT_Plus_neg_Int iFROM_add_neg iTILL_add_neg iFROM_0) lemma iIN_add_neg1: "k \ n \ [n\,d] \- k = [n - k\,d]" by (simp add: iIN_add_neg) lemma iIN_add_neg2: "\ n \ k; k \ n + d \ \ [n\,d] \- k = [\n + d - k]" by (simp add: iIN_add_neg iIN_0_iTILL_conv) lemma iIN_add_neg3: "n + d < k \ [n\,d] \- k = {}" by (simp add: iT_Plus_neg_Max_less_empty iT_finite iT_Max) lemma iMOD_0_add_neg: "[r, mod 0] \- k = {r} \- k" by (simp add: iMOD_0 iIN_0) (* lemma "[25, mod 10] \- 32 = [3, mod 10]" apply (rule set_eqI) apply (simp add: iT_Plus_neg_mem_iff iMOD_iff) apply (simp add: mod_add_eq[of _ 32] mod_Suc) apply clarify apply (rule iffI) apply simp+ done *) lemma iMOD_gr0_add_neg: " - 0 < m \ + 0 < m \ [r, mod m] \- k = ( - if k \ r then [r - k, mod m] + if k \ r then [r - k, mod m] else [(m + r mod m - k mod m) mod m, mod m])" apply (rule set_eqI) apply (simp add: iMOD_def iT_Plus_neg_def) apply (simp add: eq_sym_conv[of _ "r mod m"]) apply (intro conjI impI) apply (simp add: eq_sym_conv[of _ "(r - k) mod m"] mod_sub_add le_diff_conv) apply (simp add: eq_commute[of "r mod m"] mod_add_eq_mod_conv) apply safe apply (drule sym) apply simp done lemma iMOD_add_neg: " [r, mod m] \- k = ( - if k \ r then [r - k, mod m] + if k \ r then [r - k, mod m] else if 0 < m then [(m + r mod m - k mod m) mod m, mod m] else {})" apply (case_tac "0 < m") apply (simp add: iMOD_gr0_add_neg) apply (simp add: iMOD_0 iIN_0 iT_Plus_neg_singleton) done corollary iMOD_add_neg1: " k \ r \ [r, mod m] \- k = [r - k, mod m]" by (simp add: iMOD_add_neg) lemma iMOD_add_neg2: " \ 0 < m; r < k \ \ [r, mod m] \- k = [(m + r mod m - k mod m) mod m, mod m]" by (simp add: iMOD_add_neg) lemma iMODb_mod_0_add_neg: "[r, mod 0, c] \- k = {r} \- k" by (simp add: iMODb_mod_0 iIN_0) (* lemma "[25, mod 10, 5] \- 32 = [3, mod 10, 4]" apply (rule set_eqI) apply (simp add: iMODb_conv iT_Plus_neg_mem_iff iT_Plus_mem_iff iT_Mult_mem_iff) apply (case_tac "x < 3", simp) apply (simp add: linorder_not_less) apply (rule_tac t="(x - 3) mod 10 = 0" and s="x mod 10 = 3" in subst) apply (simp add: mod_eq_diff_mod_0_conv[symmetric]) apply (rule_tac t="(7 + x) mod 10 = 0" and s="x mod 10 = 3" in subst) apply (simp add: mod_add1_eq_if[of 7]) apply (rule conj_cong[OF refl]) apply (simp add: div_add1_eq_if) apply (simp add: div_diff1_eq1) apply (simp add: iTILL_iff) done lemma "[25, mod 10, 5] \- 32 = [3, mod 10, 4]" apply (simp add: iT_Plus_neg_image_conv iMODb_cut_ge) apply (simp add: iMODb_conv iT_Mult_def iT_Plus_def) apply (rule_tac t=4 and s="Suc(Suc(Suc(Suc 0)))" in subst, simp) apply (simp add: iTILL_def atMost_Suc) done *) lemma iMODb_add_neg: " [r, mod m, c] \- k = ( - if k \ r then [r - k, mod m, c] - else - if k \ r + m * c then + if k \ r then [r - k, mod m, c] + else + if k \ r + m * c then [(m + r mod m - k mod m) mod m, mod m, (r + m * c - k) div m] else {})" apply (clarsimp simp add: iMODb_iMOD_iIN_conv iT_Plus_neg_Int iMOD_add_neg iIN_add_neg) apply (simp add: iMOD_iIN_iMODb_conv) apply (rule_tac t="(m + r mod m - k mod m) mod m" and s="(r + m * c - k) mod m" in subst) apply (simp add: mod_diff1_eq[of k]) apply (subst iMOD_iTILL_iMODb_conv, simp) apply (subst sub_mod_div_eq_div, simp) done lemma iMODb_add_neg': " [r, mod m, c] \- k = ( - if k \ r then [r - k, mod m, c] - else if k \ r + m * c then + if k \ r then [r - k, mod m, c] + else if k \ r + m * c then if k mod m \ r mod m then [ r mod m - k mod m, mod m, c + r div m - k div m] else [ m + r mod m - k mod m, mod m, c + r div m - Suc (k div m) ] else {})" apply (clarsimp simp add: iMODb_add_neg) apply (case_tac "m = 0", simp+) apply (case_tac "k mod m \ r mod m") apply (clarsimp simp: linorder_not_le) apply (simp add: divisor_add_diff_mod_if) apply (simp add: div_diff1_eq_if) apply (clarsimp simp: linorder_not_le) apply (simp add: div_diff1_eq_if) done corollary iMODb_add_neg1: " k \ r \ [r, mod m, c] \- k = [r - k, mod m, c]" by (simp add: iMODb_add_neg) corollary iMODb_add_neg2: " - \ r < k; k \ r + m * c \ \ - [r, mod m, c] \- k = + \ r < k; k \ r + m * c \ \ + [r, mod m, c] \- k = [(m + r mod m - k mod m) mod m, mod m, (r + m * c - k) div m]" by (simp add: iMODb_add_neg) corollary iMODb_add_neg2_mod_le: " - \ r < k; k \ r + m * c; k mod m \ r mod m \ \ - [r, mod m, c] \- k = + \ r < k; k \ r + m * c; k mod m \ r mod m \ \ + [r, mod m, c] \- k = [ r mod m - k mod m, mod m, c + r div m - k div m]" by (simp add: iMODb_add_neg') corollary iMODb_add_neg2_mod_less: " - \ r < k; k \ r + m * c; r mod m < k mod m\ \ - [r, mod m, c] \- k = + \ r < k; k \ r + m * c; r mod m < k mod m\ \ + [r, mod m, c] \- k = [ m + r mod m - k mod m, mod m, c + r div m - Suc (k div m) ]" by (simp add: iMODb_add_neg') lemma iMODb_add_neg3: "r + m * c < k \ [r, mod m, c] \- k = {}" by (simp add: iMODb_add_neg) lemmas iT_add_neg = - iFROM_add_neg + iFROM_add_neg iIN_add_neg iTILL_add_neg iMOD_add_neg iMODb_add_neg iT_Plus_neg_singleton subsubsection \Subtraction of intervals from constants\ definition iT_Minus :: "Time \ iT \ iT" (infixl "\" 55) where "k \ I \ {x. x \ k \ (k - x) \ I}" lemma iT_Minus_mem_iff: "(x \ k \ I) = (x \ k \ k - x \ I)" by (simp add: iT_Minus_def) lemma iT_Minus_mono: "A \ B \ k \ A \ k \ B" by (simp add: subset_iff iT_Minus_mem_iff) lemma iT_Minus_image_conv: "k \ I = (\x. k - x)  (I \\ k)" by (fastforce simp: iT_Minus_def cut_le_def image_iff) lemma iT_Minus_cut_eq: "k \ t \ k \ (I \\ t) = k \ I" by (fastforce simp: set_eq_iff iT_Minus_mem_iff) lemma iT_Minus_Minus_cut_eq: "k \ (k \ (I \\ k)) = I \\ k" by (fastforce simp: iT_Minus_def) lemma "10 \ [\3] = [7\,3]" by (fastforce simp: iT_Minus_def) lemma iT_Minus_empty: "k \ {} = {}" by (simp add: iT_Minus_def) lemma iT_Minus_0: "k \ {0} = {k}" by (simp add: iT_Minus_image_conv cut_le_def image_Collect) lemma iT_Minus_bound: "x \ k \ I \ x \ k" by (simp add: iT_Minus_def) lemma iT_Minus_finite: "finite (k \ I)" apply (rule finite_nat_iff_bounded_le2[THEN iffD2]) apply (rule_tac x=k in exI) apply (simp add: iT_Minus_bound) done lemma iT_Minus_less_Min_empty: "k < iMin I \ k \ I = {}" by (simp add: iT_Minus_image_conv cut_le_Min_empty) lemma iT_Minus_Min_singleton: "I \ {} \ (iMin I) \ I = {0}" apply (rule set_eqI) apply (simp add: iT_Minus_mem_iff) apply (fastforce intro: iMinI_ex2) done lemma iT_Minus_empty_iff: "(k \ I = {}) = (I = {} \ k < iMin I)" apply (case_tac "I = {}", simp add: iT_Minus_empty) apply (simp add: iT_Minus_image_conv cut_le_empty_iff iMin_gr_iff) done -(* -An example: - 100 \ {60, 70, 80, 90, 95} = {5, 10, 20, 30, 40} +(* +An example: + 100 \ {60, 70, 80, 90, 95} = {5, 10, 20, 30, 40} imirror {60, 70, 80, 90, 95} = {60, 65, 75, 95, 95} {60, 65, 75, 85, 95} \ 100 \- (60 + 95) - = {160, 165, 175, 185, 195} \- 155 + = {160, 165, 175, 185, 195} \- 155 = {5, 10, 20, 30, 40} I \ k \- (iMin I + Max I)) *) lemma iT_Minus_imirror_conv: " k \ I = imirror (I \\ k) \ k \- (iMin I + Max (I \\ k))" apply (case_tac "I = {}") apply (simp add: iT_Minus_empty cut_le_empty imirror_empty iT_Plus_empty iT_Plus_neg_empty) apply (case_tac "k < iMin I") apply (simp add: iT_Minus_less_Min_empty cut_le_Min_empty imirror_empty iT_Plus_empty iT_Plus_neg_empty) apply (simp add: linorder_not_less) apply (frule cut_le_Min_not_empty[of _ k], assumption) apply (rule set_eqI) apply (simp add: iT_Minus_image_conv iT_Plus_neg_image_conv iT_Plus_neg_mem_iff iT_Plus_mem_iff imirror_iff image_iff Bex_def i_cut_mem_iff cut_le_Min_eq) apply (rule iffI) apply (clarsimp, rename_tac x') apply (rule_tac x="k - x' + iMin I + Max (I \\ k)" in exI, simp) apply (simp add: add.assoc le_add_diff) apply (simp add: add.commute[of k] le_add_diff nat_cut_le_finite cut_leI trans_le_add2) apply (rule_tac x=x' in exI, simp) apply (clarsimp, rename_tac x1 x2) apply (rule_tac x=x2 in exI) apply simp -apply (drule add_right_cancel[THEN iffD2, of _ _ k], simp) +apply (drule nat_add_right_cancel[THEN iffD2, of _ _ k], simp) apply (simp add: trans_le_add2 nat_cut_le_finite cut_le_mem_iff) done lemma iT_Minus_imirror_conv': " k \ I = imirror (I \\ k) \ k \- (iMin (I \\ k) + Max (I \\ k))" apply (case_tac "I = {}") apply (simp add: iT_Minus_empty cut_le_empty imirror_empty iT_Plus_empty iT_Plus_neg_empty) apply (case_tac "k < iMin I") apply (simp add: iT_Minus_less_Min_empty cut_le_Min_empty imirror_empty iT_Plus_empty iT_Plus_neg_empty) apply (simp add: cut_le_Min_not_empty cut_le_Min_eq iT_Minus_imirror_conv) done lemma iT_Minus_Max: " \ I \ {}; iMin I \ k \ \ Max (k \ I) = k - (iMin I)" apply (rule Max_equality) apply (simp add: iT_Minus_mem_iff iMinI_ex2) apply (simp add: iT_Minus_finite) apply (fastforce simp: iT_Minus_def) done lemma iT_Minus_Min: " \ I \ {}; iMin I \ k \ \ iMin (k \ I) = k - (Max (I \\ k))" apply (insert nat_cut_le_finite[of I k]) apply (frule cut_le_Min_not_empty[of _ k], assumption) apply (rule iMin_equality) apply (simp add: iT_Minus_mem_iff nat_cut_le_Max_le del: Max_le_iff) apply (simp add: subsetD[OF cut_le_subset, OF Max_in]) apply (clarsimp simp add: iT_Minus_image_conv image_iff, rename_tac x') apply (rule diff_le_mono2) apply (simp add: Max_ge_iff cut_le_mem_iff) done lemma iT_Minus_Minus_eq: "\ finite I; Max I \ k \ \ k \ (k \ I) = I" apply (simp add: iT_Minus_cut_eq[of k k I, symmetric] iT_Minus_Minus_cut_eq) apply (simp add: cut_le_Max_all) done lemma iT_Minus_Minus_eq2: "I \ [\k] \ k \ (k \ I) = I" apply (case_tac "I = {}") apply (simp add: iT_Minus_empty) apply (rule iT_Minus_Minus_eq) apply (simp add: finite_subset iTILL_finite) apply (frule Max_subset) apply (simp add: iTILL_finite iTILL_Max)+ done (* An example: - 10 \ (100 \ {97,98,99,101,102}) = {7,8,9} - 1000 \ (100 \ {97,98,99,101,102, 998,1002}) = {997,998,999} + 10 \ (100 \ {97,98,99,101,102}) = {7,8,9} + 1000 \ (100 \ {97,98,99,101,102, 998,1002}) = {997,998,999} *) lemma iT_Minus_Minus: "a \ (b \ I) = (I \\ b) \ a \- b" apply (rule set_eqI) apply (simp add: iT_Minus_image_conv iT_Plus_image_conv iT_Plus_neg_image_conv image_iff Bex_def i_cut_mem_iff) apply fastforce done lemma iT_Minus_Plus_empty: "k < n \ k \ (I \ n) = {}" apply (case_tac "I = {}") apply (simp add: iT_Plus_empty iT_Minus_empty) apply (simp add: iT_Minus_empty_iff iT_Plus_empty_iff iT_Plus_Min) done lemma iT_Minus_Plus_commute: "n \ k \ k \ (I \ n) = (k - n) \ I" apply (rule set_eqI) apply (simp add: iT_Minus_image_conv iT_Plus_image_conv image_iff Bex_def i_cut_mem_iff) apply fastforce done lemma iT_Minus_Plus_cut_assoc: "(k \ I) \ n = (k + n) \ (I \\ k)" apply (rule set_eqI) apply (simp add: iT_Plus_mem_iff iT_Minus_mem_iff cut_le_mem_iff) apply fastforce done lemma iT_Minus_Plus_assoc: " \ finite I; Max I \ k \ \ (k \ I) \ n = (k + n) \ I" by (insert iT_Minus_Plus_cut_assoc[of k I n], simp add: cut_le_Max_all) lemma iT_Minus_Plus_assoc2: " I \ [\k] \ (k \ I) \ n = (k + n) \ I" apply (case_tac "I = {}") apply (simp add: iT_Minus_empty iT_Plus_empty) apply (rule iT_Minus_Plus_assoc) apply (simp add: finite_subset iTILL_finite) apply (frule Max_subset) apply (simp add: iTILL_finite iTILL_Max)+ done lemma iT_Minus_Un: "k \ (A \ B) = (k \ A) \ (k \ B)" by (fastforce simp: iT_Minus_def) lemma iT_Minus_Int: "k \ (A \ B) = (k \ A) \ (k \ B)" by (fastforce simp: set_eq_iff iT_Minus_mem_iff) lemma iT_Minus_singleton: "k \ {a} = (if a \ k then {k - a} else {})" by (simp add: iT_Minus_image_conv cut_le_singleton) corollary iT_Minus_singleton1: "a \ k \ k \ {a} = {k-a}" by (simp add: iT_Minus_singleton) corollary iT_Minus_singleton2: "k < a \ k \ {a} = {}" by (simp add: iT_Minus_singleton) lemma iMOD_sub: " - k \ [r, mod m] = + k \ [r, mod m] = (if r \ k then [(k - r) mod m, mod m, (k - r) div m] else {})" apply (rule set_eqI) apply (simp add: iT_Minus_mem_iff iT_iff) apply (fastforce simp add: mod_sub_eq_mod_swap[of r, symmetric]) done corollary iMOD_sub1: " r \ k \ k \ [r, mod m] = [(k - r) mod m, mod m, (k - r) div m]" by (simp add: iMOD_sub) corollary iMOD_sub2: "k < r \ k \ [r, mod m] = {}" apply (rule iT_Minus_less_Min_empty) apply (simp add: iMOD_Min) done lemma iTILL_sub: "k \ [\n] = (if n \ k then [k - n\,n] else [\k])" by (force simp add: set_eq_iff iT_Minus_mem_iff iT_iff) corollary iTILL_sub1: "n \ k \ k \ [\n] = [k - n\,n]" by (simp add: iTILL_sub) corollary iTILL_sub2: "k \ n \ k \ [\n] = [\k]" by (simp add: iTILL_sub iIN_0_iTILL_conv) (* An example: 30 \ [2, mod 10] = {8,18,28} *) lemma iMODb_sub: " k \ [r, mod m, c] = ( - if r + m * c \ k then [ k - r - m * c, mod m, c] else + if r + m * c \ k then [ k - r - m * c, mod m, c] else if r \ k then [ (k - r) mod m, mod m, (k - r) div m] else {})" apply (case_tac "m = 0") apply (simp add: iMODb_mod_0 iIN_0 iT_Minus_singleton) apply (subst iMODb_iMOD_iTILL_conv) -apply (subst iT_Minus_Int) +apply (subst iT_Minus_Int) apply (simp add: iMOD_sub iTILL_sub) apply (intro conjI impI) apply simp apply (subgoal_tac "(k - r) mod m \ k - (r + m * c)") prefer 2 apply (subgoal_tac "m * c \ k - r - (k - r) mod m") prefer 2 apply (drule add_le_imp_le_diff2) apply (drule div_le_mono[of _ _ m], simp) apply (drule mult_le_mono2[of _ _ m]) apply (simp add: minus_mod_eq_mult_div [symmetric]) apply (simp add: le_diff_conv2[OF mod_le_dividend] del: diff_diff_left) apply (subst iMODb_iMOD_iIN_conv) apply (simp add: Int_assoc minus_mod_eq_mult_div [symmetric]) apply (subst iIN_inter, simp+) apply (rule set_eqI) apply (fastforce simp add: iT_iff mod_diff_mult_self2 diff_diff_left[symmetric] simp del: diff_diff_left) apply (simp add: Int_absorb2 iMODb_iTILL_subset) done corollary iMODb_sub1: " - \ r \ k; k \ r + m * c \ \ + \ r \ k; k \ r + m * c \ \ k \ [r, mod m, c] = [(k - r) mod m, mod m, (k - r) div m]" by (clarsimp simp: iMODb_sub iMODb_mod_0) corollary iMODb_sub2: "k < r \ k \ [r, mod m, c] = {}" apply (rule iT_Minus_less_Min_empty) apply (simp add: iMODb_Min) done corollary iMODb_sub3: " r + m * c \ k \ k \ [r, mod m, c] = [ k - r - m * c, mod m, c]" by (simp add: iMODb_sub) lemma iFROM_sub: "k \ [n\] = (if n \ k then [\k - n] else {})" by (simp add: iMOD_1[symmetric] iMOD_sub iMODb_mod_1 iIN_0_iTILL_conv) corollary iFROM_sub1: "n \ k \ k \ [n\] = [\k-n]" by (simp add: iFROM_sub) corollary iFROM_sub_empty: "k < n \ k \ [n\] = {}" by (simp add: iFROM_sub) (* Examples: 10 \ [2\,3] = {3,4,5,6,7,8} - 10 \ [7\,5] = {0,1,2,3} + 10 \ [7\,5] = {0,1,2,3} *) lemma iIN_sub: " k \ [n\,d] = ( if n + d \ k then [k - (n + d)\,d] else if n \ k then [\k - n] else {})" apply (simp add: iMODb_mod_1[symmetric] iMODb_sub) apply (simp add: iMODb_mod_1 iIN_0_iTILL_conv) done lemma iIN_sub1: "n + d \ k \ k \ [n\,d] = [k - (n + d)\,d]" by (simp add: iIN_sub) lemma iIN_sub2: "\ n \ k; k \ n + d \ \ k \ [n\,d] = [\k - n]" by (clarsimp simp: iIN_sub iIN_0_iTILL_conv) lemma iIN_sub3: "k < n \ k \ [n\,d] = {}" by (simp add: iIN_sub) lemmas iT_sub = iFROM_sub iIN_sub iTILL_sub iMOD_sub iMODb_sub iT_Minus_singleton subsubsection \Division of intervals by constants\ text \Monotonicity and injectivity of artithmetic operators\ lemma iMOD_div_right_strict_mono_on: " \ 0 < k; k \ m \ \ strict_mono_on (\x. x div k) [r, mod m]" apply (rule div_right_strict_mono_on, assumption) apply (clarsimp simp: iT_iff) apply (drule_tac s="y mod m" in sym, simp) apply (rule_tac y="x + m" in order_trans, simp) apply (simp add: less_mod_eq_imp_add_divisor_le) done corollary iMOD_div_right_inj_on: " \ 0 < k; k \ m \ \ inj_on (\x. x div k) [r, mod m]" by (rule strict_mono_on_imp_inj_on[OF iMOD_div_right_strict_mono_on]) lemma iMOD_mult_div_right_inj_on: " inj_on (\x. x div (k::nat)) [r, mod (k * m)]" apply (case_tac "k * m = 0") apply (simp del: mult_is_0 mult_eq_0_iff add: iMOD_0 iIN_0) apply (simp add: iMOD_div_right_inj_on) done lemma iMOD_mult_div_right_inj_on2: " m mod k = 0 \ inj_on (\x. x div k) [r, mod m]" by (auto simp add: iMOD_mult_div_right_inj_on) lemma iMODb_div_right_strict_mono_on: " \ 0 < k; k \ m \ \ strict_mono_on (\x. x div k) [r, mod m, c]" by (rule strict_mono_on_subset[OF iMOD_div_right_strict_mono_on iMODb_iMOD_subset_same]) corollary iMODb_div_right_inj_on: " \ 0 < k; k \ m \ \ inj_on (\x. x div k) [r, mod m, c]" by (rule strict_mono_on_imp_inj_on[OF iMODb_div_right_strict_mono_on]) lemma iMODb_mult_div_right_inj_on: " inj_on (\x. x div (k::nat)) [r, mod (k * m), c]" by (rule subset_inj_on[OF iMOD_mult_div_right_inj_on iMODb_iMOD_subset_same]) corollary iMODb_mult_div_right_inj_on2: " m mod k = 0 \ inj_on (\x. x div k) [r, mod m, c]" by (auto simp add: iMODb_mult_div_right_inj_on) definition iT_Div :: "iT \ Time \ iT" (infixl "\" 55) where "I \ k \ (\n.(n div k))  I" lemma iT_Div_image_conv: "I \ k = (\n.(n div k))  I" by (simp add: iT_Div_def) lemma iT_Div_mono: "A \ B \ A \ k \ B \ k" by (simp add: iT_Div_def image_mono) lemma iT_Div_empty: "{} \ k = {}" by (simp add: iT_Div_def) lemma iT_Div_not_empty: "I \ {} \ I \ k \ {}" by (simp add: iT_Div_def) lemma iT_Div_empty_iff: "(I \ k = {}) = (I = {})" by (simp add: iT_Div_def) lemma iT_Div_0: "I \ {} \ I \ 0 = [\0]" by (force simp: iT_Div_def) corollary iT_Div_0_if: "I \ 0 = (if I = {} then {} else [\0])" by (force simp: iT_Div_def) -corollary +corollary iFROM_div_0: "[n\] \ 0 = [\0]" and iTILL_div_0: "[\n] \ 0 = [\0]" and iIN_div_0: "[n\,d] \ 0 = [\0]" and iMOD_div_0: "[r, mod m] \ 0 = [\0]" and iMODb_div_0: "[r, mod m, c] \ 0 = [\0]" by (simp add: iT_Div_0 iT_not_empty)+ lemmas iT_div_0 = - iTILL_div_0 + iTILL_div_0 iFROM_div_0 iIN_div_0 iMOD_div_0 iMODb_div_0 lemma iT_Div_1: "I \ Suc 0 = I" by (simp add: iT_Div_def) lemma iT_Div_mem_iff_0: "x \ (I \ 0) = (I \ {} \ x = 0)" by (force simp: iT_Div_0_if) lemma iT_Div_mem_iff: " 0 < k \ x \ (I \ k) = (\y \ I. y div k = x)" by (force simp: iT_Div_def) lemma iT_Div_mem_iff2: " 0 < k \ x div k \ (I \ k) = (\y \ I. y div k = x div k)" by (rule iT_Div_mem_iff) lemma iT_Div_mem_iff_Int: " 0 < k \ x \ (I \ k) = (I \ [x * k\,k - Suc 0] \ {})" apply (simp add: ex_in_conv[symmetric] iT_Div_mem_iff iT_iff) apply (simp add: le_less_div_conv[symmetric] add.commute[of k]) apply (subst less_eq_le_pred, simp) apply blast done lemma iT_Div_imp_mem: " 0 < k \ x \ I \ x div k \ (I \ k)" by (force simp: iT_Div_mem_iff2) lemma iT_Div_singleton: "{a} \ k = {a div k}" by (simp add: iT_Div_def) lemma iT_Div_Un: "(A \ B) \ k = (A \ k) \ (B \ k)" by (fastforce simp: iT_Div_def) lemma iT_Div_insert: "(insert n I) \ k = insert (n div k) (I \ k)" by (fastforce simp: iT_Div_def) (* Examples: {1,2,3,4} \ 3 \ {5,6,7} \ 3 = {0,1} \ {1,2} = {1} - ({1,2,3,4} \ {5,6,7}) \ 3 = {} \ 3 = {} + ({1,2,3,4} \ {5,6,7}) \ 3 = {} \ 3 = {} *) lemma not_iT_Div_Int: "\ (\ k A B. (A \ B) \ k = (A \ k) \ (B \ k))" apply simp apply ( rule_tac x=3 in exI, rule_tac x="{0}" in exI, rule_tac x="{1}" in exI) by (simp add: iT_Div_def) lemma subset_iT_Div_Int: "A \ B \ (A \ B) \ k = (A \ k) \ (B \ k)" by (simp add: iT_Div_def subset_image_Int) lemma iFROM_iT_Div_Int: " \ 0 < k; n \ iMin A \ \ (A \ [n\]) \ k = (A \ k) \ ([n\] \ k)" apply (rule subset_iT_Div_Int) apply (blast intro: order_trans iMin_le) done lemma iIN_iT_Div_Int: " - \ 0 < k; n \ iMin A; \x\A. x div k \ (n + d) div k \ x \ n + d \ \ + \ 0 < k; n \ iMin A; \x\A. x div k \ (n + d) div k \ x \ n + d \ \ (A \ [n\,d]) \ k = (A \ k) \ ([n\,d] \ k)" apply (rule set_eqI) apply (simp add: iT_Div_mem_iff Bex_def iIN_iff) apply (rule iffI) apply blast apply (clarsimp, rename_tac x1 x2) apply (frule iMin_le) apply (rule_tac x=x1 in exI, simp) apply (drule_tac x=x1 in bspec, simp) apply (drule div_le_mono[of _ "n + d" k]) apply simp done corollary iTILL_iT_Div_Int: " - \ 0 < k; \x\A. x div k \ n div k \ x \ n \ \ + \ 0 < k; \x\A. x div k \ n div k \ x \ n \ \ (A \ [\n]) \ k = (A \ k) \ ([\n] \ k)" by (simp add: iIN_0_iTILL_conv[symmetric] iIN_iT_Div_Int) lemma iIN_iT_Div_Int_mod_0: " - \ 0 < k; n mod k = 0; \x\A. x div k \ (n + d) div k \ x \ n + d \ \ + \ 0 < k; n mod k = 0; \x\A. x div k \ (n + d) div k \ x \ n + d \ \ (A \ [n\,d]) \ k = (A \ k) \ ([n\,d] \ k)" apply (rule set_eqI) apply (simp add: iT_Div_mem_iff Bex_def iIN_iff) apply (rule iffI) apply blast apply (elim conjE exE, rename_tac x1 x2) apply (rule_tac x=x1 in exI, simp) apply (rule conjI) apply (rule ccontr, simp add: linorder_not_le) apply (drule_tac m=n and n=x2 and k=k in div_le_mono) apply (drule_tac a=x1 and m=k in less_mod_0_imp_div_less) apply simp+ apply (drule_tac x=x1 in bspec, simp) apply (drule div_le_mono[of _ "n + d" k]) apply simp done lemma mod_partition_iT_Div_Int: " - \ 0 < k; 0 < d \ \ - (A \ [n * k\,d * k - Suc 0]) \ k = + \ 0 < k; 0 < d \ \ + (A \ [n * k\,d * k - Suc 0]) \ k = (A \ k) \ ([n * k\,d * k - Suc 0] \ k)" apply (rule iIN_iT_Div_Int_mod_0, simp+) apply (clarify, rename_tac x) apply (simp add: mod_0_imp_sub_1_div_conv) apply (rule ccontr, simp add: linorder_not_le pred_less_eq_le) apply (drule_tac n=x and k=k in div_le_mono) apply simp done (*<*) lemma "{0,1,2} \ x = {0*x, 1*x, 2*x}" by (simp add: iT_Mult_def) (*>*) corollary mod_partition_iT_Div_Int2: " - \ 0 < k; 0 < d; n mod k = 0; d mod k = 0 \ \ - (A \ [n\,d - Suc 0]) \ k = + \ 0 < k; 0 < d; n mod k = 0; d mod k = 0 \ \ + (A \ [n\,d - Suc 0]) \ k = (A \ k) \ ([n\,d - Suc 0] \ k)" by (auto simp add: ac_simps mod_partition_iT_Div_Int elim!: dvdE) corollary mod_partition_iT_Div_Int_one_segment: " - 0 < k \ + 0 < k \ (A \ [n * k\,k - Suc 0]) \ k = (A \ k) \ ([n * k\,k - Suc 0] \ k)" by (insert mod_partition_iT_Div_Int[where d=1], simp) corollary mod_partition_iT_Div_Int_one_segment2: " \ 0 < k; n mod k = 0 \ \ (A \ [n\,k - Suc 0]) \ k = (A \ k) \ ([n\,k - Suc 0] \ k)" using mod_partition_iT_Div_Int2[where k=k and d=k and n=n] by (insert mod_partition_iT_Div_Int2[where k=k and d=k and n=n], simp) lemma iT_Div_assoc:"I \ a \ b = I \ (a * b)" by (simp add: iT_Div_def image_image div_mult2_eq) lemma iT_Div_commute: "I \ a \ b = I \ b \ a" by (simp add: iT_Div_assoc mult.commute[of a]) lemma iT_Mult_Div_self: "0 < k \ I \ k \ k = I" by (simp add: iT_Mult_def iT_Div_def image_image) lemma iT_Mult_Div: " \ 0 < d; k mod d = 0 \ \ I \ k \ d = I \ (k div d)" by (auto simp add: ac_simps iT_Mult_assoc[symmetric] iT_Mult_Div_self) lemma iT_Div_Mult_self: " 0 < k \ I \ k \ k = {y. \x \ I. y = x - x mod k}" by (simp add: set_eq_iff iT_Mult_def iT_Div_def image_image image_iff div_mult_cancel) lemma iT_Plus_Div_distrib_mod_less: " \x\I. x mod m + n mod m < m \ I \ n \ m = I \ m \ n div m" by (simp add: set_eq_iff iT_Div_def iT_Plus_def image_image image_iff div_add1_eq1) corollary iT_Plus_Div_distrib_mod_0: " n mod m = 0 \ I \ n \ m = I \ m \ n div m" apply (case_tac "m = 0", simp add: iT_Plus_0 iT_Div_0) apply (simp add: iT_Plus_Div_distrib_mod_less) done lemma iT_Div_Min: "I \ {} \ iMin (I \ k) = iMin I div k" by (simp add: iT_Div_def iMin_mono2 mono_def div_le_mono) -corollary +corollary iFROM_div_Min: "iMin ([n\] \ k) = n div k" and iIN_div_Min: "iMin ([n\,d] \ k) = n div k" and iTILL_div_Min: "iMin ([\n] \ k) = 0" and iMOD_div_Min: "iMin ([r, mod m] \ k) = r div k" and iMODb_div_Min: "iMin ([r, mod m, c] \ k) = r div k" by (simp add: iT_not_empty iT_Div_Min iT_Min)+ -lemmas iT_div_Min = +lemmas iT_div_Min = iFROM_div_Min iIN_div_Min iTILL_div_Min iMOD_div_Min iMODb_div_Min lemma iT_Div_Max: "\ finite I; I \ {} \ \ Max (I \ k) = Max I div k" by (simp add: iT_Div_def Max_mono2 mono_def div_le_mono) -corollary +corollary iIN_div_Max: "Max ([n\,d] \ k) = (n + d) div k" and iTILL_div_Max: "Max ([\n] \ k) = n div k" and iMODb_div_Max: "Max ([r, mod m, c] \ k) = (r + m * c) div k" by (simp add: iT_not_empty iT_finite iT_Div_Max iT_Max)+ lemma iT_Div_0_finite: "finite (I \ 0)" by (simp add: iT_Div_0_if iTILL_0) lemma iT_Div_infinite_iff: "0 < k \ infinite (I \ k) = infinite I" apply (unfold iT_Div_def) apply (rule iffI) apply (rule infinite_image_imp_infinite, assumption) apply (clarsimp simp: infinite_nat_iff_unbounded_le image_iff, rename_tac x1) apply (drule_tac x="x1 * k" in spec, clarsimp, rename_tac x2) apply (drule div_le_mono[of _ _ k], simp) apply (rule_tac x="x2 div k" in exI) apply fastforce done lemma iT_Div_finite_iff: "0 < k \ finite (I \ k) = finite I" by (insert iT_Div_infinite_iff, simp) lemma iFROM_div: "0 < k \ [n\] \ k = [n div k\]" apply (clarsimp simp: set_eq_iff iT_Div_def image_iff Bex_def iFROM_iff, rename_tac x) apply (rule iffI) apply (clarsimp simp: div_le_mono) apply (rule_tac x="n mod k + k * x" in exI) apply simp apply (subst add.commute, subst le_diff_conv[symmetric]) apply (subst minus_mod_eq_mult_div) apply simp done lemma iIN_div: " - 0 < k \ + 0 < k \ [n\,d] \ k = [n div k\, d div k + (n mod k + d mod k) div k ]" apply (clarsimp simp: set_eq_iff iT_Div_def image_iff Bex_def iIN_iff, rename_tac x) apply (rule iffI) apply clarify apply (drule div_le_mono[of n _ k]) apply (drule div_le_mono[of _ "n + d" k]) apply (simp add: div_add1_eq[of n d]) apply (clarify, rename_tac x) apply (simp add: add.assoc[symmetric] div_add1_eq[symmetric]) apply (frule mult_le_mono1[of "n div k" _ k]) apply (frule mult_le_mono1[of _ "(n + d) div k" k]) apply (simp add: mult.commute[of _ k] minus_mod_eq_mult_div [symmetric]) apply (simp add: le_diff_conv le_diff_conv2[OF mod_le_dividend]) apply (drule order_le_less[of _ "(n + d) div k", THEN iffD1], erule disjE) apply (rule_tac x="k * x + n mod k" in exI) apply (simp add: add.commute[of _ "n mod k"]) apply (case_tac "n mod k \ (n + d) mod k", simp) apply (simp add: linorder_not_le) apply (drule_tac m=x in less_imp_le_pred) apply (drule_tac i=x and k=k in mult_le_mono2) apply (simp add: diff_mult_distrib2 minus_mod_eq_mult_div [symmetric]) apply (subst add.commute[of "n mod k"]) apply (subst le_diff_conv2[symmetric]) apply (simp add: trans_le_add1) apply (rule order_trans, assumption) apply (rule diff_le_mono2) apply (simp add: trans_le_add2) apply (rule_tac x="n + d" in exI, simp) done corollary iIN_div_if: " - 0 < k \ [n\,d] \ k = + 0 < k \ [n\,d] \ k = [n div k\, d div k + (if n mod k + d mod k < k then 0 else Suc 0)]" apply (simp add: iIN_div) apply (simp add: iIN_def add.assoc[symmetric] div_add1_eq[symmetric] div_add1_eq2[where a=n]) done corollary iIN_div_eq1: " - \ 0 < k; n mod k + d mod k < k \ \ + \ 0 < k; n mod k + d mod k < k \ \ [n\,d] \ k = [n div k\,d div k]" by (simp add: iIN_div_if) corollary iIN_div_eq2: " - \ 0 < k; k \ n mod k + d mod k \ \ + \ 0 < k; k \ n mod k + d mod k \ \ [n\,d] \ k = [n div k\, Suc (d div k)]" by (simp add: iIN_div_if) corollary iIN_div_mod_eq_0: " \ 0 < k; n mod k = 0 \ \ [n\,d] \ k = [n div k\,d div k]" by (simp add: iIN_div_eq1) lemma iTILL_div: " 0 < k \ [\n] \ k = [\n div k]" by (simp add: iIN_0_iTILL_conv[symmetric] iIN_div_if) lemma iMOD_div_ge: " \ 0 < m; m \ k \ \ [r, mod m] \ k = [r div k\]" apply (frule less_le_trans[of _ _ k], assumption) apply (clarsimp simp: set_eq_iff iT_Div_mem_iff Bex_def iT_iff, rename_tac x) apply (rule iffI) apply (fastforce simp: div_le_mono) apply (rule_tac x=" - if x * k < r then r else - ((if x * k mod m \ r mod m then 0 else m) + r mod m + (x * k - x * k mod m))" + if x * k < r then r else + ((if x * k mod m \ r mod m then 0 else m) + r mod m + (x * k - x * k mod m))" in exI) apply (case_tac "x * k < r") apply simp apply (drule less_imp_le[of _ r], drule div_le_mono[of _ r k], simp) apply (simp add: linorder_not_less linorder_not_le) apply (simp add: div_le_conv add.commute[of k]) apply (subst diff_add_assoc, simp)+ apply (simp add: div_mult_cancel[symmetric] del: add_diff_assoc) apply (case_tac "x * k mod m = 0") apply (clarsimp elim!: dvdE) apply (drule sym) apply (simp add: mult.commute[of m]) apply (blast intro: div_less order_less_le_trans mod_less_divisor) apply simp apply (intro conjI impI) apply (simp add: div_mult_cancel) apply (simp add: div_mult_cancel) apply (subst add.commute, subst diff_add_assoc, simp) apply (subst add.commute, subst div_mult_self1, simp) apply (subst div_less) apply (rule order_less_le_trans[of _ m], simp add: less_imp_diff_less) apply simp apply simp apply (rule_tac y="x * k" in order_trans, assumption) apply (simp add: div_mult_cancel) apply (rule le_add_diff) apply (simp add: trans_le_add1) apply (simp add: div_mult_cancel) apply (subst diff_add_assoc2, simp add: trans_le_add1) apply simp done corollary iMOD_div_self: " 0 < m \ [r, mod m] \ m = [r div m\]" by (simp add: iMOD_div_ge) lemma iMOD_div: " - \ 0 < k; m mod k = 0 \ \ + \ 0 < k; m mod k = 0 \ \ [r, mod m] \ k = [r div k, mod (m div k) ]" apply (case_tac "m = 0") apply (simp add: iMOD_0 iIN_0 iT_Div_singleton) apply (clarsimp elim!: dvdE) apply (rename_tac q) apply hypsubst_thin apply (cut_tac r="r div k" and k=k and m=q in iMOD_mult) apply (drule arg_cong[where f="\x. x \ (r mod k)"]) apply (drule sym) apply (simp add: iMOD_add mult.commute[of k]) apply (cut_tac I="[r div k, mod q] \ k" and m=k and n="r mod k" in iT_Plus_Div_distrib_mod_less) apply (rule ballI) apply (simp only: iMOD_mult iMOD_iff, elim conjE) apply (drule mod_factor_imp_mod_0) apply simp apply (simp add: iT_Plus_0) apply (simp add: iT_Mult_Div[OF _ mod_self] iT_Mult_1) done lemma iMODb_div_self: " 0 < m \ [r, mod m, c] \ m = [r div m\,c]" apply (subst iMODb_iMOD_iTILL_conv) apply (subst iTILL_iT_Div_Int) apply simp apply (clarsimp simp: iT_iff simp del: div_mult_self1 div_mult_self2, rename_tac x) apply (drule div_le_mod_le_imp_le) apply simp+ apply (simp add: iMOD_div_self iTILL_div iFROM_iTILL_iIN_conv) done lemma iMODb_div_ge: " - \ 0 < m; m \ k \ \ + \ 0 < m; m \ k \ \ [r, mod m, c] \ k = [r div k\,(r + m * c) div k - r div k]" apply (case_tac "m = k") apply (simp add: iMODb_div_self) apply (drule le_neq_trans, simp+) apply (induct c) apply (simp add: iMODb_0 iIN_0 iT_Div_singleton) apply (rule_tac t="[ r, mod m, Suc c ]" and s="[ r, mod m, c ] \ {r + m * c + m}" in subst) apply (cut_tac c=c and c'=0 and r=r and m=m in iMODb_append_union_Suc[symmetric]) apply (simp add: iMODb_0 iIN_0 add.commute[of m] add.assoc) apply (subst iT_Div_Un) apply (simp add: iT_Div_singleton) apply (simp add: add.commute[of m] add.assoc[symmetric]) apply (case_tac "(r + m * c) mod k + m mod k < k") apply (simp add: div_add1_eq1) apply (rule insert_absorb) apply (simp add: iIN_iff div_le_mono) apply (simp add: linorder_not_less) apply (simp add: div_add1_eq2) apply (rule_tac t="Suc ((r + m * c) div k)" and s="Suc (r div k + ((r + m * c) div k - r div k))" in subst) apply (simp add: div_le_mono) apply (simp add: iIN_Suc_insert_conv) done corollary iMODb_div_ge_if: " - \ 0 < m; m \ k \ \ - [r, mod m, c] \ k = + \ 0 < m; m \ k \ \ + [r, mod m, c] \ k = [r div k\, m * c div k + (if r mod k + m * c mod k < k then 0 else Suc 0)]" by (simp add: iMODb_div_ge div_add1_eq_if[of _ r]) lemma iMODb_div: " - \ 0 < k; m mod k = 0 \ \ + \ 0 < k; m mod k = 0 \ \ [r, mod m, c] \ k = [r div k, mod (m div k), c ]" apply (subst iMODb_iMOD_iTILL_conv) apply (subst iTILL_iT_Div_Int) apply simp apply (simp add: Ball_def iMOD_iff, intro allI impI, elim conjE, rename_tac x) apply (drule div_le_mod_le_imp_le) apply (subst mod_add1_eq_if) apply (simp add: mod_0_imp_mod_mult_right_0) apply (drule mod_eq_mod_0_imp_mod_eq, simp+) apply (simp add: iMOD_div iTILL_div) apply (simp add: iMOD_iTILL_iMODb_conv div_le_mono) apply (clarsimp simp: mult.assoc iMODb_mod_0 iMOD_0 elim!: dvdE) done lemmas iT_div = iTILL_div iFROM_div iIN_div iMOD_div iMODb_div iT_Div_singleton -text \This lemma is valid for all @{term "k \ m"},i. e., also for k with @{term "m mod k \ 0"}.\ +text \This lemma is valid for all @{term "k \ m"},i. e., also for k with @{term "m mod k \ 0"}.\ lemma iMODb_div_unique: " - \ 0 < k; k \ m; k \ c; [r', mod m', c'] = [r, mod m, c] \ k \ \ + \ 0 < k; k \ m; k \ c; [r', mod m', c'] = [r, mod m, c] \ k \ \ r' = r div k \ m' = m div k \ c' = c" apply (case_tac "r' \ r div k") apply (drule arg_cong[where f="iMin"]) apply (simp add: iT_Min iT_not_empty iT_Div_Min) apply simp apply (case_tac "m' = 0 \ c' = 0") apply (subgoal_tac "[ r div k, mod m', c' ] = {r div k}") prefer 2 apply (rule iMODb_singleton_eq_conv[THEN iffD2], simp) apply simp apply (drule arg_cong[where f="Max"]) apply (simp add: iMODb_mod_0 iIN_0 iT_Max iT_Div_Max iT_Div_finite_iff iT_Div_not_empty iT_finite iT_not_empty) apply (subgoal_tac "r div k < (r + m * c) div k", simp) apply (subst div_add1_eq_if, simp) apply clarsimp apply (rule order_less_le_trans[of _ "k * k div k"], simp) apply (rule div_le_mono) apply (simp add: mult_mono) apply (subgoal_tac "c' = c") prefer 2 apply (drule arg_cong[where f="\A. card A"]) apply (simp add: iT_Div_def card_image[OF iMODb_div_right_inj_on] iMODb_card) apply clarsimp apply (frule iMODb_div_right_strict_mono_on[of k m r c], assumption) apply (frule_tac a=k and b=0 and m=m' and r="r div k" and c=c in iMODb_inext_nth_diff, simp) apply (simp add: iT_Div_Min iT_not_empty iT_Min) apply (simp add: iT_Div_def inext_nth_image[OF iMODb_not_empty]) apply (simp add: iMODb_inext_nth) done lemma iMODb_div_mod_gr0_is_0_not_ex0: " \ 0 < k; k < m; 0 < m mod k; k \ c; r mod k = 0 \ \ $$\r' m' c'. [r', mod m', c'] = [r, mod m, c] \ k)" apply (rule ccontr, simp, elim exE conjE) apply (frule_tac r'=r' and m'=m' and c'=c' and r=r and k=k and m=m and c=c in iMODb_div_unique[OF _ less_imp_le], simp+) apply (drule arg_cong[where f="Max"]) apply (simp add: iT_Max iT_Div_Max iT_Div_finite_iff iT_Div_not_empty iT_finite iT_not_empty) apply (simp add: div_add1_eq1) apply (simp add: mult.commute[of m]) apply (simp add: div_mult1_eq[of c m] div_eq_0_conv) apply (subgoal_tac "c \ c * (m mod k)") apply simp+ done lemma iMODb_div_mod_gr0_not_ex__arith_aux1: " \ (0::nat) < k; k < m; 0 < x1 \ \ x1 * m + x2 - x mod k + x3 + x mod k = x1 * m + x2 + x3" apply (drule Suc_leI[of _ x1]) apply (drule mult_le_mono1[of "Suc 0" _ m]) apply (subgoal_tac "x mod k \ x1 * m") prefer 2 apply (rule order_trans[OF mod_le_divisor], assumption) apply (rule order_less_imp_le) apply (rule order_less_le_trans) apply simp+ done lemma iMODb_div_mod_gr0_not_ex: " \ 0 < k; k < m; 0 < m mod k; k \ c \ \ \(\r' m' c'. [r', mod m', c'] = [r, mod m, c] \ k)" apply (case_tac "r mod k = 0") apply (simp add: iMODb_div_mod_gr0_is_0_not_ex0) apply (rule ccontr, simp, elim exE conjE) apply (frule_tac r'=r' and m'=m' and c'=c' and r=r and k=k and m=m and c=c in iMODb_div_unique[OF _ less_imp_le], simp+) apply clarsimp apply (drule arg_cong[where f="Max"]) apply (simp add: iT_Max iT_Div_Max iT_Div_finite_iff iT_Div_not_empty iT_finite iT_not_empty) apply (simp add: div_add1_eq[of r "m * c"]) apply (simp add: mult.commute[of _ c]) apply (clarsimp simp add: div_mult1_eq[of c m k]) apply (subgoal_tac "Suc 0 \ c * (m mod k) div k", simp) apply (thin_tac "_ = 0")+ apply (drule div_le_mono[of k c k], simp) apply (rule order_trans[of _ "c div k"], simp) apply (rule div_le_mono, simp) done lemma iMOD_div_eq_imp_iMODb_div_eq: " \ 0 < k; k \ m; [r', mod m'] = [r, mod m] \ k \ \ [r', mod m', c] = [r, mod m, c] \ k" apply (subgoal_tac "r' = r div k") prefer 2 apply (drule arg_cong[where f=iMin]) apply (simp add: iT_Div_Min iMOD_not_empty iMOD_Min) apply clarsimp apply (frule iMOD_div_right_strict_mono_on[of _ m r], assumption) apply (frule card_image[OF strict_mono_on_imp_inj_on[OF iMODb_div_right_strict_mono_on[of k m r c]]], assumption) apply (simp add: iMODb_card) apply (subgoal_tac "r + m * c \ [r, mod m]") prefer 2 apply (simp add: iMOD_iff) apply (subgoal_tac "[r, mod m, c] = [ r, mod m ] \\ (r + m * c)") prefer 2 apply (simp add: iMOD_cut_le1) apply (simp add: iT_Div_def) apply (simp add: cut_le_image[symmetric]) apply (drule sym) apply (simp add: iMOD_cut_le) apply (simp add: linorder_not_le[of "r div k", symmetric]) apply (simp add: div_le_mono) apply (case_tac "m' = 0") apply (simp add: iMODb_mod_0_card) apply (rule arg_cong[where f="\c. [r div k, mod m', c]"]) apply (simp add: iMODb_card) done lemma iMOD_div_unique: " \ 0 < k; k \ m; [r', mod m'] = [r, mod m] \ k \ \ r' = r div k \ m' = m div k" apply (frule iMOD_div_eq_imp_iMODb_div_eq[of k m r' m' r k], assumption+) apply (simp add: iMODb_div_unique[of k _ k]) done lemma iMOD_div_mod_gr0_not_ex: " \ 0 < k; k < m; 0 < m mod k \ \ \ (\r' m'. [r', mod m'] = [r, mod m] \ k)" apply (rule ccontr, clarsimp) -apply (frule_tac k=k and m=m and r'=r' and m'=m' and c=k +apply (frule_tac k=k and m=m and r'=r' and m'=m' and c=k in iMOD_div_eq_imp_iMODb_div_eq[OF _ less_imp_le], assumption+) apply (frule iMODb_div_mod_gr0_not_ex[of k m k r], simp+) done subsection \Interval cut operators with arithmetic interval operators\ -lemma +lemma iT_Plus_cut_le2: "(I \ k) \\ (t + k) = (I \\ t) \ k" and iT_Plus_cut_less2: "(I \ k) \< (t + k) = (I \< t) \ k" and iT_Plus_cut_ge2: "(I \ k) \\ (t + k) = (I \\ t) \ k" and iT_Plus_cut_greater2: "(I \ k) \> (t + k) = (I \> t) \ k" unfolding iT_Plus_def by fastforce+ lemma iT_Plus_cut_le: " (I \ k) \\ t = (if t < k then {} else I \\ (t - k) \ k)" apply (case_tac "t < k") apply (simp add: cut_le_empty_iff iT_Plus_mem_iff) apply (insert iT_Plus_cut_le2[of I k "t - k"], simp) done lemma iT_Plus_cut_less: "(I \ k) \< t = I \< (t - k) \ k" apply (case_tac "t < k") apply (simp add: cut_less_0_empty iT_Plus_empty cut_less_empty_iff iT_Plus_mem_iff) apply (insert iT_Plus_cut_less2[of I k "t - k"], simp) done lemma iT_Plus_cut_ge: "(I \ k) \\ t = I \\ (t - k) \ k" apply (case_tac "t < k") apply (simp add: cut_ge_0_all cut_ge_all_iff iT_Plus_mem_iff) apply (insert iT_Plus_cut_ge2[of I k "t - k"], simp) done lemma iT_Plus_cut_greater: " (I \ k) \> t = (if t < k then I \ k else I \> (t - k) \ k)" apply (case_tac "t < k") apply (simp add: cut_greater_all_iff iT_Plus_mem_iff) apply (insert iT_Plus_cut_greater2[of I k "t - k"], simp) done -lemma +lemma iT_Mult_cut_le2: "0 < k \ (I \ k) \\ (t * k) = (I \\ t) \ k" and iT_Mult_cut_less2: "0 < k \ (I \ k) \< (t * k) = (I \< t) \ k" and iT_Mult_cut_ge2: "0 < k \ (I \ k) \\ (t * k) = (I \\ t) \ k" and iT_Mult_cut_greater2: "0 < k \ (I \ k) \> (t * k) = (I \> t) \ k" unfolding iT_Mult_def by fastforce+ lemma iT_Mult_cut_le: " 0 < k \ (I \ k) \\ t = (I \\ (t div k)) \ k" apply (clarsimp simp: set_eq_iff iT_Mult_mem_iff cut_le_mem_iff) apply (rule conj_cong, simp)+ apply (rule iffI) apply (simp add: div_le_mono) apply (rule div_le_mod_le_imp_le, simp+) done lemma iT_Mult_cut_less: " - 0 < k \ (I \ k) \< t = + 0 < k \ (I \ k) \< t = (if t mod k = 0 then (I \< (t div k)) else I \< Suc (t div k)) \ k" apply (case_tac "t mod k = 0") apply (clarsimp simp add: mult.commute[of k] iT_Mult_cut_less2 elim!: dvdE) apply (clarsimp simp: set_eq_iff iT_Mult_mem_iff cut_less_mem_iff) apply (rule conj_cong, simp)+ apply (subst less_Suc_eq_le) apply (rule iffI) apply (rule div_le_mono, simp) apply (rule ccontr, simp add: linorder_not_less) apply (drule le_imp_less_or_eq[of t], erule disjE) apply (fastforce dest: less_mod_0_imp_div_less[of t _ k]) apply simp done lemma iT_Mult_cut_greater: " 0 < k \ (I \ k) \> t = (I \> (t div k)) \ k" apply (clarsimp simp: set_eq_iff iT_Mult_mem_iff cut_greater_mem_iff) apply (rule conj_cong, simp)+ apply (rule iffI) apply (simp add: less_mod_ge_imp_div_less) apply (rule ccontr, simp add: linorder_not_less) apply (fastforce dest: div_le_mono[of _ _ k]) done lemma iT_Mult_cut_ge: " - 0 < k \ (I \ k) \\ t = + 0 < k \ (I \ k) \\ t = (if t mod k = 0 then (I \\ (t div k)) else I \\ Suc (t div k)) \ k" apply (case_tac "t mod k = 0") apply (clarsimp simp add: mult.commute[of k] iT_Mult_cut_ge2 elim!: dvdE) apply (clarsimp simp: set_eq_iff iT_Mult_mem_iff cut_ge_mem_iff) apply (rule conj_cong, simp)+ apply (rule iffI) apply (rule Suc_leI) apply (simp add: le_mod_greater_imp_div_less) apply (rule ccontr) apply (drule Suc_le_lessD) apply (simp add: linorder_not_le) apply (fastforce dest: div_le_mono[OF order_less_imp_le, of _ t k]) done lemma iT_Plus_neg_cut_le2: "k \ t \ (I \- k) \\ (t - k) = (I \\ t) \- k" apply (simp add: iT_Plus_neg_image_conv) apply (simp add: i_cut_commute_disj[of "(\$$" "(\\)"]) apply (rule i_cut_image[OF sub_left_strict_mono_on]) apply (simp add: cut_ge_Int_conv)+ done lemma iT_Plus_neg_cut_less2: "(I \- k) \< (t - k) = (I \< t) \- k" apply (case_tac "t \ k") apply (simp add: cut_less_0_empty) apply (case_tac "I \< t = {}") apply (simp add: iT_Plus_neg_empty) apply (rule sym, rule iT_Plus_neg_Max_less_empty[OF nat_cut_less_finite]) apply (rule order_less_le_trans[OF cut_less_Max_less[OF nat_cut_less_finite]], assumption+) apply (simp add: linorder_not_le iT_Plus_neg_image_conv) apply (simp add: i_cut_commute_disj[of "(\<)" "(\\)"]) apply (rule i_cut_image[OF sub_left_strict_mono_on]) apply (simp add: cut_ge_Int_conv)+ done lemma iT_Plus_neg_cut_ge2: "(I \- k) \\ (t - k) = (I \\ t) \- k" apply (case_tac "t \ k") apply (simp add: cut_ge_0_all iT_Plus_neg_cut_eq) apply (simp add: linorder_not_le iT_Plus_neg_image_conv) apply (simp add: i_cut_commute_disj[of "(\\)" "(\\)"]) apply (rule i_cut_image[OF sub_left_strict_mono_on]) apply (simp add: cut_ge_Int_conv)+ done lemma iT_Plus_neg_cut_greater2: "k \ t \ (I \- k) \> (t - k) = (I \> t) \- k" apply (simp add: iT_Plus_neg_image_conv) apply (simp add: i_cut_commute_disj[of "(\>)" "(\\)"]) apply (rule i_cut_image[OF sub_left_strict_mono_on]) apply (simp add: cut_ge_Int_conv)+ done lemma iT_Plus_neg_cut_le: "(I \- k) \\ t = I \\ (t + k) \- k" by (insert iT_Plus_neg_cut_le2[of k "t + k" I, OF le_add2], simp) lemma iT_Plus_neg_cut_less: "(I \- k) \< t = I \< (t + k) \- k" by (insert iT_Plus_neg_cut_less2[of I k "t + k"], simp) lemma iT_Plus_neg_cut_ge: "(I \- k) \\ t = I \\ (t + k) \- k" by (insert iT_Plus_neg_cut_ge2[of I k "t + k"], simp) lemma iT_Plus_neg_cut_greater: "(I \- k) \> t = I \> (t + k) \- k" by (insert iT_Plus_neg_cut_greater2[of k "t + k" I], simp) lemma iT_Minus_cut_le2: "t \ k \ (k \ I) \\ (k - t) = k \ (I \\ t)" by (fastforce simp: i_cut_mem_iff iT_Minus_mem_iff) lemma iT_Minus_cut_less2: "(k \ I) \< (k - t) = k \ (I \> t)" by (fastforce simp: i_cut_mem_iff iT_Minus_mem_iff) lemma iT_Minus_cut_ge2: "(k \ I) \\ (k - t) = k \ (I \\ t)" by (fastforce simp: i_cut_mem_iff iT_Minus_mem_iff) lemma iT_Minus_cut_greater2: "t \ k \ (k \ I) \> (k - t) = k \ (I \< t)" by (fastforce simp: i_cut_mem_iff iT_Minus_mem_iff) lemma iT_Minus_cut_le: "(k \ I) \\ t = k \ (I \\ (k - t))" by (fastforce simp: i_cut_mem_iff iT_Minus_mem_iff) lemma iT_Minus_cut_less: " (k \ I) \< t = (if t \ k then k \ (I \> (k - t)) else k \ I)" apply (case_tac "t \ k") apply (cut_tac iT_Minus_cut_less2[of k I "k - t"], simp) apply (fastforce simp: i_cut_mem_iff iT_Minus_mem_iff) done lemma iT_Minus_cut_ge: " (k \ I) \\ t = (if t \ k then k \ (I \\ (k - t)) else {})" apply (case_tac "t \ k") apply (cut_tac iT_Minus_cut_ge2[of k I "k - t"], simp) apply (fastforce simp: i_cut_mem_iff iT_Minus_mem_iff) done lemma iT_Minus_cut_greater: "(k \ I) \> t = k \ (I \< (k - t))" apply (case_tac "t \ k") apply (cut_tac iT_Minus_cut_greater2[of "k - t" k I], simp+) apply (fastforce simp: i_cut_mem_iff iT_Minus_mem_iff) done lemma iT_Div_cut_le: " 0 < k \ (I \ k) \\ t = I \\ (t * k + (k - Suc 0)) \ k" apply (simp add: set_eq_iff i_cut_mem_iff iT_Div_mem_iff Bex_def) apply (fastforce simp: div_le_conv) done lemma iT_Div_cut_less: " 0 < k \ (I \ k) \< t = I \< (t * k) \ k" apply (case_tac "t = 0") apply (simp add: cut_less_0_empty iT_Div_empty) apply (simp add: nat_cut_less_le_conv iT_Div_cut_le diff_mult_distrib) done lemma iT_Div_cut_ge: " 0 < k \ (I \ k) \\ t = I \\ (t * k) \ k" apply (simp add: set_eq_iff i_cut_mem_iff iT_Div_mem_iff Bex_def) apply (fastforce simp: le_div_conv) done lemma iT_Div_cut_greater: " 0 < k \ (I \ k) \> t = I \> (t * k + (k - Suc 0)) \ k" by (simp add: nat_cut_ge_greater_conv[symmetric] iT_Div_cut_ge add.commute[of k]) lemma iT_Div_cut_le2: " 0 < k \ (I \ k) \\ (t div k) = I \\ (t - t mod k + (k - Suc 0)) \ k" by (frule iT_Div_cut_le[of k I "t div k"], simp add: div_mult_cancel) lemma iT_Div_cut_less2: " 0 < k \ (I \ k) \< (t div k) = I \< (t - t mod k) \ k" by (frule iT_Div_cut_less[of k I "t div k"], simp add: div_mult_cancel) lemma iT_Div_cut_ge2: " 0 < k \ (I \ k) \\ (t div k) = I \\ (t - t mod k) \ k" by (frule iT_Div_cut_ge[of k I "t div k"], simp add: div_mult_cancel) lemma iT_Div_cut_greater2: " 0 < k \ (I \ k) \> (t div k) = I \> (t - t mod k + (k - Suc 0)) \ k" by (frule iT_Div_cut_greater[of k I "t div k"], simp add: div_mult_cancel) subsection \\inext\ and \iprev\ with interval operators\ lemma iT_Plus_inext: "inext (n + k) (I \ k) = (inext n I) + k" by (unfold iT_Plus_def, rule inext_image2[OF add_right_strict_mono]) lemma iT_Plus_iprev: "iprev (n + k) (I \ k) = (iprev n I) + k" by (unfold iT_Plus_def, rule iprev_image2[OF add_right_strict_mono]) lemma iT_Plus_inext2: "k \ n \ inext n (I \ k) = (inext (n - k) I) + k" by (insert iT_Plus_inext[of "n - k" k I], simp) lemma iT_Plus_prev2: "k \ n \ iprev n (I \ k) = (iprev (n - k) I) + k" by (insert iT_Plus_iprev[of "n - k" k I], simp) lemma iT_Mult_inext: "inext (n * k) (I \ k) = (inext n I) * k" apply (case_tac "I = {}") apply (simp add: iT_Mult_empty inext_empty) apply (case_tac "k = 0") apply (simp add: iT_Mult_0 iTILL_0 inext_singleton) apply (simp add: iT_Mult_def inext_image2[OF mult_right_strict_mono]) done lemma iT_Mult_iprev: "iprev (n * k) (I \ k) = (iprev n I) * k" apply (case_tac "I = {}") apply (simp add: iT_Mult_empty iprev_empty) apply (case_tac "k = 0") apply (simp add: iT_Mult_0 iTILL_0 iprev_singleton) apply (simp add: iT_Mult_def iprev_image2[OF mult_right_strict_mono]) done lemma iT_Mult_inext2_if: " inext n (I \ k) = (if n mod k = 0 then (inext (n div k) I) * k else n)" apply (case_tac "I = {}") apply (simp add: iT_Mult_empty inext_empty div_mult_cancel) apply (case_tac "k = 0") apply (simp add: iT_Mult_0 iTILL_0 inext_singleton) apply (case_tac "n mod k = 0") apply (clarsimp simp: mult.commute[of k] iT_Mult_inext elim!: dvdE) apply (simp add: not_in_inext_fix iT_Mult_mem_iff) done lemma iT_Mult_iprev2_if: " iprev n (I \ k) = (if n mod k = 0 then (iprev (n div k) I) * k else n)" apply (case_tac "I = {}") apply (simp add: iT_Mult_empty iprev_empty div_mult_cancel) apply (case_tac "k = 0") apply (simp add: iT_Mult_0 iTILL_0 iprev_singleton) apply (case_tac "n mod k = 0") apply (clarsimp simp: mult.commute[of k] iT_Mult_iprev elim!: dvdE) apply (simp add: not_in_iprev_fix iT_Mult_mem_iff) done corollary iT_Mult_inext2: " n mod k = 0 \ inext n (I \ k) = (inext (n div k) I) * k" by (simp add: iT_Mult_inext2_if) corollary iT_Mult_iprev2: " n mod k = 0 \ iprev n (I \ k) = (iprev (n div k) I) * k" by (simp add: iT_Mult_iprev2_if) lemma iT_Plus_neg_inext: " k \ n \ inext (n - k) (I \- k) = inext n I - k" apply (case_tac "I = {}") apply (simp add: iT_Plus_neg_empty inext_empty) apply (case_tac "n \ I") apply (simp add: iT_Plus_neg_image_conv) apply (rule subst[OF inext_cut_ge_conv, of k], simp) apply (rule inext_image) apply (simp add: cut_ge_mem_iff) apply (subst cut_ge_Int_conv) apply (rule strict_mono_on_subset[OF _ Int_lower2]) apply (rule sub_left_strict_mono_on) apply (subgoal_tac "n - k \ I \- k") prefer 2 apply (simp add: iT_Plus_neg_mem_iff) apply (simp add: not_in_inext_fix) done lemma iT_Plus_neg_iprev: " iprev (n - k) (I \- k) = iprev n (I \\ k) - k" apply (case_tac "I = {}") apply (simp add: iT_Plus_neg_empty i_cut_empty iprev_empty) apply (case_tac "n < k") apply (simp add: iprev_le_iMin) apply (simp add: order_trans[OF iprev_mono]) apply (simp add: linorder_not_less) apply (case_tac "n \ I") apply (frule iT_Plus_neg_mem_iff2[THEN iffD2, of _ _ I], assumption) apply (simp add: iT_Plus_neg_image_conv) apply (rule iprev_image) apply (simp add: cut_ge_mem_iff) apply (subst cut_ge_Int_conv) apply (rule strict_mono_on_subset[OF _ Int_lower2]) apply (rule sub_left_strict_mono_on) apply (frule cut_ge_not_in_imp[of _ _ k]) apply (subgoal_tac "n - k \ I \- k") prefer 2 apply (simp add: iT_Plus_neg_mem_iff) apply (simp add: not_in_iprev_fix) done corollary iT_Plus_neg_inext2: "inext n (I \- k) = inext (n + k) I - k" by (insert iT_Plus_neg_inext[of k "n + k" I, OF le_add2], simp) corollary iT_Plus_neg_iprev2: "iprev n (I \- k) = iprev (n + k) (I \\ k) - k" by (insert iT_Plus_neg_iprev[of "n + k" k I], simp) lemma iT_Minus_inext: " \ k \ I \ {}; n \ k \ \ inext (k - n) (k \ I) = k - iprev n I" apply (subgoal_tac "iMin I \ k") prefer 2 apply (simp add: iT_Minus_empty_iff) apply (subgoal_tac "I \\ k \ {}") prefer 2 apply (simp add: iT_Minus_empty_iff cut_le_Min_not_empty) apply (case_tac "n \ I") apply (simp add: iT_Minus_imirror_conv) apply (simp add: iT_Plus_neg_inext2) apply (subgoal_tac "n \ iMin I + Max (I \\ k)") prefer 2 apply (rule trans_le_add2) apply (rule Max_ge[OF nat_cut_le_finite]) apply (simp add: cut_le_mem_iff) apply (simp add: diff_add_assoc del: add_diff_assoc) apply (subst add.commute[of k], subst iT_Plus_inext) apply (simp add: cut_le_Min_eq[of I, symmetric]) apply (fold nat_mirror_def mirror_elem_def) apply (simp add: inext_imirror_iprev_conv[OF nat_cut_le_finite]) apply (simp add: iprev_cut_le_conv) apply (simp add: mirror_elem_def nat_mirror_def) apply (frule iprev_mono[THEN order_trans, of n "iMin (I \\ k) + Max (I \\ k)" I]) apply simp apply (subgoal_tac "k - n \ k \ I") prefer 2 apply (simp add: iT_Minus_mem_iff) apply (simp add: not_in_inext_fix not_in_iprev_fix) done corollary iT_Minus_inext2: " \ k \ I \ {}; n \ k \ \ inext n (k \ I) = k - iprev (k - n) I" by (insert iT_Minus_inext[of k I "k - n"], simp) lemma iT_Minus_iprev: " \ k \ I \ {}; n \ k \ \ iprev (k - n) (k \ I) = k - inext n (I \\ k)" apply (subgoal_tac "I \\ k \ {}") prefer 2 apply (simp add: iT_Minus_empty_iff cut_le_Min_not_empty) apply (subst iT_Minus_cut_eq[OF le_refl, of _ I, symmetric]) apply (insert iT_Minus_inext2[of k "k \ (I \\ k)" n]) apply (simp add: iT_Minus_Minus_cut_eq) apply (rule diff_diff_cancel[symmetric]) apply (rule order_trans[OF iprev_mono]) apply simp done lemma iT_Minus_iprev2: " \ k \ I \ {}; n \ k \ \ iprev n (k \ I) = k - inext (k - n) (I \\ k)" by (insert iT_Minus_iprev[of k I "k - n"], simp) lemma iT_Plus_inext_nth: "I \ {} \ (I \ k) \ n = (I \ n) + k" apply (induct n) apply (simp add: iT_Plus_Min) apply (simp add: iT_Plus_inext) done lemma iT_Plus_iprev_nth: "\ finite I; I \ {} \ \ (I \ k) \ n = (I \ n) + k" apply (induct n) apply (simp add: iT_Plus_Max) apply (simp add: iT_Plus_iprev) done lemma iT_Mult_inext_nth: "I \ {} \ (I \ k) \ n = (I \ n) * k" apply (induct n) apply (simp add: iT_Mult_Min) apply (simp add: iT_Mult_inext) done lemma iT_Mult_iprev_nth: "\ finite I; I \ {} \ \ (I \ k) \ n = (I \ n) * k" apply (induct n) apply (simp add: iT_Mult_Max) apply (simp add: iT_Mult_iprev) done lemma iT_Plus_neg_inext_nth: " I \- k \ {} \ (I \- k) \ n = (I \\ k \ n) - k" apply (subgoal_tac "I \\ k \ {}") prefer 2 apply (simp add: cut_ge_not_empty_iff iT_Plus_neg_not_empty_iff) apply (induct n) apply (simp add: iT_Plus_neg_Min) apply (simp add: iT_Plus_neg_cut_eq[of k k I, symmetric]) apply (rule iT_Plus_neg_inext) apply (rule cut_ge_bound[of _ I]) apply (simp add: inext_nth_closed) done lemma iT_Plus_neg_iprev_nth: " \ finite I; I \- k \ {} \ \ (I \- k) \ n = (I \\ k \ n) - k" apply (subgoal_tac "I \\ k \ {}") prefer 2 apply (simp add: cut_ge_not_empty_iff iT_Plus_neg_not_empty_iff) apply (induct n) apply (simp add: iT_Plus_neg_Max cut_ge_Max_eq) apply (simp add: iT_Plus_neg_iprev) done lemma iT_Minus_inext_nth: " k \ I \ {} \ (k \ I) \ n = k - ((I \\ k) \ n)" apply (subgoal_tac "I \\ k \ {} \ I \ {} \ iMin I \ k") prefer 2 apply (simp add: iT_Minus_empty_iff cut_le_Min_not_empty) apply (elim conjE) apply (induct n) apply(simp add: iT_Minus_Min) apply (simp add: iT_Minus_cut_eq[OF order_refl, of _ I, symmetric]) apply (rule iT_Minus_inext) apply simp apply (rule cut_le_bound, rule iprev_nth_closed[OF nat_cut_le_finite]) apply assumption done lemma iT_Minus_iprev_nth: " k \ I \ {} \ (k \ I) \ n = k - ((I \\ k) \ n)" apply (subgoal_tac "I \\ k \ {} \ I \ {} \ iMin I \ k") prefer 2 apply (simp add: iT_Minus_empty_iff cut_le_Min_not_empty) apply (elim conjE) apply (induct n) apply(simp add: iT_Minus_Max cut_le_Min_eq) apply simp apply (rule iT_Minus_iprev) apply simp apply (rule cut_le_bound, rule inext_nth_closed) apply assumption done lemma iT_Div_ge_inext_nth: " \ I \ {}; \x\I. \y\I. x < y \ x + k \ y \ \ (I \ k) \ n = (I \ n) div k" apply (case_tac "k = 0") apply (simp add: iT_Div_0 iTILL_0 inext_nth_singleton) apply (simp add: iT_Div_def) by (rule inext_nth_image[OF _ div_right_strict_mono_on]) lemma iT_Div_mod_inext_nth: " \ I \ {}; \x\I. \y\I. x mod k = y mod k \ \ (I \ k) \ n = (I \ n) div k" apply (case_tac "k = 0") apply (simp add: iT_Div_0 iTILL_0 inext_nth_singleton) apply (simp add: iT_Div_def) by (rule inext_nth_image[OF _ mod_eq_div_right_strict_mono_on]) lemma iT_Div_ge_iprev_nth: " \ finite I; I \ {}; \x\I. \y\I. x < y \ x + k \ y \ \ (I \ k) \ n = (I \ n) div k" apply (case_tac "k = 0") apply (simp add: iT_Div_0 iTILL_0 iprev_nth_singleton) apply (simp add: iT_Div_def) by (rule iprev_nth_image[OF _ _ div_right_strict_mono_on]) lemma iT_Div_mod_iprev_nth: " \ finite I; I \ {}; \x\I. \y\I. x mod k = y mod k \ \ (I \ k) \ n = (I \ n) div k" apply (case_tac "k = 0") apply (simp add: iT_Div_0 iTILL_0 iprev_nth_singleton) apply (simp add: iT_Div_def) by (rule iprev_nth_image[OF _ _ mod_eq_div_right_strict_mono_on]) subsection \Cardinality of intervals with interval operators\ lemma iT_Plus_card: "card (I \ k) = card I" apply (unfold iT_Plus_def) apply (rule card_image) apply (rule inj_imp_inj_on) apply (rule add_right_inj) done lemma iT_Mult_card: "0 < k \ card (I \ k) = card I" apply (unfold iT_Mult_def) apply (rule card_image) apply (rule inj_imp_inj_on) apply (rule mult_right_inj) apply assumption done lemma iT_Plus_neg_card: "card (I \- k) = card (I \\ k)" apply (simp add: iT_Plus_neg_image_conv) apply (rule card_image) apply (subst cut_ge_Int_conv) apply (rule subset_inj_on[OF _ Int_lower2]) apply (rule sub_left_inj_on) done lemma iT_Plus_neg_card_le: "card (I \- k) \ card I" apply (simp add: iT_Plus_neg_card) apply (case_tac "finite I") apply (rule cut_ge_card, assumption) apply (simp add: nat_cut_ge_finite_iff) done lemma iT_Minus_card: "card (k \ I) = card (I \\ k)" apply (simp add: iT_Minus_image_conv) apply (rule card_image) apply (subst cut_le_Int_conv) apply (rule subset_inj_on[OF _ Int_lower2]) apply (rule sub_right_inj_on) done lemma iT_Minus_card_le: "finite I \ card (k \ I) \ card I" by (subst iT_Minus_card, rule cut_le_card) lemma iT_Div_0_card_if: " card (I \ 0) = (if I ={} then 0 else Suc 0)" by (fastforce simp: iT_Div_empty iT_Div_0 iTILL_0) lemma Int_empty_sum:" (\k$$n::nat). if {} \ (I k) = {} then 0 else Suc 0) = 0" apply (rule sum_eq_0_iff[THEN iffD2]) apply (rule finite_atMost) apply simp done lemma iT_Div_mod_partition_card:" card (I \ [n * d\,d - Suc 0] \ d) = (if I \ [n * d\,d - Suc 0] = {} then 0 else Suc 0)" apply (case_tac "d = 0") apply (simp add: iIN_0 iTILL_0 iT_Div_0_if) apply (split if_split, rule conjI) apply (simp add: iT_Div_empty) apply clarsimp apply (subgoal_tac "I \ [n * d\,d - Suc 0] \ d = {n}", simp) apply (rule set_eqI) apply (simp add: iT_Div_mem_iff Bex_def iIN_iff) apply (rule iffI) apply (clarsimp simp: le_less_imp_div) apply (drule ex_in_conv[THEN iffD2], clarsimp simp: iIN_iff, rename_tac x') apply (rule_tac x=x' in exI) apply (simp add: le_less_imp_div) done lemma iT_Div_conv_count: " 0 < d \ I \ d = {k. I \ [k * d\,d - Suc 0] \ {}}" apply (case_tac "I = {}") apply (simp add: iT_Div_empty) apply (rule set_eqI) apply (simp add: iT_Div_mem_iff_Int) done lemma iT_Div_conv_count2: " - \ 0 < d; finite I; Max I div d \ n \ \ + \ 0 < d; finite I; Max I div d \ n \ \ I \ d = {k. k \ n \ I \ [k * d\,d - Suc 0] \ {}}" apply (simp add: iT_Div_conv_count) apply (rule set_eqI, simp) apply (rule iffI) apply simp apply (rule ccontr) apply (drule ex_in_conv[THEN iffD2], clarify, rename_tac x') apply (clarsimp simp: linorder_not_le iIN_iff) apply (drule order_le_less_trans, simp) apply (drule div_less_conv[THEN iffD1, of _ "Max I"], simp) apply (drule_tac x=x' in Max_ge, simp) apply simp+ done lemma mod_partition_count_Suc: " - {k. k \ Suc n \ I \ [k * d\,d - Suc 0] \ {}} = - {k. k \ n \ I \ [k * d\,d - Suc 0] \ {}} \ + {k. k \ Suc n \ I \ [k * d\,d - Suc 0] \ {}} = + {k. k \ n \ I \ [k * d\,d - Suc 0] \ {}} \ (if I \ [Suc n * d\,d - Suc 0] \ {} then {Suc n} else {})" apply (rule set_eqI, rename_tac x) apply (simp add: le_less[of _ "Suc n"] less_Suc_eq_le) apply (simp add: conj_disj_distribR) apply (intro conjI impI) apply fastforce apply (rule iffI, clarsimp+) done lemma iT_Div_card: " \I.\ 0 < d; finite I; Max I div d \ n\ \ - card (I \ d) = (\k\n. + card (I \ d) = (\k\n. if I \ [k * d\,d - Suc 0] = {} then 0 else Suc 0)" apply (case_tac "I = {}") apply (simp add: iT_Div_empty) apply (simp add: iT_Div_conv_count2) apply (induct n) apply (simp add: div_eq_0_conv iIN_0_iTILL_conv) apply (subgoal_tac "I \ [\d - Suc 0] \ {}") prefer 2 apply (simp add: ex_in_conv[symmetric], fastforce) apply (simp add: card_1_singleton_conv) apply (rule_tac x=0 in exI) apply (rule set_eqI) apply (simp add: ex_in_conv[symmetric], fastforce) apply simp apply (simp add: mod_partition_count_Suc) apply (drule_tac x="I \ [\n * d + d - Suc 0]" in meta_spec) apply simp apply (case_tac "I \ [\n * d + d - Suc 0] = {}") apply simp apply (subgoal_tac "{k. k \ n \ I \ [k * d\,d - Suc 0] \ {}} = {}", simp) apply (clarsimp, rename_tac x) apply (subgoal_tac "I \ [x * d\,d - Suc 0] \ I \ [\n * d + d - Suc 0]", simp) apply (rule Int_mono[OF order_refl]) apply (simp add: iIN_iTILL_subset_conv) apply (simp add: diff_le_mono) apply (subgoal_tac "Max (I \ [\n * d + d - Suc 0]) div d \ n") prefer 2 apply (simp add: div_le_conv add.commute[of d] iTILL_iff) apply (subgoal_tac "\k. k \ n \ [\n * d + d - Suc 0] \ [k * d\,d - Suc 0] = [k * d\,d - Suc 0]") prefer 2 apply (subst Int_commute) apply (simp add: iTILL_def cut_le_Int_conv[symmetric]) apply (rule cut_le_Max_all[OF iIN_finite]) apply (simp add: iIN_Max diff_le_mono) apply (simp add: Int_assoc) apply (subgoal_tac " {k. k \ n \ I \ ([\n * d + d - Suc 0] \ [k * d\,d - Suc 0]) \ {}} = {k. k \ n \ I \ [k * d\,d - Suc 0] \ {}}") prefer 2 apply (rule set_eqI, rename_tac x) apply simp apply (rule conj_cong, simp) apply simp apply simp done corollary iT_Div_card_Suc: " \I.\ 0 < d; finite I; Max I div d \ n\ \ - card (I \ d) = (\k d) = (\k [k * d\,d - Suc 0] = {} then 0 else Suc 0)" by (simp add: lessThan_Suc_atMost iT_Div_card) -corollary iT_Div_Max_card: "\ 0 < d; finite I \ \ +corollary iT_Div_Max_card: "\ 0 < d; finite I \ \ card (I \ d) = (\k\Max I div d. if I \ [k * d\,d - Suc 0] = {} then 0 else Suc 0)" by (simp add: iT_Div_card) lemma iT_Div_card_le: "0 < k \ card (I \ k) \ card I" apply (case_tac "finite I") apply (simp add: iT_Div_def card_image_le) apply (simp add: iT_Div_finite_iff) done lemma iT_Div_card_inj_on: " inj_on (\n. n div k) I \ card (I \ k) = card I" by (unfold iT_Div_def, rule card_image) (* -lemma "let I=[\19] in +lemma "let I=[\19] in d \ {1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21} \ card I div d \ card (I \ d)" apply (simp add: Let_def iTILL_card iTILL_div) done -lemma "let I=[\19] in +lemma "let I=[\19] in d \ {1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21} \ card I div d + (if card I mod d \ 0 then 1 else 0) \ card (I \ d)" apply (simp add: Let_def iTILL_card iTILL_div) done -lemma "let I=[5\,19] in +lemma "let I=[5\,19] in d \ {1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21} \ card I div d + (if card I mod d \ 0 then 1 else 0) \ card (I \ d)" apply (simp add: Let_def iIN_card iIN_div) done *) (* ToDo: to be moved to Util_Div *) lemma mod_Suc': " 0 < n \ Suc m mod n = (if m mod n < n - Suc 0 then Suc (m mod n) else 0)" apply (simp add: mod_Suc) apply (intro conjI impI) apply simp apply (insert le_neq_trans[OF mod_less_divisor[THEN Suc_leI, of n m]], simp) done lemma div_Suc: " 0 < n \ Suc m div n = (if Suc (m mod n) = n then Suc (m div n) else m div n)" apply (drule Suc_leI, drule le_imp_less_or_eq) apply (case_tac "n = Suc 0", simp) apply (split if_split, intro conjI impI) apply (rule_tac t="Suc m" and s="m + 1" in subst, simp) apply (subst div_add1_eq2, simp+) apply (insert le_neq_trans[OF mod_less_divisor[THEN Suc_leI, of n m]], simp) apply (rule_tac t="Suc m" and s="m + 1" in subst, simp) apply (subst div_add1_eq1, simp+) done lemma div_Suc': " 0 < n \ Suc m div n = (if m mod n < n - Suc 0 then m div n else Suc (m div n))" apply (simp add: div_Suc) apply (intro conjI impI) apply simp apply (insert le_neq_trans[OF mod_less_divisor[THEN Suc_leI, of n m]], simp) done lemma iT_Div_card_ge_aux: " - \I. \ 0 < d; finite I; Max I div d \ n \ \ + \I. \ 0 < d; finite I; Max I div d \ n \ \ card I div d + (if card I mod d = 0 then 0 else Suc 0) \ card (I \ d)" apply (induct n) apply (case_tac "I = {}", simp) apply (frule_tac m=d and n="Max I" and k=0 in div_le_conv[THEN iffD1, rule_format], assumption) apply (simp del: Max_le_iff) apply (subgoal_tac "I \ d = {0}") prefer 2 apply (rule set_eqI) apply (simp add: iT_Div_mem_iff) apply (rule iffI) apply (fastforce simp: div_eq_0_conv') apply fastforce apply (simp add: iT_Div_singleton card_singleton del: Max_le_iff) apply (drule Suc_le_mono[THEN iffD2, of _ "d - Suc 0"]) apply (drule order_trans[OF nat_card_le_Max]) apply (simp, intro conjI impI) apply (drule div_le_mono[of _ d d]) apply simp apply (subgoal_tac "card I \ d", simp) apply clarsimp apply (drule order_le_less[THEN iffD1], erule disjE) apply simp apply (rule_tac t=I and s="I \ [\n * d + d - Suc 0] \ I \ [Suc n * d\,d - Suc 0]" in subst) apply (simp add: Int_Un_distrib[symmetric] add.commute[of d]) apply (subst iIN_0_iTILL_conv[symmetric]) apply (simp add: iIN_union) apply (rule Int_absorb2) apply (simp add: iIN_0_iTILL_conv iTILL_def) apply (case_tac "I = {}", simp) apply (simp add: subset_atMost_Max_le_conv le_less_div_conv[symmetric] less_eq_le_pred[symmetric] add.commute[of d]) apply (cut_tac A="I \ [\n * d + d - Suc 0]" and B="I \ [Suc n * d\,d - Suc 0]" in card_Un_disjoint) apply simp apply simp apply (clarsimp simp: disjoint_iff_in_not_in1 iT_iff) apply (case_tac "I \ [\n * d + d - Suc 0] = {}") apply (simp add: iT_Div_mod_partition_card del: mult_Suc) apply (intro conjI impI) apply (rule div_le_conv[THEN iffD2], assumption) apply simp apply (rule order_trans[OF Int_card2[OF iIN_finite]]) apply (simp add: iIN_card) apply (cut_tac A=I and n="Suc n * d" and d="d - Suc 0" in Int_card2[OF iIN_finite, rule_format]) apply (simp add: iIN_card) apply (drule order_le_less[THEN iffD1], erule disjE) apply simp apply simp apply (subgoal_tac "Max (I \ [\n * d + d - Suc 0]) div d \ n") prefer 2 apply (rule div_le_conv[THEN iffD2], assumption) apply (rule order_trans[OF Max_Int_le2[OF _ iTILL_finite]], assumption) apply (simp add: iTILL_Max) apply (simp only: iT_Div_Un) apply (cut_tac A="I \ [\n * d + d - Suc 0] \ d" and B="I \ [Suc n * d\,d - Suc 0] \ d" in card_Un_disjoint) apply (simp add: iT_Div_finite_iff) apply (simp add: iT_Div_finite_iff) apply (subst iIN_0_iTILL_conv[symmetric]) apply (subst mod_partition_iT_Div_Int_one_segment, simp) apply (cut_tac n=0 and d="n * d+d" and k=d and A=I in mod_partition_iT_Div_Int2, simp+) apply (rule disjoint_iff_in_not_in1[THEN iffD2]) apply clarsimp apply (simp add: iIN_div_mod_eq_0) apply (simp add: mod_0_imp_sub_1_div_conv iIN_0_iTILL_conv iIN_0 iTILL_iff) apply (simp only: iT_Div_mod_partition_card) apply (subgoal_tac "finite (I \ [\n * d + d - Suc 0])") - prefer 2 + prefer 2 apply simp apply simp apply (intro conjI impI) apply (rule add_le_divisor_imp_le_Suc_div) apply (rule add_leD1, blast) apply (rule Int_card2[OF iIN_finite, THEN le_trans]) apply (simp add: iIN_card) apply (cut_tac A=I and n="Suc n * d" and d="d - Suc 0" in Int_card2[OF iIN_finite, rule_format]) apply (simp add: iIN_card) apply (rule_tac y="let I=I \ [\n * d + d - Suc 0] in card I div d + (if card I mod d = 0 then 0 else Suc 0)" in order_trans) prefer 2 apply (simp add: Let_def) apply (unfold Let_def) apply (split if_split, intro conjI impI) apply (subgoal_tac "card (I \ [Suc n * d\,d - Suc 0]) \ d") prefer 2 apply (rule ccontr, simp) apply (simp add: div_add1_eq1_mod_0_left) apply (simp add: add_le_divisor_imp_le_Suc_div) done lemma iT_Div_card_ge: " card I div d + (if card I mod d = 0 then 0 else Suc 0) \ card (I \ d)" apply (case_tac "I = {}", simp) apply (case_tac "finite I") prefer 2 apply simp apply (case_tac "d = 0") apply (simp add: iT_Div_0 iTILL_0) apply (simp add: iT_Div_card_ge_aux[OF _ _ order_refl]) done corollary iT_Div_card_ge_div: "card I div d \ card (I \ d)" by (rule iT_Div_card_ge[THEN add_leD1]) text \ - There is no better lower bound function @{term f} for @{term "(i \ d)"} + There is no better lower bound function @{term f} for @{term "(i \ d)"} with @{term "card i"} and @{term d} as arguments.\ lemma iT_Div_card_ge__is_maximal_lower_bound: " - \I d. card I div d + (if card I mod d = 0 then 0 else Suc 0) \ f (card I) d \ - f (card I) d \ card (I \ d) \ + \I d. card I div d + (if card I mod d = 0 then 0 else Suc 0) \ f (card I) d \ + f (card I) d \ card (I \ d) \ f (card (I::nat set)) d = card I div d + (if card I mod d = 0 then 0 else Suc 0)" apply (case_tac "I = {}") apply (erule_tac x=I in allE, erule_tac x=d in allE) apply (simp add: iT_Div_empty) apply (case_tac "d = 0") apply (frule_tac x="{}" in spec, erule_tac x=I in allE) apply (erule_tac x=d in allE, erule_tac x=d in allE) apply (clarsimp simp: iT_Div_0 iTILL_card iT_Div_empty) apply (rule order_antisym) prefer 2 apply simp apply (case_tac "finite I") prefer 2 apply (erule_tac x=I in allE, erule_tac x=d in allE) apply (simp add: iT_Div_finite_iff) apply (erule_tac x="[\card I - Suc 0]" in allE, erule_tac x=d in allE, elim conjE) apply (frule not_empty_card_gr0_conv[THEN iffD1], assumption) apply (simp add: iTILL_card iTILL_div) apply (intro conjI impI) apply (simp add: mod_0_imp_sub_1_div_conv) apply (subgoal_tac "d \ card I") prefer 2 apply (clarsimp elim!: dvdE) apply (drule div_le_mono[of d _ d]) apply simp apply (case_tac "d = Suc 0", simp) apply (simp add: div_diff1_eq1) done lemma iT_Plus_icard: "icard (I \ k) = icard I" by (simp add: iT_Plus_def icard_image) lemma iT_Mult_icard: "0 < k \ icard (I \ k) = icard I" apply (unfold iT_Mult_def) apply (rule icard_image) apply (rule inj_imp_inj_on) apply (simp add: mult_right_inj) done - + lemma iT_Plus_neg_icard: "icard (I \- k) = icard (I \\ k)" apply (case_tac "finite I") apply (simp add: iT_Plus_neg_finite_iff cut_ge_finite icard_finite iT_Plus_neg_card) apply (simp add: iT_Plus_neg_finite_iff nat_cut_ge_finite_iff) done lemma iT_Plus_neg_icard_le: "icard (I \- k) \ icard I" apply (case_tac "finite I") apply (simp add: iT_Plus_neg_finite_iff icard_finite iT_Plus_neg_card_le) apply simp done lemma iT_Minus_icard: "icard (k \ I) = icard (I \\ k)" by (simp add: icard_finite iT_Minus_finite nat_cut_le_finite iT_Minus_card) - + lemma iT_Minus_icard_le: "icard (k \ I) \ icard I" apply (case_tac "finite I") apply (simp add: icard_finite iT_Minus_finite iT_Minus_card_le) apply simp done lemma iT_Div_0_icard_if: "icard (I \ 0) = enat (if I = {} then 0 else Suc 0)" by (simp add: icard_finite iT_Div_0_finite iT_Div_0_card_if) lemma iT_Div_mod_partition_icard: " icard (I \ [n * d\,d - Suc 0] \ d) = enat (if I \ [n * d\,d - Suc 0] = {} then 0 else Suc 0)" apply (subgoal_tac "finite (I \ [n * d\,d - Suc 0] \ d)") prefer 2 apply (case_tac "d = 0", simp add: iT_Div_0_finite) apply (simp add: iT_Div_finite_iff iIN_finite) apply (simp add: icard_finite iT_Div_mod_partition_card) done lemma iT_Div_icard: " \ 0 < d; finite I \ Max I div d \ n\ \ - icard (I \ d) = + icard (I \ d) = (if finite I then enat (\k\n. if I \ [k * d\,d - Suc 0] = {} then 0 else Suc 0) else$$" by (simp add: icard_finite iT_Div_finite_iff iT_Div_card) -corollary iT_Div_Max_icard: "0 < d \ - icard (I \ d) = (if finite I +corollary iT_Div_Max_icard: "0 < d \ + icard (I \ d) = (if finite I then enat (\k\Max I div d. if I \ [k * d\,d - Suc 0] = {} then 0 else Suc 0) else \)" by (simp add: iT_Div_icard) lemma iT_Div_icard_le: "0 < k \ icard (I \ k) \ icard I" apply (case_tac "finite I") apply (simp add: iT_Div_finite_iff icard_finite iT_Div_card_le) apply simp done lemma iT_Div_icard_inj_on: "inj_on (\n. n div k) I \ icard (I \ k) = icard I" by (simp add: iT_Div_def icard_image) lemma iT_Div_icard_ge: "icard I div (enat d) + enat (if icard I mod (enat d) = 0 then 0 else Suc 0) \ icard (I \ d)" apply (case_tac "d = 0") apply (simp add: icard_finite iT_Div_0_finite) apply (case_tac "icard I") apply (fastforce simp: iT_Div_0_card_if) apply (simp add: iT_Div_0_card_if icard_infinite_conv infinite_imp_nonempty) apply (case_tac "finite I") apply (simp add: iT_Div_finite_iff icard_finite iT_Div_card_ge) apply (simp add: iT_Div_finite_iff) done corollary iT_Div_icard_ge_div: "icard I div (enat d) \ icard (I \ d)" by (rule iT_Div_icard_ge[THEN iadd_ileD1]) lemma iT_Div_icard_ge__is_maximal_lower_bound: " - \I d. icard I div (enat d) + enat (if icard I mod (enat d) = 0 then 0 else Suc 0) - \ f (icard I) d \ - f (icard I) d \ icard (I \ d) \ - f (icard (I::nat set)) d = + \I d. icard I div (enat d) + enat (if icard I mod (enat d) = 0 then 0 else Suc 0) + \ f (icard I) d \ + f (icard I) d \ icard (I \ d) \ + f (icard (I::nat set)) d = icard I div (enat d) + enat (if icard I mod (enat d) = 0 then 0 else Suc 0)" apply (case_tac "d = 0") apply (drule_tac x=I in spec, drule_tac x=d in spec, erule conjE) apply (simp add: iT_Div_0_icard_if icard_0_eq[unfolded zero_enat_def]) apply (case_tac "finite I") prefer 2 apply (drule_tac x=I in spec, drule_tac x=d in spec) apply simp apply simp apply (frule_tac iT_Div_finite_iff[THEN iffD2], assumption) apply (cut_tac f="\c d. the_enat (f (enat c) d)" and I=I and d=d in iT_Div_card_ge__is_maximal_lower_bound) apply (intro allI, rename_tac I' d') apply (subgoal_tac "\k. f 0 k = 0") prefer 2 apply (drule_tac x="{}" in spec, drule_tac x=k in spec, erule conjE) apply (simp add: iT_Div_empty) apply (drule_tac x=I' in spec, drule_tac x=d' in spec, erule conjE) apply (case_tac "d' = 0") apply (simp add: idiv_by_0 imod_by_0 iT_Div_0_card_if iT_Div_0_icard_if) apply (case_tac "I' = {}", simp) apply (case_tac "finite I'") apply (simp add: icard_finite) apply simp apply simp apply (case_tac "finite I'") apply (frule_tac I=I' and k=d' in iT_Div_finite_iff[THEN iffD2, rule_format], assumption) apply (simp add: icard_finite) apply (subgoal_tac "\n. f (enat (card I')) d' = enat n") prefer 2 apply (rule enat_ile, assumption) apply clarsimp apply (subgoal_tac "infinite (I' \ d')") prefer 2 apply (simp add: iT_Div_finite_iff) apply simp apply (drule_tac x=I in spec, drule_tac x=d in spec, erule conjE) apply (simp add: icard_finite) apply (subgoal_tac "\n. f (enat (card I)) d = enat n") prefer 2 apply (rule enat_ile, assumption) apply clarsimp done subsection \Results about sets of intervals\ subsubsection \Set of intervals without and with empty interval\ definition iFROM_UN_set :: "(nat set) set" where "iFROM_UN_set \ \n. {[n\]}" definition iTILL_UN_set :: "(nat set) set" where "iTILL_UN_set \ \n. {[\n]}" definition iIN_UN_set :: "(nat set) set" where "iIN_UN_set \ \n d. {[n\,d]}" definition iMOD_UN_set :: "(nat set) set" where "iMOD_UN_set \ \r m. {[r, mod m]}" definition iMODb_UN_set :: "(nat set) set" where "iMODb_UN_set \ \r m c. {[r, mod m, c]}" definition iFROM_set :: "(nat set) set" where "iFROM_set \ {[n\] |n. True}" definition iTILL_set :: "(nat set) set" where "iTILL_set \ {[\n] |n. True}" definition iIN_set :: "(nat set) set" where "iIN_set \ {[n\,d] |n d. True}" definition iMOD_set :: "(nat set) set" where "iMOD_set \ {[r, mod m] |r m. True}" definition iMODb_set :: "(nat set) set" where "iMODb_set \ {[r, mod m, c] |r m c. True}" definition iMOD2_set :: "(nat set) set" where "iMOD2_set \ {[r, mod m] |r m. 2 \ m}" definition iMODb2_set :: "(nat set) set" where "iMODb2_set \ {[r, mod m, c] |r m c. 2 \ m \ 1 \ c}" definition iMOD2_UN_set :: "(nat set) set" where "iMOD2_UN_set \ \r. \m\{2..}. {[r, mod m]}" definition iMODb2_UN_set :: "(nat set) set" where "iMODb2_UN_set \ \r. \m\{2..}. \c\{1..}. {[r, mod m, c]}" -lemmas i_set_defs = +lemmas i_set_defs = iFROM_set_def iTILL_set_def iIN_set_def iMOD_set_def iMODb_set_def iMOD2_set_def iMODb2_set_def -lemmas i_UN_set_defs = - iFROM_UN_set_def iTILL_UN_set_def iIN_UN_set_def +lemmas i_UN_set_defs = + iFROM_UN_set_def iTILL_UN_set_def iIN_UN_set_def iMOD_UN_set_def iMODb_UN_set_def iMOD2_UN_set_def iMODb2_UN_set_def lemma iFROM_set_UN_set_eq: "iFROM_set = iFROM_UN_set" by (fastforce simp: iFROM_set_def iFROM_UN_set_def) -lemma +lemma iTILL_set_UN_set_eq: "iTILL_set = iTILL_UN_set" and iIN_set_UN_set_eq: "iIN_set = iIN_UN_set" and iMOD_set_UN_set_eq: "iMOD_set = iMOD_UN_set" and iMODb_set_UN_set_eq: "iMODb_set = iMODb_UN_set" by (fastforce simp: i_set_defs i_UN_set_defs)+ lemma iMOD2_set_UN_set_eq: "iMOD2_set = iMOD2_UN_set" by (fastforce simp: i_set_defs i_UN_set_defs) lemma iMODb2_set_UN_set_eq: "iMODb2_set = iMODb2_UN_set" by (fastforce simp: i_set_defs i_UN_set_defs) lemmas i_set_i_UN_set_sets_eq = iFROM_set_UN_set_eq iTILL_set_UN_set_eq iIN_set_UN_set_eq iMOD_set_UN_set_eq iMODb_set_UN_set_eq iMOD2_set_UN_set_eq iMODb2_set_UN_set_eq lemma iMOD2_set_iMOD_set_subset: "iMOD2_set \ iMOD_set" by (fastforce simp: i_set_defs) lemma iMODb2_set_iMODb_set_subset: "iMODb2_set \ iMODb_set" by (fastforce simp: i_set_defs) definition i_set :: "(nat set) set" where "i_set \ iFROM_set \ iTILL_set \ iIN_set \ iMOD_set \ iMODb_set" definition i_UN_set :: "(nat set) set" where "i_UN_set \ iFROM_UN_set \ iTILL_UN_set \ iIN_UN_set \ iMOD_UN_set \ iMODb_UN_set" text \Minimal definitions for @{term i_set} and @{term i_set}\ definition i_set_min :: "(nat set) set" where "i_set_min \ iFROM_set \ iIN_set \ iMOD2_set \ iMODb2_set" definition i_UN_set_min :: "(nat set) set" where "i_UN_set_min \ iFROM_UN_set \ iIN_UN_set \ iMOD2_UN_set \ iMODb2_UN_set" definition i_set0 :: "(nat set) set" where "i_set0 \ insert {} i_set" lemma i_set_i_UN_set_eq: "i_set = i_UN_set" by (simp add: i_set_def i_UN_set_def i_set_i_UN_set_sets_eq) lemma i_set_min_i_UN_set_min_eq: "i_set_min = i_UN_set_min" by (simp add: i_set_min_def i_UN_set_min_def i_set_i_UN_set_sets_eq) lemma i_set_min_eq: "i_set = i_set_min" apply (unfold i_set_def i_set_min_def) apply (rule equalityI) apply (rule subsetI) apply (simp add: i_set_defs) apply (elim disjE) apply blast apply (fastforce simp: iIN_0_iTILL_conv[symmetric]) apply blast apply (elim exE) apply (case_tac "2 \ m", blast) apply (simp add: nat_ge2_conv) apply (fastforce simp: iMOD_0 iMOD_1) apply (elim exE) apply (case_tac "1 \ c") apply (case_tac "2 \ m", fastforce) - apply (simp add: nat_ge2_conv) + apply (simp add: nat_ge2_conv) apply (fastforce simp: iMODb_mod_0 iMODb_mod_1) apply (fastforce simp: linorder_not_le less_Suc_eq_le iMODb_0) apply (rule Un_mono)+ apply (simp_all add: iMOD2_set_iMOD_set_subset iMODb2_set_iMODb_set_subset) done corollary i_UN_set_i_UN_min_set_eq: "i_UN_set = i_UN_set_min" by (simp add: i_set_min_eq i_set_i_UN_set_eq[symmetric] i_set_min_i_UN_set_min_eq[symmetric]) lemma i_set_min_is_minimal_let: " let s1 = iFROM_set; s2= iIN_set; s3= iMOD2_set; s4= iMODb2_set in - s1 \ s2 = {} \ s1 \ s3 = {} \ s1 \ s4 = {} \ + s1 \ s2 = {} \ s1 \ s3 = {} \ s1 \ s4 = {} \ s2 \ s3 = {} \ s2 \ s4 = {} \ s3 \ s4 = {}" apply (unfold Let_def i_set_defs, intro conjI) apply (rule disjoint_iff_in_not_in1[THEN iffD2], clarsimp simp: iT_neq)+ done lemmas i_set_min_is_minimal = i_set_min_is_minimal_let[simplified] inductive_set i_set_ind:: "(nat set) set" where i_set_ind_FROM[intro!]: "[n\] \ i_set_ind" | i_set_ind_TILL[intro!]: "[\n] \ i_set_ind" | i_set_ind_IN[intro!]: "[n\,d] \ i_set_ind" | i_set_ind_MOD[intro!]: "[r, mod m] \ i_set_ind" | i_set_ind_MODb[intro!]: "[r, mod m, c] \ i_set_ind" inductive_set i_set0_ind :: "(nat set) set" where i_set0_ind_empty[intro!] : "{} \ i_set0_ind" | i_set0_ind_i_set[intro]: "I \ i_set_ind \ I \ i_set0_ind" text \ The introduction rule \i_set0_ind_i_set\ is not declared a safe introduction rule, because it would disturb the correct usage of the \safe\ method.\ lemma i_set_ind_subset_i_set0_ind: "i_set_ind \ i_set0_ind" by (rule subsetI, rule i_set0_ind_i_set) -lemma +lemma i_set0_ind_FROM[intro!] : "[n\] \ i_set0_ind" and i_set0_ind_TILL[intro!] : "[\n] \ i_set0_ind" and i_set0_ind_IN[intro!] : "[n\,d] \ i_set0_ind" and i_set0_ind_MOD[intro!] : "[r, mod m] \ i_set0_ind" and i_set0_ind_MODb[intro!] : "[r, mod m, c] \ i_set0_ind" by (rule subsetD[OF i_set_ind_subset_i_set0_ind], rule i_set_ind.intros)+ -lemmas i_set0_ind_intros2 = +lemmas i_set0_ind_intros2 = i_set0_ind_empty i_set0_ind_FROM i_set0_ind_TILL i_set0_ind_IN i_set0_ind_MOD i_set0_ind_MODb lemma i_set_i_set_ind_eq: "i_set = i_set_ind" apply (rule set_eqI, unfold i_set_def i_set_defs) apply (rule iffI, blast) apply (induct_tac x rule: i_set_ind.induct) apply blast+ done lemma i_set0_i_set0_ind_eq: "i_set0 = i_set0_ind" apply (rule set_eqI, unfold i_set0_def) apply (simp add: i_set_i_set_ind_eq) apply (rule iffI) apply blast apply (rule_tac a=x in i_set0_ind.cases) apply blast+ done lemma i_set_imp_not_empty: "I \ i_set \ I \ {}" apply (simp add: i_set_i_set_ind_eq) apply (induct I rule: i_set_ind.induct) apply (rule iT_not_empty)+ done lemma i_set0_i_set_mem_conv: "(I \ i_set0) = (I \ i_set \ I = {})" apply (simp add: i_set_i_set_ind_eq i_set0_i_set0_ind_eq) apply (rule iffI) apply (rule i_set0_ind.cases[of I]) apply blast+ done lemma i_set_i_set0_mem_conv: "(I \ i_set) = (I \ i_set0 \ I \ {})" apply (insert i_set_imp_not_empty[of I]) apply (fastforce simp: i_set0_i_set_mem_conv) done lemma i_set0_i_set_conv: "i_set0 - {{}} = i_set" by (fastforce simp: i_set_i_set0_mem_conv) corollary i_set_subset_i_set0: "i_set \ i_set0" by (simp add: i_set0_i_set_conv[symmetric]) lemma i_set_singleton: "{a} \ i_set" by (fastforce simp: i_set_def iIN_set_def iIN_0[symmetric]) lemma i_set0_singleton: "{a} \ i_set0" apply (rule subsetD[OF i_set_subset_i_set0]) apply (simp add: iIN_0[symmetric] i_set_i_set_ind_eq i_set_ind.intros) done corollary i_set_FROM[intro!] : "[n\] \ i_set" and i_set_TILL[intro!] : "[\n] \ i_set" and i_set_IN[intro!] : "[n\,d] \ i_set" and i_set_MOD[intro!] : "[r, mod m] \ i_set" and i_set_MODb[intro!] : "[r, mod m, c] \ i_set" by (rule ssubst[OF i_set_i_set_ind_eq], rule i_set_ind.intros)+ lemmas i_set_intros = i_set_FROM i_set_TILL i_set_IN i_set_MOD i_set_MODb lemma i_set0_empty[intro!]: "{} \ i_set0" and i_set0_FROM[intro!] : "[n\] \ i_set0" and i_set0_TILL[intro!] : "[\n] \ i_set0" and i_set0_IN[intro!] : "[n\,d] \ i_set0" and i_set0_MOD[intro!] : "[r, mod m] \ i_set0" and i_set0_MODb[intro!] : "[r, mod m, c] \ i_set0" by (rule ssubst[OF i_set0_i_set0_ind_eq], rule i_set0_ind_intros2)+ lemmas i_set0_intros = i_set0_empty i_set0_FROM i_set0_TILL i_set0_IN i_set0_MOD i_set0_MODb lemma i_set_infinite_as_iMOD:" \ I \ i_set; infinite I \ \ \r m. I = [r, mod m]" apply (simp add: i_set_i_set_ind_eq) apply (induct I rule: i_set_ind.induct) apply (simp_all add: iT_finite) apply (rule_tac x=n in exI, rule_tac x="Suc 0" in exI, simp add: iMOD_1) apply blast done lemma i_set_finite_as_iMODb:" \ I \ i_set; finite I \ \ \r m c. I = [r, mod m, c]" apply (simp add: i_set_i_set_ind_eq) apply (induct I rule: i_set_ind.induct) apply (simp add: iT_infinite) apply (rule_tac x=0 in exI, rule_tac x="Suc 0" in exI, rule_tac x=n in exI) apply (simp add: iMODb_mod_1 iIN_0_iTILL_conv) apply (rule_tac x=n in exI, rule_tac x="Suc 0" in exI, rule_tac x=d in exI) apply (simp add: iMODb_mod_1) apply (case_tac "m = 0") apply (rule_tac x=r in exI, rule_tac x="Suc 0" in exI, rule_tac x=0 in exI) apply (simp add: iMOD_0 iIN_0 iMODb_0) apply (simp add: iT_infinite) apply blast done lemma i_set_as_iMOD_iMODb: " I \ i_set \ (\r m. I = [r, mod m]) \ (\r m c. I = [r, mod m, c])" by (blast intro: i_set_finite_as_iMODb i_set_infinite_as_iMOD) subsubsection \Interval sets are closed under cutting\ lemma i_set_cut_le_ge_closed_disj: " - \ I \ i_set; t \ I; cut_op = (\\) \ cut_op = (\\) \ \ + \ I \ i_set; t \ I; cut_op = (\\) \ cut_op = (\\) \ \ cut_op I t \ i_set" apply (simp add: i_set_i_set_ind_eq) apply (induct rule: i_set_ind.induct) apply safe apply (simp_all add: iT_cut_le1 iT_cut_ge1 i_set_ind.intros iMODb_iff) done -corollary +corollary i_set_cut_le_closed: "\ I \ i_set; t \ I \ \ I \\ t \ i_set" and i_set_cut_ge_closed: "\ I \ i_set; t \ I \ \ I \\ t \ i_set" by (simp_all add: i_set_cut_le_ge_closed_disj) lemmas i_set_cut_le_ge_closed = i_set_cut_le_closed i_set_cut_ge_closed lemma i_set0_cut_closed_disj: " \ I \ i_set0; cut_op = (\\) \ cut_op = (\\) \ - cut_op = (\<) \ cut_op = (\>) \ \ + cut_op = (\<) \ cut_op = (\>) \ \ cut_op I t \ i_set0" apply (simp add: i_set0_i_set0_ind_eq) apply (induct rule: i_set0_ind.induct) apply (rule ssubst[OF set_restriction_empty, where P="\x. x \ i_set0_ind"]) apply (rule i_cut_set_restriction_disj[of cut_op], blast) apply blast apply blast apply (induct_tac I rule: i_set_ind.induct) apply safe apply (simp_all add: iT_cut_le iT_cut_ge iT_cut_less iT_cut_greater i_set0_ind_intros2) done -corollary +corollary i_set0_cut_le_closed: "I \ i_set0 \ I \\ t \ i_set0" and i_set0_cut_less_closed: "I \ i_set0 \ I \< t \ i_set0" and i_set0_cut_ge_closed: "I \ i_set0 \ I \\ t \ i_set0" and i_set0_cut_greater_closed: "I \ i_set0 \ I \> t \ i_set0" by (simp_all add: i_set0_cut_closed_disj) lemmas i_set0_cut_closed = - i_set0_cut_le_closed + i_set0_cut_le_closed i_set0_cut_less_closed i_set0_cut_ge_closed i_set0_cut_greater_closed subsubsection \Interval sets are closed under addition and multiplication\ lemma i_set_Plus_closed: "I \ i_set \ I \ k \ i_set" apply (simp add: i_set_i_set_ind_eq) apply (induct rule: i_set_ind.induct) apply (simp_all add: iT_add i_set_ind.intros) done lemma i_set_Mult_closed: "I \ i_set \ I \ k \ i_set" apply (case_tac "k = 0") apply (simp add: i_set_imp_not_empty iT_Mult_0_if i_set_intros) apply (simp add: i_set_i_set_ind_eq) apply (induct rule: i_set_ind.induct) apply (simp_all add: iT_mult i_set_ind.intros) done lemma i_set0_Plus_closed: "I \ i_set0 \ I \ k \ i_set0" apply (simp add: i_set0_i_set0_ind_eq) apply (induct I rule: i_set0_ind.induct) apply (simp add: iT_Plus_empty i_set0_ind_empty) apply (rule subsetD[OF i_set_ind_subset_i_set0_ind]) apply (simp add: i_set_i_set_ind_eq[symmetric] i_set_Plus_closed) done lemma i_set0_Mult_closed: "I \ i_set0 \ I \ k \ i_set0" apply (simp add: i_set0_i_set0_ind_eq) apply (induct I rule: i_set0_ind.induct) apply (simp add: iT_Mult_empty i_set0_ind_empty) apply (rule subsetD[OF i_set_ind_subset_i_set0_ind]) apply (simp add: i_set_i_set_ind_eq[symmetric] i_set_Mult_closed) done subsubsection \Interval sets are closed with certain conditions under subtraction\ lemma i_set_Plus_neg_closed: " \ I \ i_set; \x\I. k \ x \ \ I \- k \ i_set" apply (simp add: i_set_i_set_ind_eq) apply (induct rule: i_set_ind.induct) apply (fastforce simp: iT_iff iT_add_neg)+ done lemma i_set_Minus_closed: " \ I \ i_set; iMin I \ k \ \ k \ I \ i_set" apply (simp add: i_set_i_set_ind_eq) apply (induct rule: i_set_ind.induct) apply (fastforce simp: iT_Min iT_sub)+ done lemma i_set0_Plus_neg_closed: "I \ i_set0 \ I \- k \ i_set0" apply (simp add: i_set0_i_set0_ind_eq) apply (induct rule: i_set0_ind.induct) apply (fastforce simp: iT_Plus_neg_empty) apply (induct_tac I rule: i_set_ind.induct) apply (fastforce simp: iT_add_neg)+ done lemma i_set0_Minus_closed: "I \ i_set0 \ k \ I \ i_set0" apply (simp add: i_set0_i_set0_ind_eq) apply (induct rule: i_set0_ind.induct) apply (simp add: iT_Minus_empty i_set0_ind_empty) apply (induct_tac I rule: i_set_ind.induct) apply (fastforce simp: iT_sub)+ done lemmas i_set_IntOp_closed = i_set_Plus_closed i_set_Mult_closed i_set_Plus_neg_closed i_set_Minus_closed lemmas i_set0_IntOp_closed = i_set0_Plus_closed i_set0_Mult_closed i_set0_Plus_neg_closed i_set0_Minus_closed subsubsection \Interval sets are not closed under division\ lemma iMOD_div_mod_gr0_not_in_i_set: " \ 0 < k; k < m; 0 < m mod k \ \ [r, mod m] \ k \ i_set" apply (rule ccontr, simp) apply (drule i_set_infinite_as_iMOD) apply (simp add: iT_Div_finite_iff iMOD_infinite) apply (elim exE, rename_tac r' m') apply (frule iMOD_div_mod_gr0_not_ex[of k m r], assumption+) apply fastforce done lemma iMODb_div_mod_gr0_not_in_i_set: " \ 0 < k; k < m; 0 < m mod k; k \ c \ \ [r, mod m, c] \ k \ i_set" apply (rule ccontr, simp) apply (drule i_set_finite_as_iMODb) apply (simp add: iT_Div_finite_iff iMODb_finite) apply (elim exE, rename_tac r' m' c') apply (frule iMODb_div_mod_gr0_not_ex[of k m c r], assumption+) apply fastforce done lemma "[0, mod 3] \ 2 \ i_set" by (rule iMOD_div_mod_gr0_not_in_i_set, simp+) lemma i_set_Div_not_closed: "Suc 0 < k \ \I\i_set. I \ k \ i_set" apply (rule_tac x="[0, mod (Suc k)]" in bexI) apply (rule iMOD_div_mod_gr0_not_in_i_set) apply (simp_all add: mod_Suc i_set_MOD) done lemma i_set0_Div_not_closed: "Suc 0 < k \ \I\i_set0. I \ k \ i_set0" apply (frule i_set_Div_not_closed, erule bexE) apply (rule_tac x=I in bexI) apply (simp add: i_set0_def iT_Div_not_empty i_set_imp_not_empty) apply (rule subsetD[OF i_set_subset_i_set0], assumption) done subsubsection \Sets of intervals closed under division\ inductive_set NatMultiples :: "nat set \ nat set" for F :: "nat set" -where +where NatMultiples_Factor: "k \ F \ k \ NatMultiples F" | NatMultiples_Product: "\ k \ F; m \ NatMultiples F \ \ k * m \ NatMultiples F" lemma NatMultiples_ex_divisor: "m \ NatMultiples F \ \k\F. m mod k = 0" apply (induct m rule: NatMultiples.induct) apply (rule_tac x=k in bexI, simp+)+ done lemma NatMultiples_product_factor: "\ a \ F; b \ F \ \ a * b \ NatMultiples F" by (drule NatMultiples_Factor[of b], rule NatMultiples_Product) lemma NatMultiples_product_factor_multiple: " \ a \ F; b \ NatMultiples F \ \ a * b \ NatMultiples F" by (rule NatMultiples_Product) lemma NatMultiples_product_multiple_factor: " \ a \ NatMultiples F; b \ F \ \ a * b \ NatMultiples F" by (simp add: mult.commute[of a] NatMultiples_Product) lemma NatMultiples_product_multiple: " \ a \ NatMultiples F; b \ NatMultiples F \ \ a * b \ NatMultiples F" apply (induct a rule: NatMultiples.induct) apply (simp add: NatMultiples_Product) apply (simp add: mult.assoc[of _ _ b] NatMultiples_Product) done text \Subset of @{term i_set} containing only continuous intervals, i. e., without @{term iMOD} and @{term iMODb}.\ - + inductive_set i_set_cont :: "(nat set) set" where i_set_cont_FROM[intro]: "[n\] \ i_set_cont" | i_set_cont_TILL[intro]: "[\n] \ i_set_cont" | i_set_cont_IN[intro]: "[n\,d] \ i_set_cont" definition i_set0_cont :: "(nat set) set" where "i_set0_cont \ insert {} i_set_cont" lemma i_set_cont_subset_i_set: "i_set_cont \ i_set" apply (unfold subset_eq, rule ballI, rename_tac x) apply (rule_tac a=x in i_set_cont.cases) apply blast+ done lemma i_set0_cont_subset_i_set0: "i_set0_cont \ i_set0" apply (unfold i_set0_cont_def i_set0_def) apply (rule insert_mono) apply (rule i_set_cont_subset_i_set) done text \Minimal definition of @{term i_set_cont}\ - + inductive_set i_set_cont_min :: "(nat set) set" where i_set_cont_FROM[intro]: "[n\] \ i_set_cont_min" | i_set_cont_IN[intro]: "[n\,d] \ i_set_cont_min" definition i_set0_cont_min :: "(nat set) set" where "i_set0_cont_min \ insert {} i_set_cont_min" lemma i_set_cont_min_eq: "i_set_cont = i_set_cont_min" apply (rule set_eqI, rule iffI) apply (rename_tac x, rule_tac a=x in i_set_cont.cases) apply (fastforce simp: iIN_0_iTILL_conv[symmetric])+ apply (rename_tac x, rule_tac a=x in i_set_cont_min.cases) apply blast+ done text \\inext\ and \iprev\ with continuous intervals\ lemma i_set_cont_inext: " \ I \ i_set_cont; n \ I; finite I \ n < Max I \ \ inext n I = Suc n" apply (simp add: i_set_cont_min_eq) apply (rule i_set_cont_min.cases, assumption) apply (simp_all add: iT_finite iT_Max iT_inext_if iT_iff) done lemma i_set_cont_iprev: " \ I \ i_set_cont; n \ I; iMin I < n \ \ iprev n I = n - Suc 0" apply (simp add: i_set_cont_min_eq) apply (rule i_set_cont_min.cases, assumption) apply (simp_all add: iT_iprev_if iT_Min iT_iff) done lemma i_set_cont_inext__less: " \ I \ i_set_cont; n \ I; n < n0; n0 \ I \ \ inext n I = Suc n" apply (case_tac "finite I") apply (rule i_set_cont_inext, assumption+) apply (rule order_less_le_trans[OF _ Max_ge], assumption+) apply (rule i_set_cont.cases, assumption) apply (simp_all add: iT_finite iT_inext) done lemma i_set_cont_iprev__greater: " \ I \ i_set_cont; n \ I; n0 < n; n0 \ I \ \ iprev n I = n - Suc 0" apply (rule i_set_cont_iprev, assumption+) apply (rule order_le_less_trans[OF iMin_le, of n0], assumption+) done text \Sets of modulo intervals\ inductive_set i_set_mult :: "nat \ (nat set) set" for k :: nat where i_set_mult_FROM[intro!]: "[n\] \ i_set_mult k" | i_set_mult_TILL[intro!]: "[\n] \ i_set_mult k" | i_set_mult_IN[intro!]: "[n\,d] \ i_set_mult k" | i_set_mult_MOD[intro!]: "[r, mod m * k] \ i_set_mult k" | i_set_mult_MODb[intro!]: "[r, mod m * k, c] \ i_set_mult k" definition i_set0_mult :: "nat \ (nat set) set" where "i_set0_mult k \ insert {} (i_set_mult k)" lemma i_set0_mult_empty[intro!]: "{} \ i_set0_mult k" and i_set0_mult_FROM[intro!] : "[n\] \ i_set0_mult k" and i_set0_mult_TILL[intro!] : "[\n] \ i_set0_mult k" and i_set0_mult_IN[intro!] : "[n\,d] \ i_set0_mult k" and i_set0_mult_MOD[intro!] : "[r, mod m * k] \ i_set0_mult k" and i_set0_mult_MODb[intro!] : "[r, mod m * k, c] \ i_set0_mult k" by (simp_all add: i_set0_mult_def i_set_mult.intros) lemmas i_set0_mult_intros = i_set0_mult_empty i_set0_mult_FROM i_set0_mult_TILL i_set0_mult_IN i_set0_mult_MOD i_set0_mult_MODb lemma i_set_mult_subset_i_set0_mult: "i_set_mult k \ i_set0_mult k" by (unfold i_set0_mult_def, rule subset_insertI) lemma i_set_mult_subset_i_set: "i_set_mult k \ i_set" apply (clarsimp simp: subset_iff) apply (rule_tac a=t in i_set_mult.cases[of _ k]) apply (simp_all add: i_set_intros) done lemma i_set0_mult_subset_i_set0: "i_set0_mult k \ i_set0" apply (simp add: i_set0_mult_def i_set0_empty) apply (rule order_trans[OF _ i_set_subset_i_set0, OF i_set_mult_subset_i_set]) done lemma i_set_mult_0_eq_i_set_cont: "i_set_mult 0 = i_set_cont" apply (rule set_eqI, rule iffI) apply (rename_tac x, rule_tac a=x in i_set_mult.cases[of _ 0]) apply (simp_all add: i_set_cont.intros iMOD_0 iMODb_mod_0) apply (rename_tac x, rule_tac a=x in i_set_cont.cases) apply (simp_all add: i_set_mult.intros) done lemma i_set0_mult_0_eq_i_set0_cont: "i_set0_mult 0 = i_set0_cont" by (simp add: i_set0_mult_def i_set0_cont_def i_set_mult_0_eq_i_set_cont) lemma i_set_mult_1_eq_i_set: "i_set_mult (Suc 0) = i_set" apply (rule set_eqI, rule iffI) apply (rename_tac x, induct_tac x rule: i_set_mult.induct[of _ 1]) apply (simp_all add: i_set_intros) apply (simp add: i_set_i_set_ind_eq) apply (rename_tac x, induct_tac x rule: i_set_ind.induct) apply (simp_all add: i_set_mult.intros) apply (rule_tac t=m and s="m * Suc 0" in subst, simp, rule i_set_mult.intros)+ done lemma i_set0_mult_1_eq_i_set0: "i_set0_mult (Suc 0) = i_set0" by (simp add: i_set0_mult_def i_set0_def i_set_mult_1_eq_i_set) lemma i_set_mult_imp_not_empty: "I \ i_set_mult k \ I \ {}" by (induct I rule: i_set_mult.induct, simp_all add: iT_not_empty) lemma iMOD_in_i_set_mult_imp_divisor_mod_0: " \ m \ Suc 0; [r, mod m] \ i_set_mult k \ \ m mod k = 0" apply (case_tac "m = 0", simp) apply (rule i_set_mult.cases[of "[r, mod m]" k], assumption) apply (blast dest: iFROM_iMOD_neq) apply (blast dest: iTILL_iMOD_neq) apply (blast dest: iIN_iMOD_neq) apply (simp add: iMOD_eq_conv) apply (blast dest: iMOD_iMODb_neq) done -lemma +lemma divisor_mod_0_imp_iMOD_in_i_set_mult: "m mod k = 0 \ [r, mod m] \ i_set_mult k" and divisor_mod_0_imp_iMODb_in_i_set_mult: "m mod k = 0 \ [r, mod m, c] \ i_set_mult k" by (auto simp add: ac_simps) lemma iMOD_in_i_set_mult__divisor_mod_0_conv: " m \ Suc 0 \ ([r, mod m] \ i_set_mult k) = (m mod k = 0)" apply (rule iffI) apply (simp add: iMOD_in_i_set_mult_imp_divisor_mod_0) apply (simp add: divisor_mod_0_imp_iMOD_in_i_set_mult) done lemma i_set_mult_neq1_subset_i_set: "k \ Suc 0 \ i_set_mult k \ i_set" apply (rule psubsetI, rule i_set_mult_subset_i_set) apply (simp add: set_eq_iff) apply (drule neq_iff[THEN iffD1], erule disjE) apply (simp add: i_set_mult_0_eq_i_set_cont) apply (thin_tac "k = 0") apply (rule_tac x="[0, mod 2]" in exI) apply (rule ccontr) apply (simp add: i_set_intros) apply (drule i_set_cont.cases[where P=False]) apply (drule sym, simp add: iT_neq)+ apply simp apply (rule_tac x="[0, mod Suc k]" in exI) apply (rule ccontr) apply (simp add: i_set_intros) apply (insert iMOD_in_i_set_mult_imp_divisor_mod_0[of "Suc k" 0 k]) apply (simp add: mod_Suc) done lemma mod_0_imp_i_set_mult_subset: " a mod b = 0 \ i_set_mult a \ i_set_mult b" apply (auto simp add: ac_simps elim!: dvdE) apply (rule_tac a=x and k="k * b" in i_set_mult.cases) apply (simp_all add: i_set_mult.intros mult.assoc[symmetric]) done lemma i_set_mult_subset_imp_mod_0: " \ a \ Suc 0; (i_set_mult a \ i_set_mult b) \ \ a mod b = 0" apply (simp add: subset_iff) apply (erule_tac x="[0, mod a]" in allE) apply (simp add: divisor_mod_0_imp_iMOD_in_i_set_mult) apply (simp add: iMOD_in_i_set_mult_imp_divisor_mod_0[of _ 0 b]) done lemma i_set_mult_subset_conv: " a \ Suc 0 \ (i_set_mult a \ i_set_mult b) = (a mod b = 0)" apply (rule iffI) apply (simp add: i_set_mult_subset_imp_mod_0) apply (simp add: mod_0_imp_i_set_mult_subset) done lemma i_set_mult_mod_0_div: " \ I \ i_set_mult k; k mod d = 0 \ \ I \ d \ i_set_mult (k div d)" apply (case_tac "d = 0") apply (simp add: iT_Div_0[OF i_set_mult_imp_not_empty] i_set_mult.intros) apply (induct I rule: i_set_mult.induct) apply (simp_all add: iT_div i_set_mult.intros) apply (simp_all add: iMOD_div iMODb_div mod_0_imp_mod_mult_left_0 mod_0_imp_div_mult_left_eq i_set_mult.intros) done text \Intervals from @{term "i_set_mult k"} remain in @{term i_set} after division by @{term d} a divisor of @{term k}.\ corollary i_set_mult_mod_0_div_i_set: " \ I \ i_set_mult k; k mod d = 0 \ \ I \ d \ i_set" by (rule subsetD[OF i_set_mult_subset_i_set[of "k div d"]], rule i_set_mult_mod_0_div) corollary i_set_mult_div_self_i_set: " I \ i_set_mult k \ I \ k \ i_set" by (simp add: i_set_mult_mod_0_div_i_set) lemma i_set_mod_0_mult_in_i_set_mult: " \ I \ i_set; m mod k = 0 \ \ I \ m \ i_set_mult k" apply (case_tac "m = 0") apply (simp add: iT_Mult_0 i_set_imp_not_empty i_set_mult.intros) apply (clarsimp simp: mult.commute[of k] elim!: dvdE) apply (simp add: i_set_i_set_ind_eq) apply (rule_tac a=I in i_set_ind.cases) apply (simp_all add: iT_mult mult.assoc[symmetric] i_set_mult.intros) done lemma i_set_self_mult_in_i_set_mult: " I \ i_set \ I \ k \ i_set_mult k" by (rule i_set_mod_0_mult_in_i_set_mult[OF _ mod_self]) lemma i_set_mult_mod_gr0_div_not_in_i_set:" \ 0 < k; 0 < d; 0 < k mod d \ \ \I\i_set_mult k. I \ d \ i_set" apply (case_tac "d = Suc 0", simp) apply (frule iMOD_div_mod_gr0_not_ex[of d "Suc d * k" 0]) apply (rule Suc_le_lessD, rule gr0_imp_self_le_mult1, assumption) apply simp apply (rule_tac x="[0, mod Suc d * k]" in bexI) apply (rule ccontr, simp) apply (frule i_set_infinite_as_iMOD) apply (simp add: iT_Div_finite_iff iMOD_infinite) apply fastforce apply (simp add: i_set_mult.intros del: mult_Suc) done lemma i_set0_mult_mod_0_div: " \ I \ i_set0_mult k; k mod d = 0 \ \ I \ d \ i_set0_mult (k div d)" apply (simp add: i_set0_mult_def) apply (elim disjE) apply (simp add: iT_Div_empty) apply (simp add: i_set_mult_mod_0_div) done corollary i_set0_mult_mod_0_div_i_set0: " \ I \ i_set0_mult k; k mod d = 0 \ \ I \ d \ i_set0" by (rule subsetD[OF i_set0_mult_subset_i_set0[of "k div d"]], rule i_set0_mult_mod_0_div) corollary i_set0_mult_div_self_i_set0: " I \ i_set0_mult k \ I \ k \ i_set0" by (simp add: i_set0_mult_mod_0_div_i_set0) lemma i_set0_mod_0_mult_in_i_set0_mult: " \ I \ i_set0; m mod k = 0 \ \ I \ m \ i_set0_mult k" apply (simp add: i_set0_def) apply (erule disjE) apply (simp add: iT_Mult_empty i_set0_mult_empty) apply (rule subsetD[OF i_set_mult_subset_i_set0_mult]) apply (simp add: i_set_mod_0_mult_in_i_set_mult) done lemma i_set0_self_mult_in_i_set0_mult: " I \ i_set0 \ I \ k \ i_set0_mult k" by (simp add: i_set0_mod_0_mult_in_i_set0_mult) lemma i_set0_mult_mod_gr0_div_not_in_i_set0:" \ 0 < k; 0 < d; 0 < k mod d \ \ \I\i_set0_mult k. I \ d \ i_set0" apply (frule i_set_mult_mod_gr0_div_not_in_i_set[of k d], assumption+) apply (erule bexE, rename_tac I, rule_tac x=I in bexI) apply (simp add: i_set0_def iT_Div_not_empty i_set_mult_imp_not_empty) apply (simp add: subsetD[OF i_set_mult_subset_i_set0_mult]) done end diff --git a/thys/Probabilistic_Timed_Automata/PTA_Reachability.thy b/thys/Probabilistic_Timed_Automata/PTA_Reachability.thy --- a/thys/Probabilistic_Timed_Automata/PTA_Reachability.thy +++ b/thys/Probabilistic_Timed_Automata/PTA_Reachability.thy @@ -1,2268 +1,2268 @@ theory PTA_Reachability imports PTA begin section \Classifying Regions for Divergence\ subsection \Pairwise\ coinductive pairwise :: "('a \ 'a \ bool) \ 'a stream \ bool" for P where "P a b \ pairwise P (b ## xs) \ pairwise P (a ## b ## xs)" lemma pairwise_Suc: "pairwise P xs \ P (xs !! i) (xs !! (Suc i))" by (induction i arbitrary: xs) (force elim: pairwise.cases)+ lemma Suc_pairwise: "\ i. P (xs !! i) (xs !! (Suc i)) \ pairwise P xs" apply (coinduction arbitrary: xs) apply (subst stream.collapse[symmetric]) apply (rewrite in "stl _" stream.collapse[symmetric]) apply (intro exI conjI, rule HOL.refl) apply (erule allE[where x = 0]; simp; fail) by simp (metis snth.simps(2)) lemma pairwise_iff: "pairwise P xs \ (\ i. P (xs !! i) (xs !! (Suc i)))" using pairwise_Suc Suc_pairwise by blast lemma pairwise_stlD: "pairwise P xs \ pairwise P (stl xs)" by (auto elim: pairwise.cases) lemma pairwise_pairD: "pairwise P xs \ P (shd xs) (shd (stl xs))" by (auto elim: pairwise.cases) lemma pairwise_mp: assumes "pairwise P xs" and lift: "\ x y. x \ sset xs \ y \ sset xs \ P x y \ Q x y" shows "pairwise Q xs" using assms apply (coinduction arbitrary: xs) subgoal for xs apply (subst stream.collapse[symmetric]) apply (rewrite in "stl _" stream.collapse[symmetric]) apply (intro exI conjI) apply (rule HOL.refl) by (auto intro: stl_sset dest: pairwise_pairD pairwise_stlD) done lemma pairwise_sdropD: "pairwise P (sdrop i xs)" if "pairwise P xs" using that proof (coinduction arbitrary: i xs) case (pairwise i xs) then show ?case apply (inst_existentials "shd (sdrop i xs)" "shd (stl (sdrop i xs))" "stl (stl (sdrop i xs))") subgoal by (auto dest: pairwise_Suc) (metis sdrop_simps(1) sdrop_stl stream.collapse) subgoal by (inst_existentials "i - 1" "stl xs") (auto dest: pairwise_Suc pairwise_stlD) by (metis sdrop_simps(2) stream.collapse) qed subsection \Regions\ (* XXX Move. Rename? *) lemma gt_GreaterD: assumes "u \ region X I r" "valid_region X k I r" "c \ X" "u c > k c" shows "I c = Greater (k c)" proof - from assms have "intv_elem c u (I c)" "valid_intv (k c) (I c)" by auto with assms(4) show ?thesis by (cases "I c") auto qed lemma const_ConstD: assumes "u \ region X I r" "valid_region X k I r" "c \ X" "u c = d" "d \ k c" shows "I c = Const d" proof - from assms have "intv_elem c u (I c)" "valid_intv (k c) (I c)" by auto with assms(4,5) show ?thesis by (cases "I c") auto qed lemma not_Greater_bounded: assumes "I x \ Greater (k x)" "x \ X" "valid_region X k I r" "u \ region X I r" shows "u x \ k x" proof - from assms have "intv_elem x u (I x)" "valid_intv (k x) (I x)" by auto with assms(1) show "u x \ k x" by (cases "I x") auto qed lemma Greater_closed: fixes t :: "real" assumes "u \ region X I r" "valid_region X k I r" "c \ X" "I c = Greater (k c)" "t > k c" shows "u(c := t) \ region X I r" using assms apply (intro region.intros) apply (auto; fail) apply standard subgoal for x by (cases "x = c"; cases "I x"; force intro!: intv_elem.intros) by auto lemma Greater_unbounded_aux: assumes "finite X" "valid_region X k I r" "c \ X" "I c = Greater (k c)" shows "\ u \ region X I r. u c > t" using assms Greater_closed[OF _ assms(2-4)] proof - let ?R = "region X I r" let ?t = "if t > k c then t + 1 else k c + 1" have t: "?t > k c" by auto from region_not_empty[OF assms(1,2)] obtain u where u: "u \ ?R" by auto from Greater_closed[OF this assms(2-4) t] have "u(c:=?t) \ ?R" by auto with t show ?thesis by (inst_existentials "u(c:=?t)") auto qed subsection \Unbounded and Zero Regions\ definition "unbounded x R \ \ t. \ u \ R. u x > t" definition "zero x R \ \ u \ R. u x = 0" lemma Greater_unbounded: assumes "finite X" "valid_region X k I r" "c \ X" "I c = Greater (k c)" shows "unbounded c (region X I r)" using Greater_unbounded_aux[OF assms] unfolding unbounded_def by blast lemma unbounded_Greater: assumes "valid_region X k I r" "c \ X" "unbounded c (region X I r)" shows "I c = Greater (k c)" using assms unfolding unbounded_def by (auto intro: gt_GreaterD) lemma Const_zero: assumes "c \ X" "I c = Const 0" shows "zero c (region X I r)" using assms unfolding zero_def by force lemma zero_Const: assumes "finite X" "valid_region X k I r" "c \ X" "zero c (region X I r)" shows "I c = Const 0" proof - from assms obtain u where "u \ region X I r" by atomize_elim (auto intro: region_not_empty) with assms show ?thesis unfolding zero_def by (auto intro: const_ConstD) qed lemma zero_all: assumes "finite X" "valid_region X k I r" "c \ X" "u \ region X I r" "u c = 0" shows "zero c (region X I r)" proof - from assms have "intv_elem c u (I c)" "valid_intv (k c) (I c)" by auto then have "I c = Const 0" using assms(5) by cases auto with assms have "u' c = 0" if "u' \ region X I r" for u' using that by force then show ?thesis unfolding zero_def by blast qed section \Reachability\ subsection \Definitions\ locale Probabilistic_Timed_Automaton_Regions_Reachability = Probabilistic_Timed_Automaton_Regions k v n not_in_X A for k v n not_in_X and A :: "('c, t, 's) pta" + fixes \ \ :: "('s * ('c, t) cval) \ bool" fixes s assumes \: "\ x y. x \ S \ x ~ y \ \ x \ \ y" assumes \: "\ x y. x \ S \ x ~ y \ \ x \ \ y" assumes s[intro, simp]: "s \ S" begin definition "\' \ absp \" definition "\' \ absp \" definition "s' \ abss s" lemma s_s'_cfg_on[intro]: assumes "cfg \ MDP.cfg_on s" shows "absc cfg \ R_G.cfg_on s'" proof - from assms s have "cfg \ valid_cfg" unfolding MDP.valid_cfg_def by auto then have "absc cfg \ R_G.cfg_on (state (absc cfg))" by (auto intro: R_G.valid_cfgD) with assms show ?thesis unfolding s'_def by (auto simp: state_absc) qed lemma s'_$simp, intro]: "s' \ \" unfolding s'_def using s by auto lemma s'_s_cfg_on[intro]: assumes "cfg \ R_G.cfg_on s'" shows "repcs s cfg \ MDP.cfg_on s" proof - from assms s have "cfg \ R_G.valid_cfg" unfolding R_G.valid_cfg_def by auto with assms have "repcs s cfg \ valid_cfg" by (auto simp: s'_def intro: R_G.valid_cfgD) then show ?thesis by (auto dest: MDP.valid_cfgD) qed lemma (in Probabilistic_Timed_Automaton_Regions) compatible_stream: assumes \: "\ x y. x \ S \ x ~ y \ \ x \ \ y" assumes "pred_stream (\s. s \ S) xs" and [intro]: "x \ S" shows "pred_stream (\s. \ (reps (abss s)) = \ s) (x ## xs)" unfolding stream.pred_set proof clarify fix l u assume A: "(l, u) \ sset (x ## xs)" from assms have "pred_stream (\s. s \ S) (x ## xs)" by auto with A have "(l, u) \ S" by (fastforce simp: stream.pred_set) then have "abss (l, u) \ \" by auto then have "reps (abss (l, u)) ~ (l, u)" by simp with \ $$l, u) \ S\ show "\ (reps (abss (l, u))) = \ (l, u)" by blast qed lemma \_stream': "pred_stream (\s. \ (reps (abss s)) = \ s) (x ## xs)" if "pred_stream (\s. s \ S) xs" "x \ S" using compatible_stream[of \, OF \ that] . lemma \_stream': "pred_stream (\s. \ (reps (abss s)) = \ s) (x ## xs)" if "pred_stream (\s. s \ S) xs" "x \ S" using compatible_stream[of \, OF \ that] . lemmas \_stream = compatible_stream[of \, OF$ lemmas \_stream = compatible_stream[of \, OF \] subsection \Easier Result on All Configurations\ (* TODO: Rename *) lemma suntil_reps: assumes "\s\sset (smap abss y). s \ \" "(holds \' suntil holds \') (s' ## smap abss y)" shows "(holds \ suntil holds$$ (s ## y)" using assms by (subst region_compatible_suntil[symmetric]; (intro \_stream \_stream)?) (auto simp: \'_def \'_def absp_def stream.pred_set \_abss_S s'_def comp_def) (* TODO: Rename *) lemma suntil_abss: assumes "\s\sset y. s \ S" "(holds \ suntil holds \) (s ## y)" shows "(holds \' suntil holds \') (s' ## smap abss y)" using assms by (subst (asm) region_compatible_suntil[symmetric]; (intro \_stream \_stream)?) (auto simp: \'_def \'_def absp_def stream.pred_set s'_def comp_def) (* TODO: Generalize to CTL formulae *) theorem P_sup_sunitl_eq: notes [measurable] = in_space_UNIV and [iff] = pred_stream_iff shows "(MDP.P_sup s (\x. (holds \ suntil holds \) (s ## x))) = (R_G.P_sup s' (\x. (holds \' suntil holds \') (s' ## x)))" unfolding MDP.P_sup_def R_G.P_sup_def proof (rule SUP_eq, goal_cases) case prems: (1 cfg) let ?cfg' = "absc cfg" from prems have "cfg \ valid_cfg" by (auto intro: MDP.valid_cfgI) then have "?cfg' \ R_G.valid_cfg" by (auto intro: R_G.valid_cfgI) from \cfg \ valid_cfg\ have alw_S: "almost_everywhere (MDP.T cfg) (pred_stream (\s. s \ S))" by (rule MDP.alw_S) from \?cfg'\ R_G.valid_cfg\ have alw_\: "almost_everywhere (R_G.T ?cfg') (pred_stream (\s. s \ \))" by (rule R_G.alw_S) have "emeasure (MDP.T cfg) {x \ space MDP.St. (holds \ suntil holds \) (s ## x)} = emeasure (R_G.T ?cfg') {x \ space R_G.St. (holds \' suntil holds \') (s' ## x)}" apply (rule path_measure_eq_absc1_new[symmetric, where P = "pred_stream (\ s. s \ \)" and Q = "pred_stream (\ s. s \ S)"] ) using prems alw_S alw_\ apply (auto intro: MDP.valid_cfgI simp: )[7] by (auto simp: S_abss_\ intro: \_abss_S intro!: suntil_abss suntil_reps, measurable) with prems show ?case by (inst_existentials ?cfg') auto next case prems: (2 cfg) let ?cfg' = "repcs s cfg" have "s = state ?cfg'" by simp from prems have "s' = state cfg" by auto have "pred_stream (\s. \ (reps (abss s)) = \ s) (state (repcs s cfg) ## x)" if "pred_stream (\s. s \ S) x" for x using prems that by (intro \_stream) auto moreover have "pred_stream (\s. \ (reps (abss s)) = \ s) (state (repcs s cfg) ## x)" if "pred_stream (\s. s \ S) x" for x using prems that by (intro \_stream) auto ultimately have "emeasure (R_G.T cfg) {x \ space R_G.St. (holds \' suntil holds \') (s' ## x)} = emeasure (MDP.T (repcs s cfg)) {x \ space MDP.St. (holds \ suntil holds \) (s ## x)}" apply (rewrite in "s ## _" \s = _\) apply (subst \s' = _\) unfolding \'_def \'_def s'_def apply (rule path_measure_eq_repcs''_new) using prems by (auto 4 3 simp: s'_def intro: R_G.valid_cfgI MDP.valid_cfgI) with prems show ?case by (inst_existentials ?cfg') auto qed end (* PTA Reachability Problem *) subsection \Divergent Adversaries\ context Probabilistic_Timed_Automaton begin definition "elapsed u u' \ Max ({u' c - u c | c. c \ \} \ {0})" definition "eq_elapsed u u' \ elapsed u u' > 0 \ (\ c \ \. u' c - u c = elapsed u u')" fun dur :: "('c, t) cval stream \ nat \ t" where "dur _ 0 = 0" | "dur (x ## y ## xs) (Suc i) = elapsed x y + dur (y ## xs) i" definition "divergent \ \ \ t. \ n. dur \ n > t" definition "div_cfg cfg \ AE \ in MDP.MC.T cfg. divergent (smap (snd o state) \)" definition "\_div \ \ \x \ \. (\ i. (\ j \ i. zero x (\ !! j)) \ (\ j \ i. \ zero x (\ !! j))) \ (\ i. \ j \ i. unbounded x (\ !! j))" definition "R_G_div_cfg cfg \ AE \ in MDP.MC.T cfg. \_div (smap (snd o state) \)" end context Probabilistic_Timed_Automaton_Regions begin definition "cfg_on_div st \ MDP.cfg_on st \ {cfg. div_cfg cfg}" definition "R_G_cfg_on_div st \ R_G.cfg_on st \ {cfg. R_G_div_cfg cfg}" lemma measurable_\_div[measurable]: "Measurable.pred MDP.MC.S \_div" unfolding \_div_def by (intro pred_intros_finite[OF beta_interp.finite] pred_intros_logic pred_intros_countable measurable_count_space_const measurable_compose[OF measurable_snth] ) measurable lemma elapsed_ge0[simp]: "elapsed x y \ 0" unfolding elapsed_def using finite(1) by auto lemma dur_pos: "dur xs i \ 0" apply (induction i arbitrary: xs) apply (auto; fail) subgoal for i xs apply (subst stream.collapse[symmetric]) apply (rewrite at "stl xs" stream.collapse[symmetric]) apply (subst dur.simps) by simp done lemma dur_mono: "i \ j \ dur xs i \ dur xs j" proof (induction i arbitrary: xs j) case 0 show ?case by (auto intro: dur_pos) next case (Suc i xs j) obtain x y ys where xs: "xs = x ## y ## ys" using stream.collapse by metis from Suc obtain j' where j': "j = Suc j'" by (cases j) auto with xs have "dur xs j = elapsed x y + dur (y ## ys) j'" by auto also from Suc j' have "\ \ elapsed x y + dur (y ## ys) i" by auto also have "elapsed x y + dur (y ## ys) i = dur xs (Suc i)" by (simp add: xs) finally show ?case . qed lemma dur_monoD: assumes "dur xs i < dur xs j" shows "i < j" using assms by - (rule ccontr; auto 4 4 dest: leI dur_mono[where xs = xs]) lemma elapsed_0D: assumes "c \ \" "elapsed u u' \ 0" shows "u' c - u c \ 0" proof - from assms have "u' c - u c \ {u' c - u c | c. c \ \} \ {0}" by auto with finite(1) have "u' c - u c \ Max ({u' c - u c | c. c \ \} \ {0})" by auto with assms(2) show ?thesis unfolding elapsed_def by auto qed lemma elapsed_ge: assumes "eq_elapsed u u'" "c \ \" shows "elapsed u u' \ u' c - u c" using assms unfolding eq_elapsed_def by (auto intro: elapsed_ge0 order.trans[OF elapsed_0D]) lemma elapsed_eq: assumes "eq_elapsed u u'" "c \ \" "u' c - u c \ 0" shows "elapsed u u' = u' c - u c" using elapsed_ge[OF assms(1,2)] assms unfolding eq_elapsed_def by auto lemma dur_shift: "dur \ (i + j) = dur \ i + dur (sdrop i \) j" apply (induction i arbitrary: \) apply simp subgoal for i \ apply simp apply (subst stream.collapse[symmetric]) apply (rewrite at "stl \" stream.collapse[symmetric]) apply (subst dur.simps) apply (rewrite in "dur \" stream.collapse[symmetric]) apply (rewrite in "dur (_ ## \) (Suc _)" stream.collapse[symmetric]) apply (subst dur.simps) apply simp done done lemma dur_zero: assumes "\ i. xs !! i \ \ !! i" "\ j \ i. zero x (\ !! j)" "x \ \" "\ i. eq_elapsed (xs !! i) (xs !! Suc i)" shows "dur xs i = 0" using assms proof (induction i arbitrary: xs \) case 0 then show ?case by simp next case (Suc i xs \) let ?x = "xs !! 0" let ?y = "xs !! 1" let ?ys = "stl (stl xs)" have xs: "xs = ?x ## ?y ## ?ys" by auto from Suc.prems have "\ i. (?y ## ?ys) !! i \ stl \ !! i" "\ j \ i. zero x (stl \ !! j)" "\ i. eq_elapsed (stl xs !! i) (stl xs !! Suc i)" by (metis snth.simps(2) | auto)+ from Suc.IH[OF this(1,2) \x \ _\] this(3) have [simp]: "dur (stl xs) i = 0" by auto from Suc.prems(1,2) have "?y x = 0" "?x x = 0" unfolding zero_def by force+ then have *: "?y x - ?x x = 0" by simp have "dur xs (Suc i) = elapsed ?x ?y" apply (subst xs) apply (subst dur.simps) by simp also have "\ = 0" apply (subst elapsed_eq[OF _ \x \ _\]) unfolding One_nat_def using Suc.prems(4) apply blast using * by auto finally show ?case . qed lemma dur_zero_tail: assumes "\ i. xs !! i \ \ !! i" "\ k \ i. k \ j \ zero x (\ !! k)" "x \ \" "j \ i" "\ i. eq_elapsed (xs !! i) (xs !! Suc i)" shows "dur xs j = dur xs i" proof - from \j \ i\ dur_shift[of xs i "j - i"] have "dur xs j = dur xs i + dur (sdrop i xs) (j - i)" by simp also have "\ = dur xs i" using assms by (rewrite in "dur (sdrop _ _) _" dur_zero[where \ = "sdrop i \"]) (auto dest: prop_nth_sdrop_pair[of eq_elapsed] prop_nth_sdrop prop_nth_sdrop_pair[of "(\)"]) finally show ?thesis . qed lemma elapsed_ge_pos: fixes u :: "('c, t) cval" assumes "eq_elapsed u u'" "c \ \" "u \ V" "u' \ V" shows "elapsed u u' \ u' c" proof (cases "elapsed u u' = 0") case True with assms show ?thesis by (auto simp: V_def) next case False from \u \ V\ \c \ \ \ have "u c \ 0" by (auto simp: V_def) from False assms have "elapsed u u' = u' c - u c" unfolding eq_elapsed_def by (auto simp add: less_le) also from \u c \ 0\ have "\ \ u' c" by simp finally show ?thesis . qed lemma dur_Suc: "dur xs (Suc i) - dur xs i = elapsed (xs !! i) (xs !! Suc i)" apply (induction i arbitrary: xs) apply simp apply (subst stream.collapse[symmetric]) apply (rewrite in "stl _" stream.collapse[symmetric]) apply (subst dur.simps) apply simp apply simp subgoal for i xs apply (subst stream.collapse[symmetric]) apply (rewrite in "stl _" stream.collapse[symmetric]) apply (subst dur.simps) apply simp apply (rewrite in "dur xs (Suc _)" stream.collapse[symmetric]) apply (rewrite at "stl xs" in "_ ## stl xs" stream.collapse[symmetric]) apply (subst dur.simps) apply simp done done inductive trans where succ: "t \ 0 \ u' = u \ t \ trans u u'" | reset: "set l \ \ \ u' = clock_set l 0 u \ trans u u'" | id: "u = u' \ trans u u'" abbreviation "stream_trans \ pairwise trans" lemma K_cfg_trans: assumes "cfg \ MDP.cfg_on (l, R)" "cfg' \ K_cfg cfg" "state cfg' = (l', R')" shows "trans R R'" using assms apply (simp add: set_K_cfg) apply (drule MDP.cfg_onD_action) apply (cases rule: K.cases) apply (auto intro: trans.intros) using admissible_targets_clocks(2) by (blast intro: trans.intros(2)) lemma enabled_stream_trans: assumes "cfg \ valid_cfg" "MDP.MC.enabled cfg xs" shows "stream_trans (smap (snd o state) xs)" using assms proof (coinduction arbitrary: cfg xs) case prems: (pairwise cfg xs) let ?xs = "stl (stl xs)" let ?x = "shd xs" let ?y = "shd (stl xs)" from MDP.pred_stream_cfg_on[OF prems] have *: "pred_stream (\cfg. state cfg \ S \ cfg \ MDP.cfg_on (state cfg)) xs" . obtain l R l' R' where eq: "state ?x = (l, R)" "state ?y = (l', R')" by force moreover from * have "?x \ MDP.cfg_on (state ?x)" "?x \ valid_cfg" by (auto intro: MDP.valid_cfgI simp: stream.pred_set) moreover from prems(2) have "?y \ K_cfg ?x" by (auto elim: MDP.MC.enabled.cases) ultimately have "trans R R'" by (intro K_cfg_trans[where cfg = ?x and cfg' = ?y and l = l and l' = l']) metis+ with \?x \ valid_cfg\ prems(2) show ?case apply (inst_existentials R R' "smap (snd o state) ?xs") apply (simp add: eq; fail)+ apply (rule disjI1, inst_existentials ?x "stl xs") by (auto simp: eq elim: MDP.MC.enabled.cases) qed lemma stream_trans_trans: assumes "stream_trans xs" shows "trans (xs !! i) (stl xs !! i)" using pairwise_Suc assms by auto lemma trans_eq_elapsed: assumes "trans u u'" "u \ V" shows "eq_elapsed u u'" using assms proof cases case (succ t) with finite(1) show ?thesis by (auto simp: cval_add_def elapsed_def max_def eq_elapsed_def) next case prems: (reset l) then have "u' c - u c \ 0" if "c \ \" for c using that \u \ V\ by (cases "c \ set l") (auto simp: V_def) then have "elapsed u u' = 0" unfolding elapsed_def using finite(1) apply simp apply (subst Max_insert2) by auto then show ?thesis by (auto simp: eq_elapsed_def) next case id then show ?thesis using finite(1) by (auto simp: Max_gr_iff elapsed_def eq_elapsed_def) qed lemma pairwise_trans_eq_elapsed: assumes "stream_trans xs" "pred_stream (\ u. u \ V) xs" shows "pairwise eq_elapsed xs" using trans_eq_elapsed assms by (auto intro: pairwise_mp simp: stream.pred_set) lemma not_reset_dur: assumes "\k>i. k \ j \ \ zero c ([xs !! k]\<^sub>\)" "j \ i" "c \ \" "stream_trans xs" "\ i. eq_elapsed (xs !! i) (xs !! Suc i)" "\ i. xs !! i \ V" shows "dur xs j - dur xs i = (xs !! j) c - (xs !! i) c" using assms proof (induction j) case 0 then show ?case by simp next case (Suc j) from stream_trans_trans[OF Suc.prems(4)] have trans: "trans (xs !! j) (xs !! Suc j)" by auto from Suc.prems have *: "\ zero c ([xs !! Suc j]\<^sub>\)" "eq_elapsed (xs !! j) (xs !! Suc j)" if "Suc j > i" using that by auto from Suc.prems(6) have "xs !! j \ V" "xs !! Suc j \ V" by blast+ then have regions: "[xs !! j]\<^sub>\ \ \" "[xs !! Suc j]\<^sub>\ \ \" by auto from trans have "(xs !! Suc j) c - (xs !! j) c \ 0" if "Suc j > i" proof (cases) case succ with regions show ?thesis by (auto simp: cval_add_def) next case prems: (reset l) show ?thesis proof (cases "c \ set l") case False with prems show ?thesis by auto next case True with prems have "(xs !! Suc j) c = 0" by auto moreover from assms have "xs !! Suc j \ [xs !! Suc j]\<^sub>\" by blast ultimately have "zero c ([xs !! Suc j]\<^sub>\)" using zero_all[OF finite(1) _ \c \ \\] regions(2) by (auto simp: \_def) with * that show ?thesis by auto qed next case id then show ?thesis by simp qed with * \c \ \\ elapsed_eq have *: "elapsed (xs !! j) (xs !! Suc j) = (xs !! Suc j) c - (xs !! j) c" if "Suc j > i" using that by blast show ?case proof (cases "i = Suc j") case False with Suc have "dur xs (Suc j) - dur xs i = dur xs (Suc j) - dur xs j + (xs !! j) c - (xs !! i) c" by auto also have "\ = elapsed (xs !! j) (xs !! Suc j) + (xs !! j) c - (xs !! i) c" by (simp add: dur_Suc) also have "\ = (xs !! Suc j) c - (xs !! j) c + (xs !! j) c - (xs !! i) c" using * False Suc.prems by auto also have "\ = (xs !! Suc j) c - (xs !! i) c" by simp finally show ?thesis by auto next case True then show ?thesis by simp qed qed lemma not_reset_dur': assumes "\j\i. \ zero c ([xs !! j]\<^sub>\)" "j \ i" "c \ \" "stream_trans xs" "\ i. eq_elapsed (xs !! i) (xs !! Suc i)" "\ j. xs !! j \ V" shows "dur xs j - dur xs i = (xs !! j) c - (xs !! i) c" using assms not_reset_dur by auto lemma not_reset_unbounded: assumes "\j\i. \ zero c ([xs !! j]\<^sub>\)" "j \ i" "c \ \" "stream_trans xs" "\ i. eq_elapsed (xs !! i) (xs !! Suc i)" "\ j. xs !! j \ V" "unbounded c ([xs !! i]\<^sub>\)" shows "unbounded c ([xs !! j]\<^sub>\)" proof - let ?u = "xs !! i" let ?u' = "xs !! j" let ?R = "[xs !! i]\<^sub>\" from assms have "?u \ ?R" by auto from assms(6) have "?R \ \" by auto then obtain I r where "?R = region \ I r" "valid_region \ k I r" unfolding \_def by auto with assms(3,7) unbounded_Greater \?u \ ?R\ have "?u c > k c" by force also from not_reset_dur'[OF assms(1-6)] dur_mono[OF \j \ i\, of xs] have "?u' c \ ?u c" by auto finally have "?u' c > k c" by auto let ?R' = "[xs !! j]\<^sub>\" from assms have "?u' \ ?R'" by auto from assms(6) have "?R' \ \" by auto then obtain I r where "?R' = region \ I r" "valid_region \ k I r" unfolding \_def by auto moreover with \?u' c > _\ \?u' \ _\ gt_GreaterD \c \ \\ have "I c = Greater (k c)" by auto ultimately show ?thesis using Greater_unbounded[OF finite(1) _ \c \ \\] by auto qed lemma gt_unboundedD: assumes "u \ R" and "R \ \" and "c \ \" and "real (k c) < u c" shows "unbounded c R" proof - from assms obtain I r where "R = region \ I r" "valid_region \ k I r" unfolding \_def by auto with Greater_unbounded[of \ k I r c] gt_GreaterD[of u \ I r k c] assms finite(1) show ?thesis by auto qed definition trans' :: "('c, t) cval \ ('c, t) cval \ bool" where "trans' u u' \ ((\ c \ \. u c > k c \ u' c > k c \ u \ u') \ u' = u \ 0.5) \ ((\ c \ \. u c = 0 \ u' c > 0 \ (\c\\. \d. d \ k c \ u' c = real d)) \ u' = delayedR ([u']\<^sub>\) u)" (* XXX Move *) lemma zeroI: assumes "c \ \" "u \ V" "u c = 0" shows "zero c ([u]\<^sub>\)" proof - from assms have "u \ [u]\<^sub>\" "[u]\<^sub>\ \ \" by auto then obtain I r where "[u]\<^sub>\ = region \ I r" "valid_region \ k I r" unfolding \_def by auto with zero_all[OF finite(1) this(2) \c \ \\] \u \ [u]\<^sub>\\ \u c = 0\ show ?thesis by auto qed (* XXX Move, rename *) lemma zeroD: "u x = 0" if "zero x ([u]\<^sub>\)" "u \ V" using that by (metis regions_part_ex(1) zero_def) lemma not_zeroD: assumes "\ zero x ([u]\<^sub>\)" "u \ V" "x \ \" shows "u x > 0" proof - from zeroI assms have "u x \ 0" by auto moreover from assms have "u x \ 0" unfolding V_def by auto ultimately show ?thesis by auto qed (* XXX Move *) lemma not_const_intv: assumes "u \ V" "\c\\. \d. d \ k c \ u c = real d" shows "\c\\. \u \ [u]\<^sub>\. \d. d \ k c \ u c = real d" proof - from assms have "u \ [u]\<^sub>\" "[u]\<^sub>\ \ \" by auto then obtain I r where I: "[u]\<^sub>\ = region \ I r" "valid_region \ k I r" unfolding \_def by auto have "\d. d \ k c \ u' c = real d" if "c \ \" "u' \ [u]\<^sub>\" for c u' proof safe fix d assume A: "d \ k c" "u' c = real d" from I that have "intv_elem c u' (I c)" "valid_intv (k c) (I c)" by auto then show False using A I \u \ [u]\<^sub>\\ \c \ \\ assms(2) by (cases; fastforce) qed then show ?thesis by auto qed lemma K_cfg_trans': assumes "repcs (l, u) cfg \ MDP.cfg_on (l, u)" "cfg' \ K_cfg (repcs (l, u) cfg)" "state cfg' = (l', u')" "(l, u) \ S" "cfg \ R_G.valid_cfg" "abss (l, u) = state cfg" shows "trans' u u'" using assms apply (simp add: set_K_cfg) apply (drule MDP.cfg_onD_action) apply (cases rule: K.cases) apply assumption proof goal_cases case prems: (1 l u t) from assms \_ = (l, u)\ have "repcs (l, u) cfg \ valid_cfg" by (auto intro: MDP.valid_cfgI) then have "absc (repcs (l, u) cfg) \ R_G.valid_cfg" by auto from prems have *: "rept (l, u) (action cfg) = return_pmf (l, u \ t)" unfolding repcs_def by auto from \abss _ = _\ \_ = (l, u)\ \cfg \ R_G.valid_cfg\ have "action cfg \ \ (abss (l, u))" by (auto dest: R_G_I) from abst_rept_id[OF this] * have "action cfg = abst (return_pmf (l, u \ t))" by auto with prems have **: "action cfg = return_pmf (l, [u \ t]\<^sub>\)" unfolding abst_def by auto show ?thesis proof (cases "\ c \ \. u c > k c") case True from prems have "u \ t \ [u]\<^sub>\" by (auto intro: upper_right_closed[OF True]) with prems have "[u \ t]\<^sub>\ = [u]\<^sub>\" by (auto dest: alpha_interp.region_unique_spec) with ** have "action cfg = return_pmf (l, [u]\<^sub>\)" by simp with True have "rept (l, u) (action cfg) = return_pmf (l, u \ 0.5)" unfolding rept_def using prems by auto with * have "u \ t = u \ 0.5" by auto moreover from prems have "u' = u \ t" by auto moreover from prems True have "\ c \ \. u' c > k c" by (auto simp: cval_add_def) ultimately show ?thesis using True \_ = (l, u)\ unfolding trans'_def by auto next case F: False show ?thesis proof (cases "\c\\. u c = 0 \ 0 < u' c \ (\c\\. \d. d \ k c \ u' c = real d)") case True from prems have "u' \ [u']\<^sub>\" by auto from prems have "[u \ t]\<^sub>\ \ Succ \ ([u]\<^sub>\)" by auto from True obtain c where "c \ \" "u c = 0" "u' c > 0" by auto with zeroI prems have "zero c ([u]\<^sub>\)" by auto moreover from \u' \ _\ \u' c > 0\ have "\ zero c ([u']\<^sub>\)" unfolding zero_def by fastforce ultimately have "[u \ t]\<^sub>\ \ [u]\<^sub>\" using prems by auto moreover from True not_const_intv prems have "\ u \ [u \ t]\<^sub>\. \c\\. \d. d \ k c \ u c = real d" by auto ultimately have "\R'. (l, u) \ S \ action cfg = return_pmf (l, R') \ R' \ Succ \ ([u]\<^sub>\) \ [u]\<^sub>\ \ R' \ (\u\R'. \c\\. \d. d \ k c \ u c = real d)" apply - apply (rule exI[where x = "[u \ t]\<^sub>\"]) apply safe using prems ** by auto then have "rept (l, u) (action cfg) = return_pmf (l, delayedR (SOME R'. action cfg = return_pmf (l, R')) u)" unfolding rept_def by auto with * ** prems have "u' = delayedR ([u \ t]\<^sub>\) u" by auto with F True prems show ?thesis unfolding trans'_def by auto next case False with F \_ = (l, u)\ show ?thesis unfolding trans'_def by auto qed qed next case prems: (2 _ _ \ \) then obtain X where X: "u' = ([X := 0]u)" "(X, l') \ set_pmf \" by auto from \_ \ S\ have "u \ V" by auto let ?r = "SOME r. set r = X" show ?case proof (cases "X = {}") case True with X have "u = u'" by auto with non_empty show ?thesis unfolding trans'_def by auto next case False then obtain x where "x \ X" by auto moreover have "X \ \" using admissible_targets_clocks(1)[OF prems(10) X(2)] by auto ultimately have "x \ \" by auto from \X \ \\ finite(1) obtain r where "set r = X" using finite_list finite_subset by blast then have r: "set ?r = X" by (rule someI) with \x \ X\ X have "u' x = 0" by auto from X r \u \ V\ \X \ \\ have "u' x \ u x" for x by (cases "x \ X"; auto simp: V_def) have False if "u' x > 0 \ u x = 0" for x using \u' _ \ _$of x] that by auto with \u' x = 0\ show ?thesis using \x \ \\ unfolding trans'_def by auto qed next case 3 with non_empty show ?case unfolding trans'_def by auto qed coinductive enabled_repcs where "enabled_repcs (shd xs) (stl xs) \ shd xs = repcs st' cfg' \ st' \ rept st (action cfg) \ abss st' = state cfg' \ cfg' \ R_G.valid_cfg \ enabled_repcs (repcs st cfg) xs" (* XXX Move *) lemma K_cfg_rept_in: assumes "cfg \ R_G.valid_cfg" and "abss st = state cfg" and "cfg' \ K_cfg cfg" shows "(THE s'. s' \ set_pmf (rept st (action cfg)) \ abss s' = state cfg') \ set_pmf (rept st (action cfg))" proof - from assms(1,2) have "action cfg \ \ (abss st)" by (auto simp: R_G_I) from \cfg' \ _\ have "cfg' = cont cfg (state cfg')" "state cfg' \ action cfg" by (auto simp: set_K_cfg) with abst_rept_id[OF \action _ \ _$ pmf.set_map have "state cfg' \ abss  set_pmf (rept st (action cfg))" unfolding abst_def by metis then obtain st' where "st' \ rept st (action cfg)" "abss st' = state cfg'" unfolding abst_def by auto with K_cfg_rept_aux[OF assms(1,2) this(1)] show ?thesis by auto qed lemma enabled_repcsI: assumes "cfg \ R_G.valid_cfg" "abss st = state cfg" "MDP.MC.enabled (repcs st cfg) xs" shows "enabled_repcs (repcs st cfg) xs" using assms proof (coinduction arbitrary: cfg xs st) case prems: (enabled_repcs cfg xs st) let ?x = "shd xs" and ?y = "shd (stl xs)" let ?st = "THE s'. s' \ set_pmf (rept st (action cfg)) \ abss s' = state (absc ?x)" from prems(3) have "?x \ K_cfg (repcs st cfg)" by cases with K_cfg_map_repcs[OF prems(1,2)] obtain cfg' where "cfg' \ K_cfg cfg" "?x = repcs (THE s'. s' \ rept st (action cfg) \ abss s' = state cfg') cfg'" by auto let ?st = "THE s'. s' \ rept st (action cfg) \ abss s' = state cfg'" from K_cfg_rept_action[OF prems(1,2) \cfg' \ _\] have "abss ?st = state cfg'" . moreover from K_cfg_rept_in[OF prems(1,2) \cfg' \ _\] have "?st \ rept st (action cfg)" . moreover have "cfg' \ R_G.valid_cfg" using \cfg' \ K_cfg cfg\ prems(1) by blast moreover from absc_repcs_id[OF this \abss ?st = state cfg'\] \?x = _\ have "absc ?x = cfg'" by auto moreover from prems(3) have "MDP.MC.enabled (shd xs) (stl xs)" by cases ultimately show ?case using \?x = _\ by (inst_existentials xs ?st "absc ?x" st cfg) fastforce+ qed lemma repcs_eq_rept: "rept st (action cfg) = rept st'' (action cfg'')" if "repcs st cfg = repcs st'' cfg''" by (metis (mono_tags, lifting) action_cfg_corec old.prod.case repcs_def that) lemma enabled_stream_trans': assumes "cfg \ R_G.valid_cfg" "abss st = state cfg" "MDP.MC.enabled (repcs st cfg) xs" shows "pairwise trans' (smap (snd o state) xs)" using assms proof (coinduction arbitrary: cfg xs st) case prems: (pairwise cfg xs) let ?xs = "stl xs" from prems have A: "enabled_repcs (repcs st cfg) xs" by (auto intro: enabled_repcsI) then obtain st' cfg' where "enabled_repcs (shd xs) (stl xs)" "shd xs = repcs st' cfg'" "st' \ rept st (action cfg)" "abss st' = state cfg'" "cfg' \ R_G.valid_cfg" apply atomize_elim apply (cases rule: enabled_repcs.cases) apply assumption subgoal for st' cfg' st'' cfg'' by (inst_existentials st' cfg') (auto dest: repcs_eq_rept) done then obtain st'' cfg'' where "enabled_repcs (shd ?xs) (stl ?xs)" "shd ?xs = repcs st'' cfg''" "st'' \ rept st' (action cfg')" "abss st'' = state cfg''" by atomize_elim (subst (asm)enabled_repcs.simps, fastforce dest: repcs_eq_rept) let ?x = "shd xs" let ?y = "shd (stl xs)" let ?cfg = "repcs st cfg" from prems have "?cfg \ valid_cfg" by auto from MDP.pred_stream_cfg_on[OF \?cfg \ valid_cfg\ prems(3)] have *: "pred_stream (\cfg. state cfg \ S \ cfg \ MDP.cfg_on (state cfg)) xs" . obtain l u l' u' where eq: "st' = (l, u)" "st'' = (l', u')" by force moreover from * have "?x \ MDP.cfg_on (state ?x)" "?x \ valid_cfg" by (auto intro: MDP.valid_cfgI simp: stream.pred_set) moreover from prems(3) have "?y \ K_cfg ?x" by (auto elim: MDP.MC.enabled.cases) ultimately have "trans' u u'" using \?x = _\ \?y = _\ \cfg' \ _\ \abss st' = _\ by (intro K_cfg_trans') (auto dest: MDP.valid_cfg_state_in_S) with \?x \ valid_cfg\ \cfg' \ R_G.valid_cfg\ prems(3) \abss _ = state cfg'\ show ?case apply (inst_existentials u u' "smap (snd o state) (stl ?xs)") apply (simp add: eq \?x = _\ \?y = _\; fail)+ by ((intro disjI1 exI)?; auto simp: \?x = _\ \?y = _\ eq elim: MDP.MC.enabled.cases) qed lemma divergent_\_divergent: assumes in_S: "pred_stream (\ u. u \ V) xs" and div: "divergent xs" and trans: "stream_trans xs" shows "\_div (smap (\ u. [u]\<^sub>\) xs)" (is "\_div ?\") unfolding \_div_def proof (safe, simp_all) fix x i assume x: "x \ \" and bounded: "\i. \j\i. \ unbounded x ([xs !! j]\<^sub>\)" from in_S have xs_\: "\i. xs !! i \ ?\ !! i" by (auto simp: stream.pred_set) from trans in_S have elapsed: "\ i. eq_elapsed (xs !! i) (xs !! Suc i)" by (fastforce intro: pairwise_trans_eq_elapsed pairwise_Suc[where P = eq_elapsed]) { assume A: "\j \ i. \ zero x ([xs !! j]\<^sub>\)" let ?t = "dur xs i + k x" from div obtain j where j: "dur xs j > dur xs i + k x" unfolding divergent_def by auto then have "k x < dur xs j - dur xs i" by auto also with not_reset_dur'[OF A less_imp_le[OF dur_monoD], of xs] \x \ \\ assms elapsed have "\ = (xs !! j) x - (xs !! i) x" by (auto simp: stream.pred_set) also have "\ \ (xs !! j) x" using assms(1) \x \ \\ unfolding V_def by (auto simp: stream.pred_set) finally have "unbounded x ([xs !! j]\<^sub>\)" using assms \x \ \\ by (intro gt_unboundedD) (auto simp: stream.pred_set) moreover from dur_monoD[of xs i j] j A have "\j' \ j. \ zero x ([xs !! j']\<^sub>\)" by auto ultimately have "\i\j. unbounded x ([xs !! i]\<^sub>\)" using elapsed assms x by (auto intro: not_reset_unbounded simp: stream.pred_set) with bounded have False by auto } then show "\j\i. zero x ([xs !! j]\<^sub>\)" by auto { assume A: "\j \ i. zero x ([xs !! j]\<^sub>\)" from div obtain j where j: "dur xs j > dur xs i" unfolding divergent_def by auto then have "j \ i" by (auto dest: dur_monoD) from A have "\j \ i. zero x (?\ !! j)" by auto with dur_zero_tail[OF xs_\ _ x \i \ j\ elapsed] j have False by simp } then show "\j\i. \ zero x ([xs !! j]\<^sub>\)" by auto qed lemma (in -) fixes f :: "nat \ real" assumes "\ i. f i \ 0" "\ i. \ j \ i. f j > d" "d > 0" shows "\ n. (\ i \ n. f i) > t" oops (* TODO: Reduce this proof to a more general theorem *) lemma dur_ev_exceedsI: assumes "\ i. \ j \ i. dur xs j - dur xs i \ d" and "d > 0" obtains i where "dur xs i > t" proof - have base: "\ i. dur xs i > t" if "t < d" for t proof - from assms obtain j where "dur xs j - dur xs 0 \ d" by fastforce with dur_pos[of xs 0] have "dur xs j \ d" by simp with \d > 0\ \t < d\ show ?thesis by - (rule exI[where x = j]; auto) qed have base2: "\ i. dur xs i > t" if "t \ d" for t proof (cases "t = d") case False with \t \ d\ base show ?thesis by simp next case True from base \d > 0\ obtain i where "dur xs i > 0" by auto moreover from assms obtain j where "dur xs j - dur xs i \ d" by auto ultimately have "dur xs j > d" by auto with \t = d\ show ?thesis by auto qed show ?thesis proof (cases "t \ 0") case False with dur_pos have "dur xs 0 > t" by auto then show ?thesis by (fastforce intro: that) next case True let ?m = "nat \t / d\" from True have "\ i. dur xs i > ?m * d" proof (induction ?m arbitrary: t) case 0 with base[OF \0 < d\] show ?case by simp next case (Suc n t) let ?t = "t - d" show ?case proof (cases "t \ d") case True have "?t / d = t / d - 1" (* Generated by sledgehammer *) (* Alternative: by (smt assms(2) diff_divide_distrib divide_self_if) *) proof - have "t / d + - 1 * ((t + - 1 * d) / d) + - 1 * (d / d) = 0" by (simp add: diff_divide_distrib) then have "t / d + - 1 * ((t + - 1 * d) / d) = 1" using assms(2) by fastforce then show ?thesis by algebra qed then have "\?t / d\ = \t / d\ - 1" by simp with \Suc n = _\ have "n = nat \?t / d\" by simp with Suc \t \ d\ obtain i where "nat \?t / d\ * d < dur xs i" by fastforce from assms obtain j where "dur xs j - dur xs i \ d" "j \ i" by auto with \dur xs i > _\ have "nat \?t / d\ * d + d < dur xs j" by simp with True have "dur xs j > nat \t / d\ * d" by (metis Suc.hyps(2) \n = nat $$t - d) / d\\ add.commute distrib_left mult.commute mult.right_neutral of_nat_Suc) then show ?thesis by blast next case False with \t \ 0\ \d > 0\ have "nat \t / d\ \ 1" by simp then have "nat \t / d\ * d \ d" by (metis One_nat_def \Suc n = _\ Suc_leI add.right_neutral le_antisym mult.commute mult.right_neutral of_nat_0 of_nat_Suc order_refl zero_less_Suc) with base2 show ?thesis by auto qed qed then obtain i where "dur xs i > ?m * d" by atomize_elim moreover from \t \ 0\ \d > 0\ have "?m * d \ t" using pos_divide_le_eq real_nat_ceiling_ge by blast ultimately show ?thesis using that[of i] by simp qed qed lemma not_reset_mono: assumes "stream_trans xs" "shd xs c1 \ shd xs c2" "stream_all (\ u. u \ V) xs" "c2 \ \" shows "(holds (\ u. u c1 \ u c2) until holds (\ u. u c1 = 0)) xs" using assms proof (coinduction arbitrary: xs) case prems: (UNTIL xs) let ?xs = "stl xs" let ?x = "shd xs" let ?y = "shd ?xs" show ?case proof (cases "?x c1 = 0") case False show ?thesis proof (cases "?y c1 = 0") case False from prems have "trans ?x ?y" by (intro pairwise_pairD[of trans]) then have "?y c1 \ ?y c2" proof cases case A: (reset t) show ?thesis proof (cases "c1 \ set t") case True with A False show ?thesis by auto next case False from prems have "?x c2 \ 0" by (auto simp: V_def) with A have "?y c2 \ ?x c2" by (cases "c2 \ set t") auto with A False \?x c1 \ ?x c2\ show ?thesis by auto qed qed (use prems in \auto simp: cval_add_def$$ moreover from prems have "stream_trans ?xs" "stream_all (\ u. u \ V) ?xs" by (auto intro: pairwise_stlD stl_sset) ultimately show ?thesis using prems by auto qed (use prems in \auto intro: UNTIL.base\) qed auto qed lemma \_divergent_divergent_aux: fixes xs :: "('c, t) cval stream" assumes "stream_trans xs" "stream_all (\ u. u \ V) xs" "(xs !! i) c1 = 0" "\ k > i. k \ j \ (xs !! k) c2 = 0" "\ k > i. k \ j \ (xs !! k) c1 \ 0" "c1 \ \" "c2 \ \" shows "(xs !! j) c1 \ (xs !! j) c2" proof - from assms obtain k where k: "k > i" "k \ j" "(xs !! k) c2 = 0" by auto with assms(5) \k \ j\ have "(xs !! k) c1 \ 0" by auto moreover from assms(2) \c1 \ \\ have "(xs !! k) c1 \ 0" by (auto simp: V_def) ultimately have "(xs !! k) c1 > 0" by auto with $$xs !! k) c2 = 0\ have "shd (sdrop k xs) c1 \ shd (sdrop k xs) c2" by auto from not_reset_mono[OF _ this] assms have "(holds (\u. u c2 \ u c1) until holds (\u. u c1 = 0)) (sdrop k xs)" by (auto intro: sset_sdrop pairwise_sdropD) from assms(5) k(2) \k > i\ have "\ m \ j - k. (sdrop k xs !! m) c1 \ 0" by simp with holds_untilD[OF \(_ until _) _\, of "j - k"] have "(sdrop k xs !! (j - k)) c2 \ (sdrop k xs !! (j - k)) c1" . then show "(xs !! j) c2 \ (xs !! j) c1" using k(1,2) by simp qed lemma unbounded_all: assumes "R \ \" "u \ R" "unbounded x R" "x \ \" shows "u x > k x" proof - from assms obtain I r where R: "R = region \ I r" "valid_region \ k I r" unfolding \_def by auto with unbounded_Greater \x \ \\ assms(3) have "I x = Greater (k x)" by simp with \u \ R\ R \x \ \\ show ?thesis by force qed lemma trans_not_delay_mono: "u' c \ u c" if "trans u u'" "u \ V" "x \ \" "u' x = 0" "c \ \" using \trans u u'\ proof (cases) case (reset l) with that show ?thesis by (cases "c \ set l") (auto simp: V_def) qed (use that in \auto simp: cval_add_def V_def add_nonneg_eq_0_iff$$ lemma dur_reset: assumes "pairwise eq_elapsed xs" "pred_stream (\ u. u \ V) xs" "zero x ([xs !! Suc i]\<^sub>\)" "x \ \" shows "dur xs (Suc i) - dur xs i = 0" proof - from assms(2) have in_V: "xs !! Suc i \ V" unfolding stream.pred_set by auto (metis snth.simps(2) snth_sset) with elapsed_ge_pos[of "xs !! i" "xs !! Suc i" x] pairwise_Suc[OF assms(1)] assms(2-) have "elapsed (xs !! i) (xs !! Suc i) \ (xs !! Suc i) x" unfolding stream.pred_set by auto with in_V assms(3) have "elapsed (xs !! i) (xs !! Suc i) \ 0" by (auto simp: zeroD) with elapsed_ge0[of "xs !! i" "xs !! Suc i"] have "elapsed (xs !! i) (xs !! Suc i) = 0" by linarith then show ?thesis by (subst dur_Suc) qed lemma resets_mono_0': assumes "pairwise eq_elapsed xs" "stream_all (\ u. u \ V) xs" "stream_trans xs" "\ j \ i. zero x ([xs !! j]\<^sub>\)" "x \ \" "c \ \" shows "(xs !! i) c = (xs !! 0) c \ (xs !! i) c = 0" using assms proof (induction i) case 0 then show ?case by auto next case (Suc i) from Suc.prems have *: "(xs !! Suc i) x = 0" "(xs !! i) x = 0" by (blast intro: zeroD snth_sset, force intro: zeroD snth_sset) from pairwise_Suc[OF Suc.prems(3)] have "trans (xs !! i) (xs !! Suc i)" . then show ?case proof cases case prems: (succ t) with * have "t = 0" unfolding cval_add_def by auto with prems have "(xs !! Suc i) c = (xs !! i) c" unfolding cval_add_def by auto with Suc show ?thesis by auto next case prems: (reset l) then have "(xs !! Suc i) c = 0 \ (xs !! Suc i) c = (xs !! i) c" by (cases "c \ set l") auto with Suc show ?thesis by auto next case id with Suc show ?thesis by auto qed qed lemma resets_mono': assumes "pairwise eq_elapsed xs" "pred_stream (\ u. u \ V) xs" "stream_trans xs" "\ k \ i. k \ j \ zero x ([xs !! k]\<^sub>\)" "x \ \" "c \ \" "i \ j" shows "(xs !! j) c = (xs !! i) c \ (xs !! j) c = 0" using assms proof - from assms have 1: "stream_all (\ u. u \ V) (sdrop i xs)" using sset_sdrop unfolding stream.pred_set by force from assms have 2: "pairwise eq_elapsed (sdrop i xs)" by (intro pairwise_sdropD) from assms have 3: "stream_trans (sdrop i xs)" by (intro pairwise_sdropD) from assms have 4: "\k\j - i. zero x ([sdrop i xs !! k]\<^sub>\)" - by (simp add: le_diff_conv2 assms(6)) + by (simp add: Nat.le_diff_conv2 assms(6)) from resets_mono_0'[OF 2 1 3 4 assms(5,6)] \i \ j\ show ?thesis by simp qed lemma resets_mono: assumes "pairwise eq_elapsed xs" "pred_stream (\ u. u \ V) xs" "stream_trans xs" "\ k \ i. k \ j \ zero x ([xs !! k]\<^sub>\)" "x \ \" "c \ \" "i \ j" shows "(xs !! j) c \ (xs !! i) c" using assms using assms by (auto simp: V_def dest: resets_mono'[where c = c] simp: stream.pred_set) lemma \_divergent_divergent_aux2: fixes M :: "(nat \ bool) set" assumes "\ i. \ P \ M. \ j \ i. P j" "M \ {}" "finite M" shows "\i.\j\i.\k>j.\ P \ M. P j \ P k \ (\ m < k. j < m \ \ P m) \ (\ Q \ M. \ m \ k. j < m \ Q m)" proof fix i let ?j1 = "Max {LEAST m. m > i \ P m | P. P \ M}" from \M \ {}\ obtain P where "P \ M" by auto let ?m = "LEAST m. m > i \ P m" from assms(1) \P \ M\ obtain j where "j \ Suc i" "P j" by auto then have "j > i" "P j" by auto with \P \ M\ have "?m > i \ P ?m" by - (rule LeastI; auto) moreover with \finite M\ \P \ M\ have "?j1 \ ?m" by - (rule Max_ge; auto) ultimately have "?j1 \ i" by simp moreover have "\ m > i. m \ ?j1 \ P m" if "P \ M" for P proof - let ?m = "LEAST m. m > i \ P m" from assms(1) \P \ M\ obtain j where "j \ Suc i" "P j" by auto then have "j > i" "P j" by auto with \P \ M\ have "?m > i \ P ?m" by - (rule LeastI; auto) moreover with \finite M\ \P \ M\ have "?j1 \ ?m" by - (rule Max_ge; auto) ultimately show ?thesis by auto qed ultimately obtain j1 where j1: "j1 \ i" "\ P \ M. \ m > i. j1 \ m \ P m" by auto define k where "k Q = (LEAST k. k > j1 \ Q k)" for Q let ?k = "Max {k Q | Q. Q \ M}" let ?P = "SOME P. P \ M \ k P = ?k" let ?j = "Max {j. i \ j \ j \ j1 \ ?P j}" have "?k \ {k Q | Q. Q \ M}" using assms by - (rule Max_in; auto) then obtain P where P: "k P = ?k" "P \ M" by auto have "?k \ k Q" if "Q \ M" for Q using assms that by - (rule Max_ge; auto) have *: "?P \ M \ k ?P = ?k" using P by - (rule someI[where x = P]; auto) with j1 have "\ m > i. j1 \ m \ ?P m" by auto with \finite _\ have "?j \ {j. i \ j \ j \ j1 \ ?P j}" by - (rule Max_in; auto) have k: "k Q > j1 \ Q (k Q)" if "Q \ M" for Q proof - from assms(1) \Q \ M\ obtain m where "m \ Suc j1" "Q m" by auto then have "m > j1" "Q m" by auto then show "k Q > j1 \ Q (k Q)" unfolding k_def by - (rule LeastI; blast) qed with * \?j \ _\ have "?P ?k" "?j < ?k" by fastforce+ have "\ ?P m" if "?j < m" "m < ?k" for m proof (rule ccontr, simp) assume "?P m" have "m > j1" proof (rule ccontr) assume "\ j1 < m" with \?j < m\ \?j \ _\ have "i \ m" "m \ j1" by auto with \?P m\ \finite _\ have "?j \ m" by - (rule Max_ge; auto) with \?j < m\ show False by simp qed with \?P m\ \finite _\ have "k ?P \ m" unfolding k_def by (auto intro: Least_le) with * \m < ?k\ show False by auto qed moreover have "\ m \ ?k. ?j < m \ Q m" if "Q \ M" for Q proof - from k[OF \Q \ M\] have "k Q > j1 \ Q (k Q)" . moreover with \finite _\ \Q \ M\ have "k Q \ ?k" by - (rule Max_ge; auto) moreover with \?j \ _\ \k Q > _ \ _\ have "?j < k Q" by auto ultimately show ?thesis by auto qed ultimately show "\j\i.\k>j.\ P \ M. P j \ P k \ (\ m < k. j < m \ \ P m) \ (\ Q \ M. \ m \ k. j < m \ Q m)" using \?j < ?k\ \?j \ _\ \?P ?k\ * by (inst_existentials ?j ?k ?P; blast) qed lemma \_divergent_divergent: assumes in_S: "pred_stream (\ u. u \ V) xs" and div: "\_div (smap (\ u. [u]\<^sub>\) xs)" and trans: "stream_trans xs" and trans': "pairwise trans' xs" and unbounded_not_const: "\u. (\c\\. real (k c) < u c) \ \ ev (alw (\xs. shd xs = u)) xs" shows "divergent xs" unfolding divergent_def proof fix t from pairwise_trans_eq_elapsed[OF trans in_S] have eq_elapsed: "pairwise eq_elapsed xs" . define X1 where "X1 = {x. x \ \ \ (\i. \ j \ i. unbounded x ([xs !! j]\<^sub>\))}" let ?i = "Max {(SOME i. \ j \ i. unbounded x ([xs !! j]\<^sub>\)) | x. x \ \}" from finite(1) non_empty have "?i \ {(SOME i. \ j \ i. unbounded x ([xs !! j]\<^sub>\)) | x. x \ \}" by (intro Max_in) auto have "unbounded x ([xs !! j]\<^sub>\)" if "x \ X1" "j \ ?i" for x j proof - have "X1 \ \" unfolding X1_def by auto with finite(1) non_empty \x \ X1\ have *: "?i \ (SOME i. \ j \ i. unbounded x ([xs !! j]\<^sub>\))" (is "?i \ ?k") by (intro Max_ge) auto from \x \ X1\ have "\ k. \ j \ k. unbounded x ([xs !! j]\<^sub>\)" by (auto simp: X1_def) then have "\ j \ ?k. unbounded x ([xs !! j]\<^sub>\)" by (rule someI_ex) moreover from \j \ ?i\ \?i \ _\ have "j \ ?k" by auto ultimately show ?thesis by blast qed then obtain i where unbounded: "\ x \ X1. \ j \ i. unbounded x ([xs !! j]\<^sub>\)" using finite by auto show "\ n. t < dur xs n" proof (cases "\ x \ \. (\i. \ j \ i. unbounded x ([xs !! j]\<^sub>\))") case True then have "X1 = \" unfolding X1_def by auto have "\k\j. 0.5 \ dur xs k - dur xs j" for j proof - let ?u = "xs !! max i j" from in_S have "?u \ [?u]\<^sub>\" "[?u]\<^sub>\ \ \" by (auto simp: stream.pred_set) moreover from unbounded \X1 = \\ have "\ x \ \. unbounded x ([?u]\<^sub>\)" by force ultimately have "\ x \ \. ?u x > k x" by (auto intro: unbounded_all) with unbounded_not_const have "\ ev (alw (HLD {?u})) xs" unfolding HLD_iff by simp then obtain r where "r \ max i j" "xs !! r \ xs !! Suc r" apply atomize_elim apply (simp add: not_ev_iff not_alw_iff) apply (drule alw_sdrop[where n = "max i j"]) apply (drule alwD) apply (subst (asm) (3) stream.collapse[symmetric]) apply simp apply (drule ev_neq_start_implies_ev_neq[simplified comp_def]) using stream.collapse[of "sdrop (max i j) xs"] by (auto 4 3 elim: ev_sdropD) let ?k = "Suc r" from in_S have "xs !! ?k \ V" using snth_sset unfolding stream.pred_set by blast with in_S have *: "xs !! r \ [xs !! r]\<^sub>\" "[xs !! r]\<^sub>\ \ \" "xs !! ?k \ [xs !! ?k]\<^sub>\" "[xs !! ?k]\<^sub>\ \ \" by (auto simp: stream.pred_set) from \r \ _\ have "r \ i" "?k \ i" by auto with unbounded \X1 = \\ have "\ x \ \. unbounded x ([xs !! r]\<^sub>\)" "\ x \ \. unbounded x ([xs !! ?k]\<^sub>\)" by (auto simp del: snth.simps(2)) with in_S have "\ x \ \. (xs !! r) x > k x" "\ x \ \. (xs !! ?k) x > k x" using * by (auto intro: unbounded_all) moreover from trans' have "trans' (xs !! r) (xs !! ?k)" using pairwise_Suc by auto ultimately have "(xs !! ?k) = (xs !! r) \ 0.5" unfolding trans'_def using \xs !! r \ _\ by auto moreover from pairwise_Suc[OF eq_elapsed] have "eq_elapsed (xs !! r) (xs !! ?k)" by auto ultimately have "dur xs ?k - dur xs r = 0.5" using non_empty by (auto simp: cval_add_def dur_Suc elapsed_eq) with dur_mono[of j r xs] \r \ max i j\ have "dur xs ?k - dur xs j \ 0.5" by auto with \r \ max i j\ show ?thesis by - (rule exI[where x = ?k]; auto) qed then show ?thesis by - (rule dur_ev_exceedsI[where d = "0.5"]; auto) next case False define X2 where "X2 = \ - X1" from False have "X2 \ {}" unfolding X1_def X2_def by fastforce have inf_resets: "\i. (\j\i. zero x ([xs !! j]\<^sub>\)) \ (\j\i. \ zero x ([xs !! j]\<^sub>\))" if "x \ X2" for x using that div unfolding X1_def X2_def \_div_def by fastforce have "\ j \ i. \ k > j. \ x \ X2. zero x ([xs !! j]\<^sub>\) \ zero x ([xs !! k]\<^sub>\) \ (\ m. j < m \ m < k \ \ zero x ([xs !! m]\<^sub>\)) \ (\ x \ X2. \ m. j < m \ m \ k \ zero x ([xs !! m]\<^sub>\)) \ (\ x \ X1. \ m \ j. unbounded x ([xs !! m]\<^sub>\))" for i proof - from unbounded obtain i' where i': "\ x \ X1. \ m \ i'. unbounded x ([xs !! m]\<^sub>\)" by auto then obtain i' where i': "i' \ i" "\ x \ X1. \ m \ i'. unbounded x ([xs !! m]\<^sub>\)" by (cases "i' \ i"; auto) from finite(1) have "finite X2" unfolding X2_def by auto with \X2 \ {}\ \_divergent_divergent_aux2[where M = "{\ i. zero x ([xs !! i]\<^sub>\) | x. x \ X2}"] inf_resets have "\j\i'. \k>j. \P\{\i. zero x ([xs !! i]\<^sub>\) |x. x \ X2}. P j \ P k \ (\m \ P m) \ (\Q\{\i. zero x ([xs !! i]\<^sub>\) |x. x \ X2}. \m\k. j < m \ Q m)" by force then obtain j k x where "j \ i'" "k > j" "x \ X2" "zero x ([xs !! j]\<^sub>\)" "zero x ([xs !! k]\<^sub>\)" "\m. j < m \ m < k \ \ zero x ([xs !! m]\<^sub>\)" "\Q\{\i. zero x ([xs !! i]\<^sub>\) |x. x \ X2}. \m\k. j < m \ Q m" by auto moreover from this(7) have "\x\X2. \m \ k. j < m \ zero x ([xs !! m]\<^sub>\)" by auto ultimately show ?thesis using i' by (inst_existentials j k x) auto qed moreover have "\ j' \ j. dur xs j' - dur xs i \ 0.5" if x: "x \ X2" "i < j" "zero x ([xs !! i]\<^sub>\)" "zero x ([xs !! j]\<^sub>\)" and not_reset: "\ m. i < m \ m < j \ \ zero x ([xs !! m]\<^sub>\)" and X2: "\ x \ X2. \ m. i < m \ m \ j \ zero x ([xs !! m]\<^sub>\)" and X1: "\ x \ X1. \ m \ i. unbounded x ([xs !! m]\<^sub>\)" for x i j proof - have "\j'>j. \ zero x ([xs !! j']\<^sub>\)" proof - from inf_resets[OF x(1)] obtain j' where "j' \ Suc j" "\ zero x ([xs !! j']\<^sub>\)" by auto then show ?thesis by - (rule exI[where x = j']; auto) qed from inf_resets[OF x(1)] obtain j' where "j' \ Suc j" "\ zero x ([xs !! j']\<^sub>\)" by auto with nat_eventually_critical_path[OF x(4) this(2)] obtain j' where j': "j' > j" "\ zero x ([xs !! j']\<^sub>\)" "\ m \ j. m < j' \ zero x ([xs !! m]\<^sub>\)" by auto from \x \ X2\ have "x \ \" unfolding X2_def by simp with \i < j\ not_reset not_reset_dur \stream_trans _\ in_S pairwise_Suc[OF eq_elapsed] have "dur xs (j - 1) - dur xs i = (xs !! (j - 1)) x - (xs !! i) x" (is "?d1 = ?d2") by (auto simp: stream.pred_set) moreover from \zero x ([xs !! i]\<^sub>\)\ in_S have "(xs !! i) x = 0" by (auto intro: zeroD simp: stream.pred_set) ultimately have "dur xs (j - 1) - dur xs i = (xs !! (j - 1)) x" (is "?d1 = ?d2") by simp show ?thesis proof (cases "?d1 \ 0.5") case True (* XXX Fix SMT *) with dur_mono[of "j - 1" j xs] have "5 / 10 \ dur xs j - dur xs i" by simp then show ?thesis by blast next case False have j_c_bound: "(xs !! j) c \ ?d2" if "c \ X2" for c proof (cases "(xs !! j) c = 0") case True from in_S \j > _\ True \x \ \\ show ?thesis by (auto simp: V_def stream.pred_set) next case False from X2 \c \ X2\ in_S have "\k>i. k \ j \ (xs !! k) c = 0" by (force simp: zeroD stream.pred_set) with False have "\k>i. k \ j - Suc 0 \ (xs !! k) c = 0" by (metis Suc_le_eq Suc_pred linorder_neqE_nat not_less not_less_zero) moreover from that have "c \ \" by (auto simp: X2_def) moreover from not_reset in_S \x \ \\ have "\k>i. k \ j - 1 \ (xs !! k) x \ 0" by (auto simp: zeroI stream.pred_set) ultimately have "(xs !! (j - 1)) c \ ?d2" using trans in_S \_ x = 0\ \x \ \\ by (auto intro: \_divergent_divergent_aux that simp: stream.pred_set) moreover from trans_not_delay_mono[OF pairwise_Suc[OF trans], of "j - 1"] \x \ \\ \c \ \\ \j > _\ in_S x(4) have "(xs !! j) c \ (xs !! (j - 1)) c" by (auto simp: zeroD stream.pred_set) ultimately show ?thesis by auto qed moreover from False \?d1 = ?d2\ have "?d2 < 1" by auto moreover from in_S have "(xs !! j) c \ 0" if "c \ \" for c using that by (auto simp: V_def stream.pred_set) ultimately have frac_bound: "frac ((xs !! j) c) \ ?d2" if "c \ X2" for c using that frac_le_1I by (force simp: X2_def) let ?u = "(xs !! j)" from in_S have "[xs !! j]\<^sub>\ \ \" by (auto simp: stream.pred_set) then obtain I r where region: "[xs !! j]\<^sub>\ = region \ I r" "valid_region \ k I r" unfolding \_def by auto let ?S = "{frac (?u c) | c. c \ \ \ isIntv (I c)}" have \_X2: "c \ X2" if "c \ \" "isIntv (I c)" for c proof - from X1 \j > i\ have "\x\X1. unbounded x ([xs !! j]\<^sub>\)" by auto with unbounded_Greater[OF region(2) \c \ \\] region(1) that(2) have "c \ X1" by auto with \c \ \\ show "c \ X2" unfolding X2_def by auto qed have frac_bound: "frac ((xs !! j) c) \ ?d2" if "c \ \" "isIntv (I c)" for c using frac_bound[OF \_X2] that . have "dur xs (j' - 1) = dur xs j" using j' \x \ \\ in_S eq_elapsed by (subst dur_zero_tail[where \ = "smap (\ u. [u]\<^sub>\) xs"]) (auto dest: pairwise_Suc simp: stream.pred_set) moreover from dur_reset[OF eq_elapsed in_S, of x "j - 1"] \x \ \\ x(4) \j > _\ have "dur xs j = dur xs (j - 1)" by (auto simp: stream.pred_set) ultimately have "dur xs (j' - 1) = dur xs (j - 1)" by auto moreover have "dur xs j' - dur xs (j' - 1) \ (1 - ?d2) / 2" proof - from \j' > _\ have "j' > 0" by auto with pairwise_Suc[OF trans', of "j' - 1"] have "trans' (xs !! (j' - 1)) (xs !! j')" by auto moreover from j' have "(xs !! (j' - 1)) x = 0" "(xs !! j') x > 0" using in_S \x \ \\ by (force intro: zeroD dest: not_zeroD simp: stream.pred_set)+ moreover note delayedR_aux = calculation obtain t where "(xs !! j') = (xs !! (j' - 1)) \ t" "t \ (1 - ?d2) / 2" "t \ 0" proof - from in_S have "[xs !! j']\<^sub>\ \ \" by (auto simp: stream.pred_set) then obtain I' r' where region': "[xs !! j']\<^sub>\ = region \ I' r'" "valid_region \ k I' r'" unfolding \_def by auto let ?S' = "{frac ((xs !! (j' - 1)) c) |c. c \ \ \ Regions.isIntv (I' c)}" from finite(1) have "?d2 \ Max (?S' \ {0})" apply - apply (rule Max.boundedI) apply fastforce apply fastforce apply safe subgoal premises prems for _ c d proof - from j' have "(xs !! (j' - 1)) c = ?u c \ (xs !! (j' - 1)) c = 0" by (intro resets_mono'[OF eq_elapsed in_S trans _ \x \ \\ \c \ \\]; auto) then show ?thesis proof (standard, goal_cases) case A: 1 show ?thesis proof (cases "c \ X1") case True with X1 \j' > j\ \j > i\ have "unbounded c ([xs !! j']\<^sub>\)" by auto with region' \c \ \\ have "I' c = Greater (k c)" by (auto intro: unbounded_Greater) with prems show ?thesis by auto next case False with \c \ \\ have "c \ X2" unfolding X2_def by auto with j_c_bound have mono: "(xs !! j) c \ (xs !! (j - 1)) x" . from in_S \c \ \\ have "(xs !! (j' - 1)) c \ 0" unfolding V_def stream.pred_set by auto then have "frac ((xs !! (j' - 1)) c) \ (xs !! (j' - 1)) c" using frac_le_self by auto with A mono show ?thesis by auto qed next case prems: 2 (* XXX *) have "frac (0 :: real) = (0 :: real)" by auto then have "frac (0 :: real) \ (0 :: real)" by linarith moreover from in_S \x \ \\ have "(xs !! (j - 1)) x \ 0" unfolding V_def stream.pred_set by auto ultimately show ?thesis using prems by auto qed qed using in_S \x \ \\ by (auto simp: V_def stream.pred_set) then have le: "(1 - ?d2) / 2 \ (1 - Max (?S' \ {0})) / 2" by simp let ?u = "xs !! j'" let ?u' = "xs !! (j' - 1)" from in_S have *: "?u' \ V" "[?u']\<^sub>\ \ \" "?u \ V" "[?u]\<^sub>\ \ \" by (auto simp: stream.pred_set) from pairwise_Suc[OF trans, of "j' - 1"] \j' > j\ have "trans (xs !! (j' - 1)) (xs !! j')" by auto then have Succ: "[xs !! j']\<^sub>\ \ Succ \ ([xs !! (j' - 1)]\<^sub>\) \ (\ t\ 0. ?u = ?u' \ t)" proof cases case prems: (succ t) from * have "?u' \ [?u']\<^sub>\" by auto with prems * show ?thesis by auto next case (reset l) with \?u' \ V\ have "?u x \ ?u' x" by (cases "x \ set l") (auto simp: V_def) from j' have "zero x ([?u']\<^sub>\)" by auto with \?u' \ V\ have "?u' x = 0" unfolding zero_def by auto with \?u x \ _\ \?u x > 0\ show ?thesis by auto next case id with * Succ_refl[of \ \ k, folded \_def, OF _ finite(1)] show ?thesis unfolding cval_add_def by auto qed then obtain t where t: "?u = xs !! (j' - 1) \ t" "t \ 0" by auto note Succ = Succ[THEN conjunct1] show ?thesis proof (cases "\ c \ X2. \ d :: nat. ?u c = d") case True from True obtain c and d :: nat where c: "c \ \" "c \ X2" "?u c = d" by (auto simp: X2_def) have "?u x > 0" by fact from pairwise_Suc[OF eq_elapsed, of "j' - 1"] \j' > j\ have "eq_elapsed (xs !! (j' - 1)) ?u" by auto moreover from elapsed_eq[OF this \x \ \\] $$xs !! (j' - 1)) x = 0\ \(xs !! j') x > 0\ have "elapsed (xs !! (j' - 1)) (xs !! j') > 0" by auto ultimately have "?u c - (xs !! (j' - 1)) c > 0" using \c \ \\ unfolding eq_elapsed_def by auto moreover from in_S have "xs !! (j' - 1) \ V" by (auto simp: stream.pred_set) ultimately have "?u c > 0" using \c \ \\ unfolding V_def by auto from region' in_S \c \ \\ have "intv_elem c ?u (I' c)" by (force simp: stream.pred_set) with \?u c = d\ \?u c > 0\ have "?u c \ 1" by auto moreover have "(xs !! (j' - 1)) c \ 0.5" proof - have "(xs !! (j' - 1)) c \ (xs !! j) c" (* XXX This proof is duplicated at least once above *) using j'(1,3) by (auto intro: resets_mono[OF eq_elapsed in_S trans _ \x \ \\ \c \ \\]) also have "\ \ ?d2" using j_c_bound[OF \c \ X2\] . also from \?d1 = ?d2\ \\ 5 / 10 \ _\ have "\ \ 0.5" by simp finally show ?thesis . qed moreover have "?d2 \ 0" using in_S \x \ \\ by (auto simp: V_def stream.pred_set) ultimately have "?u c - (xs !! (j' - 1)) c \ (1 - ?d2) / 2" by auto with t have "t \ (1 - ?d2) / 2" unfolding cval_add_def by auto with t show ?thesis by (auto intro: that) next case F: False have not_const: "\ isConst (I' c)" if "c \ \" for c proof (rule ccontr, simp) assume A: "isConst (I' c)" show False proof (cases "c \ X1") case True with X1 \j' > j\ \j > _\ have "unbounded c ([xs !! j']\<^sub>$$" by auto with unbounded_Greater \c \ \\ region' have "isGreater (I' c)" by force with A show False by auto next case False with \c \ \\ have "c \ X2" unfolding X2_def by auto from region' in_S \c \ \\ have "intv_elem c ?u (I' c)" unfolding stream.pred_set by force with \c \ X2\ A False F show False by auto qed qed have "\x. x \ k c \ (xs !! j') c = real x" if "c \ \" for c proof (cases "c \ X2"; safe) fix d assume "c \ X2" "(xs !! j') c = real d" with F show False by auto next fix d assume "c \ X2" with that have "c \ X1" unfolding X2_def by auto with X1 \j' > j\ \j > i\ have "unbounded c ([?u]\<^sub>\)" by auto from unbounded_all[OF _ _ this] \c \ \\ in_S have "?u c > k c" by (force simp: stream.pred_set) moreover assume "?u c = real d" "d \ k c" ultimately show False by auto qed with delayedR_aux have "(xs !! j') = delayedR ([xs !! j']\<^sub>\) (xs !! (j' - 1))" using \x \ \\ unfolding trans'_def by auto from not_const region'(1) in_S Succ(1) have "\t\0. delayedR ([xs !! j']\<^sub>\) (xs !! (j' - 1)) = xs !! (j' - 1) \ t \ (1 - Max (?S' \ {0})) / 2 \ t" apply simp apply (rule delayedR_correct(2)[OF _ _ region'(2), simplified]) by (auto simp: stream.pred_set) with le \_ = delayedR _ _\ show ?thesis by (auto intro: that) qed qed moreover from pairwise_Suc[OF eq_elapsed, of "j' - 1"] \j' > 0\ have "eq_elapsed (xs !! (j' - 1)) (xs !! j')" by auto ultimately show "dur xs j' - dur xs (j' - 1) \ (1 - ?d2) / 2" using \j' > 0\ dur_Suc[of _ "j' - 1"] \x \ \\ by (auto simp: cval_add_def elapsed_eq) qed moreover from dur_mono[of i "j - 1" xs] \i < j\ have "dur xs i \ dur xs (j - 1)" by simp ultimately have "dur xs j' - dur xs i \ 0.5" unfolding \?d1 = ?d2$symmetric] by auto then show ?thesis using \j < j'\ by - (rule exI[where x = j']; auto) qed qed moreover have "\ j' \ i. dur xs j' - dur xs i \ 0.5" for i proof - from calculation(1)[of i] obtain j k x where "j\i" "k>j" "x\X2" "zero x ([xs !! j]\<^sub>\)" "zero x ([xs !! k]\<^sub>\)" "\m. j < m \ m < k \ \ zero x ([xs !! m]\<^sub>\)" "\x\X2. \m>j. m \ k \ zero x ([xs !! m]\<^sub>\)" "\x\X1. \m\j. unbounded x ([xs !! m]\<^sub>\)" by auto from calculation(2)[OF this(3,2,4-8)] obtain j' where "j'\k" "5 / 10 \ dur xs j' - dur xs j" by auto with dur_mono[of i j xs] \j \ i\ \k > j\ show ?thesis by (intro exI[where x = j']; auto) qed then show ?thesis by - (rule dur_ev_exceedsI[where d = "0.5"]; auto) qed qed lemma cfg_on_div_absc: notes in_space_UNIV[measurable] assumes "cfg \ cfg_on_div st" "st \ S" shows "absc cfg \ R_G_cfg_on_div (abss st)" proof - from assms have *: "cfg \ MDP.cfg_on st" "state cfg = st" "div_cfg cfg" unfolding cfg_on_div_def by auto with assms have "cfg \ valid_cfg" by (auto intro: MDP.valid_cfgI) have "almost_everywhere (MDP.MC.T cfg) (MDP.MC.enabled cfg)" by (rule MDP.MC.AE_T_enabled) moreover from * have "AE x in MDP.MC.T cfg. divergent (smap (snd \ state) x)" by (simp add: div_cfg_def) ultimately have "AE x in MDP.MC.T cfg. \_div (smap (snd \ state) (smap absc x))" proof eventually_elim case (elim \) let ?xs = "smap (snd o state) \" from MDP.pred_stream_cfg_on[OF \_ \ valid_cfg\ \MDP.MC.enabled _ _$ have *: "pred_stream (\ x. x \ S) (smap state \)" by (auto simp: stream.pred_set) have "[snd (state x)]\<^sub>\ = snd (abss (state x))" if "x \ sset \" for x proof - from * that have "state x \ S" by (auto simp: stream.pred_set) then have "snd (abss (state x)) = [snd (state x)]\<^sub>\" by (metis abss_S snd_conv surj_pair) then show ?thesis .. qed then have "smap (\z. [snd (state z)]\<^sub>\) \ = (smap (\z. snd (abss (state z))) \)" by auto from * have "pred_stream (\ u. u \ V) ?xs" apply (simp add: map_def stream.pred_set) apply (subst (asm) surjective_pairing) using S_V by blast moreover have "stream_trans ?xs" by (rule enabled_stream_trans \_ \ valid_cfg\ \MDP.MC.enabled _ _\)+ ultimately show ?case using \divergent _\ \smap _ \ = _\ by - (drule divergent_\_divergent, auto simp add: stream.map_comp state_absc) qed with \cfg \ valid_cfg\ have "R_G_div_cfg (absc cfg)" unfolding R_G_div_cfg_def by (subst absc_distr_self) (auto intro: MDP.valid_cfgI simp: AE_distr_iff) with R_G.valid_cfgD \cfg \ valid_cfg\ * show ?thesis unfolding R_G_cfg_on_div_def by auto force qed definition "alternating cfg = (AE \ in MDP.MC.T cfg. alw (ev (HLD {cfg. \cfg' \ K_cfg cfg. fst (state cfg') = fst (state cfg)})) \)" lemma K_cfg_same_loc_iff: "(\cfg'\ K_cfg cfg. fst (state cfg') = fst (state cfg)) \ (\cfg'\ K_cfg (absc cfg). fst (state cfg') = fst (state (absc cfg)))" if "cfg \ valid_cfg" using that by (auto simp: state_absc fst_abss K_cfg_map_absc) lemma (in -) stream_all2_flip: "stream_all2 (\a b. R b a) xs ys = stream_all2 R ys xs" by (standard; coinduction arbitrary: xs ys; auto dest: sym) (* TODO: Lots of duplication here, e.g. with path_measure_eq_repcs1_new *) lemma AE_alw_ev_same_loc_iff: assumes "cfg \ valid_cfg" shows "alternating cfg \ alternating (absc cfg)" unfolding alternating_def apply (simp add: MDP.MC.T.AE_iff_emeasure_eq_1) subgoal proof - show ?thesis (is "(?x = 1) = (?y = 1)") proof - have *: "stream_all2 (\s t. t = absc s) x y = stream_all2 (=) y (smap absc x)" for x y by (subst stream_all2_flip) simp have "?x = ?y" apply (rule T_eq_rel_half[where f = absc and S = valid_cfg, OF HOL.refl, rotated 2]) subgoal apply (simp add: space_stream_space rel_set_strong_def) apply (intro allI impI) apply (frule stream.rel_mono_strong[where Ra = "\s t. t = absc s"]) by (auto simp: * stream.rel_eq stream_all2_refl alw_holds_pred_stream_iff[symmetric] K_cfg_same_loc_iff HLD_def elim!: alw_ev_cong) subgoal by (rule rel_funI) (auto intro!: rel_pmf_reflI simp: pmf.rel_map(2) K_cfg_map_absc) using \cfg \ valid_cfg\ by simp+ then show ?thesis by simp qed qed done lemma AE_alw_ev_same_loc_iff': assumes "cfg \ R_G.cfg_on (abss st)" "st \ S" shows "alternating cfg \ alternating (repcs st cfg)" proof - from assms have "cfg \ R_G.valid_cfg" by (auto intro: R_G.valid_cfgI) with assms show ?thesis by (subst AE_alw_ev_same_loc_iff) (auto simp: absc_repcs_id) qed lemma (in -) cval_add_non_id: False if "b \ d = b" "d > 0" for d :: real proof - from that(1) have "(b \ d) x = b x" by (rule fun_cong) with \d > 0\ show False unfolding cval_add_def by simp qed lemma repcs_unbounded_AE_non_loop_end_strong: assumes "cfg \ R_G.cfg_on (abss st)" "st \ S" and "alternating cfg" shows "AE \ in MDP.MC.T (repcs st cfg). (\ u :: ('c \ real). (\ c \ \. u c > real (k c)) \ \ (ev (alw (\ xs. shd xs = u))) (smap (snd o state) \))" (is "AE \ in ?M. ?P \") proof - from assms have "cfg \ R_G.valid_cfg" by (auto intro: R_G.valid_cfgI) with assms(1) have "repcs st cfg \ valid_cfg" by auto from R_G.valid_cfgD[OF \cfg \ R_G.valid_cfg\] have "cfg \ R_G.cfg_on (state cfg)" . let ?U = "\ u. \ l \ L. {\ \ K (l, u). \ \ return_pmf (l, u) \ (\ x \ \. fst x = l)}" let ?r = "\ u. Sup ({0} \ (\ \. measure_pmf \ {x. snd x = u})  ?U u)" have lt_1: "?r u < 1" for u proof - have *: "emeasure (measure_pmf \) {x. snd x = u} < 1" if "\ \ return_pmf (l, u)" "\x\set_pmf \. fst x = l" for \ and l :: 's proof (rule ccontr) assume "\ emeasure (measure_pmf \) {x. snd x = u} < 1" then have "1 = emeasure (measure_pmf \) {x. snd x = u}" using measure_pmf.emeasure_ge_1_iff by force also from that(2) have "\ \ emeasure (measure_pmf \) {(l, u)}" by (subst emeasure_Int_set_pmf[symmetric]) (auto intro!: emeasure_mono) finally show False by (simp add: measure_pmf.emeasure_ge_1_iff measure_pmf_eq_1_iff that(1)) qed let ?S = "{map_pmf (\ (X, l). (l, ([X := 0]u))) \ | \ l g. (l, g, \) \ trans_of A}" have "(\ \. measure_pmf \ {x. snd x = u})  ?U u \ {0, 1} \ (\ \. measure_pmf \ {x. snd x = u})  ?S" by (force elim!: K.cases) moreover have "finite ?S" proof - have "?S \ (\ (l, g, \). map_pmf (\ (X, l). (l, ([X := 0]u))) \)  trans_of A" by force also from finite(3) have "finite \" .. finally show ?thesis . qed ultimately have "finite ((\ \. measure_pmf \ {x. snd x = u})  ?U u)" by (auto intro: finite_subset) then show ?thesis by (fastforce intro: * finite_imp_Sup_less) qed { fix l :: 's and u :: "'c \ real" and cfg :: "('s \ ('c \ real) set) cfg" assume unbounded: "\ c \ \. u c > k c" and "cfg \ R_G.cfg_on (abss (l, u))" "abss (l, u) \ \" and same_loc: "\ cfg' \ K_cfg cfg. fst (state cfg') = l" then have "cfg \ R_G.valid_cfg" "repcs (l, u) cfg \ valid_cfg" by (auto intro: R_G.valid_cfgI) then have cfg_on: "repcs (l, u) cfg \ MDP.cfg_on (l, u)" by (auto dest: MDP.valid_cfgD) from \cfg \ R_G.cfg_on _\ have "action cfg \ \ (abss (l, u))" by (rule R_G.cfg_onD_action) (* TODO: Pull out? *) have K_cfg_rept: "state  K_cfg (repcs (l, u) cfg) = rept (l, u) (action cfg)" unfolding K_cfg_def by (force simp: action_repcs) have "l \ L" using MDP.valid_cfg_state_in_S \repcs (l, u) cfg \ MDP.valid_cfg\ by fastforce moreover have "rept (l, u) (action cfg) \ return_pmf (l, u)" proof (rule ccontr, simp) assume "rept (l, u) (action cfg) = return_pmf (l, u)" then have "action cfg = return_pmf (abss (l, u))" using abst_rept_id[OF \action cfg \ _\] by (simp add: abst_def) moreover have "(l, u) \ S" using \_ \ \\ by (auto dest: \_abss_S) moreover have "abss (l, u) = (l, [u]\<^sub>\)" by (metis abss_S calculation(2)) ultimately show False using \rept (l, u) _ = _\ unbounded unfolding rept_def by (auto dest: cval_add_non_id) qed moreover have "rept (l, u) (action cfg) \ K (l, u)" proof - have "action (repcs (l, u) cfg) \ K (l, u)" using cfg_on by blast then show ?thesis by (simp add: repcs_def) qed moreover have "\x\set_pmf (rept (l, u) (action cfg)). fst x = l" using same_loc K_cfg_same_loc_iff[of "repcs (l, u) cfg"] \repcs (l, u) _ \ valid_cfg\ \cfg \ R_G.valid_cfg\ \cfg \ R_G.cfg_on _\ by (simp add: absc_repcs_id fst_abss K_cfg_rept[symmetric]) ultimately have "rept (l, u) (action cfg) \ ?U u" by blast then have "measure_pmf (rept (l, u) (action cfg)) {x. snd x = u} \ ?r u" by (fastforce intro: Sup_upper) moreover have "rept (l, u) (action cfg) = action (repcs (l, u) cfg)" by (simp add: repcs_def) ultimately have "measure_pmf (action (repcs (l, u) cfg)) {x. snd x = u} \ ?r u" by auto } note * = this let ?S = "{cfg. \ cfg' s. cfg' \ R_G.valid_cfg \ cfg = repcs s cfg' \ abss s = state cfg'}" have start: "repcs st cfg \ ?S" using \cfg \ R_G.valid_cfg\ assms unfolding R_G_cfg_on_div_def by clarsimp (inst_existentials cfg "fst st" "snd st", auto) have step: "y \ ?S" if "y \ K_cfg x" "x \ ?S" for x y using that apply safe subgoal for cfg' l u apply (inst_existentials "absc y" "state y") subgoal by blast subgoal by (metis K_cfg_valid_cfgD R_G.valid_cfgD R_G.valid_cfg_state_in_S absc_repcs_id cont_absc_1 cont_repcs1 repcs_valid ) subgoal by (simp add: state_absc) done done have **: "x \ ?S" if "(repcs st cfg, x) \ MDP.MC.acc" for x proof - from MDP.MC.acc_relfunD[OF that] obtain n where "((\ a b. b \ K_cfg a) ^^ n) (repcs st cfg) x" . then show ?thesis proof (induction n arbitrary: x) (* XXX Extract induction rule *) case 0 with start show ?case by simp next case (Suc n) from this(2)[simplified] show ?case apply (rule relcomppE) apply (erule step) apply (erule Suc.IH) done qed qed have ***: "almost_everywhere (MDP.MC.T (repcs st cfg)) (alw (HLD ?S))" by (rule AE_mp[OF MDP.MC.AE_T_reachable]) (fastforce dest: ** simp: HLD_iff elim: alw_mono) from \alternating cfg\ assms have "alternating (repcs st cfg)" by (simp add: AE_alw_ev_same_loc_iff'[of _ st]) then have alw_ev_same2: "almost_everywhere (MDP.MC.T (repcs st cfg)) (alw (\\. HLD (state - snd - {u}) \ \ ev (HLD {cfg. \cfg'\set_pmf (K_cfg cfg). fst (state cfg') = fst (state cfg)}) \))" for u unfolding alternating_def by (auto elim: alw_mono) let ?X = "{cfg :: ('s \ ('c \ real)) cfg. \ c \ \. snd (state cfg) c > k c}" let ?Y = "{cfg. \ cfg' \ K_cfg cfg. fst (state cfg') = fst (state cfg)}" have "(AE \ in ?M. ?P \) \ (AE \ in ?M. \ u :: ('c \ real). (\ c \ \. u c > k c) \ u \ snd  state  (MDP.MC.acc  {repcs st cfg}) \ \ (ev (alw (\ xs. shd xs = u))) (smap (snd o state) \))" (is "?L \ ?R") proof assume ?L then show ?R by eventually_elim auto next assume ?R with MDP.MC.AE_T_reachable[of "repcs st cfg"] show ?L proof (eventually_elim, intro allI impI notI, goal_cases) case (1 \ u) then show ?case by - (intro alw_HLD_smap alw_disjoint_ccontr[where S = "(snd o state)  MDP.MC.acc  {repcs st cfg}" and R = "{u}" and \ = "smap (snd o state) \" ]; auto simp: HLD_iff) qed qed also have "\ \ (\ u :: ('c \ real). (\ c \ \. u c > k c) \ u \ snd  state  (MDP.MC.acc  {repcs st cfg}) \ (AE \ in ?M. \ (ev (alw (\ xs. shd xs = u))) (smap (snd o state) \)))" using MDP.MC.countable_reachable[of "repcs st cfg"] by - (rule AE_all_imp_countable, auto intro: countable_subset[where B = "snd  state  MDP.MC.acc  {repcs st cfg}"]) also show ?thesis unfolding calculation apply clarsimp subgoal for l u x apply (rule MDP.non_loop_tail_strong[simplified, of snd "snd (state x)" ?Y ?S "?r (snd (state x))"] ) subgoal apply safe subgoal premises prems for cfg l1 u1 _ cfg' l2 u2 proof - have [simp]: "l2 = l1" "u2 = u1" subgoal by (metis MDP.cfg_onD_state Pair_inject prems(4) state_repcs) subgoal by (metis MDP.cfg_onD_state prems(4) snd_conv state_repcs) done with prems have [simp]: "u2 = u" by (metis $$l, u) = state x\ \snd (l1, u1) = snd (state x)\ \u2 = u1\ snd_conv) have [simp]: "snd - {snd (state x)} = {y. snd y = snd (state x)}" by (simp add: vimage_def) from prems show ?thesis apply simp apply (erule *[simplified]) subgoal using prems(1) prems(2)[symmetric] prems(3-) by (auto simp: R_G.valid_cfg_def) subgoal using prems(1) prems(2)[symmetric] prems(3-) by (auto simp: R_G.valid_cfg_def) subgoal using K_cfg_same_loc_iff[of "repcs (l1, snd (state x)) cfg'"] by (simp add: absc_repcs_id) (metis fst_abss fst_conv repcs_valid) done qed done subgoal by (auto intro: lt_1[simplified]) apply (rule MDP.valid_cfgD[OF \repcs st cfg \ valid_cfg\]; fail) subgoal using *** unfolding alw_holds_pred_stream_iff[symmetric] HLD_def . subgoal by (rule alw_ev_same2) done done qed lemma cfg_on_div_repcs_strong: notes in_space_UNIV[measurable] assumes "cfg \ R_G_cfg_on_div (abss st)" "st \ S" and "alternating cfg" shows "repcs st cfg \ cfg_on_div st" proof - let ?st = "abss st" let ?cfg = "repcs st cfg" from assms have *: "cfg \ R_G.cfg_on ?st" "state cfg = ?st" "R_G_div_cfg cfg" unfolding R_G_cfg_on_div_def by auto with assms have "cfg \ R_G.valid_cfg" by (auto intro: R_G.valid_cfgI) with \st \ S\ \_ = ?st\ have "?cfg \ valid_cfg" by auto from *(1) \st \ S\ \alternating cfg\ have "AE \ in MDP.MC.T ?cfg. \u. (\c\\. real (k c) < u c) \ \ ev (alw (\xs. shd xs = u)) (smap (snd \ state)$$" by (rule repcs_unbounded_AE_non_loop_end_strong) \ \Move to lower level\ moreover from *(2,3) have "AE \ in MDP.MC.T ?cfg. \_div (smap (snd \ state) (smap absc \))" unfolding R_G_div_cfg_def by (subst (asm) R_G_trace_space_distr_eq[OF \cfg \ R_G.valid_cfg\]; simp add: AE_distr_iff) ultimately have "div_cfg ?cfg" unfolding div_cfg_def using MDP.MC.AE_T_enabled[of ?cfg] proof eventually_elim case prems: (elim \) let ?xs = "smap (snd o state) \" from MDP.pred_stream_cfg_on[OF \_ \ valid_cfg\ \MDP.MC.enabled _ _\] have *: "pred_stream (\ x. x \ S) (smap state \)" by (auto simp: stream.pred_set) have "[snd (state x)]\<^sub>\ = snd (abss (state x))" if "x \ sset \" for x proof - from * that have "state x \ S" by (auto simp: stream.pred_set) then have "snd (abss (state x)) = [snd (state x)]\<^sub>\" by (metis abss_S snd_conv surj_pair) then show ?thesis .. qed then have "smap (\z. [snd (state z)]\<^sub>\) \ = (smap (\z. snd (abss (state z))) \)" by auto from * have "pred_stream (\ u. u \ V) ?xs" by (simp add: map_def stream.pred_set, subst (asm) surjective_pairing, blast) moreover have "stream_trans ?xs" by (rule enabled_stream_trans \_ \ valid_cfg\ \MDP.MC.enabled _ _\)+ moreover have "pairwise trans' ?xs" using \_ \ R_G.valid_cfg\ \state cfg = _$symmetric] \MDP.MC.enabled _ _\ by (rule enabled_stream_trans') moreover from prems(1) have "\u. (\c\\. real (k c) < u c) \ \ ev (alw (\xs. snd (shd xs) = u)) (smap state \)" by simp ultimately show ?case using \\_div _\ by (simp add: stream.map_comp state_absc \smap _ \ = _\ \_divergent_divergent) qed with MDP.valid_cfgD \cfg \ R_G.valid_cfg\ * show ?thesis unfolding cfg_on_div_def by auto force qed lemma repcs_unbounded_AE_non_loop_end: assumes "cfg \ R_G.cfg_on (abss st)" "st \ S" shows "AE \ in MDP.MC.T (repcs st cfg). (\ s :: ('s \ ('c \ real)). (\ c \ \. snd s c > k c) \ \ (ev (alw (\ xs. shd xs = s))) (smap state \))" (is "AE \ in ?M. ?P \") proof - from assms have "cfg \ R_G.valid_cfg" by (auto intro: R_G.valid_cfgI) with assms(1) have "repcs st cfg \ valid_cfg" by auto from R_G.valid_cfgD[OF \cfg \ R_G.valid_cfg$ have "cfg \ R_G.cfg_on (state cfg)" . let ?K = "\ x. {\ \ K x. \ \ return_pmf x}" let ?r = "\ x. Sup ((\ \. measure_pmf \ {x})  ?K x)" have lt_1: "?r x < 1" if "\ \ ?K x" for \ x proof - have *: "emeasure (measure_pmf \) {x} < 1" if "\ \ return_pmf x" for \ proof (rule ccontr) assume "\ emeasure (measure_pmf \) {x} < 1" then have "emeasure (measure_pmf \) {x} = 1" using measure_pmf.emeasure_ge_1_iff by force with that show False by (simp add: measure_pmf_eq_1_iff) qed let ?S = "{map_pmf (\ (X, l). (l, ([X := 0]u))) \ | \ l u g. x = (l, u) \ (l, g, \) \ trans_of A}" have "(\ \. measure_pmf \ {x})  ?K x \ {0, 1} \ (\ \. measure_pmf \ {x})  ?S" by (force elim!: K.cases) moreover have "finite ?S" proof - have "?S \ (\ (l, g, \). map_pmf (\ (X, l). (l, ([X := 0](snd x)))) \)  trans_of A" by force also from finite(3) have "finite \" .. finally show ?thesis . qed ultimately have "finite ((\ \. measure_pmf \ {x})  ?K x)" by (auto intro: finite_subset) then show ?thesis using that by (auto intro: * finite_imp_Sup_less) qed { fix s :: "'s \ ('c \ real)" and cfg :: "('s \ ('c \ real) set) cfg" assume unbounded: "\ c \ \. snd s c > k c" and "cfg \ R_G.cfg_on (abss s)" "abss s \ \" then have "repcs s cfg \ valid_cfg" by (auto intro: R_G.valid_cfgI) then have cfg_on: "repcs s cfg \ MDP.cfg_on s" by (auto dest: MDP.valid_cfgD) from \cfg \ _\ have "action cfg \ \ (abss s)" by (rule R_G.cfg_onD_action) have "rept s (action cfg) \ return_pmf s" proof (rule ccontr, simp) assume "rept s (action cfg) = return_pmf s" then have "action cfg = return_pmf (abss s)" using abst_rept_id[OF \action cfg \ _\] by (simp add: abst_def) moreover have "(fst s, snd s) \ S" using \_ \ \\ by (auto dest: \_abss_S) moreover have "abss s = (fst s, [snd s]\<^sub>\)" by (metis abss_S calculation(2) prod.collapse) ultimately show False using \rept s _ = _\ unbounded unfolding rept_def by (cases s) (auto dest: cval_add_non_id) qed moreover have "rept s (action cfg) \ K s" proof - have "action (repcs s cfg) \ K s" using cfg_on by blast then show ?thesis by (simp add: repcs_def) qed ultimately have "rept s (action cfg) \ ?K s" by blast then have "measure_pmf (rept s (action cfg)) {s} \ ?r s" by (auto intro: Sup_upper) moreover have "rept s (action cfg) = action (repcs s cfg)" by (simp add: repcs_def) ultimately have "measure_pmf (action (repcs s cfg)) {s} \ ?r s" by auto note this \rept s (action cfg) \ ?K s\ } note * = this let ?S = "{cfg. \ cfg' s. cfg' \ R_G.valid_cfg \ cfg = repcs s cfg' \ abss s = state cfg'}" have start: "repcs st cfg \ ?S" using \cfg \ R_G.valid_cfg\ assms unfolding R_G_cfg_on_div_def by clarsimp (inst_existentials cfg "fst st" "snd st", auto) have step: "y \ ?S" if "y \ K_cfg x" "x \ ?S" for x y using that apply safe subgoal for cfg' l u apply (inst_existentials "absc y" "state y") subgoal by blast subgoal by (metis K_cfg_valid_cfgD R_G.valid_cfgD R_G.valid_cfg_state_in_S absc_repcs_id cont_absc_1 cont_repcs1 repcs_valid ) subgoal by (simp add: state_absc) done done have **: "x \ ?S" if "(repcs st cfg, x) \ MDP.MC.acc" for x proof - from MDP.MC.acc_relfunD[OF that] obtain n where "((\ a b. b \ K_cfg a) ^^ n) (repcs st cfg) x" . then show ?thesis proof (induction n arbitrary: x) (* XXX Extract induction rule *) case 0 with start show ?case by simp next case (Suc n) from this(2)[simplified] show ?case by (elim relcomppE step Suc.IH) qed qed have ***: "almost_everywhere (MDP.MC.T (repcs st cfg)) (alw (HLD ?S))" by (rule AE_mp[OF MDP.MC.AE_T_reachable]) (fastforce dest: ** simp: HLD_iff elim: alw_mono) have "(AE \ in ?M. ?P \) \ (AE \ in ?M. \ s :: ('s \ ('c \ real)). (\ c \ \. snd s c > k c) \ s \ state  (MDP.MC.acc  {repcs st cfg}) \ \ (ev (alw (\ xs. shd xs = s))) (smap state \))" (is "?L \ ?R") proof assume ?L then show ?R by eventually_elim auto next assume ?R with MDP.MC.AE_T_reachable[of "repcs st cfg"] show ?L proof (eventually_elim, intro allI impI notI, goal_cases) case (1 \ s) from this(1,2,5,6) show ?case by (intro alw_HLD_smap alw_disjoint_ccontr[where S = "state  MDP.MC.acc  {repcs st cfg}" and R = "{s}" and \ = "smap state \" ]; simp add: HLD_iff; blast) qed qed also have "\ \ (\ s :: ('s \ ('c \ real)). (\ c \ \. snd s c > k c) \ s \ state  (MDP.MC.acc  {repcs st cfg}) \ (AE \ in ?M. \ (ev (alw (\ xs. shd xs = s))) (smap state \)))" using MDP.MC.countable_reachable[of "repcs st cfg"] by - (rule AE_all_imp_countable, auto intro: countable_subset[where B = "state  MDP.MC.acc  {repcs st cfg}"]) also show ?thesis unfolding calculation apply clarsimp subgoal for l u x apply (rule MDP.non_loop_tail'[simplified, of "state x" ?S "?r (state x)"]) subgoal apply safe subgoal premises prems for cfg cfg' l' u' proof - from prems have "state x = (l', u')" by (metis MDP.cfg_onD_state state_repcs) with \_ = state x\ have [simp]: "l = l'" "u = u'" by auto show ?thesis unfolding \state x = _\ using prems(1,3-) by (auto simp: R_G.valid_cfg_def intro: *) qed done subgoal apply (drule **) apply clarsimp apply (rule lt_1) apply (rule *) apply (auto dest: R_G.valid_cfg_state_in_S R_G.valid_cfgD) done apply (rule MDP.valid_cfgD[OF \repcs st cfg \ valid_cfg\]; fail) using *** unfolding alw_holds_pred_stream_iff[symmetric] HLD_def . done qed end (* PTA Regions *) subsection \Main Result\ text_raw \ \label{thm:minmax} \ context Probabilistic_Timed_Automaton_Regions_Reachability begin lemma R_G_cfg_on_valid: "cfg \ R_G.valid_cfg" if "cfg \ R_G_cfg_on_div s'" using that unfolding R_G_cfg_on_div_def R_G.valid_cfg_def by auto lemma cfg_on_valid: "cfg \ valid_cfg" if "cfg \ cfg_on_div s" using that unfolding cfg_on_div_def MDP.valid_cfg_def by auto abbreviation "path_measure P cfg \ emeasure (MDP.T cfg) {x\space MDP.St. P x}" abbreviation "R_G_path_measure P cfg \ emeasure (R_G.T cfg) {x\space R_G.St. P x}" abbreviation "progressive st \ cfg_on_div st \ {cfg. alternating cfg}" abbreviation "R_G_progressive st \ R_G_cfg_on_div st \ {cfg. alternating cfg}" text \Summary of our results on divergent configurations:\ lemma absc_valid_cfg_eq: "absc  progressive s = R_G_progressive s'" apply safe subgoal unfolding s'_def by (rule cfg_on_div_absc) auto subgoal by (simp add: AE_alw_ev_same_loc_iff cfg_on_valid) subgoal for cfg unfolding s'_def by (frule cfg_on_div_repcs_strong) (auto 4 4 simp: s'_def R_G_cfg_on_div_def AE_alw_ev_same_loc_iff'[symmetric] intro: R_G_cfg_on_valid absc_repcs_id[symmetric] ) done text \Main theorem:\ theorem Min_Max_reachability: notes in_space_UNIV[measurable] and [iff] = pred_stream_iff shows "(\cfg\ progressive s. path_measure (\ x. (holds \ suntil holds \) (s ## x)) cfg) = (\cfg\ R_G_progressive s'. R_G_path_measure (\ x. (holds \' suntil holds \') (s' ## x)) cfg) \ (\cfg\ progressive s. path_measure (\ x. (holds \ suntil holds \) (s ## x)) cfg) = (\cfg\ R_G_progressive s'. R_G_path_measure (\ x. (holds \' suntil holds \') (s' ## x)) cfg)" proof (rule SUP_eq_and_INF_eq; rule bexI[rotated]; erule IntE) fix cfg assume cfg_div: "cfg \ R_G_cfg_on_div s'" and "cfg \ Collect alternating" then have "alternating cfg" by auto let ?cfg' = "repcs s cfg" from \alternating cfg\ cfg_div have "alternating ?cfg'" by (simp add: R_G_cfg_on_div_def s'_def AE_alw_ev_same_loc_iff'[of _ s]) with cfg_div \alternating cfg\ show "?cfg' \ cfg_on_div s \ Collect alternating" by (auto intro: cfg_on_div_repcs_strong simp: s'_def) show "emeasure (R_G.T cfg) {x \ space R_G.St. (holds \' suntil holds \') (s' ## x)} = emeasure (MDP.T ?cfg') {x \ space MDP.St. (holds \ suntil holds \) (s ## x)}" (is "?a = ?b") proof - from cfg_div have "cfg \ R_G.valid_cfg" by (rule R_G_cfg_on_valid) from cfg_div have "cfg \ R_G.cfg_on s'" unfolding R_G_cfg_on_div_def by auto then have "state cfg = s'" by auto have "?a = ?b" apply (rule path_measure_eq_repcs''_new[ of s cfg \ \, folded \'_def \'_def, unfolded \_ = s'\ state_repcs ] ) subgoal unfolding s'_def .. subgoal by fact subgoal using \?cfg' \ cfg_on_div s \ _\ by (blast intro: cfg_on_valid) subgoal premises prems for xs using prems s by (intro \_stream) subgoal premises prems using prems s by (intro \_stream) done then show ?thesis by simp qed next fix cfg assume cfg_div: "cfg \ cfg_on_div s" and "cfg \ Collect alternating" with absc_valid_cfg_eq show "absc cfg \ R_G_cfg_on_div s' \ Collect alternating" by auto show "emeasure (MDP.T cfg) {x \ space MDP.St. (holds \ suntil holds \) (s ## x)} = emeasure (R_G.T (absc cfg)) {x \ space R_G.St. (holds \' suntil holds \') (s' ## x)}" (is "?a = ?b") proof - have "absc cfg \ R_G.valid_cfg" using R_G_cfg_on_valid \absc cfg \ R_G_cfg_on_div s' \ _\ by blast from cfg_div have "cfg \ valid_cfg" by (simp add: cfg_on_valid) with \absc cfg \ R_G.valid_cfg\ have "?b = ?a" by (intro MDP.alw_S R_G.alw_S path_measure_eq_absc1_new [where P = "pred_stream (\s. s \ \)" and Q = "pred_stream (\s. s \ S)"] ) (auto simp: S_abss_\ intro: \_abss_S intro!: suntil_abss suntil_reps, measurable) then show "?a = ?b" by simp qed qed end (* PTA Reachability Problem *) end (* Theory *) diff --git a/thys/Probabilistic_Timed_Automata/library/Basic.thy b/thys/Probabilistic_Timed_Automata/library/Basic.thy --- a/thys/Probabilistic_Timed_Automata/library/Basic.thy +++ b/thys/Probabilistic_Timed_Automata/library/Basic.thy @@ -1,95 +1,95 @@ (* Author: Julian Brunner *) (* This is originally a part of the CAVA model checker *) theory Basic imports Main begin abbreviation (input) "const x \ \ _. x" lemma infinite_subset[trans]: "infinite A \ A \ B \ infinite B" using infinite_super by this lemma finite_subset[trans]: "A \ B \ finite B \ finite A" using finite_subset by this declare infinite_coinduct[case_names infinite, coinduct pred: infinite] lemma infinite_psubset_coinduct[case_names infinite, consumes 1]: assumes "R A" assumes "\ A. R A \ \ B \ A. R B" shows "infinite A" proof assume "finite A" then show "False" using assms by (induct rule: finite_psubset_induct) (auto) qed lemma GreatestI: fixes k :: nat assumes "P k" "\ k. P k \ k \ l" shows "P (GREATEST k. P k)" - proof (rule GreatestI_nat) + proof (rule GreatestI_nat, safe) show "P k" using assms(1) by this show "k \ l" if "P k" for k using assms(2) that by force qed lemma Greatest_le: fixes k :: nat assumes "P k" "\ k. P k \ k \ l" shows "k \ (GREATEST k. P k)" - proof (rule Greatest_le_nat) + proof (rule Greatest_le_nat, safe) show "P k" using assms(1) by this show "k \ l" if "P k" for k using assms(2) that by force qed lemma Greatest_not_less: fixes k :: nat assumes "k > (GREATEST k. P k)" "\ k. P k \ k \ l" shows "\ P k" proof assume 1: "P k" have 2: "k \ (GREATEST k. P k)" using Greatest_le 1 assms(2) by this show "False" using assms(1) 2 by auto qed lemma finite_set_of_finite_maps': assumes "finite A" "finite B" shows "finite {m. dom m \ A \ ran m \ B}" proof - have "{m. dom m \ A \ ran m \ B} = (\ \ \ Pow A. {m. dom m = \ \ ran m \ B})" by auto also have "finite \" using finite_subset assms by (auto intro: finite_set_of_finite_maps) finally show ?thesis by this qed primrec alternate :: "('a \ 'a) \ ('a \ 'a) \ nat \ ('a \ 'a)" where "alternate f g 0 = id" | "alternate f g (Suc k) = alternate g f k \ f" lemma alternate_Suc[simp]: "alternate f g (Suc k) = (if even k then f else g) \ alternate f g k" proof (induct k arbitrary: f g) case (0) show ?case by simp next case (Suc k) have "alternate f g (Suc (Suc k)) = alternate g f (Suc k) \ f" by auto also have "\ = (if even k then g else f) \ (alternate g f k \ f)" unfolding Suc by auto also have "\ = (if even (Suc k) then f else g) \ alternate f g (Suc k)" by auto finally show ?case by this qed declare alternate.simps(2)[simp del] lemma alternate_antimono: assumes "\ x. f x \ x" "\ x. g x \ x" shows "antimono (alternate f g)" proof fix k l :: nat assume 1: "k \ l" obtain n where 2: "l = k + n" using le_Suc_ex 1 by auto have 3: "alternate f g (k + n) \ alternate f g k" proof (induct n) case (0) show ?case by simp next case (Suc n) have "alternate f g (k + Suc n) \ alternate f g (k + n)" using assms by (auto intro: le_funI) also have "\ \ alternate f g k" using Suc by this finally show ?case by this qed show "alternate f g l \ alternate f g k" using 3 unfolding 2 by this qed end diff --git a/thys/QR_Decomposition/Gram_Schmidt.thy b/thys/QR_Decomposition/Gram_Schmidt.thy --- a/thys/QR_Decomposition/Gram_Schmidt.thy +++ b/thys/QR_Decomposition/Gram_Schmidt.thy @@ -1,913 +1,913 @@ (* Title: Gram_Schmidt.thy Author: Jose Divasón Author: Jesús Aransay *) section\The Gram-Schmidt algorithm\ theory Gram_Schmidt imports Miscellaneous_QR Projections begin subsection\Gram-Schmidt algorithm\ text\ The algorithm is used to orthogonalise a set of vectors. The Gram-Schmidt process takes a set of vectors \S\ and generates another orthogonal set that spans the same subspace as \S\. We present three ways to compute the Gram-Schmidt algorithm. \begin{enumerate} \item The fist one has been developed thinking about the simplicity of its formalisation. Given a list of vectors, the output is another list of orthogonal vectors with the same span. Such a list is constructed following the Gram-Schmidt process presented in any book, but in the reverse order (starting the process from the last element of the input list). \item Based on previous formalization, another function has been defined to compute the process of the Gram-Schmidt algorithm in the natural order (starting from the first element of the input list). \item The third way has as input and output a matrix. The algorithm is applied to the columns of a matrix, obtaining a matrix whose columns are orthogonal and where the column space is kept. This will be a previous step to compute the QR decomposition. \end{enumerate} Every function can be executed with arbitrary precision (using rational numbers). \ subsubsection\First way\ definition Gram_Schmidt_step :: "('a::{real_inner}^'b) => ('a^'b) list => ('a^'b) list" where "Gram_Schmidt_step a ys = ys @ [(a - proj_onto a (set ys))]" definition "Gram_Schmidt xs = foldr Gram_Schmidt_step xs []" lemma Gram_Schmidt_cons: "Gram_Schmidt (a#xs) = Gram_Schmidt_step a (Gram_Schmidt xs)" unfolding Gram_Schmidt_def by auto lemma basis_orthogonal': fixes xs::"('a::{real_inner}^'b) list" shows "length (Gram_Schmidt xs) = length (xs) \ span (set (Gram_Schmidt xs)) = span (set xs) \ pairwise orthogonal (set (Gram_Schmidt xs))" proof (induct xs) case Nil show ?case unfolding Gram_Schmidt_def pairwise_def by fastforce next case (Cons a xs) have l: "length (Gram_Schmidt xs) = length xs" and s: "span (set (Gram_Schmidt xs)) = span (set xs)" and p: "pairwise orthogonal (set (Gram_Schmidt xs))" using Cons.hyps by auto show "length (Gram_Schmidt (a # xs)) = length (a # xs) \ span (set (Gram_Schmidt (a # xs))) = span (set (a # xs)) \ pairwise orthogonal (set (Gram_Schmidt (a # xs)))" proof show "length (Gram_Schmidt (a # xs)) = length (a # xs)" unfolding Gram_Schmidt_cons unfolding Gram_Schmidt_step_def using l by auto show "span (set (Gram_Schmidt (a # xs))) = span (set (a # xs)) \ pairwise orthogonal (set (Gram_Schmidt (a # xs)))" proof have set_rw1: "set (a # xs) = insert a (set xs)" by simp have set_rw2: "set (Gram_Schmidt (a # xs)) = (insert (a - (\x\set (Gram_Schmidt xs). (a \ x / (x \ x)) *\<^sub>R x)) (set (Gram_Schmidt xs)))" unfolding Gram_Schmidt_cons Gram_Schmidt_step_def proj_onto_def proj_def[abs_def] by auto define C where "C = set (Gram_Schmidt xs)" have finite_C: "finite C" unfolding C_def by auto { fix x k have th0: "!!(a::'a^'b) b c. a - (b - c) = c + (a - b)" by (simp add: field_simps) have "x - k *\<^sub>R (a - (\x\C. (a \ x / (x \ x)) *\<^sub>R x)) \ span C \ x - k *\<^sub>R a \ span C" apply (simp only: scaleR_right_diff_distrib th0) apply (rule span_add_eq) apply (rule span_mul) apply (rule span_sum) apply (rule span_mul) apply (rule span_base) apply assumption done } then show "span (set (Gram_Schmidt (a # xs))) = span (set (a # xs))" unfolding set_eq_iff set_rw2 set_rw1 span_breakdown_eq C_def s[symmetric] by auto with p show "pairwise orthogonal (set (Gram_Schmidt (a # xs)))" using pairwise_orthogonal_proj_set[OF finite_C] unfolding set_rw2 unfolding C_def proj_def[symmetric] proj_onto_def[symmetric] by simp qed qed qed lemma card_Gram_Schmidt: fixes xs::"('a::{real_inner}^'b) list" assumes "distinct xs" shows "card(set (Gram_Schmidt xs)) \ card (set (xs))" using assms proof (induct xs) case Nil show ?case unfolding Gram_Schmidt_def by simp next case (Cons x xs) define b where "b = (\xa\set (Gram_Schmidt xs). (x \ xa / (xa \ xa)) *\<^sub>R xa)" have distinct_xs: "distinct xs" using Cons.prems by auto show ?case proof (cases "x - b \ set (Gram_Schmidt xs)") case True have "card (set (Gram_Schmidt (x # xs))) = card (insert (x - b) (set (Gram_Schmidt xs)))" unfolding Gram_Schmidt_cons Gram_Schmidt_step_def b_def unfolding proj_onto_def proj_def[abs_def] by simp also have "... = Suc (card (set (Gram_Schmidt xs)))" proof (rule card_insert_disjoint) show "finite (set (Gram_Schmidt xs))" by simp show "x - b \ set (Gram_Schmidt xs)" using True . qed also have "... \ Suc (card (set xs))" using Cons.hyps[OF distinct_xs] by simp also have "... = Suc (length (remdups xs))" unfolding List.card_set .. also have "... \ (length (remdups (x # xs)))" by (metis Cons.prems distinct_xs impossible_Cons not_less_eq_eq remdups_id_iff_distinct) also have "... \ (card (set (x # xs)))" by (metis dual_order.refl length_remdups_card_conv) finally show ?thesis . next case False have x_b_in: "x - b \ set (Gram_Schmidt xs)" using False by simp have "card (set (Gram_Schmidt (x # xs))) = card (insert (x - b) (set (Gram_Schmidt xs)))" unfolding Gram_Schmidt_cons Gram_Schmidt_step_def b_def unfolding proj_onto_def proj_def[abs_def] by simp also have "... = (card (set (Gram_Schmidt xs)))" by (metis False insert_absorb) also have "... \ (card (set xs))" using Cons.hyps[OF distinct_xs] . also have "... \ (card (set (x # xs)))" unfolding List.card_set by simp finally show ?thesis . qed qed lemma orthogonal_basis_exists: fixes V :: "(real^'b) list" assumes B: "is_basis (set V)" and d: "distinct V" shows "vec.independent (set (Gram_Schmidt V)) \ (set V) \ vec.span (set (Gram_Schmidt V)) \ (card (set (Gram_Schmidt V)) = vec.dim (set V)) \ pairwise orthogonal (set (Gram_Schmidt V))" proof - have "(set V) \ vec.span (set (Gram_Schmidt V))" using basis_orthogonal'[of V] using vec.span_superset[where ?'a=real, where ?'b='b] by (auto simp: span_vec_eq) moreover have "pairwise orthogonal (set (Gram_Schmidt V))" using basis_orthogonal'[of V] by blast moreover have c: "(card (set (Gram_Schmidt V)) = vec.dim (set V))" proof - have card_eq_dim: "card (set V) = vec.dim (set V)" by (metis B independent_is_basis vec.dim_span vec.indep_card_eq_dim_span) have "vec.dim (set V) \ (card (set (Gram_Schmidt V)))" using B unfolding is_basis_def using vec.independent_span_bound[of "(set (Gram_Schmidt V))" "set V"] using basis_orthogonal'[of V] by (simp add: calculation(1) local.card_eq_dim) moreover have "(card (set (Gram_Schmidt V))) \ vec.dim (set V)" using card_Gram_Schmidt[OF d] card_eq_dim by auto ultimately show ?thesis by auto qed moreover have "vec.independent (set (Gram_Schmidt V))" proof (rule vec.card_le_dim_spanning[of _ "UNIV::(real^'b) set"]) show "set (Gram_Schmidt V) \ (UNIV::(real^'b) set)" by simp show "UNIV \ vec.span (set (Gram_Schmidt V))" using basis_orthogonal'[of V] using B unfolding is_basis_def by (simp add: span_vec_eq) show "finite (set (Gram_Schmidt V))" by simp show "card (set (Gram_Schmidt V)) \ vec.dim (UNIV::(real^'b) set)" by (metis c top_greatest vec.dim_subset) qed ultimately show ?thesis by simp qed corollary orthogonal_basis_exists': fixes V :: "(real^'b) list" assumes B: "is_basis (set V)" and d: "distinct V" shows "is_basis (set (Gram_Schmidt V)) \ distinct (Gram_Schmidt V) \ pairwise orthogonal (set (Gram_Schmidt V))" using B orthogonal_basis_exists basis_orthogonal' card_distinct d vec.dim_unique distinct_card is_basis_def subset_refl by (metis span_vec_eq) subsubsection\Second way\ text\This definition applies the Gram Schmidt process starting from the first element of the list.\ definition "Gram_Schmidt2 xs = Gram_Schmidt (rev xs)" lemma basis_orthogonal2: fixes xs::"('a::{real_inner}^'b) list" shows "length (Gram_Schmidt2 xs) = length (xs) \ span (set (Gram_Schmidt2 xs)) = span (set xs) \ pairwise orthogonal (set (Gram_Schmidt2 xs))" by (metis Gram_Schmidt2_def basis_orthogonal' length_rev set_rev) lemma card_Gram_Schmidt2: fixes xs::"('a::{real_inner}^'b) list" assumes "distinct xs" shows "card(set (Gram_Schmidt2 xs)) \ card (set (xs))" by (metis Gram_Schmidt2_def assms card_Gram_Schmidt distinct_rev set_rev) lemma orthogonal_basis_exists2: fixes V :: "(real^'b) list" assumes B: "is_basis (set V)" and d: "distinct V" shows "vec.independent (set (Gram_Schmidt2 V)) \ (set V) \ vec.span (set (Gram_Schmidt2 V)) \ (card (set (Gram_Schmidt2 V)) = vec.dim (set V)) \ pairwise orthogonal (set (Gram_Schmidt2 V))" by (metis Gram_Schmidt.orthogonal_basis_exists Gram_Schmidt2_def distinct_rev set_rev B basis_orthogonal2 d) subsubsection\Third way\ text\The following definitions applies the Gram Schmidt process in the columns of a given matrix. It is previous step to the computation of the QR decomposition.\ definition Gram_Schmidt_column_k :: "'a::{real_inner}^'cols::{mod_type}^'rows \ nat \ 'a^'cols::{mod_type}^'rows" where "Gram_Schmidt_column_k A k = (\ a. (\ b. (if b = from_nat k then (column b A - (proj_onto (column b A) {column i A|i. i < b})) else (column b A)) $a))" definition "Gram_Schmidt_upt_k A k = foldl Gram_Schmidt_column_k A [0..<(Suc k)]" definition "Gram_Schmidt_matrix A = Gram_Schmidt_upt_k A (ncols A - 1)" text\Some definitions and lemmas in order to get execution.\ definition "Gram_Schmidt_column_k_row A k a = vec_lambda(\b. (if b = from_nat k then (column b A - (\x\{column i A|i. i < b}. ((column b A) \ x / (x \ x)) *\<^sub>R x)) else (column b A))$ a)" lemma Gram_Schmidt_column_k_row_code[code abstract]: "vec_nth (Gram_Schmidt_column_k_row A k a) = (%b. (if b = from_nat k then (column b A - (\x\{column i A|i. i < b}. ((column b A) \ x / (x \ x)) *\<^sub>R x)) else (column b A)) $a)" unfolding Gram_Schmidt_column_k_row_def by (metis (lifting) vec_lambda_beta) lemma Gram_Schmidt_column_k_code[code abstract]: "vec_nth (Gram_Schmidt_column_k A k) = Gram_Schmidt_column_k_row A k" unfolding Gram_Schmidt_column_k_def unfolding Gram_Schmidt_column_k_row_def[abs_def] unfolding proj_onto_def proj_def[abs_def] by fastforce text\Proofs\ lemma Gram_Schmidt_upt_k_suc: "Gram_Schmidt_upt_k A (Suc k) = (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k))" proof - have rw: "[0..(Suc k)} = {column i (Gram_Schmidt_upt_k A k) |i. to_nat i\k} \ {column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) - (\x\{column i (Gram_Schmidt_upt_k A k) |i. to_nat i\k}. (x \ (column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k)) / (x \ x)) *\<^sub>R x)}" proof - have set_rw: "{\ ia. Gram_Schmidt_upt_k A k$ ia $i |i. i < from_nat (Suc k)} = {\ ia. Gram_Schmidt_upt_k A k$ ia $i |i. to_nat i \ k}" proof (auto, vector, metis less_Suc_eq_le to_nat_le) fix i::'cols assume "to_nat i \ k" hence "to_nat i < Suc k" by simp hence i_less_suc: "i < from_nat (Suc k)" using from_nat_le[OF _ k] by simp show "\l. (\j. Gram_Schmidt_upt_k A k$ j $i) = (\j'. Gram_Schmidt_upt_k A k$ j' $l) \ l < mod_type_class.from_nat (Suc k)" by (rule exI[of _ i], simp add: i_less_suc) qed have rw: "[0..(Suc k)} = {column i (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k)) |i. to_nat i \ Suc k}" unfolding Gram_Schmidt_upt_k_def unfolding rw unfolding foldl_append unfolding foldl.simps .. also have "... = {column i (Gram_Schmidt_upt_k A k) |i. to_nat i\k} \ {column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) - (\x\{column i (Gram_Schmidt_upt_k A k) |i. to_nat i\k}. (x \ (column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k)) / (x \ x)) *\<^sub>R x)}" proof (auto) fix i::'cols assume ik: "to_nat i \ k" show "\ia. column i (Gram_Schmidt_upt_k A k) = column ia (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k)) \ to_nat ia \ Suc k" proof (rule exI[of _ i], rule conjI) have i_less_suc: "to_nat i < Suc k" using ik by auto thus "to_nat i \ Suc k" by simp show "column i (Gram_Schmidt_upt_k A k) = column i (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k))" using column_Gram_Schmidt_upt_k_preserves[OF i_less_suc k, of A] unfolding Gram_Schmidt_upt_k_suc .. qed next show "\a. column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) - (\x\{column i (Gram_Schmidt_upt_k A k) |i. to_nat i \ k}. (x \ column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) / (x \ x)) *\<^sub>R x) = column a (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k)) \ to_nat a \ Suc k" proof (rule exI[of _ "from_nat (Suc k)::'cols"], rule conjI) show "to_nat (from_nat (Suc k)::'cols) \ Suc k" unfolding to_nat_from_nat_id[OF k] .. show "column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) - (\x\{column i (Gram_Schmidt_upt_k A k) |i. to_nat i \ k}. (x \ column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) / (x \ x)) *\<^sub>R x) = column (from_nat (Suc k)) (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k))" unfolding Gram_Schmidt_column_k_def column_def apply auto unfolding set_rw unfolding vector_scaleR_component[symmetric] unfolding sum_component[symmetric] unfolding proj_onto_def proj_def[abs_def] unfolding proj_onto_sum_rw by vector qed next fix i assume col_not_eq: "column i (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k)) \ column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) - (\x\{column i (Gram_Schmidt_upt_k A k) |i. to_nat i \ k}. (x \ column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) / (x \ x)) *\<^sub>R x)" and i: "to_nat i \ Suc k" have i_not_suc_k: "i \ from_nat (Suc k)" proof (rule ccontr, simp) assume i2: "i = from_nat (Suc k)" have "column i (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k)) = column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) - (\x\{column i (Gram_Schmidt_upt_k A k) |i. to_nat i \ k}. (x \ column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) / (x \ x)) *\<^sub>R x)" unfolding i2 Gram_Schmidt_column_k_def column_def apply auto unfolding set_rw unfolding vector_scaleR_component[symmetric] unfolding sum_component[symmetric] unfolding proj_onto_def proj_def[abs_def] unfolding proj_onto_sum_rw by vector thus False using col_not_eq by contradiction qed show "\ia. column i (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k)) = column ia (Gram_Schmidt_upt_k A k) \ to_nat ia \ k" proof (rule exI[of _ i], rule conjI, unfold Gram_Schmidt_upt_k_suc[symmetric], rule column_Gram_Schmidt_upt_k_preserves) show "to_nat i < Suc k" using i i_not_suc_k by (metis le_imp_less_or_eq from_nat_to_nat_id) thus "to_nat i \ k" using less_Suc_eq_le by simp show "Suc k < CARD('cols)" using k . qed qed finally show ?thesis . qed lemma orthogonal_Gram_Schmidt_upt_k: assumes s: "k < ncols A" shows "pairwise orthogonal ({column i (Gram_Schmidt_upt_k A k) |i. to_nat i\k})" using s proof (induct k) case 0 have set_rw: "{column i (Gram_Schmidt_upt_k A 0) |i. to_nat i \ 0} = {column 0 (Gram_Schmidt_upt_k A 0)}" by (simp add: to_nat_eq_0) show ?case unfolding set_rw unfolding pairwise_def by auto next case (Suc k) have rw: "[0.. UNIV} = {column i (Gram_Schmidt_upt_k A (ncols A - 1)) |i. to_nat i\ (ncols A - 1)}" proof (auto) fix i show "\ia. column i (Gram_Schmidt_matrix A) = column ia (Gram_Schmidt_upt_k A (ncols A - Suc 0)) \ to_nat ia \ ncols A - Suc 0" apply (rule exI[of _ i]) unfolding Gram_Schmidt_matrix_def using to_nat_less_card[of i] unfolding ncols_def by fastforce show "\ia. column i (Gram_Schmidt_upt_k A (ncols A - Suc 0)) = column ia (Gram_Schmidt_matrix A)" unfolding Gram_Schmidt_matrix_def by auto qed corollary orthogonal_Gram_Schmidt_matrix: shows "pairwise orthogonal ({column i (Gram_Schmidt_matrix A) |i. i \ UNIV})" unfolding columns_Gram_Schmidt_matrix_rw by (rule orthogonal_Gram_Schmidt_upt_k, simp add: ncols_def) corollary orthogonal_Gram_Schmidt_matrix2: shows "pairwise orthogonal (columns (Gram_Schmidt_matrix A))" unfolding columns_def using orthogonal_Gram_Schmidt_matrix . lemma column_Gram_Schmidt_column_k: fixes A::"'a::{real_inner}^'n::{mod_type}^'m::{mod_type}" shows "column k (Gram_Schmidt_column_k A (to_nat k)) = (column k A) - (\x\{column i A|i. i < k}. (x \ (column k A) / (x \ x)) *\<^sub>R x)" unfolding Gram_Schmidt_column_k_def column_def unfolding from_nat_to_nat_id unfolding proj_onto_def proj_def[abs_def] unfolding proj_onto_sum_rw by vector lemma column_Gram_Schmidt_column_k': fixes A::"'a::{real_inner}^'n::{mod_type}^'m::{mod_type}" assumes i_not_k: "i\k" shows "column i (Gram_Schmidt_column_k A (to_nat k)) = (column i A)" using i_not_k unfolding Gram_Schmidt_column_k_def column_def unfolding from_nat_to_nat_id by vector definition "cols_upt_k A k = {column i A|i. i\from_nat k}" lemma cols_upt_k_insert: fixes A::"'a^'n::{mod_type}^'m::{mod_type}" assumes k: "(Suc k) from_nat (Suc k)" and "column i A \ column (from_nat (Suc k)) A" hence i_not_suc_k: "i \ from_nat (Suc k)" by auto have i_le: "i \ from_nat k" proof - have "i < from_nat (Suc k)" by (metis le_imp_less_or_eq i i_not_suc_k) thus ?thesis by (metis Suc_eq_plus1 from_nat_suc le_Suc not_less) qed thus "\ia. column i A = column ia A \ ia \ from_nat k" by auto next fix i::'n assume i: "i \ from_nat k" also have "... < from_nat (Suc k)" by (rule from_nat_mono[OF _ k[unfolded ncols_def]], simp) finally have "i \ from_nat (Suc k)" by simp thus "\ia. column i A = column ia A \ ia \ from_nat (Suc k)" by auto qed lemma columns_eq_cols_upt_k: fixes A::"'a^'cols::{mod_type}^'rows::{mod_type}" shows "cols_upt_k A (ncols A - 1) = columns A" proof (unfold cols_upt_k_def columns_def, auto) fix i show "\ia. column i A = column ia A \ ia \ from_nat (ncols A - Suc 0)" proof (rule exI[of _ i], simp) have "to_nat i < ncols A" using to_nat_less_card[of i] unfolding ncols_def by simp hence "to_nat i \ (ncols A - 1)" by simp hence "to_nat i \ to_nat (from_nat (ncols A - 1)::'cols)" using to_nat_from_nat_id[of "ncols A - 1", where ?'a='cols] unfolding ncols_def by simp thus "i \ from_nat (ncols A - Suc 0)" by (metis One_nat_def less_le_not_le linear to_nat_mono) qed qed lemma span_cols_upt_k_Gram_Schmidt_column_k: fixes A::"'a::{real_inner}^'n::{mod_type}^'m::{mod_type}" assumes "k < ncols A" and "j < ncols A" shows "span (cols_upt_k A k) = span (cols_upt_k (Gram_Schmidt_column_k A j) k)" using assms proof (induct k) case 0 have set_rw: "{\ ia. A$ ia $i |i. i < 0} = {}" using least_mod_type not_less by auto have set_rw2: "{column i (Gram_Schmidt_column_k A j) |i. i \ 0} = {column 0 (Gram_Schmidt_column_k A j)}" by (auto, metis eq_iff least_mod_type) have set_rw3: "{column i A |i. i \ 0} ={column 0 A}" by (auto, metis eq_iff least_mod_type) have col_0_eq: "column 0 (Gram_Schmidt_column_k A j) = column 0 A" unfolding Gram_Schmidt_column_k_def column_def unfolding proj_onto_def proj_def[abs_def] by (simp add: set_rw) show ?case unfolding cols_upt_k_def from_nat_0 unfolding set_rw2 set_rw3 unfolding col_0_eq .. next case (Suc k) have hyp: "span (cols_upt_k A k) = span (cols_upt_k (Gram_Schmidt_column_k A j) k)" using Suc.prems Suc.hyps by auto have set_rw1: "(cols_upt_k A (Suc k)) = insert (column (from_nat (Suc k)) A) (cols_upt_k A k)" using cols_upt_k_insert by (auto intro!: cols_upt_k_insert[OF Suc.prems(1)]) have set_rw2: "(cols_upt_k (Gram_Schmidt_column_k A j) (Suc k)) = insert (column (from_nat (Suc k)) (Gram_Schmidt_column_k A j)) (cols_upt_k (Gram_Schmidt_column_k A j) k)" using cols_upt_k_insert Suc.prems(1) unfolding ncols_def by auto show ?case proof (cases "j=Suc k") case False have suc_not_k: "from_nat (Suc k) \ (from_nat j::'n)" proof (rule ccontr, simp) assume "from_nat (Suc k) = (from_nat j::'n)" hence "Suc k = j" apply (rule from_nat_eq_imp_eq) using Suc.prems unfolding ncols_def . thus False using False by simp qed have tnfnj: "to_nat (from_nat j::'n) = j" using to_nat_from_nat_id[OF Suc.prems(2)[unfolded ncols_def]] . let ?a_suc_k = "column (from_nat (Suc k)) A" have col_eq: "column (from_nat (Suc k)) (Gram_Schmidt_column_k A j) = ?a_suc_k" using column_Gram_Schmidt_column_k'[OF suc_not_k] unfolding tnfnj . have k: "k from_nat k} = {column i A |i. i < from_nat (Suc k)}" proof (auto) fix i::'n assume i: "i \ from_nat k" also have "... < from_nat (Suc k)" by (rule from_nat_mono[OF _ Suc.prems(1)[unfolded ncols_def]], simp) finally show "\ia. column i A = column ia A \ ia < from_nat (Suc k)" by auto next fix i::'n assume i: "i < from_nat (Suc k)" hence "i\ from_nat k" unfolding Suc_eq_plus1 unfolding from_nat_suc by (metis le_Suc not_less) thus " \ia. column i A = column ia A \ ia \ from_nat k" by auto qed have rw: "column (from_nat (Suc k)) (Gram_Schmidt_column_k A j) = (a - (\x\cols_upt_k A k. (x \ a / (x \ x)) *\<^sub>R x))" unfolding Gram_Schmidt_column_k_def True unfolding cols_upt_k_def a_def C_def unfolding column_def apply auto unfolding column_def[symmetric] col_rw minus_vec_def unfolding column_def vec_lambda_beta unfolding proj_onto_def proj_def[abs_def] unfolding proj_onto_sum_rw by auto have finite_C: "finite C" unfolding C_def cols_upt_k_def by auto { fix x b have th0: "!!(a::'a^'m::{mod_type}) b c. a - (b - c) = c + (a - b)" by (simp add: field_simps) have "x - b *\<^sub>R (a - (\x\C. (x \ a / (x \ x)) *\<^sub>R x)) \ span C \ x - b *\<^sub>R a \ span C" apply (simp only: scaleR_right_diff_distrib th0) apply (rule span_add_eq) apply (rule span_mul) apply (rule span_sum) apply (rule span_mul) apply (rule span_base) apply assumption done } thus ?thesis unfolding set_eq_iff unfolding C_def B_def unfolding set_rw1 unfolding set_rw2 unfolding span_breakdown_eq unfolding hyp by (metis (mono_tags) B_def a_def rw) qed qed corollary span_Gram_Schmidt_column_k: fixes A::"'a::{real_inner}^'n::{mod_type}^'m::{mod_type}" assumes "k ia. A$ ia \$ i |i. i < from_nat 0} = {}" by (auto, metis less_le_not_le least_mod_type from_nat_0) thus "\ia. column i (Gram_Schmidt_column_k A 0) = column ia A" unfolding Gram_Schmidt_column_k_def column_def unfolding proj_onto_def proj_def[abs_def] by auto show "\ia. column i A = column ia (Gram_Schmidt_column_k A 0)" using set_rw unfolding Gram_Schmidt_column_k_def column_def unfolding from_nat_0 unfolding proj_onto_def proj_def[abs_def] by force qed thus ?case unfolding Gram_Schmidt_upt_k_def by auto next case (Suc k) have hyp: "span (columns A) = span (columns (Gram_Schmidt_upt_k A k))" using Suc.prems Suc.hyps by auto have "span (columns (Gram_Schmidt_upt_k A (Suc k))) = span (columns (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k)))" unfolding Gram_Schmidt_upt_k_suc .. also have "... = span (columns (Gram_Schmidt_upt_k A k))" using span_Gram_Schmidt_column_k[of "Suc k" "(Gram_Schmidt_upt_k A k)"] using Suc.prems unfolding ncols_def by auto finally show ?case using hyp by auto qed corollary span_Gram_Schmidt_matrix: fixes A::"'a::{real_inner}^'n::{mod_type}^'m::{mod_type}" shows "span (columns A) = span (columns (Gram_Schmidt_matrix A))" unfolding Gram_Schmidt_matrix_def by (simp add: span_Gram_Schmidt_upt_k ncols_def) lemma is_basis_columns_Gram_Schmidt_matrix: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes b: "is_basis (columns A)" and c: "card (columns A) = ncols A" shows "is_basis (columns (Gram_Schmidt_matrix A)) \ card (columns (Gram_Schmidt_matrix A)) = ncols A" proof - have span_UNIV: "vec.span (columns (Gram_Schmidt_matrix A)) = (UNIV::(real^'m::{mod_type}) set)" using span_Gram_Schmidt_matrix b unfolding is_basis_def by (metis span_vec_eq) moreover have c_eq: "card (columns (Gram_Schmidt_matrix A)) = ncols A" proof - have "card (columns A) \ card (columns (Gram_Schmidt_matrix A))" by (metis b is_basis_def finite_columns vec.independent_span_bound span_UNIV top_greatest) thus ?thesis using c using card_columns_le_ncols by (metis le_antisym ncols_def) qed moreover have "vec.independent (columns (Gram_Schmidt_matrix A))" proof (rule vec.card_le_dim_spanning[of _ "UNIV::(real^'m::{mod_type}) set"]) show "columns (Gram_Schmidt_matrix A) \ UNIV" by simp show "UNIV \ vec.span (columns (Gram_Schmidt_matrix A))" using span_UNIV by auto show "finite (columns (Gram_Schmidt_matrix A))" using finite_columns . show "card (columns (Gram_Schmidt_matrix A)) \ vec.dim (UNIV::(real^'m::{mod_type}) set)" by (metis b c c_eq eq_iff is_basis_def vec.dim_span_eq_card_independent) qed ultimately show ?thesis unfolding is_basis_def by simp qed text\From here on, we present some lemmas that will be useful for the formalisation of the QR decomposition.\ lemma column_gr_k_Gram_Schmidt_upt: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes "i>k" and i: "i 0" unfolding from_nat_0[symmetric] using bij_from_nat[where ?'a='n] unfolding bij_betw_def by (metis from_nat_eq_imp_eq gr_implies_not0 i ncols_def neq0_conv) thus "column (from_nat i) (Gram_Schmidt_upt_k A 0) = column (from_nat i) A" unfolding Gram_Schmidt_upt_k_def by (simp add: Gram_Schmidt_column_k_def from_nat_0 column_def) next case (Suc k) have hyp: "column (from_nat i) (Gram_Schmidt_upt_k A k) = column (from_nat i) A" using Suc.hyps Suc.prems by auto have to_nat_from_nat_suc_k: "(to_nat (from_nat (Suc k)::'n)) = Suc k" by (metis Suc.prems dual_order.strict_trans from_nat_not_eq i ncols_def) have "column (from_nat i) (Gram_Schmidt_upt_k A (Suc k)) = column (from_nat i) (Gram_Schmidt_column_k (Gram_Schmidt_upt_k A k) (Suc k))" unfolding Gram_Schmidt_upt_k_suc .. also have "... = column (from_nat i) (Gram_Schmidt_upt_k A k)" proof (rule column_Gram_Schmidt_column_k' [of "from_nat i" "from_nat (Suc k)" " (Gram_Schmidt_upt_k A k)", unfolded to_nat_from_nat_suc_k]) show "from_nat i \ (from_nat (Suc k)::'n)" by (metis Suc.prems not_less_iff_gr_or_eq from_nat_not_eq i ncols_def to_nat_from_nat_suc_k) qed finally show ?case unfolding hyp . qed lemma columns_Gram_Schmidt_upt_k_rw: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes k: "Suc k < ncols A" shows "{column i (Gram_Schmidt_upt_k A (Suc k)) |i. i < from_nat (Suc k)} = {column i (Gram_Schmidt_upt_k A k) |i. i < from_nat (Suc k)}" proof (auto) fix i::'n assume i: "i < from_nat (Suc k)" have to_nat_from_nat_k: "to_nat (from_nat (Suc k)::'n) = Suc k" using to_nat_from_nat_id k unfolding ncols_def by auto show "\ia. column i (Gram_Schmidt_upt_k A (Suc k)) = column ia (Gram_Schmidt_upt_k A k) \ ia < from_nat (Suc k)" by (metis column_Gram_Schmidt_upt_k_preserves i k ncols_def to_nat_le) show "\ia. column i (Gram_Schmidt_upt_k A k) = column ia (Gram_Schmidt_upt_k A (Suc k)) \ ia < from_nat (Suc k)" by (metis column_Gram_Schmidt_upt_k_preserves i k ncols_def to_nat_le) qed lemma column_Gram_Schmidt_upt_k: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes "kx\{column i (Gram_Schmidt_upt_k A k)|i. i < (from_nat k)}. (x \ (column (from_nat k) A) / (x \ x)) *\<^sub>R x)" using assms proof (induct k, unfold from_nat_0) have set_rw: "{column i (Gram_Schmidt_upt_k A 0) |i. i < 0} = {}" by (auto, metis least_mod_type not_le) have set_rw2: "{column i A |i. i < 0} = {}" by (auto, metis least_mod_type not_le) have col_rw: "column 0 A = column 0 (Gram_Schmidt_upt_k A 0)" unfolding Gram_Schmidt_upt_k_def apply auto unfolding Gram_Schmidt_column_k_def from_nat_0 unfolding column_def using set_rw2 unfolding proj_onto_def proj_def[abs_def] by vector show "column 0 (Gram_Schmidt_upt_k A 0) = column 0 A - (\x\{column i (Gram_Schmidt_upt_k A 0) |i. i < 0}. (x \ column 0 A / (x \ x)) *\<^sub>R x)" unfolding set_rw col_rw by simp next case (Suc k) let ?ak="column (from_nat k) A" let ?uk="column (from_nat k) (Gram_Schmidt_upt_k A k)" let ?a_suck= "column (from_nat (Suc k)) A" let ?u_suck="column (from_nat (Suc k)) (Gram_Schmidt_upt_k A (Suc k))" have to_nat_from_nat_k: "to_nat (from_nat (Suc k)::'n) = (Suc k)" using to_nat_from_nat_id Suc.prems unfolding ncols_def by auto have a_suc_rw: "column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) = ?a_suck" by (rule column_gr_k_Gram_Schmidt_upt, auto simp add: Suc.prems) have set_rw: "{column i (Gram_Schmidt_upt_k A (Suc k)) |i. i < from_nat (Suc k)} = {column i (Gram_Schmidt_upt_k A k) |i. i < from_nat (Suc k)}" by (rule columns_Gram_Schmidt_upt_k_rw[OF Suc.prems]) have "?u_suck = column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) - (\x\{column i (Gram_Schmidt_upt_k A k) |i. i < from_nat (Suc k)}. (x \ column (from_nat (Suc k)) (Gram_Schmidt_upt_k A k) / (x \ x)) *\<^sub>R x)" unfolding Gram_Schmidt_upt_k_suc using column_Gram_Schmidt_column_k[of "from_nat (Suc k)" "(Gram_Schmidt_upt_k A k)"] unfolding to_nat_from_nat_k by auto also have "... = ?a_suck - (\x\{column i (Gram_Schmidt_upt_k A k) |i. i < from_nat (Suc k)}. (x \ ?a_suck / (x \ x)) *\<^sub>R x)" unfolding a_suc_rw .. finally show "?u_suck = ?a_suck - (\x\{column i (Gram_Schmidt_upt_k A (Suc k)) |i. i < from_nat (Suc k)}. (x \ ?a_suck / (x \ x)) *\<^sub>R x)" unfolding set_rw . qed lemma column_Gram_Schmidt_upt_k_preserves2: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes "a$$from_nat i)" and "i \ j" and "j from_nat (Suc j)" by (rule from_nat_mono'[OF Suc.prems(2) Suc.prems(3)[unfolded ncols_def]]) hence "from_nat i = (from_nat (Suc j)::'n)" using Suc.prems(1) unfolding True by simp hence i_eq_suc: "i=Suc j" apply (rule from_nat_eq_imp_eq) using Suc.prems unfolding ncols_def by auto show ?thesis unfolding True i_eq_suc .. qed qed lemma set_columns_Gram_Schmidt_matrix: fixes A::"real^'n::{mod_type}^'m::{mod_type}" shows "{column i (Gram_Schmidt_matrix A)|i. i < k} = {column i (Gram_Schmidt_upt_k A (to_nat k))|i. i < k}" proof (auto) fix i assume i: "iia. column i (Gram_Schmidt_matrix A) = column ia (Gram_Schmidt_upt_k A (to_nat k)) \ ia < k" proof (rule exI[of _ i], rule conjI) show "column i (Gram_Schmidt_matrix A) = column i (Gram_Schmidt_upt_k A (to_nat k))" unfolding Gram_Schmidt_matrix_def proof (rule column_Gram_Schmidt_upt_k_preserves2[symmetric]) show "i \ from_nat (to_nat k)" using i unfolding from_nat_to_nat_id by auto show "to_nat k \ ncols A - 1" unfolding ncols_def using to_nat_less_card[of k] by auto show "ncols A - 1 < ncols A" unfolding ncols_def by simp qed show "i < k" using i . qed show "\ia. column i (Gram_Schmidt_upt_k A (to_nat k)) = column ia (Gram_Schmidt_matrix A) \ ia < k" proof (rule exI[of _ i], rule conjI) show "column i (Gram_Schmidt_upt_k A (to_nat k)) = column i (Gram_Schmidt_matrix A)" unfolding Gram_Schmidt_matrix_def proof (rule column_Gram_Schmidt_upt_k_preserves2) show "i \ from_nat (to_nat k)" using i unfolding from_nat_to_nat_id by auto show "to_nat k \ ncols A - 1" unfolding ncols_def using to_nat_less_card[of k] by auto show "ncols A - 1 < ncols A" unfolding ncols_def by simp qed show "i < k" using i . qed qed lemma column_Gram_Schmidt_matrix: fixes A::"real^'n::{mod_type}^'m::{mod_type}" shows "column k (Gram_Schmidt_matrix A) = (column k A) - (\x\{column i (Gram_Schmidt_matrix A)|i. i < k}. (x \ (column k A) / (x \ x)) *\<^sub>R x)" proof - have k: "to_nat k < ncols A" using to_nat_less_card[of k] unfolding ncols_def by simp have "column k (Gram_Schmidt_matrix A) = column k (Gram_Schmidt_upt_k A (ncols A - 1))" unfolding Gram_Schmidt_matrix_def .. also have "... = column k (Gram_Schmidt_upt_k A (to_nat k))" proof (rule column_Gram_Schmidt_upt_k_preserves2[symmetric]) show "k \ from_nat (to_nat k)" unfolding from_nat_to_nat_id .. show "to_nat k \ ncols A - 1" unfolding ncols_def using to_nat_less_card[where ?'a='n] - by (metis le_diff_conv2 add_leE less_diff_conv less_imp_le_nat less_le_not_le + by (metis Nat.le_diff_conv2 add_leE less_diff_conv less_imp_le_nat less_le_not_le nat_le_linear suc_not_zero to_nat_plus_one_less_card') show "ncols A - 1 < ncols A" unfolding ncols_def by auto qed also have "... = column k A - (\x\{column i (Gram_Schmidt_upt_k A (to_nat k)) |i. i < k}. (x \ column k A / (x \ x)) *\<^sub>R x)" using column_Gram_Schmidt_upt_k[OF k] unfolding from_nat_to_nat_id by auto also have "... = column k A - (\x\{column i (Gram_Schmidt_matrix A) |i. i < k}. (x \ column k A / (x \ x)) *\<^sub>R x)" unfolding set_columns_Gram_Schmidt_matrix[symmetric] .. finally show ?thesis . qed corollary column_Gram_Schmidt_matrix2: fixes A::"real^'n::{mod_type}^'m::{mod_type}" shows "(column k A) = column k (Gram_Schmidt_matrix A) + (\x\{column i (Gram_Schmidt_matrix A)|i. i < k}. (x \ (column k A) / (x \ x)) *\<^sub>R x)" using column_Gram_Schmidt_matrix[of k A] by simp lemma independent_columns_Gram_Schmidt_matrix: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes b: "vec.independent (columns A)" and c: "card (columns A) = ncols A" shows "vec.independent (columns (Gram_Schmidt_matrix A)) \ card (columns (Gram_Schmidt_matrix A)) = ncols A" using b c card_columns_le_ncols vec.card_eq_dim_span_indep vec.dim_span eq_iff finite_columns vec.independent_span_bound ncols_def span_Gram_Schmidt_matrix by (metis (no_types, lifting) vec.card_ge_dim_independent vec.dim_span_eq_card_independent span_vec_eq) lemma column_eq_Gram_Schmidt_matrix: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes r: "rank A = ncols A" and c: "column i (Gram_Schmidt_matrix A) = column ia (Gram_Schmidt_matrix A)" shows "i = ia" proof (rule ccontr) assume i_not_ia: "i \ ia" have "columns (Gram_Schmidt_matrix A) = (\x. column x (Gram_Schmidt_matrix A)) (UNIV::('n::{mod_type}) set)" unfolding columns_def by auto also have "... = (\x. column x (Gram_Schmidt_matrix A)) ((UNIV::('n::{mod_type}) set)-{ia})" proof (unfold image_def, auto) fix xa show "\x\UNIV - {ia}. column xa (Gram_Schmidt_matrix A) = column x (Gram_Schmidt_matrix A)" proof (cases "xa = ia") case True thus ?thesis using c i_not_ia by (metis DiffI UNIV_I empty_iff insert_iff) next case False thus ?thesis by auto qed qed finally have columns_rw: "columns (Gram_Schmidt_matrix A) = (\x. column x (Gram_Schmidt_matrix A))  (UNIV - {ia})" . have "ncols A = card (columns (Gram_Schmidt_matrix A))" by (metis full_rank_imp_is_basis2 independent_columns_Gram_Schmidt_matrix r) also have "... \ card (UNIV - {ia})" unfolding columns_rw by (rule card_image_le, simp) also have "... = card (UNIV::'n set) - 1" by (simp add: card_Diff_singleton) finally show False unfolding ncols_def - by (metis Nat.add_0_right le_diff_conv2 One_nat_def Suc_n_not_le_n add_Suc_right one_le_card_finite) + by (metis Nat.add_0_right Nat.le_diff_conv2 One_nat_def Suc_n_not_le_n add_Suc_right one_le_card_finite) qed lemma scaleR_columns_Gram_Schmidt_matrix: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes "i \ j" and "rank A = ncols A" shows "column j (Gram_Schmidt_matrix A) \ column i (Gram_Schmidt_matrix A) = 0" proof - have "column j (Gram_Schmidt_matrix A) \ column i (Gram_Schmidt_matrix A)" using column_eq_Gram_Schmidt_matrix assms by auto thus ?thesis using orthogonal_Gram_Schmidt_matrix2 unfolding pairwise_def orthogonal_def columns_def by blast qed subsubsection\Examples of execution\ text\Code lemma\ lemmas Gram_Schmidt_step_def[unfolded proj_onto_def proj_def[abs_def],code] value "let a = map (list_to_vec::real list=> real^4) [[4,-2,-1,2], [-6,3,4,-8], [5,-5,-3,-4]] in map vec_to_list (Gram_Schmidt a)" value "let a = map (list_to_vec::real list=> real^4) [[4,-2,-1,2], [-6,3,4,-8], [5,-5,-3,-4]] in map vec_to_list (Gram_Schmidt2 a)" value "let A = list_of_list_to_matrix [[4,-2,-1,2], [-6,3,4,-8], [5,-5,-3,-4]]::real^4^3 in matrix_to_list_of_list (Gram_Schmidt_matrix A)" end diff --git a/thys/QR_Decomposition/QR_Decomposition.thy b/thys/QR_Decomposition/QR_Decomposition.thy --- a/thys/QR_Decomposition/QR_Decomposition.thy +++ b/thys/QR_Decomposition/QR_Decomposition.thy @@ -1,754 +1,754 @@ (* Title: QR_Decomposition.thy Author: Jose Divasón Author: Jesús Aransay *) section\QR Decomposition\ theory QR_Decomposition imports Gram_Schmidt begin subsection\The QR Decomposition of a matrix\ text\ First of all, it's worth noting what an orthogonal matrix is. In linear algebra, an orthogonal matrix is a square matrix with real entries whose columns and rows are orthogonal unit vectors. Although in some texts the QR decomposition is presented over square matrices, it can be applied to any matrix. There are some variants of the algorithm, depending on the properties that the output matrices satisfy (see for instance, @{url "http://inst.eecs.berkeley.edu/~ee127a/book/login/l_mats_qr.html"}). We present two of them below. Let A be a matrix with m rows and n columns (A is \m \ n$$. Case 1: Starting with a matrix whose column rank is maximum. We can define the QR decomposition to obtain: \begin{itemize} \item @{term "A = Q ** R"}. \item Q has m rows and n columns. Its columns are orthogonal unit vectors and @{term "(transpose Q) * Q = mat 1"}. In addition, if A is a square matrix, then Q will be an orthonormal matrix. \item R is \n \ n\, invertible and upper triangular. \end{itemize} Case 2: The called full QR decomposition. We can obtain: \begin{itemize} \item @{term "A = Q ** R"} \item Q is an orthogonal matrix (Q is \m \ m\). \item R is \m \ n\ and upper triangular, but it isn't invertible. \end{itemize} We have decided to formalise the first one, because it's the only useful for solving the linear least squares problem (@{url "http://math.mit.edu/linearalgebra/ila0403.pdf"}). If we have an unsolvable system \A *v x = b\, we can try to find an approximate solution. A plausible choice (not the only one) is to seek an \x\ with the property that \\A ** x - y\\ (the magnitude of the error) is as small as possible. That \x\ is the least squares approximation. We will demostrate that the best approximation (the solution for the linear least squares problem) is the \x\ that satisfies: $$transpose A) ** A *v x = (transpose A) *v b\ Now we want to compute that x. If we are working with the first case, \A\ can be substituted by \Q**R\ and then obtain the solution of the least squares approximation by means of the QR decomposition: \x = (inverse R)**(transpose Q) *v b\ On the contrary, if we are working with the second case after substituting \A\ by \Q**R\ we obtain: \(transpose R) ** R *v x = (transpose R) ** (transpose Q) *v b\ But the \R\ matrix is not invertible (so neither is \transpose R$$. The left part of the equation $$transpose R) ** R\ is not going to be an upper triangular matrix, so it can't either be solved using backward-substitution. \ subsubsection\Divide a vector by its norm\ text\An orthogonal matrix is a matrix whose rows (and columns) are orthonormal vectors. So, in order to obtain the QR decomposition, we have to normalise (divide by the norm) the vectors obtained with the Gram-Schmidt algorithm.\ definition "divide_by_norm A = (\ a b. normalize (column b A)  a)" text\Properties\ lemma norm_column_divide_by_norm: fixes A::"'a::{real_inner}^'cols^'rows" assumes a: "column a A \ 0" shows "norm (column a (divide_by_norm A)) = 1" proof - have not_0: "norm (\ i. A  i  a) \ 0" by (metis a column_def norm_eq_zero) have "column a (divide_by_norm A) = (\ i. (1 / norm (\ i. A  i  a)) *\<^sub>R A  i  a)" unfolding divide_by_norm_def column_def normalize_def by auto also have "... = (1 / norm (\ i. A  i  a)) *\<^sub>R (\ i. A  i  a)" unfolding vec_eq_iff by auto finally have "norm (column a (divide_by_norm A)) = norm ((1 / norm (\ i. A  i  a)) *\<^sub>R (\ i. A  i  a))" by simp also have "... = \1 / norm (\ i. A  i  a)\ * norm (\ i. A  i  a)" unfolding norm_scaleR .. also have "... = (1 / norm (\ i. A  i  a)) * norm (\ i. A  i  a)" by auto also have "... = 1" using not_0 by auto finally show ?thesis . qed lemma span_columns_divide_by_norm: shows "span (columns A) = span (columns (divide_by_norm A))" unfolding real_vector.span_eq proof (auto) fix x assume x: "x \ columns (divide_by_norm A)" from this obtain i where x_col_i: "x=column i (divide_by_norm A)" unfolding columns_def by blast also have "... = (1/norm (column i A)) *\<^sub>R (column i A)" unfolding divide_by_norm_def column_def normalize_def by vector finally have x_eq: "x=(1/norm (column i A)) *\<^sub>R (column i A)" . show "x \ span (columns A)" by (unfold x_eq, rule span_mul, rule span_base, auto simp add: columns_def) next fix x assume x: "x \ columns A" show "x \ span (columns (divide_by_norm A))" proof (cases "x=0") case True show ?thesis by (metis True span_0) next case False from x obtain i where x_col_i: "x=column i A" unfolding columns_def by blast have "x=column i A" using x_col_i . also have "... = norm (column i A) *\<^sub>R column i (divide_by_norm A)" using False unfolding x_col_i columns_def divide_by_norm_def column_def normalize_def by vector finally have x_eq: "x = norm (column i A) *\<^sub>R column i (divide_by_norm A)" . show "x \ span (columns (divide_by_norm A))" by (unfold x_eq, rule span_mul, rule span_base, auto simp add: columns_def Let_def) qed qed text\Code lemmas\ definition "divide_by_norm_row A a = vec_lambda(% b. ((1 / norm (column b A)) *\<^sub>R column b A)  a)" lemma divide_by_norm_row_code[code abstract]: "vec_nth (divide_by_norm_row A a) = (% b. ((1 / norm (column b A)) *\<^sub>R column b A)  a)" unfolding divide_by_norm_row_def by (metis (lifting) vec_lambda_beta) lemma divide_by_norm_code [code abstract]: "vec_nth (divide_by_norm A) = divide_by_norm_row A" unfolding divide_by_norm_def unfolding divide_by_norm_row_def[abs_def] unfolding normalize_def by fastforce subsubsection\The QR Decomposition\ text\The QR decomposition. Given a real matrix @{term "A"}, the algorithm will return a pair @{term "(Q,R)"} where @{term "Q"} is an matrix whose columns are orthogonal unit vectors, @{term "R"} is upper triangular and @{term "A=Q**R"}.\ definition "QR_decomposition A = (let Q = divide_by_norm (Gram_Schmidt_matrix A) in (Q, (transpose Q) ** A))" lemma is_basis_columns_fst_QR_decomposition: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes b: "is_basis (columns A)" and c: "card (columns A) = ncols A" shows "is_basis (columns (fst (QR_decomposition A))) \ card (columns (fst (QR_decomposition A))) = ncols A" proof (rule conjI, unfold is_basis_def, rule conjI) have "vec.span (columns (fst (QR_decomposition A))) = vec.span (columns (Gram_Schmidt_matrix A))" unfolding vec.span_eq proof (auto) fix x show "x \ vec.span (columns (Gram_Schmidt_matrix A))" using assms(1) assms(2) is_basis_columns_Gram_Schmidt_matrix is_basis_def by auto next fix x assume x: "x \ columns (Gram_Schmidt_matrix A)" from this obtain i where x_col_i: "x=column i (Gram_Schmidt_matrix A)" unfolding columns_def by blast have zero_not_in: "x \ 0" using is_basis_columns_Gram_Schmidt_matrix[OF b c] unfolding is_basis_def using vec.dependent_zero[of "(columns (Gram_Schmidt_matrix A))"] x by auto have "x=column i (Gram_Schmidt_matrix A)" using x_col_i . also have "... = norm (column i (Gram_Schmidt_matrix A)) *\<^sub>R column i (divide_by_norm (Gram_Schmidt_matrix A))" using zero_not_in unfolding x_col_i columns_def divide_by_norm_def column_def normalize_def by vector finally have x_eq: "x = norm (column i (Gram_Schmidt_matrix A)) *\<^sub>R column i (divide_by_norm (Gram_Schmidt_matrix A))" . show "x \ vec.span (columns (fst (QR_decomposition A)))" unfolding x_eq span_vec_eq apply (rule subspace_mul) apply (auto simp add: columns_def QR_decomposition_def Let_def subspace_span intro: span_superset) using span_superset by force qed thus s: "vec.span (columns (fst (QR_decomposition A))) = (UNIV::(real^'m::{mod_type}) set)" using is_basis_columns_Gram_Schmidt_matrix[OF b c] unfolding is_basis_def by simp thus "card (columns (fst (QR_decomposition A))) = ncols A" by (metis (hide_lams, mono_tags) b c card_columns_le_ncols vec.card_le_dim_spanning finite_columns vec.indep_card_eq_dim_span is_basis_def ncols_def top_greatest) thus "vec.independent (columns (fst (QR_decomposition A)))" by (metis s b c vec.card_eq_dim_span_indep finite_columns vec.indep_card_eq_dim_span is_basis_def) qed lemma orthogonal_fst_QR_decomposition: shows "pairwise orthogonal (columns (fst (QR_decomposition A)))" unfolding pairwise_def columns_def proof (auto) fix i ia assume col_not_eq: "column i (fst (QR_decomposition A)) \ column ia (fst (QR_decomposition A))" hence i_not_ia: "i \ ia" by auto from col_not_eq obtain a where "(fst (QR_decomposition A))  a  i \ (fst (QR_decomposition A))  a  ia" unfolding column_def by force hence col_not_eq2: " (column i (Gram_Schmidt_matrix A)) \ (column ia (Gram_Schmidt_matrix A))" using col_not_eq unfolding QR_decomposition_def Let_def fst_conv by (metis (lifting) divide_by_norm_def vec_lambda_beta) have d1: "column i (fst (QR_decomposition A)) = (1 / norm (\ ia. Gram_Schmidt_matrix A  ia  i)) *\<^sub>R (column i (Gram_Schmidt_matrix A))" unfolding QR_decomposition_def Let_def fst_conv unfolding divide_by_norm_def column_def normalize_def unfolding vec_eq_iff by auto have d2: "column ia (fst (QR_decomposition A)) = (1 / norm (\ i. Gram_Schmidt_matrix A  i  ia)) *\<^sub>R (column ia (Gram_Schmidt_matrix A))" unfolding QR_decomposition_def Let_def fst_conv unfolding divide_by_norm_def column_def normalize_def unfolding vec_eq_iff by auto show "orthogonal (column i (fst (QR_decomposition A))) (column ia (fst (QR_decomposition A)))" unfolding d1 d2 apply (rule orthogonal_mult) using orthogonal_Gram_Schmidt_matrix[of A] unfolding pairwise_def using col_not_eq2 by auto qed lemma qk_uk_norm: "(1/(norm (column k ((Gram_Schmidt_matrix A))))) *\<^sub>R (column k ((Gram_Schmidt_matrix A))) = column k (fst(QR_decomposition A))" unfolding QR_decomposition_def Let_def fst_conv divide_by_norm_def unfolding column_def normalize_def by vector lemma norm_columns_fst_QR_decomposition: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes "rank A = ncols A" shows "norm (column i (fst (QR_decomposition A))) = 1" proof - have "vec.independent (columns (Gram_Schmidt_matrix A))" by (metis assms full_rank_imp_is_basis2 independent_columns_Gram_Schmidt_matrix) hence "column i (Gram_Schmidt_matrix A) \ 0" using vec.dependent_zero[of "columns (Gram_Schmidt_matrix A)"] unfolding columns_def by auto thus "norm (column i (fst (QR_decomposition A))) = 1" unfolding QR_decomposition_def Let_def fst_conv by (rule norm_column_divide_by_norm) qed corollary span_fst_QR_decomposition: fixes A::"real^'n::{mod_type}^'m::{mod_type}" shows "vec.span (columns A) = vec.span (columns (fst (QR_decomposition A)))" unfolding span_Gram_Schmidt_matrix[of A] unfolding QR_decomposition_def Let_def fst_conv by (metis \span (columns A) = span (columns (Gram_Schmidt_matrix A))\ span_columns_divide_by_norm span_vec_eq) corollary col_space_QR_decomposition: fixes A::"real^'n::{mod_type}^'m::{mod_type}" shows "col_space A = col_space (fst (QR_decomposition A))" unfolding col_space_def using span_fst_QR_decomposition by auto lemma independent_columns_fst_QR_decomposition: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes b: "vec.independent (columns A)" and c: "card (columns A) = ncols A" shows "vec.independent (columns (fst (QR_decomposition A))) \ card (columns (fst (QR_decomposition A))) = ncols A" proof - have r: "rank A = ncols A" thm is_basis_imp_full_rank proof - have "rank A = col_rank A" unfolding rank_col_rank .. also have "... = vec.dim (col_space A)" unfolding col_rank_def .. also have "... = card (columns A)" unfolding col_space_def using b by (rule vec.dim_span_eq_card_independent) also have "... = ncols A" using c . finally show ?thesis . qed have "vec.independent (columns (fst (QR_decomposition A)))" by (metis b c col_rank_def col_space_QR_decomposition col_space_def full_rank_imp_is_basis2 vec.indep_card_eq_dim_span ncols_def rank_col_rank) moreover have "card (columns (fst (QR_decomposition A))) = ncols A" by (metis col_space_QR_decomposition full_rank_imp_is_basis2 ncols_def r rank_eq_dim_col_space') ultimately show ?thesis by simp qed lemma orthogonal_matrix_fst_QR_decomposition: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes r: "rank A = ncols A" shows "transpose (fst (QR_decomposition A)) ** (fst (QR_decomposition A)) = mat 1" proof (unfold vec_eq_iff, clarify, unfold mat_1_fun, auto) define Q where "Q = fst (QR_decomposition A)" have n: "\i. norm (column i Q) = 1" unfolding Q_def using norm_columns_fst_QR_decomposition[OF r] by auto have c: "card (columns Q) = ncols A" unfolding Q_def by (metis full_rank_imp_is_basis2 independent_columns_fst_QR_decomposition r) have p: "pairwise orthogonal (columns Q)" by (metis Q_def orthogonal_fst_QR_decomposition) fix ia have "(transpose Q ** Q)  ia  ia = column ia Q \ column ia Q" unfolding matrix_matrix_mult_inner_mult unfolding row_transpose .. also have "... = 1" using n norm_eq_1 by blast finally show "(transpose Q ** Q)  ia  ia = 1" . fix i assume i_not_ia: "i \ ia" have column_i_not_ia: "column i Q \ column ia Q" proof (rule ccontr, simp) assume col_i_ia: "column i Q = column ia Q" have rw: "(\i. column i Q) (UNIV-{ia}) = {column i Q|i. i\ia}" unfolding columns_def by auto have "card (columns Q) = card ({column i Q|i. i\ia})" by (rule bij_betw_same_card[of id], unfold bij_betw_def columns_def, auto, metis col_i_ia i_not_ia) also have "... = card ((\i. column i Q) (UNIV-{ia}))" unfolding rw .. also have "... \ card (UNIV - {ia})" by (metis card_image_le finite_code) also have "... < CARD ('n)" by simp finally show False using c unfolding ncols_def by simp qed hence oia: "orthogonal (column i Q) (column ia Q)" using p unfolding pairwise_def unfolding columns_def by auto have "(transpose Q ** Q)  i  ia = column i Q \ column ia Q" unfolding matrix_matrix_mult_inner_mult unfolding row_transpose .. also have "... = 0" using oia unfolding orthogonal_def . finally show "(transpose Q ** Q)  i  ia = 0" . qed corollary orthogonal_matrix_fst_QR_decomposition': fixes A::"real^'n::{mod_type}^'n::{mod_type}" assumes "rank A = ncols A" shows "orthogonal_matrix (fst (QR_decomposition A))" by (metis assms orthogonal_matrix orthogonal_matrix_fst_QR_decomposition) lemma column_eq_fst_QR_decomposition: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes r: "rank A = ncols A" and c: "column i (fst (QR_decomposition A)) = column ia (fst (QR_decomposition A))" shows "i = ia" proof (rule ccontr) assume i_not_ia: "i \ ia" have "columns (fst (QR_decomposition A)) = (\x. column x (fst (QR_decomposition A))) (UNIV::('n::{mod_type}) set)" unfolding columns_def by auto also have "... = (\x. column x (fst (QR_decomposition A))) ((UNIV::('n::{mod_type}) set)-{ia})" proof (unfold image_def, auto) fix xa show "\x\UNIV - {ia}. column xa (fst (QR_decomposition A)) = column x (fst (QR_decomposition A))" proof (cases "xa = ia") case True thus ?thesis using c i_not_ia by (metis DiffI UNIV_I empty_iff insert_iff) next case False thus ?thesis by auto qed qed finally have columns_rw: "columns (fst (QR_decomposition A)) = (\x. column x (fst (QR_decomposition A)))  (UNIV - {ia})" . have "ncols A = card (columns (fst (QR_decomposition A)))" by (metis full_rank_imp_is_basis2 independent_columns_fst_QR_decomposition r) also have "... \ card (UNIV - {ia})" unfolding columns_rw by (rule card_image_le, simp) also have "... = card (UNIV::'n set) - 1" by (simp add: card_Diff_singleton) finally show False unfolding ncols_def - by (metis Nat.add_0_right le_diff_conv2 One_nat_def Suc_n_not_le_n add_Suc_right one_le_card_finite) + by (metis Nat.add_0_right Nat.le_diff_conv2 One_nat_def Suc_n_not_le_n add_Suc_right one_le_card_finite) qed corollary column_QR_decomposition: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes r: "rank A = ncols A" shows "column k ((Gram_Schmidt_matrix A)) = (column k A) - (\x\{column i (fst (QR_decomposition A))|i. i < k}. (x \ (column k A) / (x \ x)) *\<^sub>R x)" proof - let ?uk="column k ((Gram_Schmidt_matrix A))" let ?qk="column k (fst(QR_decomposition A))" let ?ak="(column k A)" define f where "f x = (1/norm x) *\<^sub>R x" for x :: "real^'m::{mod_type}" let ?g="\x::real^'m::{mod_type}. (x \ (column k A) / (x \ x)) *\<^sub>R x" have set_rw: "{column i (fst (QR_decomposition A))|i. i < k} = f{column i (Gram_Schmidt_matrix A)|i. i < k}" proof (auto) fix i assume i: "i < k" have col_rw: "column i (fst (QR_decomposition A)) = (1/norm (column i (Gram_Schmidt_matrix A))) *\<^sub>R (column i (Gram_Schmidt_matrix A))" unfolding QR_decomposition_def Let_def fst_conv divide_by_norm_def column_def normalize_def by vector thus "column i (fst (QR_decomposition A)) \ f  {column i (Gram_Schmidt_matrix A) |i. i < k}" unfolding f_def using i by auto show "\ia. f (column i (Gram_Schmidt_matrix A)) = column ia (fst (QR_decomposition A)) \ ia < k" by (rule exI[of _ i], simp add: f_def col_rw i) qed have "(\x\{column i (fst (QR_decomposition A))|i. i < k}. (x \ ?ak / (x \ x)) *\<^sub>R x) = (\x\(f{column i (Gram_Schmidt_matrix A)|i. i < k}). (x \ ?ak / (x \ x)) *\<^sub>R x)" unfolding set_rw .. also have "... = sum (?g \ f) {column i (Gram_Schmidt_matrix A)|i. i < k}" proof (rule sum.reindex, unfold inj_on_def, auto) fix i ia assume i: "i < k" and ia: "ia < k" and f_eq: "f (column i (Gram_Schmidt_matrix A)) = f (column ia (Gram_Schmidt_matrix A))" have fi: "f (column i (Gram_Schmidt_matrix A)) = column i (fst (QR_decomposition A))" unfolding f_def QR_decomposition_def Let_def fst_conv divide_by_norm_def column_def normalize_def by vector have fia: "f (column ia (Gram_Schmidt_matrix A)) = column ia (fst (QR_decomposition A))" unfolding f_def QR_decomposition_def Let_def fst_conv divide_by_norm_def column_def normalize_def by vector have "i = ia" using column_eq_fst_QR_decomposition[OF r] f_eq unfolding fi fia by simp thus "column i (Gram_Schmidt_matrix A) = column ia (Gram_Schmidt_matrix A)" by simp qed also have "... = (\x\{column i (Gram_Schmidt_matrix A) |i. i < k}. ((1 / norm x) *\<^sub>R x \ ?ak / ((1 / norm x) *\<^sub>R x \ (1 / norm x) *\<^sub>R x)) *\<^sub>R (1 / norm x) *\<^sub>R x)" unfolding o_def f_def .. also have "... = (\x\{column i (Gram_Schmidt_matrix A) |i. i < k}. ((1 / norm x) *\<^sub>R x \ ?ak) *\<^sub>R (1 / norm x) *\<^sub>R x)" proof (rule sum.cong, simp) fix x assume x: "x \ {column i (Gram_Schmidt_matrix A) |i. i < k}" have "vec.independent {column i (Gram_Schmidt_matrix A) |i. i < k}" proof (rule vec.independent_mono[of "columns (Gram_Schmidt_matrix A)"]) show "vec.independent (columns (Gram_Schmidt_matrix A))" using full_rank_imp_is_basis2[of "(Gram_Schmidt_matrix A)"] by (metis full_rank_imp_is_basis2 independent_columns_Gram_Schmidt_matrix r) show "{column i (Gram_Schmidt_matrix A) |i. i < k} \ columns (Gram_Schmidt_matrix A)" unfolding columns_def by auto qed hence "x \ 0" using vec.dependent_zero[of " {column i (Gram_Schmidt_matrix A) |i. i < k}"] x by blast hence "((1 / norm x) *\<^sub>R x \ (1 / norm x) *\<^sub>R x) = 1" by (metis inverse_eq_divide norm_eq_1 norm_sgn sgn_div_norm) thus "((1 / norm x) *\<^sub>R x \ ?ak / ((1 / norm x) *\<^sub>R x \ (1 / norm x) *\<^sub>R x)) *\<^sub>R (1 / norm x) *\<^sub>R x = ((1 / norm x) *\<^sub>R x \ column k A) *\<^sub>R (1 / norm x) *\<^sub>R x" by auto qed also have "... = (\x\{column i (Gram_Schmidt_matrix A) |i. i < k}. (((x \ ?ak)) / (x \ x)) *\<^sub>R x)" proof (rule sum.cong, simp) fix x assume x: "x \ {column i (Gram_Schmidt_matrix A) |i. i < k}" show "((1 / norm x) *\<^sub>R x \ column k A) *\<^sub>R (1 / norm x) *\<^sub>R x = (x \ column k A / (x \ x)) *\<^sub>R x" by (metis (hide_lams, no_types) mult.right_neutral inner_commute inner_scaleR_right norm_cauchy_schwarz_eq scaleR_one scaleR_scaleR times_divide_eq_right times_divide_times_eq) qed finally have "?ak - (\x\{column i (fst (QR_decomposition A))|i. i < k}. (x \ ?ak / (x \ x)) *\<^sub>R x) = ?ak - (\x\{column i (Gram_Schmidt_matrix A) |i. i < k}. (((x \ ?ak)) / (x \ x)) *\<^sub>R x)" by auto also have "... = ?uk" using column_Gram_Schmidt_matrix[of k A] by auto finally show ?thesis .. qed lemma column_QR_decomposition': fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes r: "rank A = ncols A" shows "(column k A) = column k ((Gram_Schmidt_matrix A)) + (\x\{column i (fst (QR_decomposition A))|i. i < k}. (x \ (column k A) / (x \ x)) *\<^sub>R x)" using column_QR_decomposition[OF r] by simp lemma norm_uk_eq: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes r: "rank A = ncols A" shows "norm (column k ((Gram_Schmidt_matrix A))) = ((column k (fst(QR_decomposition A))) \ (column k A))" proof - let ?uk="column k ((Gram_Schmidt_matrix A))" let ?qk="column k (fst(QR_decomposition A))" let ?ak="(column k A)" have sum_rw: "(?uk \ (\x\{column i (Gram_Schmidt_matrix A) |i. i < k}. (x \ ?ak / (x \ x)) *\<^sub>R x)) = 0" proof - have "(?uk \ (\x\{column i (Gram_Schmidt_matrix A) |i. i < k}. (x \ ?ak / (x \ x)) *\<^sub>R x)) = ((\x\{column i (Gram_Schmidt_matrix A) |i. i < k}. ?uk \ ((x \ ?ak / (x \ x)) *\<^sub>R x)))" unfolding inner_sum_right .. also have "... = (\x\{column i (Gram_Schmidt_matrix A) |i. i < k}. ((x \ ?ak / (x \ x)) * (?uk \ x)))" unfolding inner_scaleR_right .. also have "... = 0" proof (rule sum.neutral, clarify) fix x i assume "i column i (Gram_Schmidt_matrix A) = 0" by (metis less_irrefl r scaleR_columns_Gram_Schmidt_matrix) thus "column i (Gram_Schmidt_matrix A) \ ?ak / (column i (Gram_Schmidt_matrix A) \ column i (Gram_Schmidt_matrix A)) * (?uk \ column i (Gram_Schmidt_matrix A)) = 0" by auto qed finally show ?thesis . qed have "?qk \ ?ak = ((1/(norm ?uk)) *\<^sub>R ?uk) \ ?ak" unfolding qk_uk_norm .. also have "... = (1/(norm ?uk)) * (?uk \ ?ak)" unfolding inner_scaleR_left .. also have "... = (1/(norm ?uk)) * (?uk \ (?uk + (\x\{column i (Gram_Schmidt_matrix A) |i. i < k}. (x \ ?ak / (x \ x)) *\<^sub>R x)))" using column_Gram_Schmidt_matrix2[of k A] by auto also have "... = (1/(norm ?uk)) * ((?uk \ ?uk) + (?uk \ (\x\{column i (Gram_Schmidt_matrix A) |i. i < k}. (x \ ?ak / (x \ x)) *\<^sub>R x)))" unfolding inner_add_right .. also have "... = (1/(norm ?uk)) * (?uk \ ?uk)" unfolding sum_rw by auto also have "... = norm ?uk" by (metis abs_of_nonneg divide_eq_imp div_by_0 inner_commute inner_ge_zero inner_real_def norm_mult_vec real_inner_1_right real_norm_def times_divide_eq_right) finally show ?thesis .. qed corollary column_QR_decomposition2: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes r: "rank A = ncols A" shows "(column k A) = (\x\{column i (fst (QR_decomposition A))|i. i \ k}. (x \ (column k A)) *\<^sub>R x)" proof - let ?uk="column k ((Gram_Schmidt_matrix A))" let ?qk="column k (fst(QR_decomposition A))" let ?ak="(column k A)" have set_rw: "{column i (fst (QR_decomposition A))|i. i \ k} = insert (column k (fst (QR_decomposition A))) {column i (fst (QR_decomposition A))|i. i < k}" by (auto, metis less_linear not_less) have uk_norm_uk_qk: "?uk = norm ?uk *\<^sub>R ?qk" proof - have "vec.independent (columns (Gram_Schmidt_matrix A))" by (metis full_rank_imp_is_basis2 independent_columns_Gram_Schmidt_matrix r) moreover have "?uk \ columns (Gram_Schmidt_matrix A)" unfolding columns_def by auto ultimately have "?uk \ 0" using vec.dependent_zero[of "columns (Gram_Schmidt_matrix A)"] unfolding columns_def by auto hence norm_not_0: "norm ?uk \ 0" unfolding norm_eq_zero . have "norm (?uk) *\<^sub>R ?qk = (norm ?uk) *\<^sub>R ((1 / norm ?uk) *\<^sub>R ?uk)" using qk_uk_norm[of k A] by simp also have "... = ((norm ?uk) * (1 / norm ?uk)) *\<^sub>R ?uk" unfolding scaleR_scaleR .. also have "... = ?uk" using norm_not_0 by auto finally show ?thesis .. qed have norm_qk_1: "?qk \ ?qk = 1" using norm_eq_1 norm_columns_fst_QR_decomposition[OF r] by auto have "?ak = ?uk + (\x\{column i (fst (QR_decomposition A))|i. i < k}. (x \ ?ak / (x \ x)) *\<^sub>R x)" using column_QR_decomposition'[OF r] by auto also have "... = (norm ?uk *\<^sub>R ?qk) + (\x\{column i (fst (QR_decomposition A))|i. i < k}. (x \ ?ak / (x \ x)) *\<^sub>R x)" using uk_norm_uk_qk by simp also have "... = ((?qk \ ?ak) *\<^sub>R ?qk) + (\x\{column i (fst (QR_decomposition A))|i. i < k}. (x \ ?ak / (x \ x)) *\<^sub>R x)" unfolding norm_uk_eq[OF r] .. also have "... = ((?qk \ ?ak)/(?qk \ ?qk)) *\<^sub>R ?qk + (\x\{column i (fst (QR_decomposition A))|i. i < k}. (x \ ?ak / (x \ x)) *\<^sub>R x)" using norm_qk_1 by fastforce also have "... = (\x\insert ?qk {column i (fst (QR_decomposition A))|i. i < k}. (x \ ?ak / (x \ x)) *\<^sub>R x)" proof (rule sum.insert[symmetric]) show "finite {column i (fst (QR_decomposition A)) |i. i < k}" by simp show "column k (fst (QR_decomposition A)) \ {column i (fst (QR_decomposition A)) |i. i < k}" proof (rule ccontr, simp) assume "\i. column k (fst (QR_decomposition A)) = column i (fst (QR_decomposition A)) \ i < k" from this obtain i where col_eq: "column k (fst (QR_decomposition A)) = column i (fst (QR_decomposition A))" and i_less_k: "i < k" by blast show False using column_eq_fst_QR_decomposition[OF r col_eq] i_less_k by simp qed qed also have "... = (\x\{column i (fst (QR_decomposition A))|i. i \ k}. (x \ (column k A)) *\<^sub>R x)" proof (rule sum.cong, simp add: set_rw) fix x assume x: "x \ {column i (fst (QR_decomposition A)) |i. i \ k}" from this obtain i where i: "x=column i (fst (QR_decomposition A))" by blast hence "(x \ x) = 1" using norm_eq_1 norm_columns_fst_QR_decomposition[OF r] by auto thus "(x \ column k A / (x \ x)) *\<^sub>R x = (x \ column k A) *\<^sub>R x" by simp qed finally show ?thesis . qed lemma orthogonal_columns_fst_QR_decomposition: assumes i_not_ia: "(column i (fst (QR_decomposition A))) \ (column ia (fst (QR_decomposition A)))" shows "(column i (fst (QR_decomposition A)) \ column ia (fst (QR_decomposition A))) = 0" proof - have i: "column i (fst (QR_decomposition A)) \ columns (fst (QR_decomposition A))" unfolding columns_def by auto have ia: "column ia (fst (QR_decomposition A)) \ columns (fst (QR_decomposition A))" unfolding columns_def by auto show ?thesis using orthogonal_fst_QR_decomposition[of A] i ia i_not_ia unfolding pairwise_def orthogonal_def by auto qed lemma scaler_column_fst_QR_decomposition: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes i: "i>j" and r: "rank A = ncols A" shows "column i (fst (QR_decomposition A)) \ column j A = 0" proof - have "column i (fst(QR_decomposition A)) \ column j A = column i (fst (QR_decomposition A)) \ (\x\{column i (fst (QR_decomposition A))|i. i \ j}. (x \ (column j A)) *\<^sub>R x)" using column_QR_decomposition2[OF r] by presburger also have "... = (\x\{column i (fst (QR_decomposition A))|i. i \ j}. column i (fst (QR_decomposition A)) \ (x \ (column j A)) *\<^sub>R x)" unfolding real_inner_class.inner_sum_right .. also have "... = (\x\{column i (fst (QR_decomposition A))|i. i \ j}. (x \ (column j A)) *(column i (fst (QR_decomposition A)) \ x))" unfolding real_inner_class.inner_scaleR_right .. also have "... = 0" proof (rule sum.neutral, clarify) fix ia assume ia: "ia \ j" have i_not_ia: "i \ ia" using i ia by simp hence "(column i (fst (QR_decomposition A)) \ column ia (fst (QR_decomposition A)))" by (metis column_eq_fst_QR_decomposition r) hence "(column i (fst (QR_decomposition A)) \ column ia (fst (QR_decomposition A))) = 0" by (rule orthogonal_columns_fst_QR_decomposition) thus "column ia (fst (QR_decomposition A)) \ column j A * (column i (fst (QR_decomposition A)) \ column ia (fst (QR_decomposition A))) = 0" by auto qed finally show ?thesis . qed lemma R_Qi_Aj: fixes A::"real^'n::{mod_type}^'m::{mod_type}" shows "(snd (QR_decomposition A))  i  j = column i (fst (QR_decomposition A)) \ column j A" unfolding QR_decomposition_def Let_def snd_conv matrix_matrix_mult_inner_mult unfolding row_transpose by auto lemma sums_columns_Q_0: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes r: "rank A = ncols A" shows "(\x\{column i (fst (QR_decomposition A)) |i. i>b}. x \ column b A * x  a) = 0" proof (rule sum.neutral, auto) fix i assume "b column b A = 0" by (rule scaler_column_fst_QR_decomposition, simp add: r) qed lemma QR_decomposition_mult: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes r: "rank A = ncols A" shows "A = (fst (QR_decomposition A)) ** (snd (QR_decomposition A))" proof - have "\b. column b A = column b ((fst (QR_decomposition A)) ** (snd (QR_decomposition A)))" proof (clarify) fix b have "(fst (QR_decomposition A) ** snd (QR_decomposition A)) = (\ i j. \k\UNIV. fst (QR_decomposition A)  i  k * (column k (fst (QR_decomposition A)) \ column j A))" unfolding matrix_matrix_mult_def R_Qi_Aj by auto hence "column b ((fst (QR_decomposition A) ** snd (QR_decomposition A))) = column b ((\ i j. \k\UNIV. fst (QR_decomposition A)  i  k * (column k (fst (QR_decomposition A)) \ column j A)))" by auto also have "... = (\x\{column i (fst (QR_decomposition A)) |i. i \ b}. (x \ column b A) *\<^sub>R x)" proof (subst column_def, subst vec_eq_iff, auto) fix a define f where "f i = column i (fst (QR_decomposition A))" for i define g where "g x = (THE i. x = column i (fst (QR_decomposition A)))" for x have f_eq: "fUNIV = {column i (fst (QR_decomposition A)) |i. i\UNIV}" unfolding f_def by auto have inj_f: "inj f" by (metis inj_on_def f_def column_eq_fst_QR_decomposition r) have "(\x\{column i (fst (QR_decomposition A)) |i. i \ b}. x \ column b A * x  a) = (\x\{column i (fst (QR_decomposition A)) |i. i\UNIV}. x \ column b A * x  a)" proof - let ?c= "{column i (fst (QR_decomposition A)) |i. i\UNIV}" let ?d= "{column i (fst (QR_decomposition A)) |i. i\b}" let ?f = "{column i (fst (QR_decomposition A)) |i. i>b}" have set_rw: "?c = ?d \ ?f" by force have "(\x\?c. x \ column b A * x  a) = (\x\(?d \ ?f). x \ column b A * x  a)" using set_rw by simp also have "... = (\x\?d. x \ column b A * x  a) + (\x\?f. x \ column b A * x  a)" by (rule sum.union_disjoint, auto, metis f_def inj_eq inj_f not_le) also have "... = (\x\?d. x \ column b A * x  a)" using sums_columns_Q_0[OF r] by auto finally show ?thesis .. qed also have "... = (\x\fUNIV. x \ column b A * x  a)" using f_eq by auto also have "... = (\k\UNIV. fst (QR_decomposition A)  a  k * (column k (fst (QR_decomposition A)) \ column b A))" unfolding sum.reindex[OF inj_f] unfolding f_def column_def by (rule sum.cong, simp_all) finally show " (\k\UNIV. fst (QR_decomposition A)  a  k * (column k (fst (QR_decomposition A)) \ column b A)) = (\x\{column i (fst (QR_decomposition A)) |i. i \ b}. x \ column b A * x  a)" .. qed also have "... = column b A" using column_QR_decomposition2[OF r] by simp finally show "column b A = column b (fst (QR_decomposition A) ** snd (QR_decomposition A))" .. qed thus ?thesis unfolding column_def vec_eq_iff by auto qed lemma upper_triangular_snd_QR_decomposition: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes r: "rank A = ncols A" shows "upper_triangular (snd (QR_decomposition A))" proof (unfold upper_triangular_def, auto) fix i j::'n assume j_less_i: "j < i" have "snd (QR_decomposition A)  i  j = column i (fst (QR_decomposition A)) \ column j A" unfolding QR_decomposition_def Let_def fst_conv snd_conv unfolding matrix_matrix_mult_inner_mult row_transpose .. also have "... = 0" using scaler_column_fst_QR_decomposition[OF j_less_i r] . finally show "snd (QR_decomposition A)  i  j = 0" by auto qed lemma upper_triangular_invertible: fixes A :: "real^'n::{finite,wellorder}^'n::{finite,wellorder}" assumes u: "upper_triangular A" and d: "\i. A  i  i \ 0" shows "invertible A" proof - have det_R: "det A = (prod (\i. Aii) (UNIV::'n set))" using det_upperdiagonal u unfolding upper_triangular_def by blast also have "... \ 0" using d by auto finally show ?thesis by (metis invertible_det_nz) qed lemma invertible_snd_QR_decomposition: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes r: "rank A = ncols A" shows "invertible (snd (QR_decomposition A))" proof (rule upper_triangular_invertible) show "upper_triangular (snd (QR_decomposition A))" using upper_triangular_snd_QR_decomposition[OF r] . show "\i. snd (QR_decomposition A)  i  i \ 0" proof (rule allI) fix i have ind: "vec.independent (columns (Gram_Schmidt_matrix A))" by (metis full_rank_imp_is_basis2 independent_columns_Gram_Schmidt_matrix r) hence zero_not_in: "0 \ (columns (Gram_Schmidt_matrix A))" by (metis vec.dependent_zero) hence c:"column i (Gram_Schmidt_matrix A) \ 0" unfolding columns_def by simp have "snd (QR_decomposition A)  i  i = column i (fst (QR_decomposition A)) \ column i A" unfolding QR_decomposition_def Let_def snd_conv fst_conv unfolding matrix_matrix_mult_inner_mult unfolding row_transpose .. also have "... = norm (column i (Gram_Schmidt_matrix A))" unfolding norm_uk_eq[OF r, symmetric] .. also have "... \ 0" by (rule ccontr, simp add: c) finally show "snd (QR_decomposition A)  i  i \ 0" . qed qed lemma QR_decomposition: fixes A::"real^'n::{mod_type}^'m::{mod_type}" assumes r: "rank A = ncols A" shows "A = fst (QR_decomposition A) ** snd (QR_decomposition A) \ pairwise orthogonal (columns (fst (QR_decomposition A))) \ (\i. norm (column i (fst (QR_decomposition A))) = 1) \ (transpose (fst (QR_decomposition A))) ** (fst (QR_decomposition A)) = mat 1 \ vec.independent (columns (fst (QR_decomposition A))) \ col_space A = col_space (fst (QR_decomposition A)) \ card (columns A) = card (columns (fst (QR_decomposition A))) \ invertible (snd (QR_decomposition A)) \ upper_triangular (snd (QR_decomposition A))" by (metis QR_decomposition_mult col_space_def full_rank_imp_is_basis2 independent_columns_fst_QR_decomposition invertible_snd_QR_decomposition norm_columns_fst_QR_decomposition orthogonal_fst_QR_decomposition orthogonal_matrix_fst_QR_decomposition r span_fst_QR_decomposition upper_triangular_snd_QR_decomposition) lemma QR_decomposition_square: fixes A::"real^'n::{mod_type}^'n::{mod_type}" assumes r: "rank A = ncols A" shows "A = fst (QR_decomposition A) ** snd (QR_decomposition A) \ orthogonal_matrix (fst (QR_decomposition A)) \ upper_triangular (snd (QR_decomposition A)) \ invertible (snd (QR_decomposition A)) \ pairwise orthogonal (columns (fst (QR_decomposition A))) \ (\i. norm (column i (fst (QR_decomposition A))) = 1) \ vec.independent (columns (fst (QR_decomposition A))) \ col_space A = col_space (fst (QR_decomposition A)) \ card (columns A) = card (columns (fst (QR_decomposition A)))" by (metis QR_decomposition orthogonal_matrix_fst_QR_decomposition' r) text\QR for computing determinants\ lemma det_QR_decomposition: fixes A::"real^'n::{mod_type}^'n::{mod_type}" assumes r: "rank A = ncols A" shows "\det A\ = \(prod (\i. snd(QR_decomposition A)ii) (UNIV::'n set))\" proof - let ?Q="fst(QR_decomposition A)" let ?R="snd(QR_decomposition A)" have det_R: "det ?R = (prod (\i. snd(QR_decomposition A)ii) (UNIV::'n set))" apply (rule det_upperdiagonal) using upper_triangular_snd_QR_decomposition[OF r] unfolding upper_triangular_def by simp have "\det A\ = \det ?Q * det ?R\" by (metis QR_decomposition_mult det_mul r) also have "... = \det ?Q\ * \det ?R\" unfolding abs_mult .. also have "... = 1 * \det ?R\" using det_orthogonal_matrix[OF orthogonal_matrix_fst_QR_decomposition'[OF r]] by auto also have "... = \det ?R\" by simp also have "... = \(prod (\i. snd(QR_decomposition A)ii) (UNIV::'n set))\" unfolding det_R .. finally show ?thesis . qed end diff --git a/thys/TortoiseHare/Brent.thy b/thys/TortoiseHare/Brent.thy --- a/thys/TortoiseHare/Brent.thy +++ b/thys/TortoiseHare/Brent.thy @@ -1,232 +1,232 @@ (*<*) theory Brent imports Basis begin (*>*) section\ Brent's algorithm \label{sec:brent} \ text\ @{cite "Brent:1980"} improved on the Tortoise and Hare algorithm and used it to factor large primes. In practice it makes significantly fewer calls to the function \f\ before detecting a loop. We begin by defining the base-2 logarithm. \ fun lg :: "nat \ nat" where [simp del]: "lg x = (if x \ 1 then 0 else 1 + lg (x div 2))" lemma lg_safe: "lg 0 = 0" "lg (Suc 0) = 0" "lg (Suc (Suc 0)) = 1" "0 < x \ lg (x + x) = 1 + lg x" by (simp_all add: lg.simps) lemma lg_inv: "0 < x \ lg (2 ^ x) = x" proof(induct x) case (Suc x) then show ?case by (cases x, simp_all add: lg.simps Suc_lessI not_le) qed simp lemma lg_inv2: "2 ^ i = x \ 2 ^ lg x = x" by (induct i arbitrary: x) (auto simp: lg.simps, arith) lemmas lg_simps = lg_safe lg_inv lg_inv2 subsection\ Finding \lambda\ \ text (in properties) \ Imagine now that the Tortoise carries an unbounded number of carrots, which he passes to the Hare when they meet, and the Hare has a teleporter. The Hare eats a carrot each time she waits for the function @{term "f"} to execute, and initially has just one. If she runs out of carrots before meeting the Tortoise again, she teleports him to her position, and he gives her twice as many carrots as the last time they met (tracked by the variable \carrots$$. By counting how many carrots she has eaten from when she last teleported the Tortoise (recorded in \l\) until she finally has surplus carrots when she meets him again, the Hare directly discovers @{term "lambda"}. \ record 'a state = m :: nat \ \\\\\ l :: nat \ \\\\\ carrots :: nat hare :: "'a" tortoise :: "'a" context properties begin definition (in fx0) find_lambda :: "'a state \ 'a state" where "find_lambda \ (\s. s\ carrots := 1, l := 1, tortoise := x0, hare := f x0 \) ;; while (hare \<^bold>\ tortoise) ( ( \<^bold>if carrots \<^bold>= l \<^bold>then (\s. s\ tortoise := hare s, carrots := 2 * carrots s, l := 0 \) \<^bold>else SKIP ) ;; (\s. s\ hare := f (hare s), l := l s + 1 \) )" text\ The termination argument goes intuitively as follows. The Hare eats as many carrots as it takes to teleport the Tortoise into the loop. Afterwards she continues the teleportation dance until the Tortoise has given her enough carrots to make it all the way around the loop and back to him. We can calculate the Tortoise's position as a function of \carrots\. \ definition carrots_total :: "nat \ nat" where "carrots_total c \ \i carrots_total (c + c) = c + carrots_total c" by (auto simp: carrots_total_def lg_simps) definition find_lambda_measures :: "( (nat \ nat) \ (nat \ nat) ) set" where "find_lambda_measures \ measures [$$l, c). mu - carrots_total c, \(l, c). LEAST i. lambda \ c * 2^i, \(l, c). c - l]" lemma find_lambda_measures_wellfounded: "wf find_lambda_measures" by (simp add: find_lambda_measures_def) lemma find_lambda_measures_decreases1: assumes "c = 2 ^ i" assumes "mu \ carrots_total c \ c \ lambda" assumes "seq (carrots_total c) \ seq (carrots_total c + c)" shows "( (c', 2 * c), (c, c) ) \ find_lambda_measures" proof(cases "mu \ carrots_total c") case False with assms show ?thesis by (auto simp: find_lambda_measures_def carrots_total_simps mult_2 field_simps diff_less_mono2) next case True { fix x assume x: "(0::nat) < x" have "\n. lambda \ x * 2 ^ n" proof(induct lambda) case (Suc i) then obtain n where "i \ x * 2 ^ n" by blast with x show ?case by (clarsimp intro!: exI[where x="Suc n"] simp: field_simps mult_2) - (metis Nat.add_0_right Suc_leI linorder_neqE_nat mult_eq_0_iff add_left_cancel not_le numeral_2_eq_2 old.nat.distinct(2) power_not_zero trans_le_add2) + (metis Nat.add_0_right Suc_leI linorder_neqE_nat mult_eq_0_iff nat_add_left_cancel not_le numeral_2_eq_2 old.nat.distinct(2) power_not_zero trans_le_add2) qed simp } note ex = this have "(LEAST j. lambda \ 2 ^ (i + 1) * 2 ^ j) < (LEAST j. lambda \ 2 ^ i * 2 ^ j)" proof(rule LeastI2_wellorder_ex[OF ex, rotated], rule LeastI2_wellorder_ex[OF ex, rotated]) fix x y assume "lambda \ 2 ^ i * 2 ^ y" "lambda \ 2 ^ (i + 1) * 2 ^ x" "\z. lambda \ 2 ^ (i + 1) * 2 ^ z \ x \ z" with True assms properties_loop[where i="carrots_total c" and j=1] show "x < y" by (cases y, auto simp: less_Suc_eq_le) qed simp_all with True \c = 2 ^ i\ show ?thesis by (clarsimp simp: find_lambda_measures_def mult_2 carrots_total_simps field_simps power_add) qed lemma find_lambda_measures_decreases2: assumes "ls < c" shows "( (Suc ls, c), (ls, c) ) \ find_lambda_measures" using assms by (simp add: find_lambda_measures_def) lemma find_lambda: "\\True\\ find_lambda \l \<^bold>= \lambda\\" apply (simp add: find_lambda_def) apply (rule hoare_pre) apply (rule whileI[where I="\0\ \<^bold>< l \<^bold>\ l \<^bold>\ carrots \<^bold>\ (\mu\ \<^bold>\ carrots_total \ carrots \<^bold>\ l \<^bold>\ \lambda$$ \<^bold>\ (\<^bold>\i. carrots \<^bold>= \2^i\) \<^bold>\ tortoise \<^bold>= seq \ carrots_total \ carrots \<^bold>\ hare \<^bold>= seq \ (l \<^bold>+ (carrots_total \ carrots))" and r="inv_image find_lambda_measures (l \<^bold>\ carrots)"] wp_intro)+ using properties_lambda_gt_0 apply (clarsimp simp: field_simps mult_2_right carrots_total_simps) apply (intro conjI impI) apply (metis mult_2 power_Suc) apply (case_tac "mu \ carrots_total (l s)") apply (cut_tac i="carrots_total (l s)" and j="l s" in properties_distinct_contrapos, simp_all add: field_simps)[1] apply (cut_tac i="carrots_total (l s)" and j="l s" in properties_loops_ge_mu, simp_all add: field_simps)[1] apply (cut_tac i="carrots_total (2 ^ x)" and j=1 in properties_loop, simp) apply (fastforce simp: le_eq_less_or_eq field_simps) apply (cut_tac i="carrots_total (2 ^ x)" and j="l s" in properties_loops_ge_mu, simp_all add: field_simps)[1] apply (cut_tac i="carrots_total (2 ^ x)" and j="l s" in properties_distinct_contrapos, simp_all add: field_simps)[1] apply (simp add: find_lambda_measures_wellfounded) apply (clarsimp simp: add.commute find_lambda_measures_decreases1 find_lambda_measures_decreases2) apply (rule wp_intro) using properties_lambda_gt_0 apply (simp add: carrots_total_simps exI[where x=0]) done subsection\ Finding \mu\ \ text\ With @{term "lambda"} in hand, we can find \mu\ using the same approach as for the Tortoise and Hare (\S\ref{sec:th-finding-mu}), after we first move the Hare to @{term "lambda"}. \ definition (in fx0) find_mu :: "'a state \ 'a state" where "find_mu \ (\s. s\ m := 0, tortoise := x0, hare := seq (l s) \) ;; while (hare \<^bold>\ tortoise) (\s. s\ tortoise := f (tortoise s), hare := f (hare s), m := m s + 1 \)" lemma find_mu: "\l \<^bold>= \lambda\\ find_mu \l \<^bold>= \lambda\ \<^bold>\ m \<^bold>= \mu\\" apply (simp add: find_mu_def) apply (rule hoare_pre) apply (rule whileI[where I="l \<^bold>= \lambda\ \<^bold>\ m \<^bold>\ \mu\ \<^bold>\ tortoise \<^bold>= seq \ m \<^bold>\ hare \<^bold>= seq \ (m \<^bold>+ l)" and r="measure (\mu\ \<^bold>- m)"] wp_intro)+ using properties_lambda_gt_0 properties_loop[where i=mu and j=1] apply (fastforce simp: le_less dest: properties_loops_ge_mu) apply simp using properties_loop[where i=mu and j=1, simplified] apply (fastforce simp: le_eq_less_or_eq) apply (rule wp_intro) apply simp done subsection\ Top level \ definition (in fx0) brent :: "'a state \ 'a state" where "brent \ find_lambda ;; find_mu" theorem brent: "\\True\\ brent \l \<^bold>= \lambda\ \<^bold>\ m \<^bold>= \mu\\" unfolding brent_def by (rule find_lambda find_mu wp_intro)+ end corollary brent_correct: assumes s': "s' = fx0.brent f x arbitrary" shows "fx0.properties f x (l s') (m s')" using assms properties.brent[where f=f and ?x0.0=x] by (fastforce intro: fx0.properties_existence[where f=f and ?x0.0=x] simp: Basis.properties_def valid_def) schematic_goal brent_code[code]: "fx0.brent f x = ?code" unfolding fx0.brent_def fx0.find_lambda_def fx0.find_mu_def fcomp_assoc[symmetric] fcomp_comp by (rule refl) export_code fx0.brent in SML (*<*) end (*>*)