theory MediumL
imports "../Listing"
        "../Naturals"
        (*"../Nat-prfs/ProofN"*)
        (*BasicL*)
begin

(** FIXME: = or \<noteq> will fail with our current tactic: no induction associated? different rule?
      Cfr: we only have rules that induct on lists (except for the result type)
            Should we start considering more rules not present in the conjecture? **)
lemma count01: "\<not> (eqN r t) \<Longrightarrow> count r (app ts (Cons t Nil)) = count r ts"
by hipster_induct_schemes (*
apply(induction ts)
apply(simp_all)
apply(induction rule: eqN.induct)
apply(simp_all)
done*)
lemma idNat : "eqN x x"
by hipster_induct_simp_metis

lemma count02: "count t ts = n \<Longrightarrow> count t (Cons t ts) = S n"
(* apply(case_tac ts)     (* OR: induciton ts on its own *)
by (simp_all add: identityNat) (*XXX: how come the simplifier cannot get itself to the conclusion eqN v v? *)
*)
by (hipster_induct_simp_metis idNat) (* requires ProofN: eqN x x *)

lemma count03: "count t ts = n \<Longrightarrow> count t (app rs ts) = add (count t rs) n"
by (hipster_induct_simp_metis)

lemma elem01: "elem t ts \<Longrightarrow> elem t (Cons r ts)"
by (metis elem.simps)
(* apply(induction ts) by (simp_all) *)
(*by (hipster_induct_simp_metis)*)

lemma elem02: "elem t ts \<Longrightarrow> elem t (app ts rs)"
(* apply(induction ts) by (simp_all) *)
by (hipster_induct_simp_metis)

lemma elem03: "elem t ts \<Longrightarrow> elem t (app rs ts)"
(* apply(induction rs)  apply(simp_all) *)
by (hipster_induct_simp_metis)

lemma inRev: "elem t ts \<Longrightarrow> elem t (rev ts)"
(*apply(induction ts)  apply(simp_all)  by (metis elem.simps(2) elem02 elem03)*)
by (hipster_induct_simp_metis elem02 elem03 elem.simps(2))

lemma lastAfterCons: "ts \<noteq> Nil \<Longrightarrow> last ts = last (Cons t ts)"
by (metis List.exhaust Listing.last.simps(2))
(*by (hipster_induct_simp_metis)*)

lemma lastElemIsLast: "last (app ts (Cons t Nil)) = t"
by (hipster_induct_schemes) (*
apply(induction ts rule: last.induct)
by (simp_all)
OR:
apply (induction ts rule: last.induct)
by (tactic {* Ind_Schemes_Tacs.routine_tac @{context} *}) *)

lemma firstLast: "ts \<noteq> Nil \<Longrightarrow> head ts = last (rev ts)"
(* apply(induction ts)  by (simp_all add: lastElemIsLast) *)
by (hipster_induct_simp_metis lastElemIsLast)
(* apply (induction ts rule: rev.induct)
apply(simp_all)
apply (induction ts rule: head.induct)
apply simp_all
  XXX: strangely enough this brings the same subgoal twice... and does not get simplified *)

lemma addId[]: "add m Z = m"
by hipster_induct_simp_metis

lemma addS2[]: "add n (S m) = S (add n m)"
by hipster_induct_simp_metis

lemma setCountRev: "count t ts = count t (rev ts)"
by (hipster_induct_schemes count.simps rev.simps count03 addId addS2)
(* TODO: Ill-typed instantiation::: check types before inducting with a rule that does not correspond
   HOWEVER: we cannot know in some cases immediately... XXX: how to extract which var's a rule inducts over? *)
(*apply(induction ts arbitrary: t)  (* XXX: no need for  rule: rev.induct ! *)
apply (simp_all) (* for some reason still won't do with hipster and these lemmas *)
apply(metis  count.simps count03 addId addS2)*)

lemma lenTake: "leq n (len ts) \<Longrightarrow> len (take n ts) = n" (* XXX: same as previous *)
by hipster_induct_schemes (*
apply(induction ts rule: take.induct)
apply(simp_all)
done*)

lemma len0: "Z = len ts \<Longrightarrow> ts = Nil"
(* by (metis Nat.distinct(1) len.elims)  However, we do not add Nat.distinct(1) *)
by (hipster_induct_simp_metis)

  declare [[show_types]]
  declare [[show_sorts]]
  declare [[show_consts]]

lemma notLen0: "leq (S n) (len ts) \<Longrightarrow> ts \<noteq> Nil" (* FIXME: loops in Hipster \<Longrightarrow> timeout on simp too? *)
by (metis len.simps(1) leq.simps(2))  (* XXX: maybe we do not add .simps rules to routine tacs? *)
(* by hipster_induct_simp_metis
apply(induction ts)
by (simp_all)*)

(* XXX: maybe start with innermost? *)
(* XXX2: Shall we add simps for conditions always? *)
lemma notEmptyDrop: "leq (S n) (len ts) \<Longrightarrow> (drop n ts) \<noteq> Nil"
by (hipster_induct_schemes leq.simps len.simps) (*
apply(induction ts rule: drop.induct) (* XXX: same as previous; NOTE: loops in struct-ind attempt *)
by (simp_all add: notLen0) *)  (* notLen0 necessary! *)
lemma noLowerZ: "leq n Z \<Longrightarrow> n = Z" (* will fail with the rule stated *)
by hipster_induct_simp_metis (* tactic {* Tactic_Data.routine_tac @{context}*}) if lemma_az is in thy_expl*)

lemma emptyDrop: "leq (len ts) n \<Longrightarrow> drop n ts = Nil"
by (hipster_induct_schemes noLowerZ len0  leq.simps len.simps) (* :S
apply(induction ts rule: drop.induct)
apply(simp_all)
apply(frule noLowerZ) (* XXX: why frule's is not done also by the simplifier? *)
by (simp_all add: len0)*)

(* TODO: strategy: start with tailing call? nah, didn't matter: both take.induct and drop.induct get us there *)
lemma dropTake : "ts = app (take n ts) (drop n ts)" (* XXX: ill-instantiation again... *)
(*apply(induction ts)
apply(metis Nat.exhaust list.exhaust take.simps app.simps drop.simps)
apply(metis (full_types) Nat.exhaust list.exhaust take.simps app.simps drop.simps)
done*)
by hipster_induct_schemes (*
apply(induction ts rule: take.induct)
apply(case_tac n)
apply(simp_all)
(** conditional **)
done*)

lemma dropNil: "drop n Nil = Nil" (* from BasicL *)
(*by (metis drop.simps Nat.exhaust)*)
by hipster_induct_simp_metis

lemma auxLastDrop : "drop n ts \<noteq> Nil \<Longrightarrow> last (drop n ts) = last ts" (* XXX: needs schemes *)
by (hipster_induct_schemes lastAfterCons dropNil)

lemma lastDrop : "leq (S n) (len ts) \<Longrightarrow> last (drop n ts) = last ts"
by (metis notEmptyDrop auxLastDrop)
(* by (hipster_induct_schemes notEmptyDrop lastAfterCons dropNil) *)
(* OR: instead of lastAfterCons, dropNil \<Rightarrow> auxLastDrop *)

lemma takeMore: "leq (len ts) n \<Longrightarrow> take n ts = ts"
by (hipster_induct_schemes emptyDrop drop.simps) (*
apply(induction ts rule: take.induct)
apply(simp_all)
by (metis drop.simps emptyDrop) *)
(* by (hipster_induct_simp_metis appNil emptyDrop dropTake)
apply(induction ts rule: take.induct)
apply(simp_all)
apply(drule emptyDrop)
by (simp_all) *)

lemma headTake: "lt Z n \<Longrightarrow> head (take n ts) = head ts" (* No ts \<noteq> Nil ... *)
by hipster_induct_schemes

(*
lemma subId: "sub n Z = n" (* from ProofN *)
(* apply(hipster_induct_schemes add.simps) *)
by hipster_induct_simp_metis*)

(* XXX: make sure we include helping lemmas \<Longrightarrow> they avoid errors + infinite running! (ill-instantiations... none) *)
lemma initAsTake: "init ts = take (sub (len ts) (S Z)) ts"
by (hipster_induct_schemes sub.simps Nat.exhaust) (*
apply(induction ts rule: init.induct)
apply simp_all
by (metis Nat.exhaust sub.simps)
apply(induction ts rule: init.induct)
by (simp_all add: subId) (* from ProofN *) *)

lemma zipNil: "rs = Nil \<Longrightarrow> zip rs ts = Nil" (* "\<not> notNil rs *)  (* does not require condition "format" *)
by (tactic \<open>Simp_T.routine_tac @{context}\<close>)
(*by (hipster_induct_simp_metis)*)

(* XXX: we should do something about our conclusions in the induction? type of the Nil has a
    _SCHEMATIC TYPE_ variable... *)
lemma zip2nil: "zip ts Nil = Nil"
by hipster_induct_simp_metis
(* by (metis Listing.zip.simps Listing.List.exhaust)*)

lemma zipNilBis: "\<not> notNil ts \<Longrightarrow> zip rs ts = Nil"
by hipster_induct_schemes (* here: usage of notNil requires the induction? *)

lemma zipNotNil: "notNil rs \<Longrightarrow> zip (Cons t ts) rs = Cons (t, head rs) (zip ts (tail rs))"
by hipster_induct_simp_metis (*
apply(case_tac rs)
apply(simp_all)
done*)

lemma zipSingleton: "zip (Cons t Nil) (Cons r Nil) = Cons (t,r) Nil"
by simp

(* XXX: if the condition is dropped, simplification alone (our Simp_Tacs.routine_tac) suffices, of course
    But if induction is taken, the method cannot be applied and it fails...
    Notably, if we have a condition and still use Nil instead of ts, we don't get "type unification"
      for both Nil's despite the type of rev, apparently - or so it seems - *)
lemma revNil: "ts = Nil \<Longrightarrow> rev ts = Nil"
by hipster_induct_simp_metis

(*hipster rotate*)

(*hipster rotate len*)

value "(3,4)"
datatype 'a bitup = Bt 'a 'a
(*
datatype 'a ptree = Leaf 'a | Node "(('a bitup) ptree)"
datatype 'a nest = NilN | ConsN "('a \<times> ('a bitup) nest)"
datatype 'a bush = Ro | Bu "(('a bush) bush)"*)

(*hipster rotate app*)

thm rotate.induct
lemma rotSelf : "rotate n (app xs xs) = app (rotate n xs) (rotate n xs)"
apply(induction xs rule: rotate.induct)
apply(simp_all)
apply(case_tac n)
apply auto
oops

hipster app rotate

end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
section \<open>A Combined Factorization Algorithm for Polynomials over GF(p)\<close>

subsection\<open>Type Based Version\<close>
text \<open>We combine Berlekamp's algorithm with the distinct degree factorization
  to obtain an efficient factorization algorithm for square-free polynomials in GF(p).\<close>

theory Finite_Field_Factorization
imports Berlekamp_Type_Based
  Distinct_Degree_Factorization
begin

text \<open>We prove soundness of the finite field factorization,
  indepedendent on whether distinct-degree-factorization is
  applied as preprocessing or not.\<close>
consts use_distinct_degree_factorization :: bool

context
assumes "SORT_CONSTRAINT('a::prime_card)"
begin

definition finite_field_factorization :: "'a mod_ring poly \<Rightarrow> 'a mod_ring \<times> 'a mod_ring poly list" where
  "finite_field_factorization f = (if degree f = 0 then (lead_coeff f,[]) else let
     a = lead_coeff f;
     u = smult (inverse a) f;
     gs = (if use_distinct_degree_factorization then distinct_degree_factorization u else [(1,u)]);
     (irr,hs) = List.partition (\<lambda> (i,f). degree f = i) gs
    in (a,map snd irr @ concat (map (\<lambda> (i,g). berlekamp_monic_factorization i g) hs)))"

lemma finite_field_factorization_explicit:
  fixes f::"'a mod_ring poly"
  assumes sf_f: "square_free f"
    and us: "finite_field_factorization f = (c,us)"
  shows "f = smult c (prod_list us) \<and> (\<forall> u \<in> set us. monic u \<and> irreducible u)"
proof (cases "degree f = 0")
  case False note f = this
  define g where "g = smult (inverse c) f"
  obtain gs where dist: "(if use_distinct_degree_factorization then distinct_degree_factorization g else [(1,g)]) = gs" by auto
  note us = us[unfolded finite_field_factorization_def Let_def]
  from us f have c: "c = lead_coeff f" by auto
  obtain irr hs where part: "List.partition (\<lambda> (i, f). degree f = i) gs = (irr,hs)" by force
  from arg_cong[OF this, of fst] have irr: "irr = filter (\<lambda> (i, f). degree f = i) gs" by auto
  from us[folded c, folded g_def, unfolded dist part split] f
  have us: "us = map snd irr @ concat (map (\<lambda>(x, y). berlekamp_monic_factorization x y) hs)" by auto
  from f c have c0: "c \<noteq> 0" by auto
  from False c0 have deg_g: "degree g \<noteq> 0" unfolding g_def by auto
  have mon_g: "monic g" unfolding g_def
    by (metis c c0 field_class.field_inverse lead_coeff_smult)
  from sf_f have sf_g: "square_free g" unfolding g_def by (simp add: c0)
  from c0 have f: "f = smult c g" unfolding g_def by auto
  have "g = prod_list (map snd gs) \<and> (\<forall> (i,f) \<in> set gs. degree f > 0 \<and> monic f \<and> (\<forall> h. h dvd f \<longrightarrow> degree h = i \<longrightarrow> irreducible h))"
  proof (cases use_distinct_degree_factorization)
    case True
    with dist have "distinct_degree_factorization g = gs" by auto
    note dist = distinct_degree_factorization[OF this sf_g mon_g]
    from dist have g: "g = prod_list (map snd gs)" by auto
    show ?thesis
    proof (intro conjI[OF g] ballI, clarify)
      fix i f
      assume "(i,f) \<in> set gs"
      with dist have "factors_of_same_degree i f" by auto
      from factors_of_same_degreeD[OF this]
      show "degree f > 0 \<and> monic f \<and> (\<forall>h. h dvd f \<longrightarrow> degree h = i \<longrightarrow> irreducible h)" by auto
    qed
  next
    case False
    with dist have gs: "gs = [(1,g)]" by auto
    show ?thesis unfolding gs using deg_g mon_g linear_irreducible\<^sub>d[where 'a = "'a mod_ring"] by auto
  qed
  hence g_gs: "g = prod_list (map snd gs)"
    and mon_gs: "\<And> i f. (i, f) \<in> set gs \<Longrightarrow> monic f \<and> degree f > 0"
    and irrI: "\<And> i f h . (i, f) \<in> set gs \<Longrightarrow> h dvd f \<Longrightarrow> degree h = i \<Longrightarrow> irreducible h" by auto
  have g: "g = prod_list (map snd irr) * prod_list (map snd hs)" unfolding g_gs
    using prod_list_map_partition[OF part] .
  {
    fix f
    assume "f \<in> snd ` set irr"
    from this[unfolded irr] obtain i where *:  "(i,f) \<in> set gs" "degree f = i" by auto
    have "f dvd f" by auto
    from irrI[OF *(1) this *(2)] mon_gs[OF *(1)] have "monic f" "irreducible f" by auto
  } note irr = this
  let ?berl = "\<lambda> hs. concat (map (\<lambda>(x, y). berlekamp_monic_factorization x y) hs)"
  have "set hs \<subseteq> set gs" using part by auto
  hence "prod_list (map snd hs) = prod_list (?berl hs)
    \<and> (\<forall> f \<in> set (?berl hs). monic f \<and> irreducible\<^sub>d f)"
  proof (induct hs)
    case (Cons ih hs)
    obtain i h where ih: "ih = (i,h)" by force
    have "?berl (Cons ih hs) = berlekamp_monic_factorization i h @ ?berl hs" unfolding ih by auto
    from Cons(2)[unfolded ih] have mem: "(i,h) \<in> set gs" and sub: "set hs \<subseteq> set gs" by auto
    note IH = Cons(1)[OF sub]
    from mem have "h \<in> set (map snd gs)" by force
    from square_free_factor[OF prod_list_dvd[OF this], folded g_gs, OF sf_g] have sf: "square_free h" .
    from mon_gs[OF mem] irrI[OF mem] have *: "degree h > 0" "monic h"
      "\<And> g. g dvd h \<Longrightarrow> degree g = i \<Longrightarrow> irreducible g" by auto
    from berlekamp_monic_factorization[OF sf refl *(3) *(1-2), of i]
    have berl: "prod_list (berlekamp_monic_factorization i h) = h"
      and irr: "\<And> f. f \<in> set (berlekamp_monic_factorization i h) \<Longrightarrow> monic f \<and> irreducible f" by auto
    have "prod_list (map snd (Cons ih hs)) = h * prod_list (map snd hs)" unfolding ih by simp
    also have "prod_list (map snd hs) = prod_list (?berl hs)" using IH by auto
    finally have "prod_list (map snd (Cons ih hs)) = prod_list (?berl (Cons ih hs))"
      unfolding ih using berl by auto
    thus ?case using IH irr unfolding ih by auto
  qed auto
  with g irr have main: "g = prod_list us \<and> (\<forall> u \<in> set us. monic u \<and> irreducible\<^sub>d u)" unfolding us
    by auto
  thus ?thesis unfolding f using sf_g by auto
next
  case True
  with us[unfolded finite_field_factorization_def] have "c = lead_coeff f" and us: "us = []" by auto
  with degree0_coeffs[OF True] have f: "f = [:c:]" by auto
  show ?thesis unfolding us f by (auto simp: normalize_poly_def)
qed

lemma finite_field_factorization:
  fixes f::"'a mod_ring poly"
  assumes sf_f: "square_free f"
    and us: "finite_field_factorization f = (c,us)"
  shows "unique_factorization Irr_Mon f (c, mset us)"
proof -
  from finite_field_factorization_explicit[OF sf_f us]
  have fact: "factorization Irr_Mon f (c, mset us)"
    unfolding factorization_def split Irr_Mon_def by (auto simp: prod_mset_prod_list)
  from sf_f[unfolded square_free_def] have "f \<noteq> 0" by auto
  from exactly_one_factorization[OF this] fact
  show ?thesis unfolding unique_factorization_def by auto
qed
end

text \<open>Experiments revealed that preprocessing via
  distinct-degree-factorization slows down the factorization
  algorithm (statement for implementation in AFP 2017)\<close>

overloading use_distinct_degree_factorization \<equiv> use_distinct_degree_factorization
begin
  definition use_distinct_degree_factorization
    where [code_unfold]: "use_distinct_degree_factorization = False"
end
end


theory Language
  imports SumList Groups
begin

section {* Languages with shuffle product *}

subsection {* Complex product and language product *}

definition complex_product :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "complex_product f X Y = {f x y|x y. x \<in> X \<and> y \<in> Y}"

lemma complex_comm: "(\<And>x y. f x y = f y x) \<Longrightarrow> complex_product f X Y = complex_product f Y X"
  by (auto simp add: complex_product_def)

lemma complex_assoc: "(\<And>x y z. f (f x y) z = f x (f y z)) \<Longrightarrow>
  complex_product f (complex_product f X Y) Z = complex_product f X (complex_product f Y Z)"
  by (auto simp add: complex_product_def) metis+

type_synonym 'a lan = "'a list set"

definition l_prod :: "'a lan \<Rightarrow> 'a lan \<Rightarrow> 'a lan" (infixl "\<cdot>" 80) where
  "l_prod = complex_product op @"

lemma l_prod_assoc: "(X \<cdot> Y) \<cdot> Z = X \<cdot> (Y \<cdot> Z)"
  by (metis append_assoc complex_assoc l_prod_def)

lemma l_prod_isol: "X \<subseteq> Y \<Longrightarrow> X \<cdot> Z \<subseteq> Y \<cdot> Z"
  by (auto simp add: l_prod_def complex_product_def)

lemma l_prod_isor: "X \<subseteq> Y \<Longrightarrow> Z \<cdot> X \<subseteq> Z \<cdot> Y"
  by (auto simp add: l_prod_def complex_product_def)

lemma l_prod_one [simp]: shows "{[]} \<cdot> X = X" and "X \<cdot> {[]} = X"
  by (simp_all add: l_prod_def complex_product_def)

lemma l_prod_inf_distl: "X \<cdot> \<Union>\<YY> = \<Union>{X \<cdot> Y|Y. Y \<in> \<YY>}"
  by (auto simp add: l_prod_def complex_product_def)

lemma l_prod_inf_distr: "\<Union>\<XX> \<cdot> Y = \<Union>{X \<cdot> Y|X. X \<in> \<XX>}"
  by (auto simp add: l_prod_def complex_product_def)

lemma l_prod_distr: "(X \<union> Y) \<cdot> Z = X \<cdot> Z \<union> Y \<cdot> Z"
  by (insert l_prod_inf_distr[of "{X, Y}" Z]) auto

lemma l_prod_distl: "X \<cdot> (Y \<union> Z) = X \<cdot> Y \<union> X \<cdot> Z"
  by (insert l_prod_inf_distl[of "X" "{Y, Z}"]) auto

lemma l_prod_zero [simp]: shows "{} \<cdot> X = {}" and "X \<cdot> {} = {}"
  by (simp add: l_prod_def complex_product_def)+

text {* The \sha\ operator generates a language by shuffling two words together. *}

definition tshuffle_words :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a + 'b) lan" (infix "\<sha>" 75) where
  "tshuffle_words xs ys = {zs. lefts zs = xs \<and> rights zs = ys}"

text {* The resulting language contains strings where each symbol is labelled by either @{term Inl} or @{term Inr},
depending on which input it came from. This means that @{prop "\<forall>zs \<in> (xs \<sha> ys). \<ll> zs = xs \<and> \<rr> zs = ys"}.
If a function @{term f} has type @{typ "'a \<Rightarrow> 'c"} and @{term g} has type @{typ "'b \<Rightarrow> 'c"}, then the sum elimination function @{term "\<langle>f,g\<rangle>"}
can be used to eliminate values of @{typ "('a,'b) sum"} by transforming them to values of type @{typ "'c"}.
The function @{term "\<langle>id,id\<rangle>"} is therefore used when both components of the sum have the same type. *}

lemma tshuffle_words_comm: "map \<langle>id,id\<rangle> ` (x \<sha> y) = map \<langle>id,id\<rangle> ` (y \<sha> x)"
  by (auto simp add: tshuffle_words_def image_def) (rule_tac x = "map swap xa" in exI, simp)+

lemma tshuffle_word_assoc:
  "map \<langle>id,\<langle>id,id\<rangle>\<rangle> ` {ws. \<ll> ws = xs \<and> \<ll> (\<rr> ws) = ys \<and> \<rr> (\<rr> ws) = zs} = map \<langle>\<langle>id,id\<rangle>,id\<rangle> ` {ws. \<ll> (\<ll> ws) = xs \<and> \<rr> (\<ll> ws) = ys \<and> \<rr> ws = zs}"
  by (auto simp add: image_def, rule_tac x = "map rbr1 xa" in exI, simp, rule_tac x = "map rbr2 xa" in exI, simp)

definition tshuffle :: "'a lan \<Rightarrow> 'b lan \<Rightarrow> ('a + 'b) lan" (infixl "\<Sha>" 75) where
  "X \<Sha> Y \<equiv> \<Union>{x \<sha> y|x y. x \<in> X \<and> y \<in> Y}"

lemma tshuffle_lr: "xs \<in> X \<Sha> Y \<longleftrightarrow> \<ll> xs \<in> X \<and> \<rr> xs \<in> Y"
  by (auto simp add: tshuffle_def tshuffle_words_def)

lemma tshuffle_comm: "map \<langle>id,id\<rangle> ` (X \<Sha> Y) = map \<langle>id,id\<rangle> ` (Y \<Sha> X)"
proof -
  have "map \<langle>id,id\<rangle> ` (X \<Sha> Y) = \<Union>{map \<langle>id,id\<rangle> ` (x \<sha> y)|x y. x \<in> X \<and> y \<in> Y}"
    by (auto simp add: tshuffle_def)
  also have "... = \<Union>{map \<langle>id,id\<rangle> ` (y \<sha> x)|x y. x \<in> X \<and> y \<in> Y}"
    by (simp add: tshuffle_words_comm)
  also have "... = map \<langle>id,id\<rangle> ` (Y \<Sha> X)"
    by (auto simp add: tshuffle_def)
  finally show ?thesis .
qed

definition shuffle :: "'a lan \<Rightarrow> 'a lan \<Rightarrow> 'a lan" (infixl "\<parallel>" 75) where
  "shuffle X Y \<equiv> \<Union>{map \<langle>id,id\<rangle> ` (x \<sha> y)|x y. x \<in> X \<and> y \<in> Y}"

lemma shuffle_to_tshuffle: "X \<parallel> Y = map \<langle>id,id\<rangle> ` (X \<Sha> Y)"
  by (auto simp add: shuffle_def tshuffle_def image_def)

lemma shuffle_comm: "X \<parallel> Y = Y \<parallel> X"
  by (metis shuffle_to_tshuffle tshuffle_comm)

lemma tshuffle3_right:
  "X \<Sha> (Y \<Sha> Z) = \<Union>{{w. \<ll> w = x \<and> \<ll> (\<rr> w) = y \<and> \<rr> (\<rr> w) = z}|x y z. x \<in> X \<and> y \<in> Y \<and> z \<in> Z}"
  by (simp only: tshuffle_def tshuffle_words_def) blast

lemma tshuffle3_left:
  "(X \<Sha> Y) \<Sha> Z = \<Union>{{w. \<ll> (\<ll> w) = x \<and> \<rr> (\<ll> w) = y \<and> \<rr> w = z}|x y z. x \<in> X \<and> y \<in> Y \<and> z \<in> Z}"
 by (simp only: tshuffle_def tshuffle_words_def) blast

lemma tshuffle_assoc: "map \<langle>\<langle>id,id\<rangle>,id\<rangle> ` ((X \<Sha> Y) \<Sha> Z) = map \<langle>id,\<langle>id,id\<rangle>\<rangle> ` (X \<Sha> (Y \<Sha> Z))"
proof -
  have "map \<langle>\<langle>id,id\<rangle>,id\<rangle> ` ((X \<Sha> Y) \<Sha> Z) = map \<langle>\<langle>id,id\<rangle>,id\<rangle> ` \<Union>{{w. \<ll> (\<ll> w) = x \<and> \<rr> (\<ll> w) = y \<and> \<rr> w = z}|x y z. x \<in> X \<and> y \<in> Y \<and> z \<in> Z}"
    by (simp add: tshuffle3_left)
  also have "... = \<Union>{map \<langle>\<langle>id,id\<rangle>,id\<rangle> ` {w. \<ll> (\<ll> w) = x \<and> \<rr> (\<ll> w) = y \<and> \<rr> w = z}|x y z. x \<in> X \<and> y \<in> Y \<and> z \<in> Z}"
    by (auto simp add: image_def)
  also have "... = \<Union>{map \<langle>id,\<langle>id,id\<rangle>\<rangle> ` {w. \<ll> w = x \<and> \<ll> (\<rr> w) = y \<and> \<rr> (\<rr> w) = z}|x y z. x \<in> X \<and> y \<in> Y \<and> z \<in> Z}"
    by (simp add: tshuffle_word_assoc)
  also have "... = map \<langle>id,\<langle>id,id\<rangle>\<rangle> ` \<Union>{{w. \<ll> w = x \<and> \<ll> (\<rr> w) = y \<and> \<rr> (\<rr> w) = z}|x y z. x \<in> X \<and> y \<in> Y \<and> z \<in> Z}"
    by (auto simp add: image_def)
  also have "... = map \<langle>id,\<langle>id,id\<rangle>\<rangle> ` (X \<Sha> (Y \<Sha> Z))"
    by (simp add: tshuffle3_right)
  finally show ?thesis .
qed

lemma tshuffle_words_emptyl [simp]: "[] \<sha> xs = {map Inr xs}"
  by (auto simp add: tshuffle_words_def no_lefts)

lemma tshuffle_words_emptyr [simp]: "xs \<sha> [] = {map Inl xs}"
  by (auto simp add: tshuffle_words_def no_rights)

lemma tshuffle_ind: "(x#xs) \<sha> (y#ys) = (op # (Inl x) ` (xs \<sha> (y#ys))) \<union> (op # (Inr y) ` ((x#xs) \<sha> ys))"
proof
  show "(op # (Inl x) ` (xs \<sha> (y#ys))) \<union> (op # (Inr y) ` ((x#xs) \<sha> ys)) \<subseteq> (x#xs) \<sha> (y#ys)"
    by (auto simp add: tshuffle_words_def)
  show "(x#xs) \<sha> (y#ys) \<subseteq> (op # (Inl x) ` (xs \<sha> (y#ys))) \<union> (op # (Inr y) ` ((x#xs) \<sha> ys))"
  proof (auto simp add: tshuffle_words_def image_def, rule_tac x = "rfl xa" in exI, intro conjI)
    fix z
    assume "\<forall>w. \<rr> w = ys \<longrightarrow> \<ll> w = x # xs \<longrightarrow> z \<noteq> Inr y # w" and zl: "\<ll> z = x # xs" and zr: "\<rr> z = y # ys"
    hence zny: "z \<noteq> Inr y # rfr z"
      by (metis lefts.simps(3) rights.simps(3) tl.simps(2))
    show "\<ll> (rfl z) = xs"
      by (metis rfl1 zl)
    from zny zr show "\<rr> (rfl z) = y # ys"
      by (induct z rule: sum_list_induct) auto
    from zny zl zr show "z = Inl x # rfl z"
      by (induct z rule: sum_list_induct) auto
  qed
qed

lemma tshuffle_words_map:
  fixes f :: "'a \<Rightarrow> 'b"
  and g :: "'c \<Rightarrow> 'd"
  shows "map f xs \<sha> map g ys = map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> ` (xs \<sha> ys)"
proof
  show "map f xs \<sha> map g ys \<subseteq> map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> ` (xs \<sha> ys)"
  proof (induct xs arbitrary: ys, simp_all)
    fix x xs and ys :: "'c list"

    assume ih_xs: "\<And>ys::'c list. (map f xs) \<sha> (map g ys) \<subseteq> map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> ` (xs \<sha> ys)"

    show "(f x # map f xs) \<sha> (map g ys) \<subseteq> map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> ` ((x # xs) \<sha> ys)"
    proof (induct ys, simp)
      fix y and ys :: "'c list"

      assume ih_ys: "(f x # map f xs) \<sha> (map g ys) \<subseteq> map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> ` ((x # xs) \<sha> ys)"

      have "op # (Inl (f x)) ` (map f xs \<sha> map g (y # ys)) \<subseteq> map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> ` ((x # xs) \<sha> (y # ys))"
      proof -
        have "op # (Inl (f x)) ` (map f xs \<sha> map g (y # ys)) \<subseteq> op # (Inl (f x)) ` map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> ` (xs \<sha> (y # ys))"
          by (rule image_mono, rule ih_xs)
        also have "... \<subseteq> map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> ` op # (Inl x) ` (xs \<sha> (y # ys))"
          by (auto simp add: image_def)
        also have "... \<subseteq> map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> ` ((x # xs) \<sha> (y # ys))"
          by (metis (hide_lams, no_types) image_mono le_sup_iff tshuffle_ind eq_refl)
        finally show ?thesis .
      qed

      moreover have "op # (Inr (g y)) ` ((f x # map f xs) \<sha> (map g ys)) \<subseteq> map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> ` ((x # xs) \<sha> (y # ys))"
      proof -
        have "op # (Inr (g y)) ` ((f x # map f xs) \<sha> (map g ys)) \<subseteq> op # (Inr (g y)) ` map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> ` ((x # xs) \<sha> ys)"
          by (rule image_mono, rule ih_ys)
        also have "... \<subseteq> map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> ` op # (Inr y) ` ((x # xs) \<sha> ys)"
          by (auto simp add: image_def)
        also have "... \<subseteq> map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> ` ((x # xs) \<sha> (y # ys))"
          by (metis (hide_lams, no_types) image_mono le_sup_iff tshuffle_ind eq_refl)
        finally show ?thesis .
      qed

      ultimately show "((f x # map f xs) \<sha> (map g (y # ys))) \<subseteq> map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> ` ((x # xs) \<sha> (y # ys))"
        by (simp, subst tshuffle_ind, auto)
    qed
  qed

  show "map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> ` (xs \<sha> ys) \<subseteq> map f xs \<sha> map g ys"
  proof (auto simp add: tshuffle_words_def)
    fix x :: "('a, 'c) sum list"
    show "\<ll> (map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> x) = map f (\<ll> x)"
      by (induct x rule: sum_list_induct, auto)
    show "\<rr> (map \<langle>Inl \<circ> f, Inr \<circ> g\<rangle> x) = map g (\<rr> x)"
      by (induct x rule: sum_list_induct, auto)
  qed
qed

lemma shuffle_assoc: "(X \<parallel> Y) \<parallel> Z = X \<parallel> (Y \<parallel> Z)"
proof -
  have "(X \<parallel> Y) \<parallel> Z = map \<langle>id,id\<rangle> ` ((map \<langle>id,id\<rangle> ` (X \<Sha> Y)) \<Sha> Z)"
    by (simp add: shuffle_to_tshuffle)
  also have "... = map \<langle>id,id\<rangle> ` \<Union>{x \<sha> y |x y. x \<in> map \<langle>id,id\<rangle> ` (X \<Sha> Y) \<and> y \<in> Z}"
    by (simp add: tshuffle_def)
  also have "... = map \<langle>id,id\<rangle> ` \<Union>{map \<langle>id,id\<rangle> x \<sha> y|x y. x \<in> (X \<Sha> Y) \<and> y \<in> Z}"
    by (auto simp add: image_def)
  also have "... = map \<langle>id,id\<rangle> ` \<Union>{map \<langle>Inl \<circ> \<langle>id,id\<rangle>, Inr\<rangle> ` (x \<sha> y)|x y. x \<in> (X \<Sha> Y) \<and> y \<in> Z}"
    by (simp add: tshuffle_words_map[where g = id, simplified])
  also have "... = map \<langle>id,id\<rangle> ` map \<langle>Inl \<circ> \<langle>id,id\<rangle>, Inr\<rangle> ` \<Union>{x \<sha> y|x y. x \<in> (X \<Sha> Y) \<and> y \<in> Z}"
    by (auto simp add: image_def)
  also have "... = (map \<langle>id,id\<rangle> \<circ> map \<langle>Inl \<circ> \<langle>id,id\<rangle>, Inr\<rangle>) ` ((X \<Sha> Y) \<Sha> Z)"
    by (metis image_compose tshuffle_def)
  also have "... = map \<langle>\<langle>id,id\<rangle>,id\<rangle> ` ((X \<Sha> Y) \<Sha> Z)"
    by (simp only: map_sum_elim_simp1)
  also have "... = map \<langle>id,\<langle>id,id\<rangle>\<rangle> ` (X \<Sha> (Y \<Sha> Z))"
    by (metis tshuffle_assoc)
  also have "... = (map \<langle>id,id\<rangle> \<circ> map \<langle>Inl, Inr \<circ> \<langle>id,id\<rangle>\<rangle>) ` (X \<Sha> (Y \<Sha> Z))"
    by (simp only: map_sum_elim_simp2)
  also have "... = map \<langle>id,id\<rangle> ` map \<langle>Inl, Inr \<circ> \<langle>id,id\<rangle>\<rangle> ` \<Union>{x \<sha> y|x y. x \<in> X \<and> y \<in> (Y \<Sha> Z)}"
    by (metis image_compose tshuffle_def)
  also have "... = map \<langle>id,id\<rangle> ` \<Union>{map \<langle>Inl, Inr \<circ> \<langle>id,id\<rangle>\<rangle> ` (x \<sha> y)|x y. x \<in> X \<and> y \<in> (Y \<Sha> Z)}"
    by (auto simp add: image_def)
  also have "... = map \<langle>id,id\<rangle> ` \<Union>{x \<sha> map \<langle>id,id\<rangle> y|x y. x \<in> X \<and> y \<in> (Y \<Sha> Z)}"
    by (simp add: tshuffle_words_map[where f = id, simplified])
  also have "... = map \<langle>id,id\<rangle> ` \<Union>{x \<sha> y|x y. x \<in> X \<and> y \<in> map \<langle>id,id\<rangle> ` (Y \<Sha> Z)}"
    by (auto simp add: image_def)
  also have "... = map \<langle>id,id\<rangle> ` (X \<Sha> (map \<langle>id,id\<rangle> ` (Y \<Sha> Z)))"
    by (simp add: tshuffle_def)
  also have "... = X \<parallel> (Y \<parallel> Z)"
    by (simp add: shuffle_to_tshuffle)
  finally show ?thesis .
qed

lemma set_comp_mono4:
  assumes fg: "\<And>a b c d. f a b c d \<subseteq> g a b c d"
  shows "\<Union>{f a b c d|a b c d. a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> d \<in> D} \<subseteq> \<Union>{g a b c d|a b c d. a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> d \<in> D}"
  using assms by blast

lemma word_exchange: "(map \<langle>id,id\<rangle> ` (a \<sha> b)) \<cdot> (map \<langle>id,id\<rangle> ` (c \<sha> d)) \<subseteq> map \<langle>id, id\<rangle> ` ((b @ c) \<sha> (a @ d))"
  by (auto simp add: tshuffle_words_def l_prod_def complex_product_def image_def, rule_tac x = "map swap xb @ xc" in exI, simp)

lemma exchange: "(A \<parallel> B) \<cdot> (C \<parallel> D) \<subseteq> (B \<cdot> C) \<parallel> (A \<cdot> D)"
proof -
  have "(A \<parallel> B) \<cdot> (C \<parallel> D) = {x @ y|x y. x \<in> map \<langle>id, id\<rangle> ` (A \<Sha> B) \<and> y \<in> map \<langle>id, id\<rangle> ` (C \<Sha> D)}"
    by (simp add: shuffle_to_tshuffle complex_product_def l_prod_def)
  also have "... = {map \<langle>id,id\<rangle> x @ map \<langle>id,id\<rangle> y|x y. x \<in> (A \<Sha> B) \<and> y \<in> (C \<Sha> D)}"
    by blast
  also have "... = \<Union>{{map \<langle>id,id\<rangle> x @ map \<langle>id,id\<rangle> y|x y. x \<in> (a \<sha> b) \<and> y \<in> (c \<sha> d)}|a b c d. a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> d \<in> D}"
    by (simp add: tshuffle_def) blast
  also have "... = \<Union>{(map \<langle>id,id\<rangle> ` (a \<sha> b)) \<cdot> (map \<langle>id,id\<rangle> ` (c \<sha> d))|a b c d. a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> d \<in> D}"
    by (simp add: l_prod_def complex_product_def) blast
  also have "... \<subseteq> \<Union>{map \<langle>id, id\<rangle> ` ((b @ c) \<sha> (a @ d))|a b c d. a \<in> A \<and> b \<in> B \<and> c \<in> C \<and> d \<in> D}"
    by (rule set_comp_mono4) (rule word_exchange)
  also have "... = \<Union>{map \<langle>id, id\<rangle> ` (bc \<sha> ad)|bc ad. bc \<in> (B \<cdot> C) \<and> ad \<in> (A \<cdot> D)}"
    by (simp add: l_prod_def complex_product_def) blast
  also have "... = (B \<cdot> C) \<parallel> (A \<cdot> D)"
    by (simp add: shuffle_def)
  finally show ?thesis .
qed

hide_fact set_comp_mono4

lemma shuffle_distl: "X \<parallel> (Y \<union> Z) = (X \<parallel> Y) \<union> (X \<parallel> Z)"
  by (simp add: shuffle_def) blast

lemma shuffle_distr: "(X \<union> Y) \<parallel> Z = (X \<parallel> Z) \<union> (Y \<parallel> Z)"
  by (simp add: shuffle_def) blast

lemma shuffle_inf_distl: "X \<parallel> \<Union>\<YY> = \<Union>{X \<parallel> Y|Y. Y \<in> \<YY>}"
  by (simp add: shuffle_def) blast

lemma shuffle_inf_distr: "\<Union>\<XX> \<parallel> Y = \<Union>{X \<parallel> Y|X. X \<in> \<XX>}"
  by (simp add: shuffle_def) blast

lemma shuffle_one [simp]: shows "X \<parallel> {[]} = X" and "{[]} \<parallel> X = X"
proof -
  {
    fix x :: "'a list"
    have "map (\<langle>id,id\<rangle> \<circ> Inl) x = x"
      by (induct x) auto
  }
  thus "X \<parallel> {[]} = X"
    by (simp add: shuffle_def) blast
  thus "{[]} \<parallel> X = X"
    by (metis shuffle_comm)
qed

lemma shuffle_zeror [simp]: "X \<parallel> {} = {}"
  by (simp add: shuffle_def)

lemma shuffle_zerol [simp]: "{} \<parallel> X = {}"
  by (simp add: shuffle_def)

lemma shuffle_iso: "X \<subseteq> Y \<Longrightarrow> X \<parallel> Z \<subseteq> Y \<parallel> Z"
  by (metis shuffle_distr subset_Un_eq)

lemma l_prod_leq_shuffle: "X \<cdot> Y \<subseteq> X \<parallel> Y"
  by (insert exchange[where A = "X" and B = "{[]}" and C = "Y" and D = "{[]}"]) (simp add: shuffle_comm)

lemma meet_dist1: "(X \<inter> Y) \<parallel> Z \<subseteq> (X \<parallel> Z) \<inter> (Y \<parallel> Z)"
  by (metis Int_lower1 Int_lower2 le_inf_iff shuffle_iso)

lemma in_l_prod: "w \<in> X \<cdot> Y \<longleftrightarrow> (\<exists>x y. w = x @ y \<and> x \<in> X \<and> y \<in> Y)"
  by (auto simp add: l_prod_def complex_product_def)

section {* Sequential Star *}

primrec l_power :: "'a lan \<Rightarrow> nat \<Rightarrow> 'a lan" ("_\<^bsup>_\<^esup>" [101,0] 100) where
  "X\<^bsup>0\<^esup> = {[]}"
| "X\<^bsup>Suc n\<^esup> = X \<cdot> X\<^bsup>n\<^esup>"

no_notation
  Transitive_Closure.rtrancl ("(_\<^sup>*)" [1000] 999)

definition l_star :: "'a lan \<Rightarrow> 'a lan" ("_\<^sup>*" [101] 100) where
  "X\<^sup>* \<equiv> \<Union>range (l_power X)"

lemma [intro]: "[] \<in> X\<^bsup>0\<^esup>"
  by (metis insertI1 l_power.simps(1))

lemma power_in_star: "X\<^bsup>n\<^esup> \<subseteq> X\<^sup>*"
  by (auto simp add: l_star_def)

lemma [intro]: "xs \<in> X \<Longrightarrow> ys \<in> X\<^bsup>n\<^esup> \<Longrightarrow> xs @ ys \<in> X\<^bsup>Suc n\<^esup>"
  by (auto simp add: in_l_prod)

lemma l_power_def_var: "X\<^bsup>Suc n\<^esup> = X\<^bsup>n\<^esup> \<cdot> X"
  by (induct n) (simp_all add: l_prod_assoc[symmetric])

lemma [intro]: "xs \<in> X \<Longrightarrow> ys \<in> X\<^bsup>n\<^esup> \<Longrightarrow> ys @ xs \<in> X\<^bsup>Suc n\<^esup>"
  by (auto simp add: in_l_prod l_power_def_var simp del: l_power.simps(2))

lemma l_star_unfoldl: "{[]} \<union> X\<cdot>X\<^sup>* \<subseteq> X\<^sup>*"
  by (auto simp add: l_star_def l_prod_def complex_product_def)

lemma l_star_unfoldr: "{[]} \<union> X\<^sup>*\<cdot>X \<subseteq> X\<^sup>*"
  by (auto simp add: l_star_def l_prod_def complex_product_def)

lemma l_power_inductl: "Z \<union> X\<cdot>Y \<subseteq> Y \<Longrightarrow> X\<^bsup>n\<^esup>\<cdot>Z \<subseteq> Y"
  by (induct n, simp_all, metis l_prod_assoc l_prod_isor subset_trans)

lemma l_star_inductl: "Z \<union> X\<cdot>Y \<subseteq> Y \<Longrightarrow> X\<^sup>*\<cdot>Z \<subseteq> Y"
proof -
  assume asm: "Z \<union> X\<cdot>Y \<subseteq> Y"
  have "\<Union>range (\<lambda>n. X\<^bsup>n\<^esup> \<cdot> Z) \<subseteq> Y"
    by (auto, metis asm in_mono l_power_inductl)
  moreover have "\<Union>range (\<lambda>n. X\<^bsup>n\<^esup> \<cdot> Z) = \<Union>range (l_power X) \<cdot> Z"
    by (auto simp add: l_prod_def complex_product_def)
  ultimately show "X\<^sup>*\<cdot>Z \<subseteq> Y"
    by (metis l_star_def)
qed

lemma l_power_inductr: "Z \<union> Y\<cdot>X \<subseteq> Y \<Longrightarrow> Z\<cdot>X\<^bsup>n\<^esup> \<subseteq> Y"
  apply (induct n)
  apply (simp_all del: l_power.simps(2) add: l_power_def_var)
  by (metis l_prod_assoc l_prod_isol order_trans)

lemma l_star_inductr: "Z \<union> Y\<cdot>X \<subseteq> Y \<Longrightarrow> Z\<cdot>X\<^sup>* \<subseteq> Y"
proof -
  assume asm: "Z \<union> Y\<cdot>X \<subseteq> Y"
  have "\<Union>range (\<lambda>n. Z \<cdot> X\<^bsup>n\<^esup>) \<subseteq> Y"
    by (auto, metis asm in_mono l_power_inductr)
  moreover have "\<Union>range (\<lambda>n. Z \<cdot> X\<^bsup>n\<^esup>) = Z \<cdot> \<Union>range (l_power X)"
    by (auto simp add: l_prod_def complex_product_def)
  ultimately show "Z\<cdot>X\<^sup>* \<subseteq> Y"
    by (metis l_star_def)
qed

definition ewp :: "'a lan \<Rightarrow> bool" where
  "ewp X \<equiv> [] \<in> X"

lemma ewp_union [simp]: "ewp (X \<union> Y) \<longleftrightarrow> ewp X \<or> ewp Y"
  by (auto simp add: ewp_def)

lemma ewp_l_prod [simp]: "ewp (X \<cdot> Y) \<longleftrightarrow> ewp X \<and> ewp Y"
  by (auto simp add: ewp_def l_prod_def complex_product_def)

lemma ewp_shuffle [simp]: "ewp (X \<parallel> Y) \<longleftrightarrow> ewp X \<and> ewp Y"
  apply default
  apply (simp add: ewp_def shuffle_def tshuffle_words_def image_def)
  apply auto
  apply (simp add: ewp_def)
  by (metis (hide_lams, full_types) empty_subsetI insert_subset set_mp shuffle_iso shuffle_one(2))

section {* Shuffle Star *}

primrec spawn :: "'a lan \<Rightarrow> nat \<Rightarrow> 'a lan" where
  "spawn X 0 = {[]}"
| "spawn X (Suc n) = X \<parallel> spawn X n"

definition shuffle_star :: "'a lan \<Rightarrow> 'a lan" ("_\<^sup>\<parallel>" [101] 100) where
  "X\<^sup>\<parallel> \<equiv> \<Union>range (spawn X)"

lemma [intro]: "[] \<in> spawn X 0"
  by simp

lemma word_shuffle_subset: "\<lbrakk>xs \<in> X; ys \<in> Y\<rbrakk> \<Longrightarrow> map \<langle>id,id\<rangle> ` (xs \<sha> ys) \<subseteq> (X \<parallel> Y)"
  by (auto simp add: shuffle_def)

lemma spawn1 [intro]: "xs \<in> X \<Longrightarrow> ys \<in> spawn X n \<Longrightarrow> map \<langle>id,id\<rangle> ` (xs \<sha> ys) \<subseteq> spawn X (Suc n)"
  by (induct n, simp_all, metis word_shuffle_subset)

lemma spawn2 [intro]: "xs \<in> X \<Longrightarrow> ys \<in> spawn X n \<Longrightarrow> zs \<in> xs \<sha> ys \<Longrightarrow> map \<langle>id,id\<rangle> zs \<in> spawn X (Suc n)"
  by (metis image_eqI spawn1 set_mp)

lemma shuffle_star_unfold: "{[]} \<union> X\<parallel>X\<^sup>\<parallel> \<subseteq> X\<^sup>\<parallel>"
  by (auto simp add: shuffle_star_def shuffle_def)

lemma spawn_induct: "Z \<union> X \<parallel> Y \<subseteq> Y \<Longrightarrow> spawn X n \<parallel> Z \<subseteq> Y"
  apply (induct n arbitrary: Z)
  apply auto
  by (metis (hide_lams, no_types) in_mono shuffle_assoc shuffle_comm shuffle_iso)

lemma shuffle_star_induct: "Z \<union> X \<parallel> Y \<subseteq> Y \<Longrightarrow> X\<^sup>\<parallel> \<parallel> Z \<subseteq> Y"
proof -
  assume asm: "Z \<union> X \<parallel> Y \<subseteq> Y"
  have "\<Union>range (\<lambda>n. spawn X n \<parallel> Z) \<subseteq> Y"
    by (auto, metis asm in_mono spawn_induct)
  moreover have "\<Union>range (\<lambda>n. spawn X n \<parallel> Z) = \<Union>range (spawn X) \<parallel> Z"
    by (auto simp only: shuffle_inf_distr)
  ultimately show "X\<^sup>\<parallel>\<parallel>Z \<subseteq> Y"
    by (metis shuffle_star_def)
qed

section {* Power invariants *}

definition symbols :: "'a lan \<Rightarrow> 'a set" where
  "symbols X = \<Union>{set xs|xs. xs \<in> X}"

inductive_set pow_inv :: "'a set \<Rightarrow> 'a lan" for I :: "'a set" where
  pinv_empty [intro!]: "[] \<in> pow_inv I"
| pinv_cons: "x \<in> I \<Longrightarrow> xs \<in> pow_inv I \<Longrightarrow> (x # xs) \<in> pow_inv I"

lemma inv_shuffle: "pow_inv I \<parallel> pow_inv I = pow_inv I"
proof -
  {
    fix xs
    assume "xs \<in> pow_inv I"
    hence "xs \<in> pow_inv I \<parallel> pow_inv I"
      apply (induct xs rule: pow_inv.induct)
      apply (metis (full_types) ewp_def ewp_shuffle pow_inv.pinv_empty)
      by (metis (hide_lams, no_types) bot_least in_mono insert_subset pow_inv.pinv_cons pow_inv.pinv_empty shuffle_iso shuffle_one(2))
  }
  moreover
  {
    fix xs
    assume "xs \<in> pow_inv I \<parallel> pow_inv I"
    hence "xs \<in> pow_inv I"
    proof (auto simp add: shuffle_def tshuffle_words_def)
      fix xs assume "\<ll> xs \<in> pow_inv I" and "\<rr> xs \<in> pow_inv I"
      thus "map \<langle>id,id\<rangle> xs \<in> pow_inv I"
        apply (induct xs rule: sum_list_induct)
        apply simp_all
        apply (metis cons_non_empty list.inject pow_inv.simps)
        by (metis cons_non_empty list.inject pow_inv.simps)
    qed
  }
  ultimately show ?thesis by auto
qed

lemma inv_l_prod: "pow_inv I \<cdot> pow_inv I = pow_inv I"
proof -
  have "pow_inv I \<subseteq> pow_inv I \<cdot> pow_inv I"
    by (metis empty_subsetI insert_subset l_prod_isol l_prod_one(1) pow_inv.pinv_empty)
  moreover
  {
    fix xs
    assume "xs \<in> pow_inv I \<cdot> pow_inv I"
    hence "xs \<in> pow_inv I"
    proof (auto simp add: l_prod_def complex_product_def)
      fix xs ys
      assume "xs \<in> pow_inv I" and "ys \<in> pow_inv I"
      thus "xs @ ys \<in> pow_inv I"
        by (induct xs) (auto intro: pinv_cons)
    qed
  }
  ultimately show ?thesis
    by (metis subsetI subset_antisym)
qed

lemma inv_alg1: shows "X \<subseteq> pow_inv I \<cdot> X" and "X \<subseteq> X \<cdot> pow_inv I"
  by (auto simp add: l_prod_def complex_product_def)

lemma inv_alg2: shows "X \<subseteq> pow_inv I \<parallel> X" and "X \<subseteq> X \<parallel> pow_inv I"
  by (rule order_trans[OF inv_alg1(1) l_prod_leq_shuffle]) (rule order_trans[OF inv_alg1(2) l_prod_leq_shuffle])

lemma inv_distl: "pow_inv I \<cdot> (X \<parallel> Y) \<subseteq> (pow_inv I \<cdot> X) \<parallel> (pow_inv I \<cdot> Y)"
  by (metis exchange inv_shuffle)

lemma inv_distr: "(X \<parallel> Y) \<cdot> pow_inv I \<subseteq> (X \<cdot> pow_inv I) \<parallel> (Y \<cdot> pow_inv I)"
  by (metis exchange inv_shuffle shuffle_comm)

lemma inv_l_prod_leq_shuffle: "pow_inv I \<cdot> X \<cdot> pow_inv I \<subseteq> pow_inv I \<parallel> X"
  by (metis (hide_lams, no_types) inv_shuffle l_prod_assoc l_prod_isor l_prod_leq_shuffle order_trans shuffle_assoc shuffle_comm)

lemma inv_power: "pow_inv I = (pow_inv I)\<^bsup>Suc n\<^esup>"
  by (induct n) (simp_all add: inv_l_prod)

lemma inv_spawn: "pow_inv I = spawn (pow_inv I) (Suc n)"
  by (induct n) (simp_all add: inv_shuffle)

lemma inv_star: "pow_inv I = (pow_inv I)\<^sup>*"
  apply (auto simp add: l_star_def)
  apply (rule_tac x = 1 in exI)
  apply simp
  by (metis inv_alg1(2) inv_power l_power_def_var set_mp)

lemma inv_shuffle_star: "pow_inv I = (pow_inv I)\<^sup>\<parallel>"
  apply (auto simp add: shuffle_star_def)
  apply (rule_tac x = 1 in exI)
  apply simp
  by (metis inv_alg2(1) inv_spawn set_mp spawn.simps(2))

lemma symbol_cons: "x # xs \<in> X \<Longrightarrow> x \<in> symbols X"
  by (auto simp add: symbols_def)

lemma pow_inv_iso: assumes "X \<subseteq> Y" shows "pow_inv X \<subseteq> pow_inv Y"
proof
  fix xs assume "xs \<in> pow_inv X" thus "xs \<in> pow_inv Y"
    apply (induct xs rule: pow_inv.induct)
    apply auto
    by (metis assms pow_inv.pinv_cons set_mp)
qed

lemma lan_tl: "x # xs \<in> X \<Longrightarrow> xs \<in> tl ` X"
  apply (auto simp add: image_def)
  apply (rule_tac x = "x # xs" in bexI)
  by auto

lemma symbols_tl: "symbols (tl ` X) \<subseteq> symbols X"
  apply (auto simp add: symbols_def)
  by (metis Cons_eq_appendI append_assoc in_set_conv_decomp_first rotate1_hd_tl set_rotate1 tl.simps(1))

lemma inv_sym_extensive: "X \<subseteq> pow_inv (symbols X)"
proof
  fix xs
  assume "xs \<in> X" thus "xs \<in> pow_inv (symbols X)"
  proof (induct xs arbitrary: X, simp add: pinv_empty)
    fix x :: 'a and xs X
    assume ih: "\<And>X. xs \<in> X \<Longrightarrow> xs \<in> pow_inv (symbols X)"
    and xxs: "x # xs \<in> X"
    hence "xs \<in> tl ` X"
      by (metis lan_tl)
    hence "xs \<in> pow_inv (symbols (tl ` X))"
      by (metis ih)
    hence "xs \<in> pow_inv (symbols X)"
      by (metis pow_inv_iso set_mp symbols_tl)
    thus "x # xs \<in> pow_inv (symbols X)"
      by (metis pow_inv.pinv_cons symbol_cons xxs)
  qed
qed

lemma pow_inv_tshuffle: "\<lbrakk>xs \<in> X; ys \<in> pow_inv (symbols X)\<rbrakk> \<Longrightarrow> map \<langle>id,id\<rangle> ` (xs \<sha> ys) \<subseteq> pow_inv (symbols X)"
proof (induct xs arbitrary: ys, simp)
  fix x xs ys
  assume ihx: "\<And>ys. xs \<in> X \<Longrightarrow> ys \<in> pow_inv (symbols X) \<Longrightarrow> map \<langle>id,id\<rangle> ` (xs \<sha> ys) \<subseteq> pow_inv (symbols X)"
  and xs_def: "x # xs \<in> X"
  and ys_def: "ys \<in> pow_inv (symbols X)"
  from ys_def show "map \<langle>id,id\<rangle> ` ((x # xs) \<sha> ys) \<subseteq> pow_inv (symbols X)"
  proof (induct ys)
    have "x # xs \<in> pow_inv (symbols X)"
      by (metis in_mono inv_sym_extensive xs_def)
    thus "map \<langle>id,id\<rangle> ` ((x # xs) \<sha> []) \<subseteq> pow_inv (symbols X)"
      by (metis inv_shuffle pow_inv.pinv_empty word_shuffle_subset)
  next
    fix y ys assume y_def: "y \<in> symbols X" and ys_def: "ys \<in> pow_inv (symbols X)"
    and ihy: "map \<langle>id,id\<rangle> ` ((x # xs) \<sha> ys) \<subseteq> pow_inv (symbols X)"
    show "map \<langle>id,id\<rangle> ` ((x # xs) \<sha> (y # ys)) \<subseteq> pow_inv (symbols X)"
      apply (simp add: tshuffle_ind)
      by (metis (hide_lams, no_types) y_def ys_def inv_shuffle inv_sym_extensive pow_inv.pinv_cons set_rev_mp tshuffle_ind word_shuffle_subset xs_def)
  qed
qed

lemma inv_shuffle_star_leq: "X\<^sup>\<parallel> \<subseteq> pow_inv (symbols X)"
proof
  fix xs
  assume "xs \<in> X\<^sup>\<parallel>"
  thus "xs \<in> pow_inv (symbols X)"
  proof (auto simp add: shuffle_star_def)
    fix n assume "xs \<in> spawn X n"
    thus "xs \<in> pow_inv (symbols X)"
      apply (induct n arbitrary: xs, auto simp add: pinv_empty shuffle_def)
      by (metis imageI pow_inv_tshuffle subsetD)
  qed
qed

end


theory three
  imports Main
begin

text "the leaf of the tree is just referred to as Tip; acts like Nil in nat and list"
text "All nodes that are not a leaf are defined a structure of two subtrees and the element itself"
datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
  "mirror Tip = Tip" |
  "mirror (Node l a r) = Node (mirror r) a (mirror l)"

lemma double_mirror: "mirror (mirror t) = t"
  apply (induction t)
   apply (auto)
  done

fun is_element :: "'a tree \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_element Tip x = False" |
  "is_element (Node l a r) x = (if a = x then True else (is_element l x \<or> is_element r x))"

definition sq :: "nat \<Rightarrow> nat" where
  "sq n = n * n"

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "itrev Nil ys = ys" |
  "itrev (Cons x xs) ys = itrev xs (Cons x ys)"

lemma equiv_rev: "itrev xs ys = rev xs @ ys"
  apply (induction xs arbitrary: ys)
   apply (auto)
  done

end


(*  Title:      HOL/Isar_Examples/Fibonacci.thy
    Author:     Gertrud Bauer
    Copyright   1999 Technische Universitaet Muenchen

The Fibonacci function.  Original
tactic script by Lawrence C Paulson.

Fibonacci numbers: proofs of laws taken from

  R. L. Graham, D. E. Knuth, O. Patashnik.
  Concrete Mathematics.
  (Addison-Wesley, 1989)
*)

section \<open>Fib and Gcd commute\<close>

theory Fibonacci
imports "../Number_Theory/Primes"
begin

text_raw \<open>\footnote{Isar version by Gertrud Bauer.  Original tactic
  script by Larry Paulson.  A few proofs of laws taken from
  @{cite "Concrete-Math"}.}\<close>

declare One_nat_def [simp]

subsection \<open>Fibonacci numbers\<close>

fun fib :: "nat \<Rightarrow> nat" where
  "fib 0 = 0"
| "fib (Suc 0) = 1"
| "fib (Suc (Suc x)) = fib x + fib (Suc x)"

text \<open>Alternative induction rule.\<close>

theorem fib_induct:
  fixes n :: nat
  shows "P 0 \<Longrightarrow> P 1 \<Longrightarrow> (\<And>n. P (n + 1) \<Longrightarrow> P n \<Longrightarrow> P (n + 2)) \<Longrightarrow> P n"
  by (induct rule: fib.induct) simp_all

subsection \<open>Fib and gcd commute\<close>

text \<open>A few laws taken from @{cite "Concrete-Math"}.\<close>

lemma fib_add:
  "fib (n + k + 1) = fib (k + 1) * fib (n + 1) + fib k * fib n"
  (is "?P n")
  -- \<open>see @{cite \<open>page 280\<close> "Concrete-Math"}\<close>
proof (induct n rule: fib_induct)
  show "?P 0" by simp
  show "?P 1" by simp
  fix n
  have "fib (n + 2 + k + 1)
    = fib (n + k + 1) + fib (n + 1 + k + 1)" by simp
  also assume "fib (n + k + 1)
    = fib (k + 1) * fib (n + 1) + fib k * fib n"
      (is " _ = ?R1")
  also assume "fib (n + 1 + k + 1)
    = fib (k + 1) * fib (n + 1 + 1) + fib k * fib (n + 1)"
      (is " _ = ?R2")
  also have "?R1 + ?R2
    = fib (k + 1) * fib (n + 2 + 1) + fib k * fib (n + 2)"
    by (simp add: add_mult_distrib2)
  finally show "?P (n + 2)" .
qed

lemma gcd_fib_Suc_eq_1: "gcd (fib n) (fib (n + 1)) = 1" (is "?P n")
proof (induct n rule: fib_induct)
  show "?P 0" by simp
  show "?P 1" by simp
  fix n
  have "fib (n + 2 + 1) = fib (n + 1) + fib (n + 2)"
    by simp
  also have "\<dots> = fib (n + 2) + fib (n + 1)"
    by simp
  also have "gcd (fib (n + 2)) \<dots> = gcd (fib (n + 2)) (fib (n + 1))"
    by (rule gcd_add2_nat)
  also have "\<dots> = gcd (fib (n + 1)) (fib (n + 1 + 1))"
    by (simp add: gcd_commute_nat)
  also assume "\<dots> = 1"
  finally show "?P (n + 2)" .
qed

lemma gcd_mult_add: "(0::nat) < n \<Longrightarrow> gcd (n * k + m) n = gcd m n"
proof -
  assume "0 < n"
  then have "gcd (n * k + m) n = gcd n (m mod n)"
    by (simp add: gcd_non_0_nat add.commute)
  also from \<open>0 < n\<close> have "\<dots> = gcd m n"
    by (simp add: gcd_non_0_nat)
  finally show ?thesis .
qed

lemma gcd_fib_add: "gcd (fib m) (fib (n + m)) = gcd (fib m) (fib n)"
proof (cases m)
  case 0
  then show ?thesis by simp
next
  case (Suc k)
  then have "gcd (fib m) (fib (n + m)) = gcd (fib (n + k + 1)) (fib (k + 1))"
    by (simp add: gcd_commute_nat)
  also have "fib (n + k + 1)
      = fib (k + 1) * fib (n + 1) + fib k * fib n"
    by (rule fib_add)
  also have "gcd \<dots> (fib (k + 1)) = gcd (fib k * fib n) (fib (k + 1))"
    by (simp add: gcd_mult_add)
  also have "\<dots> = gcd (fib n) (fib (k + 1))"
    by (simp only: gcd_fib_Suc_eq_1 gcd_mult_cancel_nat)
  also have "\<dots> = gcd (fib m) (fib n)"
    using Suc by (simp add: gcd_commute_nat)
  finally show ?thesis .
qed

lemma gcd_fib_diff:
  assumes "m \<le> n"
  shows "gcd (fib m) (fib (n - m)) = gcd (fib m) (fib n)"
proof -
  have "gcd (fib m) (fib (n - m)) = gcd (fib m) (fib (n - m + m))"
    by (simp add: gcd_fib_add)
  also from \<open>m \<le> n\<close> have "n - m + m = n"
    by simp
  finally show ?thesis .
qed

lemma gcd_fib_mod:
  assumes "0 < m"
  shows "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)"
proof (induct n rule: nat_less_induct)
  case (1 n) note hyp = this
  show ?case
  proof -
    have "n mod m = (if n < m then n else (n - m) mod m)"
      by (rule mod_if)
    also have "gcd (fib m) (fib \<dots>) = gcd (fib m) (fib n)"
    proof (cases "n < m")
      case True
      then show ?thesis by simp
    next
      case False
      then have "m \<le> n" by simp
      from \<open>0 < m\<close> and False have "n - m < n"
        by simp
      with hyp have "gcd (fib m) (fib ((n - m) mod m))
          = gcd (fib m) (fib (n - m))" by simp
      also have "\<dots> = gcd (fib m) (fib n)"
        using \<open>m \<le> n\<close> by (rule gcd_fib_diff)
      finally have "gcd (fib m) (fib ((n - m) mod m)) =
          gcd (fib m) (fib n)" .
      with False show ?thesis by simp
    qed
    finally show ?thesis .
  qed
qed

theorem fib_gcd: "fib (gcd m n) = gcd (fib m) (fib n)" (is "?P m n")
proof (induct m n rule: gcd_nat_induct)
  fix m
  show "fib (gcd m 0) = gcd (fib m) (fib 0)"
    by simp
  fix n :: nat
  assume n: "0 < n"
  then have "gcd m n = gcd n (m mod n)"
    by (simp add: gcd_non_0_nat)
  also assume hyp: "fib \<dots> = gcd (fib n) (fib (m mod n))"
  also from n have "\<dots> = gcd (fib n) (fib m)"
    by (rule gcd_fib_mod)
  also have "\<dots> = gcd (fib m) (fib n)"
    by (rule gcd_commute_nat)
  finally show "fib (gcd m n) = gcd (fib m) (fib n)" .
qed

end


(*  Title:       Instances of Schneider's generalized protocol of clock synchronization
    Author:      Damián Barsotti <damian at hal.famaf.unc.edu.ar>, 2006
    Maintainer:  Damián Barsotti <damian at hal.famaf.unc.edu.ar>
*)

section \<open>Interactive Convergence Algorithms (ICA)\<close>

theory ICAInstance imports Complex_Main begin

text \<open>This algorithm is presented in \<^cite>\<open>"lamport_cs"\<close>.\<close>

text \<open>A proof of the three properties can be found in
\<^cite>\<open>"shankar92mechanical"\<close>.\<close>

subsection \<open>Model of the system\<close>

text \<open>The main ideas for the formalization of the system were
obtained from \<^cite>\<open>"shankar92mechanical"\<close>.\<close>

subsubsection \<open>Types in the formalization\<close>

text \<open>The election of the basics types was based on
\<^cite>\<open>"shankar92mechanical"\<close>. There, the process are natural numbers and
the real time and the clock readings are reals.\<close>

type_synonym process = nat
type_synonym time = real       \<comment> \<open>real time\<close>
type_synonym Clocktime = real  \<comment> \<open>time of the clock readings (clock time)\<close>

subsubsection \<open>Some constants\<close>

text\<open>Here we define some parameters of the algorithm that we use:
the number of process and the fix value that is used to discard the
processes whose clocks differ more than this amount from the own one
(see \<^cite>\<open>"shankar92mechanical"\<close>). The defined constants must satisfy
this axiom (if $np = 0$ we have a division by cero in the definition
of the convergence function).\<close>

axiomatization
  np :: nat      \<comment> \<open>Number of processes\<close> and
  \<Delta> :: Clocktime \<comment> \<open>Fix value to discard processes\<close> where
  constants_ax: "0 <= \<Delta> \<and> np > 0"

text \<open>We define also the set of process that the algorithm
manage. This definition exist only for readability matters.\<close>

definition
PR :: "process set" where
[simp]: "PR = {..<np}"

subsubsection \<open>Convergence function\<close>

text \<open>This functions is called ``Egocentric Average''
(\<^cite>\<open>"schneider87understanding"\<close>)\<close>

text \<open>In this algorithm each process has an array where it store the
clocks readings from the others processes (including itself). We
formalise that as a function from processes to clock time as
\<^cite>\<open>"shankar92mechanical"\<close>.\<close>

text \<open>First we define an auxiliary function. It takes a function of
clock readings and two processes, and return de reading of the second
process if the difference of the readings is grater than @{term \<Delta>},
otherwise it returns the reading of the first one.\<close>

definition
  fiX :: "[(process \<Rightarrow> Clocktime), process, process] \<Rightarrow> Clocktime" where
  "fiX f p l = (if \<bar>f p - f l\<bar> <= \<Delta> then (f l) else (f p))"

text \<open>And finally the convergence function. This is defined with the
builtin generalized summation over a set constructor of Isabelle.
Also we had to use the overloaded @{term real} function to typecast de
number @{term np}.\<close>

definition
  (* The averaging function to calculate clock adjustment *)
  cfni :: "[process, (process \<Rightarrow> Clocktime)] \<Rightarrow> Clocktime" where
  "cfni p f = (\<Sum> l\<in>{..<np}. fiX f p l) / (real np)"

subsection \<open>Translation Invariance property.\<close>

text \<open>We first need to prove this auxiliary lemma.\<close>

lemma trans_inv':
"(\<Sum> l\<in>{..<np'}. fiX (\<lambda> y. f y + x) p l) =
        (\<Sum> l\<in>{..<np'}. fiX f p l) + real np' * x"
apply (induct_tac np')
apply (auto simp add: cfni_def  fiX_def of_nat_Suc
       distrib_right lessThan_Suc)
done

theorem trans_inv:
"\<forall> p f x . cfni p (\<lambda> y. f y + x) = cfni p f + x"
apply (auto simp add: cfni_def trans_inv' distrib_right
       divide_inverse  constants_ax)
done

subsection \<open>Precision Enhancement property\<close>

text \<open>An informal proof of this theorem can be found in
\<^cite>\<open>"shankar92mechanical"\<close>\<close>

subsubsection \<open>Auxiliary lemmas\<close>

lemma finitC:
  "C \<subseteq> PR \<Longrightarrow> finite C"
proof-
  assume "C \<subseteq> PR"
  thus ?thesis using finite_subset by auto
qed

lemma finitnpC:
  "finite (PR - C)"
proof-
  show ?thesis  using finite_Diff by auto
qed

text \<open>The next lemmas are about arithmetic properties of the
generalized summation over a set constructor.\<close>

lemma sum_abs_triangle_ineq:
"finite S \<Longrightarrow>
  \<bar>\<Sum>l\<in>S. (f::'a \<Rightarrow> 'b::linordered_idom) l\<bar> <= (\<Sum>l\<in>S. \<bar>f l\<bar>)"
  (is "... \<Longrightarrow> ?P S")
  by (rule sum_abs)

lemma sum_le:
  "\<lbrakk>finite S ; \<forall> r\<in>S. f r <= b \<rbrakk>
  \<Longrightarrow>
  (\<Sum>l\<in>S. f l) <= real (card S) * b"
  (is "\<lbrakk> finite S ; \<forall> r\<in>S. f r <= b \<rbrakk> \<Longrightarrow> ?P S")
proof(induct S rule: finite_induct)
  show "?P {}" by simp
next
  fix F x
  assume  finit: "finite F" and xnotinF: "x \<notin> F" and
          HI1: "\<forall>r\<in>F. f r \<le> b \<Longrightarrow> sum f F \<le> real (card F) * b"
          and HI2: "\<forall>r\<in>insert x F. f r \<le> b"
  from HI1 HI2 and finit and xnotinF
  have "sum f (insert x F) <= b + real (card F) * b"
    by auto
  also
  have "... = real (Suc (card  F)) * b"
    by (simp add: distrib_right  of_nat_Suc)
  also
  from   finit xnotinF have "...= real (card (insert x F)) * b"
    by simp
  finally
  show "?P (insert x F)" .
qed

lemma sum_np_eq:
assumes
  hC: "C \<subseteq> PR"
shows
  "(\<Sum>l\<in>{..<np}. f l) = (\<Sum>l\<in>C. f l) + (\<Sum>l\<in>({..<np}-C). f l)"
proof-
  note finitC[where C=C]
  moreover
  note finitnpC[where C=C]
  moreover
  have "C \<inter> ({..<np}-C) = {}" by auto
  moreover
  from hC have "C \<union> ({..<np}-C) = {..<np}" by auto
  ultimately
  show ?thesis
    using sum.union_disjoint[where A=C and B="{..<np} - C"]
    by auto
qed

lemma abs_sum_np_ineq:
assumes
  hC: "C \<subseteq> PR"
shows
  "\<bar>(\<Sum>l\<in>{..<np}. (f::nat \<Rightarrow> real) l)\<bar> <=
     (\<Sum>l\<in>C. \<bar>f l\<bar>) + (\<Sum>l\<in>({..<np}-C). \<bar>f l\<bar>)"
    (is "?abs_sum <= ?sumC + ?sumnpC")
proof-
  from hC and sum_np_eq[where f=f]
  have "?abs_sum = \<bar>(\<Sum>l\<in>C. f l) + (\<Sum>l\<in>({..<np}-C). f l)\<bar>"
    (is "?abs_sum = \<bar>?sumC' + ?sumnpC'\<bar>")
    by simp
  also
  from abs_triangle_ineq
  have "...<= \<bar>?sumC'\<bar> + \<bar>?sumnpC'\<bar>" .
  also
  have "... <=  ?sumC + ?sumnpC "
  proof-
    from hC finitC sum_abs_triangle_ineq
    have "\<bar>?sumC'\<bar> <= ?sumC" by blast
    moreover
    from finitnpC and
           sum_abs_triangle_ineq[where f=f and S="PR-C"]
    have "\<bar>?sumnpC'\<bar> <= ?sumnpC"
      by force
    ultimately
    show ?thesis by arith
  qed
  finally
  show ?thesis .
qed

text \<open>The next lemmas are about the existence of bounds that are
necesary in order to prove the Precicion Enhancement theorem.\<close>

lemma fiX_ubound:
  "fiX f p l <= f p + \<Delta>"
proof(cases "\<bar>f p - f l\<bar> \<le> \<Delta>")
  assume asm: "\<bar>f p - f l\<bar> \<le> \<Delta>"
  hence "fiX f p l = f l" by (simp add: fiX_def)
  also
  from asm have "f l <= f p + \<Delta>" by arith
  finally
  show ?thesis by arith
next
  assume asm: "\<not>\<bar>f p - f l\<bar> \<le> \<Delta>"
  hence "fiX f p l = f p" by (simp add: fiX_def)
  also
  from asm and  constants_ax have "f p <= f p + \<Delta>" by arith
  finally
  show ?thesis by arith
qed

lemma fiX_lbound:
  "f p - \<Delta> <= fiX f p l"
proof(cases "\<bar>f p - f l\<bar> \<le> \<Delta>")
  assume asm: "\<bar>f p - f l\<bar> \<le> \<Delta>"
  hence "fiX f p l = f l" by (simp add: fiX_def)
  also
  from asm have "f p - \<Delta> <= f l" by arith
  finally
  show ?thesis by arith
next
  assume asm: "\<not>\<bar>f p - f l\<bar> \<le> \<Delta>"
  with  constants_ax have "f p - \<Delta> <= f p" by arith
  also
  from asm have "f p = fiX f p l" by (simp add: fiX_def)
  finally
  show ?thesis by arith
qed

lemma abs_fiX_bound: "\<bar>fiX f p l - f p \<bar> <= \<Delta>"
proof-
(*
from constants_ax and fiX_lbound and fiX_ubound show ?thesis by arith
*)
have "f p - \<Delta> <= fiX f p l \<and> fiX f p l <= f p + \<Delta> \<longrightarrow> ?thesis"
by arith
with fiX_lbound  fiX_ubound show ?thesis by blast
qed

lemma abs_dif_fiX_bound_C_aux1:
assumes
  hbx: "\<forall> l\<in>C. \<bar>f l - g l\<bar> <= x" and
  hby1: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= y" and
  hby2: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>g l - g m\<bar> <= y" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C" and
  hrC: "r\<in>C"
shows
  "\<bar>fiX f p r - fiX g q r\<bar> <= x + y"
proof(cases "\<bar>f p - f r\<bar> \<le> \<Delta>")
  case True
  note outer_IH = True
  show ?thesis
  proof(cases "\<bar>g q - g r\<bar> \<le> \<Delta>")
    case True
    show ?thesis
    proof -
      from hpC and hby1 have "0<=y" by force
      with hrC and hbx have "\<bar> f r - g r \<bar> <= x + y" by auto
      with outer_IH and True show ?thesis
        by (auto simp add: fiX_def)
    qed
  next
    case False
    show ?thesis
    proof -
      from outer_IH and False
      have "\<bar>fiX f p r - fiX g q r\<bar> = \<bar>f r - g q\<bar>"
        by  (auto simp add: fiX_def)
      also
      have "... = \<bar> f r - f q + f q - g q \<bar>" by simp
      also
      have "... <= \<bar> f r - f q \<bar> + \<bar> f q - g q \<bar>"
        by arith
      also
      from hbx hby1 hpC hqC hrC have "... <= x + y" by force
      finally
      show ?thesis .
    qed
  qed
next
  case False
  note outer_IH = False
  show ?thesis
  proof(cases "\<bar>g q - g r\<bar> \<le> \<Delta>")
    case True
    show ?thesis
    proof -
      from outer_IH and True
      have "\<bar>fiX f p r - fiX g q r\<bar> = \<bar>f p - g r\<bar>"
        by  (auto simp add: fiX_def)
      also
      have "... = \<bar> f p - f r + f r - g r \<bar>" by simp
      also
      from abs_triangle_ineq[where a = "f p - f r" and
                                   b = "f r - g r"]
      have "... <= \<bar> f p - f r \<bar> + \<bar> f r - g r \<bar>"
        by auto
      also
      from hbx hby1 hpC hrC have "... <= x + y" by force
      finally
      show ?thesis .
    qed
  next
    case False
    show ?thesis
    proof -
      from outer_IH and False
      have "\<bar>fiX f p r - fiX g q r\<bar> = \<bar>f p - g q\<bar>"
        by  (auto simp add: fiX_def)
      also
      have "... = \<bar> f p - f q + f q - g q \<bar>" by simp
      also
      from abs_triangle_ineq[where a = "f p - f q" and
                                   b = "f q - g q"]
      have "... <= \<bar> f p - f q \<bar> + \<bar> f q - g q \<bar>"
        by auto
      also
      from hbx hby1 hpC hqC have "... <= x + y" by force
      finally
      show ?thesis .
    qed
  qed
qed

lemma abs_dif_fiX_bound_C_aux2:
assumes
  hbx: "\<forall> l\<in>C. \<bar>f l - g l\<bar> <= x" and
  hby1: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= y" and
  hby2: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>g l - g m\<bar> <= y" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C" and
  hrC: "r\<in>C"
shows
  "y <= \<Delta> \<longrightarrow> \<bar>fiX f p r - fiX g q r\<bar> <= x"
proof
  assume hyd: "y<=\<Delta>"
  show "\<bar>fiX f p r - fiX g q r\<bar> <= x"
  proof-
    from hpC and hrC and hby1 and hyd have "\<bar>f p - f r\<bar> \<le> \<Delta>"
      by force
    moreover
    from hqC and hrC and hby2 and hyd have "\<bar>g q - g r\<bar> \<le> \<Delta>"
      by force
    moreover
    from hrC and hbx have "\<bar> f r - g r \<bar> <= x " by auto
    ultimately
    show ?thesis
      by (auto simp add: fiX_def)
  qed
qed

lemma abs_dif_fiX_bound_C:
assumes
  hbx: "\<forall> l\<in>C. \<bar>f l - g l\<bar> <= x" and
  hby1: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= y" and
  hby2: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>g l - g m\<bar> <= y" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C" and
  hrC: "r\<in>C"
shows
  "\<bar>fiX f p r - fiX g q r\<bar> <=
                     x + (if (y <= \<Delta>) then 0 else y)"
proof (cases "y <= \<Delta>")
  case True
  with abs_dif_fiX_bound_C_aux2 and
    hbx and hby1 and hby2 and hpC and hqC and hrC
  have "\<bar>fiX f p r - fiX g q r\<bar> <= x " by blast
  with True show "?thesis" by simp
next
  case False
  with abs_dif_fiX_bound_C_aux1 and
    hbx and hby1 and hby2 and hpC and hqC and hrC
  have "\<bar>fiX f p r - fiX g q r\<bar> <= x + y" by blast
  with False show "?thesis" by simp
qed

subsubsection \<open>Main theorem\<close>

theorem prec_enh:
assumes
  hC: "C \<subseteq> PR" and
  hbx: "\<forall> l\<in>C. \<bar>f l - g l\<bar> <= x" and
  hby1: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= y" and
  hby2: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>g l - g m\<bar> <= y" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C"
shows "\<bar> cfni p f - cfni q g \<bar> <=
  (real (card C) * (x + (if (y <= \<Delta>) then 0 else y)) +
    real (card ({..<np} - C)) * (2 * \<Delta> + x + y)) / real np"
       (is "\<bar> ?dif_div_np \<bar> <= ?B")
proof-
  have "\<bar>(\<Sum>l\<in>{..<np}. fiX f p l ) -
                    (\<Sum>l\<in>{..<np}. fiX g q l)\<bar> =
    \<bar>(\<Sum>l\<in>{..<np}. fiX f p l -fiX g q l)\<bar>"
    (is "\<bar>?dif\<bar> = \<bar>?dif'\<bar>" )
    by (simp add: sum_subtractf)
  also
  from abs_sum_np_ineq hC
  have " ... <=
      (\<Sum>l\<in>C. \<bar>fiX f p l - fiX g q l\<bar>) +
      (\<Sum>l\<in>({..<np}-C). \<bar>fiX f p l - fiX g q l\<bar>)"
    (is " \<bar>?dif'\<bar> <= ?boundC' + ?boundnpC'" )
    by simp
  also
  have "... <=
    real (card C) * (x + (if (y <= \<Delta>) then 0 else y))+
    real (card ({..<np}-C)) * (2 * \<Delta> + x + y)"
    (is " ... <= ?boundC + ?boundnpC" )
  proof-
    have " ?boundC' <= ?boundC"
    proof -
      from abs_dif_fiX_bound_C and
        hbx and hby1 and hby2 and  hpC and hqC
      have "\<forall>r\<in>C.
        \<bar>fiX f p r - fiX g q r\<bar> <= x +
                         (if (y <= \<Delta>) then 0 else y)"
        by blast
      thus ?thesis using sum_le[where S=C] and finitC[OF hC]
        by force
    qed
    moreover
    have "?boundnpC' <= ?boundnpC"
    proof -
      from abs_dif_fiX_bound and
        hbx and hby1 and  hpC and hqC
      have "\<forall>r\<in>({..<np}-C). \<bar>fiX f p r - fiX g q r\<bar> <= 2 * \<Delta> + x + y"
        by blast
      with finitnpC
      show ?thesis
        by (auto intro: sum_le)
    qed
    ultimately
    show ?thesis by arith
  qed
  finally
  have bound: "\<bar>?dif\<bar> <= ?boundC + ?boundnpC" .
  thus ?thesis
  proof-
    have "?dif_div_np = ?dif / real np"
      by (simp add: cfni_def divide_inverse algebra_simps)
    hence "\<bar> cfni p f - cfni q g \<bar> = \<bar>?dif\<bar> / real np"
      by force
    with bound show "?thesis"
      by (auto simp add: cfni_def divide_inverse constants_ax)
  qed
qed

subsection \<open>Accuracy Preservation property\<close>

text \<open>First, a simple lemma about an arithmetic propertie of the
generalized summation over a set constructor.\<close>

lemma sum_div_card:
"(\<Sum>l\<in>{..<n::nat}. f l) + q * real n=
  (\<Sum>l\<in>{..<n}. f l + q )"
  (is "?Sl n = ?Sr n")
proof (induct n)
case 0 thus ?case by simp
next
case (Suc n)
thus ?case
  by (auto simp: of_nat_Suc distrib_left lessThan_Suc)
qed

text \<open>Next, some lemmas about bounds that are used in the proof of Accuracy Preservation\<close>

lemma bound_aux_C:
assumes
  hby: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= x" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C" and
  hrC: "r\<in>C"
shows
  "\<bar>fiX f p r - f q\<bar> <= x"
proof (cases "\<bar> f p - f r \<bar> <= \<Delta>")
  case True
  then have "\<bar>fiX f p r - f q\<bar> = \<bar> f r - f q \<bar>"
    by (simp add: fiX_def)
  also
  from hby hqC hrC have "... <= x" by blast
  finally
  show ?thesis .
next
  case False
  then have "\<bar>fiX f p r - f q\<bar> = \<bar> f p - f q \<bar>"
    by (simp add: fiX_def)
  also
  from hby hpC hqC have "... <= x" by blast
  finally
  show ?thesis .
qed

lemma bound_aux:
assumes
  hby: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= x" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C"
shows
  "\<bar>fiX f p r - f q\<bar> <= x + \<Delta>"
proof (cases "\<bar> f p - f r \<bar> <= \<Delta>")
  case True
  then have "\<bar>fiX f p r - f q\<bar> = \<bar> f r - f q \<bar>"
    by (simp add: fiX_def)
  also
  have "... = \<bar> (f r - f p) + (f p - f q) \<bar>"
    by arith
  also
  have "... <= \<bar> f p - f r \<bar> + \<bar> f p - f q \<bar>"
    by arith
  also
  from True have "... <= \<Delta> + \<bar> f p - f q \<bar>" by arith
  also
  from hby hpC hqC have "... <= \<Delta> + x" by simp
  finally
  show ?thesis by simp
next
  case False
  then have "\<bar>fiX f p r - f q\<bar> = \<bar> f p - f q \<bar>"
    by (simp add: fiX_def)
  also
  from hby hpC hqC have "... <= x" by blast
  finally
  show ?thesis using constants_ax by arith
qed

subsubsection \<open>Main theorem\<close>

lemma accur_pres:
assumes
  hC: "C \<subseteq> PR" and
  hby: "\<forall> l\<in>C. \<forall> m\<in>C. \<bar>f l - f m\<bar> <= x" and
  hpC: "p\<in>C" and
  hqC: "q\<in>C"
shows "\<bar> cfni p f - f q \<bar> <=
  (real (card C) * x + real (card ({..<np} - C)) * (x + \<Delta>))/
                  real np"
  (is "?abs1 <= (?bC + ?bnpC)/real np")
proof-
from abs_sum_np_ineq and hC have
  "\<bar>\<Sum>l\<in>{..<np}. fiX f p l  - f q \<bar> <=
    (\<Sum>l\<in>C. \<bar> fiX f p l  - f q \<bar>) +
            (\<Sum>l\<in>({..<np}-C). \<bar> fiX f p l  - f q \<bar>)"
  by simp
also
have
  "... <= real (card C) * x +
            real (card ({..<np} - C)) * (x + \<Delta>)"
  proof-
    have "(\<Sum>l\<in>C. \<bar> fiX f p l  - f q \<bar>) <=
                    real (card C) * x"
    proof-
      from bound_aux_C and
        hby and  hpC and hqC
      have "\<forall>r\<in>C.
        \<bar>fiX f p r - f q\<bar> <= x"
        by blast
      thus ?thesis using sum_le[where S=C] and finitC[OF hC]
        by force
    qed
    moreover
    have " (\<Sum>l\<in>({..<np}-C). \<bar> fiX f p l  - f q \<bar>) <=
                real (card ({..<np} - C)) * (x + \<Delta>)"
    proof -
      from bound_aux and
        hby and  hpC and hqC
      have "\<forall>r\<in>({..<np}-C).
        \<bar>fiX f p r - f q\<bar> <= x + \<Delta>"
        by blast
      thus ?thesis using sum_le[where S="{..<np}-C"]
        and finitnpC
        by force
    qed
    ultimately
    show ?thesis by arith
  qed
  finally
  have bound: "\<bar>\<Sum>l\<in>{..<np}. fiX f p l - f q\<bar>
  \<le> real (card C) * x + real (card ({..<np} - C)) * (x + \<Delta>)"
    .
  thus
    ?thesis
  proof-
    from constants_ax have
      res: "inverse (real np) * real np = 1"
      by auto
    have
      "(cfni p f - f q) * real np =
      (\<Sum>l\<in>{..<np}. fiX f p l) * real np / real np - f q * real np"
      by (simp add: cfni_def algebra_simps)
    also
    have "... =
      (\<Sum>l\<in>{..<np}. fiX f p l) - f q * real np"
      by simp
    also
    from sum_div_card[where f="fiX f p" and n=np and q="- f q"]
    have "... = (\<Sum>l\<in>{..<np}. fiX f p l - f q)"
      by simp
    finally
    have
      "(cfni p f - f q) * real np = (\<Sum>l\<in>{..<np}. fiX f p l - f q)"
      .
\<comment> \<open>cambia\<close>
    hence
      "(cfni p f - f q) * real np / real np =
      (\<Sum>l\<in>{..<np}. fiX f p l - f q)/ real np"
      by auto
    with constants_ax have
      "(cfni p f - f q) =
      (\<Sum>l\<in>{..<np}. fiX f p l - f q) / real np"
    by simp
    hence "\<bar> cfni p f - f q \<bar> =
      \<bar>(\<Sum>l\<in>{..<np}. fiX f p l - f q) / real np \<bar>"
      by simp
    also have
      "... = \<bar>(\<Sum>l\<in>{..<np}. fiX f p l - f q)\<bar> / real np "
      by auto
    finally have "\<bar> cfni p f - f q \<bar> =
      \<bar>(\<Sum>l\<in>{..<np}. fiX f p l - f q)\<bar> / real np "
      .
    with bound show "?thesis"
      by (auto simp add: cfni_def divide_inverse constants_ax)
  qed
qed

end


theory Ex021
imports Main
begin

lemma "(A \<longleftrightarrow> B)  \<longleftrightarrow> (A \<and> B) \<or> (\<not>A \<and> \<not>B)"
proof -
  {
    assume a:"A \<longleftrightarrow> B"
    hence b:"A \<longrightarrow> B" by (rule iffE)
    from a have c:"B \<longrightarrow> A" by (rule iffE)
    {
      assume d:"\<not> ((A \<and> B) \<or>  (\<not>A \<and> \<not>B))"
      {
        assume e:A
        with b have B by (rule mp)
        with e have "A \<and> B" by (rule conjI)
        hence "(A \<and> B) \<or> (\<not>A \<and> \<not>B)" by (rule disjI1)
        with d have False by contradiction
      }
      hence f:"\<not>A" by (rule notI)
      {
        assume g:B
        with c have A by (rule mp)
        from this and  g have "A \<and> B" by (rule conjI)
        hence "(A \<and> B) \<or> (\<not>A \<and> \<not>B)" by (rule disjI1)
        with d have False by contradiction
      }
      hence h:"\<not>B" by (rule notI)
      from f and h have "\<not>A \<and> \<not>B" by (rule conjI)
      hence "(A \<and> B) \<or>  (\<not>A \<and> \<not>B)" by (rule disjI2)
      with d have False by contradiction
    }
    hence "\<not>\<not> ((A \<and> B) \<or>  (\<not>A \<and> \<not>B))" by (rule notI)
    hence "(A \<and> B) \<or>  (\<not>A \<and> \<not>B)" by (rule notnotD)
  }
  moreover
  {
    assume a:"(A \<and> B) \<or> (\<not>A \<and> \<not>B)"
    {
      assume b:"A \<and> B"
      hence c:A by (rule conjE)
      from b have d:B by (rule conjE)
      {
        assume A
        have B by (rule d)
      }
      moreover
      {
        assume B
        have A by (rule c)
      }
      ultimately have "A \<longleftrightarrow> B" by (rule iffI)
    }
    note d=this
    {
      assume e:"\<not>A \<and> \<not>B"
      hence f:"\<not>A" by (rule conjE)
      from e have g:"\<not>B" by (rule conjE)
      {
        assume h:"\<not>(A \<longrightarrow> B)"
        {
          assume A
          with f have False by contradiction
          hence B by (rule FalseE)
        }
        hence "A \<longrightarrow> B" by (rule impI)
        with h have False by contradiction
      }
      hence "\<not>\<not>(A \<longrightarrow> B)" by (rule notI)
      hence i:"A \<longrightarrow> B" by (rule notnotD)
      {
        assume A
        with i have B by(rule mp)
      }
      moreover
      {
        assume j:"\<not>(B \<longrightarrow> A)"
        {
          assume B
          with g have False by contradiction
          hence A by (rule FalseE)
        }
        hence " B \<longrightarrow> A" by (rule impI)
        with j have False by contradiction
      }
      hence "\<not>\<not>(B \<longrightarrow> A)" by (rule notI)
      hence k:"B \<longrightarrow> A" by (rule notnotD)
      {
        assume B
        with k have A by (rule mp)
      }
        ultimately have "A \<longleftrightarrow> B" by (rule iffI)
    }
    from a and d and this have "A \<longleftrightarrow> B" by (rule disjE)
  }
  ultimately show ?thesis by (rule iffI)
qed


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_ISortSorts
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun ordered :: "int list => bool" where
"ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

fun insert :: "int => int list => int list" where
"insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if x <= z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "int list => int list" where
"isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

theorem property0 :
  "ordered (isort xs)"
  oops

end