theory ConcreteSemantics9_1_Typed
  imports Main "~~/src/HOL/IMP/Star" Complex_Main
begin

subsection "Arithmetic Expressions"

datatype val = Iv int | Rv real

type_synonym vname = string
type_synonym state = "vname \<Rightarrow> val"

text_raw\<open>\snip{aexptDef}{0}{2}{%\<close>
datatype aexp =  Ic int | Rc real | V vname | Plus aexp aexp
text_raw\<open>}%endsnip\<close>

inductive taval :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
"taval (Ic i) s (Iv i)" |
"taval (Rc r) s (Rv r)" |
"taval (V x) s (s x)" |
"taval a1 s (Iv i1) \<Longrightarrow> taval a2 s (Iv i2)
 \<Longrightarrow> taval (Plus a1 a2) s (Iv(i1+i2))" |
"taval a1 s (Rv r1) \<Longrightarrow> taval a2 s (Rv r2)
 \<Longrightarrow> taval (Plus a1 a2) s (Rv(r1+r2))"

inductive_cases [elim!]:
  "taval (Ic i) s v"
  "taval (Rc i) s v"
  "taval (V x) s v"
  "taval (Plus a1 a2) s v"

subsection "Boolean Expressions"

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

inductive tbval :: "bexp \<Rightarrow> state \<Rightarrow> bool \<Rightarrow> bool" where
"tbval (Bc v) s v" |
"tbval b s bv \<Longrightarrow> tbval (Not b) s (\<not> bv)" |
"tbval b1 s bv1 \<Longrightarrow> tbval b2 s bv2 \<Longrightarrow> tbval (And b1 b2) s (bv1 & bv2)" |
"taval a1 s (Iv i1) \<Longrightarrow> taval a2 s (Iv i2) \<Longrightarrow> tbval (Less a1 a2) s (i1 < i2)" |
"taval a1 s (Rv r1) \<Longrightarrow> taval a2 s (Rv r2) \<Longrightarrow> tbval (Less a1 a2) s (r1 < r2)"

subsection "Syntax of Commands"
(* a copy of Com.thy - keep in sync! *)

datatype
  com = SKIP
      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;; _"  [60, 61] 60)
      | If     bexp com com     ("IF _ THEN _ ELSE _"  [0, 0, 61] 61)
      | While  bexp com         ("WHILE _ DO _"  [0, 61] 61)

subsection "Small-Step Semantics of Commands"

inductive
  small_step :: "(com \<times> state) \<Rightarrow> (com \<times> state) \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "taval a s v \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := v))" |

Seq1:   "(SKIP;;c,s) \<rightarrow> (c,s)" |
Seq2:   "(c1,s) \<rightarrow> (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow> (c1';;c2,s')" |

IfTrue:  "tbval b s True \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c1,s)" |
IfFalse: "tbval b s False \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"

lemmas small_step_induct = small_step.induct[split_format(complete)]

value "(''x'' ::= V ''y'';; ''y''  ::= Plus (V ''x'') (V ''y''), s(''y'' := Iv 7))"

value "(''x'' ::= V ''y'';; ''y''  ::= Plus (V ''x'') (V ''y''), s(''y'' := Iv 7)) \<rightarrow>
(SKIP;; ''y'' ::= Plus (V ''x'') (V ''y''), s(''x'':= Iv 7, ''y'' := Iv 7))"
value "(SKIP;; ''y'' ::= Plus (V ''x'') (V ''y''), s(''x'':= Iv 7)) \<rightarrow>
(''y'' ::= Plus (V ''x'') (V ''y''), s(''x'' := Iv 7))"
value "(''y'' ::= Plus (V ''x'') (V ''y''), s(''x'' := Iv 7)) \<rightarrow>
(SKIP, s(''x'' := Iv 7,''y'' := Iv 14))"

value "(''x'' ::= V ''y'';; ''y''  ::= Plus (V ''x'') (Rc 3), s(''y'' := Iv 7))"
value "(''x'' ::= V ''y'';; ''y''  ::= Plus (V ''x'') (Rc 3), s(''y'' := Iv 7)) \<rightarrow>
(SKIP;; ''y'' ::= Plus (V ''x'') (Rc 3), s(''x'':= Iv 7))"
value "(SKIP;; ''y'' ::= Plus (V ''x'') (Rc 3), s(''x'':= Iv 7)) \<rightarrow>
(''y'' ::= Plus (V ''x'') (Rc 3), s(''x'' := Iv 7))"

lemma "(SKIP;; ''y'' ::= Plus (V ''x'') (Rc 3), s(''x'':= Iv 7)) \<rightarrow>
(''y'' ::= Plus (V ''x'') (Rc 3), s(''x'' := Iv 7))"
  by (simp add: Seq1)
(*
after that no further execution
step is possible because we cannot find an execution for taval on the righthand
side of the second assignment
lemma "(''y'' ::= Plus (V ''x'') (Rc 3), s(''x'' := Iv 7, ''y'' := Iv 7)) \<rightarrow>
(SKIP, s(''x'' := Iv 7, ''y'' := Rc 10))"
*)

subsection "The Type System"

datatype ty = Ity | Rty

type_synonym tyenv = "vname \<Rightarrow> ty"

inductive atyping :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty \<Rightarrow> bool"
  ("(1_/ \<turnstile>/ (_ :/ _))" [50,0,50] 50)
where
Ic_ty: "\<Gamma> \<turnstile> Ic i : Ity" |
Rc_ty: "\<Gamma> \<turnstile> Rc r : Rty" |
V_ty: "\<Gamma> \<turnstile> V x : \<Gamma> x" |
Plus_ty: "\<Gamma> \<turnstile> a1 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> a2 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> Plus a1 a2 : \<tau>"

declare atyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> V x : \<tau>" "\<Gamma> \<turnstile> Ic i : \<tau>" "\<Gamma> \<turnstile> Rc r : \<tau>" "\<Gamma> \<turnstile> Plus a1 a2 : \<tau>"

inductive btyping :: "tyenv \<Rightarrow> bexp \<Rightarrow> bool" (infix "\<turnstile>" 50)
where
B_ty: "\<Gamma> \<turnstile> Bc v" |
Not_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> Not b" |
And_ty: "\<Gamma> \<turnstile> b1 \<Longrightarrow> \<Gamma> \<turnstile> b2 \<Longrightarrow> \<Gamma> \<turnstile> And b1 b2" |
Less_ty: "\<Gamma> \<turnstile> a1 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> a2 : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> Less a1 a2"

declare btyping.intros [intro!]
inductive_cases [elim!]: "\<Gamma> \<turnstile> Not b" "\<Gamma> \<turnstile> And b1 b2" "\<Gamma> \<turnstile> Less a1 a2"

text\<open>Warning: the ``:'' notation leads to syntactic ambiguities,
i.e. multiple parse trees, because ``:'' also stands for set membership.
In most situations Isabelle's type system will reject all but one parse tree,
but will still inform you of the potential ambiguity.\<close>

inductive ctyping :: "tyenv \<Rightarrow> com \<Rightarrow> bool" (infix "\<turnstile>" 50) where
Skip_ty: "\<Gamma> \<turnstile> SKIP" |
Assign_ty: "\<Gamma> \<turnstile> a : \<Gamma>(x) \<Longrightarrow> \<Gamma> \<turnstile> x ::= a" |
Seq_ty: "\<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> c1;;c2" |
If_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c1 \<Longrightarrow> \<Gamma> \<turnstile> c2 \<Longrightarrow> \<Gamma> \<turnstile> IF b THEN c1 ELSE c2" |
While_ty: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> WHILE b DO c"

declare ctyping.intros [intro!]
inductive_cases [elim!]:
  "\<Gamma> \<turnstile> x ::= a"  "\<Gamma> \<turnstile> c1;;c2"
  "\<Gamma> \<turnstile> IF b THEN c1 ELSE c2"
  "\<Gamma> \<turnstile> WHILE b DO c"

value "\<Gamma> ''y'' = Ity \<Longrightarrow>  \<Gamma> ''x'' = Ity  \<Longrightarrow> (\<Gamma> \<turnstile> ''x'' ::= V ''y'';; ''y'' ::= Plus (V ''x'') (V''y''))"

subsection "Well-typed Programs Do Not Get Stuck"

fun type :: "val \<Rightarrow> ty" where
"type (Iv i) = Ity" |
"type (Rv r) = Rty"

lemma type_eq_Ity[simp]: "type v = Ity \<longleftrightarrow> (\<exists>i. v = Iv i)"
by (cases v) simp_all

lemma type_eq_Rty[simp]: "type v = Rty \<longleftrightarrow> (\<exists>r. v = Rv r)"
by (cases v) simp_all

definition styping :: "tyenv \<Rightarrow> state \<Rightarrow> bool" (infix "\<turnstile>" 50)
  where "\<Gamma> \<turnstile> s  \<longleftrightarrow>  (\<forall>x. type (s x) = \<Gamma> x)"

(* Lemma 9.2 (Preservation for arithmetic expressions). *)
lemma apreservation:
  "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> taval a s v \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> type v = \<tau>"
apply(induction arbitrary: v rule: atyping.induct)
     apply (fastforce simp: styping_def)+
  done

(* Lemma 9.3 (Progress for arithmetic expressions). *)
lemma aprogress: "\<Gamma> \<turnstile> a : \<tau> \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. taval a s v"
proof(induction rule: atyping.induct)
case (Ic_ty \<Gamma> i)
  then show ?case
    using taval.intros(1) by auto
next
case (Rc_ty \<Gamma> r)
  then show ?case
    using taval.intros(2) by auto
next
  case (V_ty \<Gamma> x)
  then show ?case
    using taval.intros(3) by auto
next
case (Plus_ty \<Gamma> a1 \<tau> a2)
  then show ?case
    by (metis apreservation taval.intros(4) taval.intros(5) ty.distinct(1) type.elims)
qed

(* Lemma 9.4 (Progress for boolean expressions). *)
lemma bprogress: "\<Gamma> \<turnstile> b \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<exists>v. tbval b s v"
proof(induction rule: btyping.induct)
case (B_ty \<Gamma> v)
  then show ?case
    using tbval.intros(1) by blast
next
case (Not_ty \<Gamma> b)
  then show ?case
    using tbval.intros(2) by blast
next
  case (And_ty \<Gamma> b1 b2)
  then show ?case
    using tbval.intros(3) by blast
next
  case (Less_ty \<Gamma> a1 \<tau> a2)
  then obtain v1 v2 where v: "taval a1 s v1" "taval a2 s v2"
    using aprogress by blast
  show ?case
  proof (cases v1)
    case (Iv x1)
    then show ?thesis
      (* by (fastforce intro!: tbval.intros(4) dest!:apreservation) *)
      by (metis Less_ty.hyps(1) Less_ty.hyps(2) Less_ty.prems \<open>\<And>thesis. (\<And>v1 v2. \<lbrakk>taval a1 s v1; taval a2 s v2\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> apreservation tbval.intros(4) tbval.intros(5) ty.distinct(1) type.elims)
  next
    case (Rv x2)
    then show ?thesis
      (* by (fastforce intro!: tbval.intros(5) dest!:apreservation) *)
      by (metis Less_ty.hyps(1) Less_ty.hyps(2) Less_ty.prems \<open>\<And>thesis. (\<And>v1 v2. \<lbrakk>taval a1 s v1; taval a2 s v2\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> apreservation tbval.intros(4) tbval.intros(5) ty.distinct(1) type.elims)
  qed
qed

(* Theorem 9.5 (Preservation: commands stay well-typed). *)
theorem ctyping_preservation:"(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile>c'"
  apply(induction rule: small_step_induct)
       apply (simp add: Skip_ty)
  by blast+
(*proof (induction rule:small_step_induct)
  case (Assign a s v x)
  then show ?case
    by (simp add: Skip_ty)
next
  case (Seq1 c s)
  then show ?case
    by blast
next
  case (Seq2 c1 s c1' s' c2)
  then show ?case
    by blast
next
  case (IfTrue b s c1 c2)
  then show ?case by blast
next
  case (IfFalse b s c1 c2)
  then show ?case by blast
next
  case (While b c s)
  then show ?case by blast
qed*)

(* Theorem 9.6 (Preservation: states stay well-typed). *)
theorem styping_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> \<Gamma> \<turnstile> s'"
proof(induction rule: small_step_induct)
case (Assign a s v x)
  then show ?case
    using apreservation styping_def by fastforce
next
case (Seq1 c s)
  then show ?case
    by simp
next
  case (Seq2 c1 s c1' s' c2)
  then show ?case
    by blast
next
case (IfTrue b s c1 c2)
  then show ?case
    by simp
next
  case (IfFalse b s c1 c2)
  then show ?case
    by blast
next
  case (While b c s)
  then show ?case
    by simp
qed

(* Theorem 9.7 (Progress for commands). *)
theorem progress:
  "\<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists>cs'. (c,s) \<rightarrow> cs'"
proof(induction rule: ctyping.induct)
case (Skip_ty \<Gamma>)
  then show ?case
    by simp
next
case (Assign_ty \<Gamma> a x)
  then show ?case
    using Assign aprogress by blast
next
  case (Seq_ty \<Gamma> c1 c2)
  then show ?case
    by (metis Seq1 Seq2 old.prod.exhaust)
next
  case (If_ty \<Gamma> b c1 c2)
  then obtain vb where v: "tbval b s vb"
    using bprogress by blast
  show ?case
  proof(cases vb)
    case True
    then show ?thesis
      using IfTrue v by fastforce
  next
    case False
    then show ?thesis
      using IfFalse v by fastforce
  qed
next
  case (While_ty \<Gamma> b c)
  then show ?case
    using While by blast
qed

abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

(* Theorem 9.8 (Type soundness). *)
theorem type_sound:
  "(c,s) \<rightarrow>* (c',s') \<Longrightarrow> \<Gamma> \<turnstile> c \<Longrightarrow> \<Gamma> \<turnstile> s \<Longrightarrow> c' \<noteq> SKIP
   \<Longrightarrow> \<exists>cs''. (c',s') \<rightarrow> cs''"
  apply(induction rule:star_induct)
  using progress apply blast
  using ctyping_preservation styping_preservation by blast

subsection "excercises"

subsubsection "Exercise 9.1."
fun atype :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty option"
where
"atype \<Gamma> (Ic i) = Some Ity" |
"atype \<Gamma> (Rc r) = Some Rty" |
"atype \<Gamma> (V x) = Some (\<Gamma> x)" |
"atype \<Gamma> (Plus a1 a2) = (if (atype \<Gamma> a1) = (atype \<Gamma> a2) then atype \<Gamma> a1 else None)"

fun bok :: "tyenv \<Rightarrow> bexp \<Rightarrow> bool"
where
"bok \<Gamma> (Bc v) = True" |
"bok \<Gamma> (Not b) = bok \<Gamma> b" |
"bok \<Gamma> (And b1 b2) = (bok \<Gamma> b1 \<and> bok \<Gamma> b2)" |
"bok \<Gamma> (Less a1 a2) = (if atype \<Gamma> a1 = atype \<Gamma> a2 then (\<exists> a. atype \<Gamma> a1 = Some a) else False) "

fun cok :: "tyenv \<Rightarrow> com \<Rightarrow> bool"  where
"cok \<Gamma> SKIP = True" |
"cok \<Gamma> (x ::= a) = (atype \<Gamma> a = Some (\<Gamma> x))" |
"cok \<Gamma> (c1;;c2) = (cok \<Gamma> c1 \<and> cok \<Gamma> c2) " |
"cok \<Gamma> (IF b THEN c1 ELSE c2) = (bok \<Gamma> b \<and> cok \<Gamma> c1 \<and> cok \<Gamma> c2)" |
"cok \<Gamma> (WHILE b DO c) = (bok \<Gamma> b \<and> cok \<Gamma> c)"

lemma atyping_to_atype: "(\<Gamma> \<turnstile> a: t) = (atype \<Gamma> a = Some t)"
  apply(induction a)
     apply(auto)
  done

lemma btyping_to_bok: "(\<Gamma> \<turnstile> b) = bok \<Gamma> b"
  apply(induction b)
  apply(auto simp add: atyping_to_atype)
  done

lemma "(\<Gamma> \<turnstile> c) = cok \<Gamma> c"
  apply(induction c)
      apply(auto simp add: atyping_to_atype btyping_to_bok)
  done

(* Exercise 9.2. *)

(* Exercise 9.3 *)

end


section \<open>Kleene Lattice Modules and Cylindric Lattice Modules\<close>

text \<open>Using this mathematical component requires downloading the Archive of Formal Proofs.\<close>

theory CKL_Module
  imports CKL

begin

text \<open>This component shows that the semidirect product of a Kleene lattice and a
lattice with a least element forms a weak Kleene lattice. It also shows that the semidirect product
of a liberation Kleene lattice and a lattice with a least element forms a weak liberation Kleene lattice.
This is useful for establishing properties of relational fault models.\<close>

locale l_monoid_module =
  fixes act :: "'a::l_monoid \<Rightarrow> 'b::bounded_lattice_bot \<Rightarrow> 'b" ("\<alpha>")
  assumes m1: "\<alpha> (x \<cdot> y) p = \<alpha> x (\<alpha> y p)"
  and m2: "\<alpha> (x + y) p = \<alpha> x p \<squnion> \<alpha> y p"
  and m3: "\<alpha> x (p \<squnion> q) = \<alpha> x p \<squnion> \<alpha> x q"
  and m4 [simp]: "\<alpha> 1 p = p"
  and m5 [simp]: "\<alpha> 0 p = \<bottom>"

begin

lemma act_zero [simp]: "\<alpha> x \<bottom> = \<bottom>"
  by (metis annir m1 m5)

end

locale kleene_lattice_module = l_monoid_module \<alpha> for \<alpha> +
  assumes m6: "p \<squnion> \<alpha> (x::'a::kleene_lattice) q \<le> q \<Longrightarrow> \<alpha> (x\<^sup>\<star>) p \<le> q"

locale cylindric_kleene_lattice_module = cylindric_kleene_lattice cyl + kleene_lattice_module \<alpha> for cyl \<alpha> +
  constrains cyl :: "'a \<Rightarrow> 'b::kleene_lattice \<Rightarrow> 'b"
  and \<alpha> :: "'b \<Rightarrow> 'c::bounded_lattice_bot \<Rightarrow> 'c"

locale liberation_kleene_lattice_module = liberation_kleene_lattice lib + kleene_lattice_module \<alpha> for lib \<alpha> +
  constrains lib :: "'a \<Rightarrow> 'b::kleene_lattice"
  and \<alpha> :: "'b \<Rightarrow> 'c::bounded_lattice_bot \<Rightarrow> 'c"

definition "plus_prod (x::'a::l_monoid \<times> 'b::bounded_lattice_bot) y = (fst x + fst y,snd x \<squnion> snd y)"

definition "meet_prod (x::'a::l_monoid \<times> 'b::bounded_lattice_bot) y = (fst x \<sqinter> fst y, snd x \<sqinter> snd y)"

definition "zero_prod = (0,\<bottom>)"

definition "one_prod = (1,\<bottom>)"

definition  "le_prod x y = (fst x \<le> fst y \<and> snd x \<le> snd y)"

context l_monoid_module
begin

lemma plus_prod_assoc: "plus_prod x (plus_prod y z) = plus_prod (plus_prod x y) z"
  unfolding plus_prod_def by (simp add: join.sup_assoc sup_assoc)

lemma plus_prod_comm: "plus_prod x y = plus_prod y x"
  unfolding plus_prod_def by (simp add: inf_sup_aci(5) join.sup.commute)

lemma plus_prod_idem [simp]: "plus_prod x x = x"
  unfolding plus_prod_def by simp

lemma meet_prod_assoc: "meet_prod x (meet_prod y z) = meet_prod (meet_prod x y) z"
  unfolding meet_prod_def by (simp add: inf.assoc)

lemma meet_prod_comm: "meet_prod x y = meet_prod y x"
  unfolding meet_prod_def by (simp add: inf_commute)

lemma meet_prod_idem [simp]: "meet_prod x x = x"
  by (simp add: meet_prod_def)

lemma plus_meet_prod_absorp1 [simp]: "plus_prod x (meet_prod x y) = x"
  unfolding plus_prod_def meet_prod_def by simp

lemma plus_meet_prod_absorp2 [simp]: "meet_prod x (plus_prod x y) = x"
  unfolding plus_prod_def meet_prod_def by simp

lemma zero_prod_least1 [simp]: "plus_prod x zero_prod = x"
  unfolding plus_prod_def zero_prod_def by simp

lemma zero_prod_least2 [simp]: "meet_prod x zero_prod = zero_prod"
  unfolding meet_prod_def zero_prod_def by simp

definition "sd_prod x y = (fst x \<cdot> fst y, snd x \<squnion> \<alpha> (fst x) (snd y))"

lemma sd_prod_assoc: "sd_prod x (sd_prod y z) = sd_prod (sd_prod x y) z"
  unfolding sd_prod_def
  by (smt fstI l_monoid_module.m3 l_monoid_module_axioms m1 mult.assoc sndI sup.commute sup.left_commute)

lemma sd_prod_onel [simp]: "sd_prod one_prod x = x"
  unfolding sd_prod_def one_prod_def by simp

lemma sd_prod_oner [simp]: "sd_prod x one_prod = x"
  unfolding sd_prod_def one_prod_def by simp

lemma sd_prod_zerol [simp]: "sd_prod zero_prod x = zero_prod"
  unfolding sd_prod_def zero_prod_def by simp

lemma "sd_prod x zero_prod = zero_prod"
  (*nitpick*)
  oops

lemma sd_prod_distl: "sd_prod x (plus_prod y z) = plus_prod (sd_prod x y) (sd_prod x z)"
  unfolding sd_prod_def plus_prod_def by (simp add: distrib_left m3 sup_assoc sup_left_commute)

lemma sd_prod_distr: "sd_prod (plus_prod x y) z = plus_prod (sd_prod x z) (sd_prod y z)"
  unfolding sd_prod_def plus_prod_def by (simp add: m2 sup_assoc sup_left_commute)

end

context kleene_lattice_module
begin

definition "star_prod x = ((fst x)\<^sup>\<star>, \<alpha> ((fst x)\<^sup>\<star>) (snd x))"

lemma star_prod_unfoldl: "plus_prod one_prod (sd_prod x (star_prod x)) = star_prod x"
  unfolding star_prod_def plus_prod_def sd_prod_def one_prod_def
  by (metis (no_types, lifting) fst_conv inf_sup_aci(5) l_monoid_module.m4 l_monoid_module_axioms m1 m2 snd_conv star_unfoldl_eq sup_bot.right_neutral)

lemma star_prod_unfoldr: "star_prod x = plus_prod one_prod (sd_prod (star_prod x) x)"
  unfolding star_prod_def plus_prod_def sd_prod_def one_prod_def
  by simp

lemma star_prod_inductl: "le_prod (sd_prod x y) y \<Longrightarrow> le_prod (sd_prod (star_prod x) y) y"
  unfolding le_prod_def sd_prod_def star_prod_def
  using m6 by auto

lemma star_prod_inductr: "le_prod (sd_prod y x) y \<Longrightarrow> le_prod (sd_prod y (star_prod x)) y"
  unfolding le_prod_def sd_prod_def star_prod_def
  by (metis (no_types, lifting) conway.dagger_plus_one distrib_left fst_conv join.sup.orderE m1 mult.right_neutral snd_conv star_inductr_var_equiv)

end

context cylindric_kleene_lattice_module
begin

definition "cyl_prod i x = (cyl i (fst x), \<alpha> (cyl i 1) (snd x))"

lemma cyl_prod_prop: "cyl i (fst x) = cyl i 1 \<cdot> (fst x) \<cdot> cyl i 1 \<Longrightarrow> cyl_prod i x = sd_prod (cyl i 1, \<bottom>) (sd_prod x (cyl i 1, \<bottom>))"
  unfolding cyl_prod_def sd_prod_def by (simp add: mult.assoc)

end

context liberation_kleene_lattice_module
begin

lemma l1_prod: "sd_prod (lib i, \<bottom>) zero_prod = zero_prod"
  unfolding sd_prod_def zero_prod_def by simp

lemma l2_prod: "le_prod one_prod (lib i, \<bottom>::'c::bounded_lattice_bot)"
  unfolding le_prod_def one_prod_def by (simp add: l2)

lemma l3_prod:
  assumes "\<alpha> (lib i) (p \<sqinter> \<alpha> (lib i) q) = \<alpha> (lib i) p \<sqinter> \<alpha> (lib i) q"
  shows "sd_prod (lib i,\<bottom>) (meet_prod (x,p) (sd_prod (lib i,\<bottom>) (y,q))) = meet_prod (sd_prod (lib i,\<bottom>) (x,p)) (sd_prod (lib i,\<bottom>) (y,q))"
  unfolding sd_prod_def meet_prod_def by (simp add: assms l3)

lemma l4_prod: "sd_prod (meet_prod (x,p) (sd_prod (y,q) (lib i,\<bottom>))) (lib i,\<bottom>) = meet_prod (sd_prod (x,p) (lib i,\<bottom>)) (sd_prod (y,q) (lib i,\<bottom>))"
  unfolding sd_prod_def meet_prod_def by (simp add: l4)

lemma l5_prod: "sd_prod (lib i,\<bottom>) (lib j,\<bottom>) = sd_prod (lib j,\<bottom>) (lib i,\<bottom>)"
  unfolding sd_prod_def by (simp add: l5)

lemma l6_prod: "i \<noteq> i \<Longrightarrow> meet_prod (lib i,\<bottom>) (lib j,\<bottom>) = one_prod"
  unfolding meet_prod_def one_prod_def by simp

lemma l7_prod: "sd_prod (lib (i::'a),\<bottom>) (meet_prod (lib j,\<bottom>) (lib k,\<bottom>)) = meet_prod (sd_prod (lib i,\<bottom>) (lib j,\<bottom>)) (sd_prod (lib i,\<bottom>) (lib k,\<bottom>))"
  unfolding sd_prod_def meet_prod_def by (simp add: l7)

lemma l8_prod: "sd_prod (meet_prod (lib i,\<bottom>) (lib j,\<bottom>)) (lib k,\<bottom>) = meet_prod (sd_prod (lib i,\<bottom>) (lib k,\<bottom>)) (sd_prod (lib j,\<bottom>) (lib k,\<bottom>))"
  unfolding sd_prod_def meet_prod_def by (simp add: l8)

end

end


(*
  File: Cardinal.thy
  Author: Bohua Zhan

  Results about cardinals. Based on OrderType and Cardinal in Isabelle/ZF.
*)

theory Cardinal
  imports Finite WellOrder
begin

section \<open>Least ordinal satisfying a property\<close>

(* Least ordinal satisfying property P. *)
definition least_ord :: "(i \<Rightarrow> o) \<Rightarrow> i"  (binder "\<mu> " 10) where [rewrite]:
  "(\<mu> i. P(i)) = (THE i. ord(i) \<and> P(i) \<and> (\<forall>j\<in>i. \<not>P(j)))"

(* Show the definition of least_ord make sense. *)
lemma least_ord_eq [backward]:
  "P(i) \<Longrightarrow> ord(i) \<Longrightarrow> \<forall>x\<in>i. \<not>P(x) \<Longrightarrow> (\<mu> i. P(i)) = i"
@proof
  @have "\<forall>j. P(j) \<longrightarrow> ord(j) \<longrightarrow> (\<forall>y\<in>j. \<not>P(y)) \<longrightarrow> j = i" @with
    @have (@rule) "i \<in> j \<or> i = j \<or> j \<in> i"
  @end
@qed

definition le_ord :: "i \<Rightarrow> i \<Rightarrow> o"  (infix "\<le>\<^sub>O" 50) where [rewrite]:
  "i \<le>\<^sub>O j \<longleftrightarrow> (i \<in> j \<or> i = j)"

lemma least_ord_le [backward]:
  "P(i) \<Longrightarrow> ord(i) \<Longrightarrow> (\<mu> i. P(i)) \<le>\<^sub>O i"
@proof
  @induct "ord(i)" "P(i) \<longrightarrow> (\<mu> i. P(i)) \<le>\<^sub>O i"
@qed

lemma least_ord_prop:
  "ord(i) \<Longrightarrow> P(i) \<Longrightarrow> P(\<mu> i. P(i))"
@proof
  @induct "ord(i)" "\<not>P(i) \<or> P(\<mu> i. P(i))" @with
    @subgoal "\<not>P(x) \<or> P(\<mu> i. P(i))"
      @contradiction
      @have "(\<mu> i. P(i)) = x"
    @endgoal
  @end
@qed
setup {* add_forward_prfstep_cond @{thm least_ord_prop} [with_term "\<mu> i. ?P(i)"] *}

lemma ord_least_is_ord [backward]:
  "\<exists>i. ord(i) \<and> P(i) \<Longrightarrow> ord(\<mu> i. P(i))"
@proof
  @obtain i where "ord(i)" "P(i)"
  @have "(\<mu> i. P(i)) \<le>\<^sub>O i"
@qed

section \<open>Order type and order map\<close>

(* In this section, we construct an ordinal from any well-ordering on a set. *)

definition Tup_image :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "Tup_image(f,S) = {f`x. x \<in> S}"

(* Order map: given a well-founded relation r, and an element x in source(r),
   construct the ordinal corresponding to x. This is simply the collection
   of ordermap(r,y), where y < x under r.
*)
definition ordermap :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "ordermap(r,x) = wfrec(r, \<lambda>x f. Tup_image(f,ord_pred(r,x)), x)"

lemma ordermap_eq [rewrite]:
  "wf(r) \<Longrightarrow> x \<in>. r \<Longrightarrow> ordermap(r,x) = {ordermap(r,y). y \<in> ord_pred(r,x)}" by auto2
setup {* del_prfstep_thm @{thm ordermap_def} *}

lemma ord_ordermap:
  "wf(r) \<Longrightarrow> trans(r) \<Longrightarrow> x \<in>. r \<Longrightarrow> ord(ordermap(r,x))" by auto2
setup {* add_forward_prfstep_cond @{thm ord_ordermap} [with_term "ordermap(?r,?x)"] *}

(* The image of ordermap. *)
definition ordertype :: "i \<Rightarrow> i" where [rewrite]:
  "ordertype(r) = {ordermap(r,x). x \<in>. r}"

lemma ord_ordertype [forward]:
  "wf(r) \<Longrightarrow> trans(r) \<Longrightarrow> ord(ordertype(r))" by auto2

definition ordermap_fun :: "i \<Rightarrow> i" where [rewrite]:
  "ordermap_fun(r) = Fun(carrier(r),ordertype(r), \<lambda>x. ordermap(r,x))"

lemma ordermap_fun_type [typing]:
  "ordermap_fun(r) \<in> carrier(r) \<rightarrow> ordertype(r)" by auto2

lemma ordermap_fun_eval [rewrite]:
  "x \<in> source(ordermap_fun(r)) \<Longrightarrow> ordermap_fun(r)`x = ordermap(r,x)" by auto2
setup {* del_prfstep_thm @{thm ordermap_fun_def} *}

lemma ordermap_inj [forward]:
  "well_order(r) \<Longrightarrow> injective(ordermap_fun(r))"
@proof
  @let "f = ordermap_fun(r)"
  @have "\<forall>x\<in>.r. \<forall>y\<in>.r. x \<noteq> y \<longrightarrow> f`x \<noteq> f`y" @with
    @case "x \<le>\<^sub>r y" @with
      @have "ordermap(r,x) \<in> ordermap(r,y)"
    @end
    @case "y \<le>\<^sub>r x" @with
      @have "ordermap(r,y) \<in> ordermap(r,x)"
    @end
  @end
@qed

lemma ordermap_bij [forward]:
  "well_order(r) \<Longrightarrow> bijective(ordermap_fun(r))"
  by auto2

section \<open>Cardinals\<close>

definition cardinal :: "i \<Rightarrow> i" where [rewrite]:
  "cardinal(A) = (\<mu> i. i \<approx>\<^sub>S A)"

definition card :: "i \<Rightarrow> o" where [rewrite]:
  "card(i) \<longleftrightarrow> (i = cardinal(i))"

section \<open>Basic properties of cardinals\<close>

(* Without assuming axiom of choice *)
lemma cardinal_equipotent_gen [resolve]:
  "well_order(r) \<Longrightarrow> A = carrier(r) \<Longrightarrow> A \<approx>\<^sub>S cardinal(A)"
@proof
  @let "i = ordertype(r)"
  @have "A \<approx>\<^sub>S i" @with
    @have "ordermap_fun(r) \<in> A \<cong> ordertype(r)"
  @end
@qed

lemma card_is_ordinal_gen:
  "well_order(r) \<Longrightarrow> A = carrier(r) \<Longrightarrow> ord(cardinal(A))"
@proof
  @let "i = ordertype(r)"
  @have "A \<approx>\<^sub>S i" @with
    @have "ordermap_fun(r) \<in> A \<cong> ordertype(r)"
  @end
@qed
setup {* add_forward_prfstep_cond @{thm card_is_ordinal_gen} [with_term "cardinal(?A)"] *}

lemma cardinal_cong_gen [resolve]:
  "well_order(r) \<Longrightarrow> well_order(s) \<Longrightarrow> A = carrier(r) \<Longrightarrow> B = carrier(s) \<Longrightarrow>
   A \<approx>\<^sub>S B \<Longrightarrow> cardinal(A) = cardinal(B)"
@proof
  @have "A \<approx>\<^sub>S cardinal(A)"
  @have "B \<approx>\<^sub>S cardinal(B)"
  @have "cardinal(A) \<le>\<^sub>O cardinal(B)"
  @have "cardinal(B) \<le>\<^sub>O cardinal(A)"
@qed

(* With axiom of choice. Will make this assumption from now on. *)
lemma cardinal_equipotent [resolve]:
  "A \<approx>\<^sub>S cardinal(A)"
@proof
  @obtain "R\<in>raworder_space(A)" where "well_order(R)"
@qed

lemma card_is_ordinal [forward]:
  "ord(cardinal(A))"
@proof
  @obtain "R\<in>raworder_space(A)" where "well_order(R)"
@qed

lemma cardinal_from_cong [resolve]:
  "A \<approx>\<^sub>S B \<Longrightarrow> cardinal(A) = cardinal(B)"
@proof
  @obtain "R\<in>raworder_space(A)" where "well_order(R)"
  @obtain "S\<in>raworder_space(B)" where "well_order(S)"
@qed

lemma card_is_cardinal [forward]:
  "card(cardinal(A))"
@proof @have "A \<approx>\<^sub>S cardinal(A)" @qed

lemma cardinal_to_cong [resolve]:
  "cardinal(A) = cardinal(B) \<Longrightarrow> A \<approx>\<^sub>S B"
@proof
  @have "A \<approx>\<^sub>S cardinal(A)"
  @have "B \<approx>\<^sub>S cardinal(B)"
@qed

section \<open>Two successor function for cardinals\<close>

definition pow_cardinal :: "i \<Rightarrow> i" where [rewrite]:
  "pow_cardinal(K) = cardinal(Pow(K))"

lemma pow_cardinal_is_cardinal [forward]:
  "card(pow_cardinal(K))" by auto2

lemma pow_cardinal_equipotent [resolve]:
  "Pow(K) \<approx>\<^sub>S pow_cardinal(K)" by auto2

lemma cantor_non_equipotent [resolve]:
  "\<not> K \<approx>\<^sub>S Pow(K)"
@proof
  @contradiction
  @obtain f where "f \<in> K \<cong> Pow(K)"
  @let "S = {x \<in> K. x \<notin> f`x}"
  @have "\<forall>x\<in>K. f`x \<noteq> S" @with @case "x \<in> f`x" @end
@qed

lemma cantor_non_lepotent [resolve]:
  "\<not> Pow(K) \<lesssim>\<^sub>S K"
@proof @have "K \<lesssim>\<^sub>S Pow(K)" @qed

lemma pow_cardinal_less [resolve]:
  "card(K) \<Longrightarrow> K \<in> pow_cardinal(K)"
@proof
  @let "L = pow_cardinal(K)"
  @have "Pow(K) \<approx>\<^sub>S L"
  @have (@rule) "K \<in> L \<or> K = L \<or> L \<in> K"
  @case "L \<in> K" @with @have "L \<lesssim>\<^sub>S K" @end
@qed

(* Assume K is a cardinal in this definition *)
definition succ_cardinal :: "i \<Rightarrow> i" where [rewrite]:
  "succ_cardinal(K) = (\<mu> L. card(L) \<and> K \<in> L)"

lemma succ_cardinal_is_cardinal:
  "card(K) \<Longrightarrow> card(succ_cardinal(K)) \<and> K \<in> succ_cardinal(K)"
@proof
  @let "P = pow_cardinal(K)"
  @have "card(P) \<and> K \<in> P"
@qed
setup {* add_forward_prfstep (conj_left_th @{thm succ_cardinal_is_cardinal}) *}
setup {* add_resolve_prfstep (conj_right_th @{thm succ_cardinal_is_cardinal}) *}

lemma succ_cardinal_ineq [backward]:
  "card(K) \<Longrightarrow> succ_cardinal(K) \<le>\<^sub>O pow_cardinal(K)"
@proof
  @let "P = pow_cardinal(K)"
  @have "card(P) \<and> K \<in> P"
@qed

section \<open>Transfinite induction on ordinals\<close>

(* Given G a meta-function taking the family of values less than an ordinal i
   to the value at i, return the value at i. *)
definition trans_seq :: "(i \<Rightarrow> i) \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "trans_seq(G,a) = wfrec(mem_rel(succ(a)), \<lambda>_ f. G(f), a)"

lemma trans_seq_eq1 [backward]:
  "ord(b) \<Longrightarrow> a \<in> b \<Longrightarrow> i \<in> a \<Longrightarrow> wfrec(mem_rel(b),H,i) = wfrec(mem_rel(a),H,i)"
@proof
  @let "r = mem_rel(a)" "s = mem_rel(b)"
  @induct "ord(i)" "i \<in> a \<longrightarrow> wfrec(s,H,i) = wfrec(r,H,i)" @with
    @subgoal "wfrec(s, H, x) = wfrec(r, H, x)"
      @have (@rule) "\<forall>p1 p2. p1 = p2 \<longrightarrow> H(x,p1) = H(x,p2)"
      @have "wfrec(s,H,x) = H(x, Tup(x, \<lambda>x. wfrec(s,H,x)))"
      @have "wfrec(r,H,x) = H(x, Tup(x, \<lambda>x. wfrec(r,H,x)))"
      @have "Tup(x, \<lambda>x. wfrec(s,H,x)) = Tup(x, \<lambda>x. wfrec(r,H,x))"
    @endgoal
  @end
@qed

lemma not_limit_ordinal_eq [backward1]:
  "ord(a) \<Longrightarrow> \<emptyset> \<in> a \<Longrightarrow> \<not>limit_ord(a) \<Longrightarrow> \<exists>b. a = succ(b)"
@proof
  @obtain b where "b \<in> a" "succ(b) \<notin> a"
  @have (@rule) "a \<in> succ(b) \<or> a = succ(b) \<or> succ(b) \<in> a"
@qed

lemma empty_ord [resolve]: "ord(\<emptyset>)" by auto2

lemma nonzero_ordinal [resolve]: "ord(a) \<Longrightarrow> x \<in> a \<Longrightarrow> \<emptyset> \<in> a"
@proof @have "ord(\<emptyset>)" @have (@rule) "\<emptyset> \<in> x \<or> \<emptyset> = x \<or> x \<in> \<emptyset>" @qed

lemma ord_mem_succ [backward]: "ord(a) \<Longrightarrow> i \<in> a \<Longrightarrow> succ(i) \<in> succ(a)"
@proof
  @case "limit_ord(a)"
  @obtain b where "a = succ(b)"
  @induct "ord(a)" "(\<forall>x. x \<in> a \<longrightarrow> succ(x) \<in> succ(a))" @with
    @subgoal "succ(x) \<in> succ(xa)"  (* Direction is just wrong *)
      @case "limit_ord(x)"
      @obtain y where "x = succ(y)"
      @have "xa \<in> succ(y)"
      @have (@rule) "xa = y \<or> xa \<in> y"
      @case "xa = y"
    @endgoal
  @end
@qed

lemma trans_seq_unfold [rewrite]:
  "ord(a) \<Longrightarrow> trans_seq(G,a) = G(Tup(a, \<lambda>x. trans_seq(G,x)))"
@proof
  @let "r = mem_rel(succ(a))"
  @have (@rule) "\<forall>p1 p2. p1 = p2 \<longrightarrow> G(p1) = G(p2)"
  @have "trans_seq(G,a) = G(Tup(a, \<lambda>x. wfrec(r, \<lambda>_ f. G(f), x)))"
  @have "\<forall>x\<in>a. trans_seq(G,x) = wfrec(r, \<lambda>_ f. G(f), x)" @with
    @have "trans_seq(G,x) = wfrec(mem_rel(succ(x)), \<lambda>_ f. G(f), x)"
    @have "wfrec(r, \<lambda>_ f. G(f), x) = wfrec(mem_rel(succ(x)), \<lambda>_ f. G(f), x)"
  @end
@qed

setup {* del_prfstep_thm @{thm trans_seq_def} *}

definition pred :: "i \<Rightarrow> i" where [rewrite]:
  "pred(x) = (THE y. x = succ(y))"
setup {* register_wellform_data ("pred(x)", ["\<not>limit_ord(x)", "\<emptyset> \<in> x"]) *}

lemma pred_eq [rewrite]:
  "ord(x) \<Longrightarrow> \<not>limit_ord(x) \<Longrightarrow> \<emptyset> \<in> x \<Longrightarrow> succ(pred(x)) = x" by auto2

lemma pred_eq2 [rewrite]:
  "ord(x) \<Longrightarrow> pred(succ(x)) = x" by auto2
setup {* del_prfstep_thm @{thm pred_def} *}

(* Another definition of transfinite induction *)
definition trans_seq2 :: "i \<Rightarrow> (i \<Rightarrow> i) \<Rightarrow> (i \<Rightarrow> i) \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "trans_seq2(g1,G2,G3,a) =
     trans_seq(\<lambda>f. if source(f) = \<emptyset> then g1
                   else if limit_ord(source(f)) then G3(f)
                   else G2(f`pred(source(f))), a)"

lemma trans_seq2_unfold1 [rewrite]:
  "trans_seq2(g1,G2,G3,\<emptyset>) = g1"
@proof @have "ord(\<emptyset>)" @qed

lemma trans_seq2_unfold2 [rewrite]:
  "ord(a) \<Longrightarrow> trans_seq2(g1,G2,G3,succ(a)) = G2(trans_seq2(g1,G2,G3,a))"
@proof
  @have "\<not>limit_ord(succ(a))"
  @have "\<emptyset> \<in> succ(a)"
  @have "pred(succ(a)) = a"
@qed

lemma trans_seq2_unfold3 [rewrite]:
  "limit_ord(a) \<Longrightarrow> trans_seq2(g1,G2,G3,a) = G3(Tup(a, \<lambda>x. trans_seq2(g1,G2,G3,x)))"
@proof @have (@rule) "\<forall>p1 p2. p1 = p2 \<longrightarrow> G3(p1) = G3(p2)" @qed

setup {* del_prfstep_thm @{thm trans_seq2_def} *}

section \<open>Union of cardinals is a cardinal\<close>

lemma card_less [resolve]:
  "card(c) \<Longrightarrow> i \<in> c \<Longrightarrow> \<not>i \<approx>\<^sub>S c"
@proof
  @contradiction
  @have "c \<le>\<^sub>O i"
@qed

lemma union_card [backward]:
  "\<forall>x\<in>S. card(x) \<Longrightarrow> card(\<Union>S)"
@proof
  @have "(\<mu> i. i \<approx>\<^sub>S \<Union>S) = \<Union>S" @with
    @have "\<forall>i\<in>\<Union>S. \<not>i \<approx>\<^sub>S \<Union>S" @with
      @obtain c where "i \<in> c" "c \<in> S"
      @have "\<not>c \<lesssim>\<^sub>S i" @with
        @have "i \<lesssim>\<^sub>S c"
      @end
      @have "c \<lesssim>\<^sub>S \<Union>S" @with
        @have "c \<subseteq> \<Union>S"
      @end
    @end
  @end
@qed

section \<open>Aleph numbers\<close>

definition aleph :: "i \<Rightarrow> i" where [rewrite]:
  "aleph(i) = trans_seq2(\<omega>,succ_cardinal,\<lambda>f. \<Union>(Tup_image(f,source(f))),i)"

lemma aleph_unfold1 [rewrite]:
  "aleph(\<emptyset>) = \<omega>" by auto2

lemma aleph_unfold2 [rewrite]:
  "ord(a) \<Longrightarrow> aleph(succ(a)) = succ_cardinal(aleph(a))" by auto2

lemma aleph_unfold3 [rewrite]:
  "limit_ord(a) \<Longrightarrow> aleph(a) = \<Union>{aleph(c). c \<in> a}" by auto2
setup {* del_prfstep_thm @{thm aleph_def} *}

section \<open>Beth numbers\<close>

definition beth :: "i \<Rightarrow> i" where [rewrite]:
  "beth(i) = trans_seq2(\<omega>,pow_cardinal,\<lambda>f. \<Union>(Tup_image(f,source(f))),i)"

lemma beth_unfold1 [rewrite]:
  "beth(\<emptyset>) = \<omega>" by auto2

lemma beth_unfold2 [rewrite]:
  "ord(a) \<Longrightarrow> beth(succ(a)) = pow_cardinal(beth(a))" by auto2

lemma beth_unfold3 [rewrite]:
  "limit_ord(a) \<Longrightarrow> beth(a) = \<Union>{beth(c). c \<in> a}" by auto2
setup {* del_prfstep_thm @{thm beth_def} *}

section \<open>Natural numbers as cardinals\<close>

lemma nat_cardinal [forward]:
  "card(\<omega>)"
@proof
  @have "(\<mu> i. i \<approx>\<^sub>S \<omega>) = \<omega>"
@qed

section \<open>Aleph and Beth numbers are cardinals\<close>

lemma aleph_cardinal [forward]:
  "ord(a) \<Longrightarrow> card(aleph(a))"
@proof
  @induct "ord(a)" "card(aleph(a))" @with
    @subgoal "card(aleph(x))"
      @case "x = \<emptyset>"
      @case "limit_ord(x)"
      @obtain y where "x = succ(y)"
    @endgoal
  @end
@qed

lemma beth_cardinal [forward]:
  "ord(a) \<Longrightarrow> card(beth(a))"
@proof
  @induct "ord(a)" "card(beth(a))" @with
    @subgoal "card(beth(x))"
      @case "x = \<emptyset>"
      @case "limit_ord(x)"
      @obtain y where "x = succ(y)"
    @endgoal
  @end
@qed

setup {* fold del_prfstep_thm [@{thm trans_set_def}, @{thm cardinal_def}, @{thm card_def}] *}

end


subsection \<open>Masking properties\<close>

theory MachineMasking
  imports RegisterMachineSimulation "../Diophantine/Binary_And"
begin

(* [D] 4.18 *)
definition E :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "(E q b) = (\<Sum>t = 0..q. b^t)"

lemma e_geom_series:
  assumes "b \<ge> 2"
  shows "(E q b = e) \<longleftrightarrow> ((b-1) * e = b^(Suc q) - 1 )" (is "?P \<longleftrightarrow> ?Q")
proof-
  have "sum ((^) (int b)) {..<Suc q} = sum ((^) b) {0..q}" by (simp add: atLeast0AtMost lessThan_Suc_atMost)
  then have "(int b - 1) *  (E q b) = int b ^ Suc q - 1"
    using E_def by (metis power_diff_1_eq)
  moreover have "int b ^ Suc q - 1 =  b ^ (Suc q) - 1" using one_le_power[of "int b" "Suc q"] assms
    by (simp add: of_nat_diff)
  moreover have "int b - 1 = b - 1 " using assms by auto
  ultimately show ?thesis using assms
    by (metis Suc_1 Suc_diff_le Zero_not_Suc diff_Suc_Suc int_ops(7) mult_cancel_left of_nat_eq_iff)
qed

(* [D] 4.16 *)
definition D :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "(D q c b) = (\<Sum>t = 0..q. (2^c - 1) * b^t)"

lemma d_geom_series:
  assumes "b = 2^(Suc c)"
  shows "(D q c b = d) \<longleftrightarrow> ((b-1) * d = (2^c - 1) * (b^(Suc q) - 1))" (is "?P \<longleftrightarrow> ?Q")
proof-
  have "D q c b = (2^c - 1) *  E q b" by (auto simp: E_def D_def sum_distrib_left sum_distrib_right)
  moreover have "b \<ge> 2" using assms by fastforce
  ultimately show ?thesis by (smt e_geom_series mult.left_commute mult_cancel_left)
qed

(* [D] 4.21 *)
definition F :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "(F q c b) = (\<Sum>t = 0..q. 2^c * b^t)"

lemma f_geom_series:
  assumes "b = 2^(Suc c)"
  shows "(F q c b = f) \<longleftrightarrow> ( (b-1) * f = 2^c * (b^(Suc q) - 1) )"
proof-
  have "F q c b = 2^c *  E q b" by (auto simp: E_def F_def sum_distrib_left sum_distrib_right)
  moreover have "b \<ge> 2" using assms by fastforce
  ultimately show ?thesis by (smt e_geom_series mult.left_commute mult_cancel_left)
qed

(* AUX LEMMAS *)
lemma aux_lt_implies_mask:
  assumes "a < 2^k"
  shows "\<forall>r\<ge>k. a \<exclamdown> r = 0"
  using nth_bit_def assms apply auto
proof - (* found by e *)
  fix r :: nat
  assume a1: "a < 2 ^ k"
  assume a2: "k \<le> r"
  from a1 have "a div 2 ^ k = 0"
    by simp
  then have "2 = (0::nat) \<or> a < 2 ^ r"
    using a2 by (metis (no_types) div_le_mono nat_zero_less_power_iff neq0_conv not_le power_diff)
  then show "a div 2 ^ r mod 2 = 0"
    by simp
qed

lemma lt_implies_mask:
  fixes a b :: nat
  assumes "\<exists>k. a < 2^k \<and> (\<forall>r<k. nth_bit b r = 1)" (* this means a < b and b = xx11..11 *)
  shows "a \<preceq> b"
proof -
  obtain k where assms: "a < 2^k \<and> (\<forall>r<k. nth_bit b r = 1)" using assms by auto
  have k1: "\<forall>r<k. a \<exclamdown> r \<le> b \<exclamdown> r" using nth_bit_bounded
    by (simp add: \<open>a < 2 ^ k \<and> (\<forall>r<k. b \<exclamdown> r = 1)\<close>)
  hence k2: "\<forall>r\<ge>k. a \<exclamdown> r = 0" using aux_lt_implies_mask assms by auto
  show ?thesis using masks_leq_equiv
    by auto (metis k1 k2 le0 not_less)
qed

lemma mask_conversed_shift:
  fixes a b k :: nat
  assumes asm: "a \<preceq> b"
  shows "a * 2^k \<preceq> b * 2^k"
proof -
  have shift: "x \<preceq> y \<Longrightarrow> 2*x \<preceq> 2*y" for x y by (induction x; auto)
  have "a * 2 ^ k \<preceq> b * 2 ^ k \<Longrightarrow> 2 * (a * 2 ^ k) \<preceq> 2 * (b * 2 ^ k)" for k
    using shift[of "a*2^k" "b*2^k"] by auto
  thus ?thesis by (induction k; auto simp: asm shift algebra_simps)
qed

lemma base_summation_bound:
  fixes c q :: nat
    and f :: "(nat \<Rightarrow> nat)"

defines b: "b \<equiv> B c"
assumes bound: "\<forall>t. f t < 2 ^ Suc c - (1::nat)"

shows "(\<Sum>t = 0..q. f t * b^t) < b^(Suc q)"
proof (induction q)
  case 0
  then show ?case using B_def b bound less_imp_diff_less not_less_eq
    by auto blast
next
  case (Suc q)
  have "(\<Sum>t = 0..Suc q. f t * b ^ t) = f (Suc q) * b ^ (Suc q) + (\<Sum>t = 0..q. f t * b ^ t)"
    by (auto cong: sum.cong)
  also have "... < (f (Suc q) + 1) * b ^ (Suc q)"
    using Suc.IH by auto
  also have "... < b * b ^ (Suc q)"
    by (metis bound b less_diff_conv B_def mult_less_cancel2 zero_less_numeral zero_less_power)
  finally show ?case by auto
qed

lemma mask_conserved_sum:
  fixes y c q :: nat
    and x :: "(nat \<Rightarrow> nat)"

defines b: "b \<equiv> B c"
assumes mask: "\<forall>t. x t \<preceq> y"
assumes xlt: "\<forall>t. x t \<le> 2 ^ c - Suc 0"
assumes ylt: "y \<le> 2 ^ c - Suc 0"

shows "(\<Sum>t = 0..q. x t * b^t) \<preceq> (\<Sum>t = 0..q. y * b^t)"
proof (induction q)
  case 0
  then show ?case
    using mask by auto
next
  case (Suc q)

  have xb: "\<forall>t. x t < 2^Suc c - Suc 0"
    using xlt
    by (smt Suc_pred leI le_imp_less_Suc less_SucE less_trans n_less_m_mult_n numeral_2_eq_2
        power.simps(2) zero_less_numeral zero_less_power)
  have yb: "y < 2^c"
    using ylt b B_def leI order_trans by fastforce

  have sumxlt: "(\<Sum>t = 0..q. x t * b ^ t) < b^(Suc q)"
    using base_summation_bound xb b B_def by auto
  have sumylt: "(\<Sum>t = 0..q. y * b ^ t) < b^(Suc q)"
    using base_summation_bound yb b B_def by auto

  have "((\<Sum>t = 0..Suc q. x t * b ^ t) \<preceq> (\<Sum>t = 0..Suc q. y * b ^ t))
      = (x (Suc q) * b^Suc q + (\<Sum>t = 0..q. x t * b ^ t) \<preceq>
                 y * b^Suc q + (\<Sum>t = 0..q. y * b ^ t))"
    by (auto simp: atLeast0_lessThan_Suc add.commute)
  also have "... = (x (Suc q) * b^Suc q \<preceq> y * b^Suc q)
                 \<and> (\<Sum>t = 0..q. x t * b ^ t) \<preceq> (\<Sum>t = 0..q. y * b ^ t)"
    using mask_linear[where ?t = "Suc c * Suc q"] sumxlt sumylt Suc.IH b B_def
    apply auto
    apply (smt mask mask_conversed_shift power_Suc power_mult power_mult_distrib)
    by (smt mask mask_linear power_Suc power_mult power_mult_distrib)
  finally show ?case using mask_linear Suc.IH B_def
    by (metis (no_types, lifting) b mask mask_conversed_shift power_mult)
qed

lemma aux_powertwo_digits:
  fixes k c :: nat
  assumes "k < c"
  shows "nth_bit (2^c) k = 0"
proof -
  have h: "(2::nat) ^ c div 2 ^ k = 2 ^ (c - k)"
    by (simp add: assms less_imp_le power_diff)
  thus ?thesis
    by (auto simp: h nth_bit_def assms)
qed

lemma obtain_digit_rep:
  fixes x c :: nat
  shows "x && 2^c = (\<Sum>t<Suc c. 2^t * (nth_bit x t) * (nth_bit (2^c) t))"
proof -
  have "x && 2^c \<preceq> 2^c" by (simp add: lm0245)
  hence "x && 2^c \<le> 2^c" by (simp add: masks_leq)
  hence h: "x && 2^c < 2^Suc c"
    by (smt Suc_lessD le_neq_implies_less lessI less_trans_Suc n_less_m_mult_n numeral_2_eq_2
        power_Suc zero_less_power)
  have "\<forall>t. (x && 2^c) \<exclamdown> t = (nth_bit x t) * (nth_bit (2^c) t)"
    using bitAND_digit_mult by auto
  then show ?thesis using h digit_sum_repr[of "(x && 2^c)" "Suc c"]
    by (auto) (simp add: mult.commute semiring_normalization_rules(19))
qed

lemma nth_digit_bitAND_equiv:
  fixes x c :: nat
  shows "2^c * nth_bit x c = (x && 2^c)"
proof -
  have d1: "nth_bit (2^c) c = 1"
    using nth_bit_def by auto

  moreover have "x && 2^c = (2::nat)^c * (x \<exclamdown> c) * (((2::nat)^c) \<exclamdown> c)
            + (\<Sum>t<c. (2::nat)^t * (x \<exclamdown> t) * (((2::nat)^c) \<exclamdown> t))"
    using obtain_digit_rep by (auto cong: sum.cong)

  moreover have "(\<Sum>t<c. 2^t * (nth_bit x t) * (nth_bit ((2::nat)^c) t)) = 0"
    using aux_powertwo_digits by auto

  ultimately show ?thesis using d1
    by auto
qed

lemma bitAND_single_digit:
  fixes x c :: nat
assumes "2 ^ c \<le> x"
assumes "x < 2 ^ Suc c"

shows "nth_bit x c = 1"
proof -
  obtain b where b: "x = 2^c + b"
    using assms(1) le_Suc_ex by auto
  have bb: "b < 2^c"
    using assms(2) b by auto
  have "(2 ^ c + b) div 2 ^ c mod 2 = (1 + b div 2 ^ c) mod 2"
    by (auto simp: div_add_self1)
  also have "... = 1"
    by (auto simp: bb)
  finally show ?thesis
    by (simp only: nth_bit_def b)
qed

lemma aux_bitAND_distrib: "2 * (a && b) = (2 * a) && (2 * b)"
  by (induct a b rule: bitAND_nat.induct; auto)

lemma bitAND_distrib: "2^c * (a && b) = (2^c * a) && (2^c * b)"
proof (induction c)
  case 0
  then show ?case by auto
next
  case (Suc c)
  have "2 ^ Suc c * (a && b) = 2 * (2 ^ c * (a && b))" by auto
  also have "... = 2 * ((2^c * a) && (2^c * b))" using Suc.IH by auto
  also have "... = ((2^Suc c * a) && (2^Suc c * b))"
    using aux_bitAND_distrib[of "2^c * a" "2^c * b"]
    by (auto simp add: ab_semigroup_mult_class.mult_ac(1))
  finally show ?case by auto
qed

lemma bitAND_linear_sum:
  fixes x y :: "nat \<Rightarrow> nat"
    and c :: nat
    and q :: nat

defines b: "b == 2 ^ Suc c"

assumes xb: "\<forall>t. x t < 2 ^ Suc c - 1"
assumes yb: "\<forall>t. y t < 2 ^ Suc c - 1"

shows "(\<Sum>t = 0..q. (x t && y t) * b^t) =
       (\<Sum>t = 0..q. x t * b^t) && (\<Sum>t = 0..q. y t * b^t)"
proof (induction q)
  case 0
  then show ?case
    by (auto simp: b B_def)
next
  case (Suc q)
  have "(\<Sum>t = 0..Suc q. (x t && y t) * b ^ t) = (x (Suc q) && y (Suc q)) * b ^ Suc q
                                               + (\<Sum>t = 0..q. (x t && y t) * b ^ t)"
    by (auto cong: sum.cong)

  moreover have h0: "(x (Suc q) && y (Suc q)) * b ^ Suc q
                   = (x (Suc q) * b^Suc q) && (y (Suc q) * b^Suc q)"
    using b bitAND_distrib by (auto) (smt mult.commute power_Suc power_mult)

  moreover have h1: "(\<Sum>t = 0..q. (x t && y t) * b ^ t)
                   = (\<Sum>t = 0..q. x t * b^t) && (\<Sum>t = 0..q. y t * b^t)"
    using Suc.IH by auto

  ultimately have h2: "(\<Sum>t = 0..Suc q. (x t && y t) * b ^ t)
                = ((x (Suc q) * b^Suc q) && (y (Suc q) * b^Suc q))
                + ((\<Sum>t = 0..q. x t * b^t) && (\<Sum>t = 0..q. y t * b^t))"
    by auto

  have sumxb: "(\<Sum>t = 0..q. x t * b ^ t) < b ^ Suc q"
    using base_summation_bound xb b B_def by auto
  have sumyb: "(\<Sum>t = 0..q. y t * b ^ t) < b ^ Suc q"
    using base_summation_bound yb b B_def by auto

  have h3: "((x (Suc q) * b^Suc q) && (y (Suc q) * b^Suc q))
          + ((\<Sum>t = 0..q. x t * b^t) && (\<Sum>t = 0..q. y t * b^t))
          = ((\<Sum>t = 0..q. x t * b^t) + x (Suc q) * b^Suc q)
         && ((\<Sum>t = 0..q. y t * b^t) + y (Suc q) * b^Suc q)"
    using sumxb sumyb bitAND_linear h2 h0
    by (auto) (smt add.commute b power_Suc power_mult)

  thus ?case using h2 by (auto cong: sum.cong)
qed

lemma dmask_aux0:
  fixes x :: nat
  assumes "x > 0"
  shows "(2 ^ x - Suc 0) div 2 = 2 ^ (x - 1) - Suc 0"
proof -
  have 0: "(2^x - Suc 0) div 2 = (2^x - 2) div 2"
    by (smt Suc_diff_Suc Suc_pred assms dvd_power even_Suc even_Suc_div_two nat_power_eq_Suc_0_iff
            neq0_conv numeral_2_eq_2 zero_less_diff zero_less_power)
    (* can do manual parity distinction *)
  moreover have divides: "(2::nat) dvd 2^x"
    by (simp add: assms dvd_power[of x "2::nat"])
  moreover have "(2^x - 2::nat) div 2 = 2^x div 2 - 2 div 2"
    using div_plus_div_distrib_dvd_left[of "2" "2^x" "2"] divides
    by auto
  moreover have "... = 2 ^ (x - 1) - Suc 0"
    by (simp add: Suc_leI assms power_diff)
  ultimately have 1: "(2 ^ x - Suc 0) div 2 = 2 ^ (x - 1) - Suc 0"
     by (smt One_nat_def)
  thus ?thesis by simp
qed

lemma dmask_aux:
  fixes c :: nat
  shows "d < c \<Longrightarrow> (2^c - Suc 0) div 2^d = 2 ^ (c - d) - Suc 0"
proof (induction d)
  case 0
  then show ?case by (auto)
next
  case (Suc d)
  have d: "d < c" using Suc.prems by auto
  have "(2 ^ c - Suc 0) div 2 ^ Suc d = (2 ^ c - Suc 0) div 2 ^ d div 2"
    by (auto) (metis mult.commute div_mult2_eq)
  also have "... = (2 ^ (c - d) - Suc 0) div 2"
    by (subst Suc.IH) (auto simp: d)
  also have "... = 2 ^ (c - Suc d) - Suc 0"
    apply (subst dmask_aux0[of "c - d"])
    using d by (auto)
  finally show ?case by auto
qed

(* REGISTERS *)
lemma register_cells_masked:
  fixes l :: register
    and t :: nat
    and ic :: configuration
    and p :: program

assumes cells_bounded: "cells_bounded ic p c"
assumes l: "l < length (snd ic)"

shows "R ic p l t \<preceq> 2^c - 1"
proof -
  have a: "R ic p l t \<le> 2^c - 1" using cells_bounded less_Suc_eq_le
    using l by fastforce
  have b: "r < c \<Longrightarrow> nth_bit (2^c - 1) r = 1" for r
    apply (auto simp: nth_bit_def)
    apply (subst dmask_aux)
    apply (auto)
    by (metis Suc_pred dvd_power even_Suc mod_0_imp_dvd not_mod2_eq_Suc_0_eq_0
              zero_less_diff zero_less_numeral zero_less_power)
  show ?thesis using lt_implies_mask cells_bounded l
    by (auto) (metis One_nat_def b)
qed

lemma lm04_15_register_masking:
  fixes c :: nat
    and l :: register
    and ic :: configuration
    and p :: program
    and q :: nat

defines "b == B c"
defines "d == D q c b"

assumes cells_bounded: "cells_bounded ic p c"
assumes l: "l < length (snd ic)"

defines "r == RLe ic p b q"

shows "r l \<preceq> d"
proof -
  have "\<And>t. R ic p l t \<preceq> 2^c - 1" using cells_bounded l
    by (rule register_cells_masked)
  hence rmasked: "\<forall>t. R ic p l t \<preceq> 2^c - 1"
    by (intro allI)

  have rlt: "\<forall>t. R ic p l t \<le> 2^c - 1"
    using cells_bounded less_Suc_eq_le l by fastforce

  have rlmasked: "(\<Sum>t = 0..q. R ic p l t * b^t) \<preceq> (\<Sum>t = 0..q. (2^c - 1) * b^t)"
    using rmasked rlt b_def B_def mask_conserved_sum by (auto)

  thus ?thesis
    by (auto simp: r_def d_def D_def RLe_def mult.commute cong: sum.cong)
qed

(* ZERO INDICATORS *)
lemma zero_cells_masked:
  fixes l :: register
    and t :: nat
    and ic :: configuration
    and p :: program

assumes l: "l < length (snd ic)"

shows "Z ic p l t \<preceq> 1"
proof -
  have "nth_bit 1 0 = 1" by (auto simp: nth_bit_def)
  thus ?thesis apply (auto) apply (rule lt_implies_mask)
    by (metis (full_types) One_nat_def Suc_1 Z_bounded less_Suc_eq_le less_one power_one_right)
qed

lemma lm04_15_zero_masking:
  fixes c :: nat
    and l :: register
    and ic :: configuration
    and p :: program
    and q :: nat

defines "b == B c"
defines "e == E q b"

assumes cells_bounded: "cells_bounded ic p c"
assumes l: "l < length (snd ic)"
assumes c: "c > 0"

defines "z == ZLe ic p b q"

shows "z l \<preceq> e"
proof -
  have "\<And>t. Z ic p l t \<preceq> 1" using l
    by (rule zero_cells_masked)
  hence zmasked: "\<forall>t. Z ic p l t \<preceq> 1"
    by (intro allI)

  have zlt: "\<forall>t. Z ic p l t \<le> 2 ^ c - 1"
    using cells_bounded less_Suc_eq_le by fastforce

  have 1: "(1::nat) \<le> 2 ^ c - 1" using c
    by (simp add: Nat.le_diff_conv2 numeral_2_eq_2 self_le_power)

  have rlmasked: "(\<Sum>t = 0..q. Z ic p l t * b^t) \<preceq> (\<Sum>t = 0..q. 1 * b^t)"
    using zmasked zlt 1 b_def B_def mask_conserved_sum[of "Z ic p l" 1]
    by (auto)

  thus ?thesis
    by (auto simp: z_def e_def E_def ZLe_def mult.commute cong: sum.cong)
qed

(* Relation between zero indicator and register *)
lemma lm04_19_zero_register_relations:
  fixes c :: nat
    and l :: register
    and t :: nat
    and ic :: configuration
    and p :: program

assumes cells_bounded: "cells_bounded ic p c"
assumes l: "l < length (snd ic)"

defines "z == Z ic p"
defines "r == R ic p"

shows "2^c * z l t = (r l t + 2^c - 1) && 2^c"
proof -
  have a1: "R ic p l t \<noteq> 0 \<Longrightarrow> 2^c \<le> R ic p l t + 2^c - 1"
    by auto
  have a2: "R ic p l t + 2^c - 1 < 2^Suc c" using cells_bounded
    by (simp add: l less_imp_diff_less)

  have "Z ic p l t = nth_bit (R ic p l t + 2^c - 1) c"
    apply (cases "R ic p l t = 0")
    subgoal by (auto simp add: Z_def R_def nth_bit_def)
    subgoal using cells_bounded bitAND_single_digit a1 a2 Z_def
      by auto
    done

  also have "2^c * nth_bit (R ic p l t + 2^c - 1) c = ((R ic p l t + 2^c - 1) && 2^c)"
    using nth_digit_bitAND_equiv by auto

  finally show ?thesis by (auto simp: z_def r_def)
qed

lemma lm04_20_zero_definition:
  fixes c :: nat
    and l :: register
    and ic :: configuration
    and p :: program
    and q :: nat

defines "b == B c"
defines "f == F q c b"
defines "d == D q c b"

assumes cells_bounded: "cells_bounded ic p c"
assumes l: "l < length (snd ic)"

assumes c: "c > 0"

defines "z == ZLe ic p b q"
defines "r == RLe ic p b q"

shows "2^c * z l = (r l + d) && f"
proof -
  have "\<And>t. 2^c * Z ic p l t = (R ic p l t + 2^c - 1) && 2^c"
    by (rule lm04_19_zero_register_relations cells_bounded l) +
  hence raw_sums: "(\<Sum>t = 0..q. 2^c * Z ic p l t * b^t)
                 = (\<Sum>t = 0..q. ((R ic p l t + 2^c - 1) && 2^c) * b^t)"
    by auto

  have "(\<Sum>t = 0..q. 2^c * Z ic p l t * b^t) = 2^c * (\<Sum>t = 0..q. Z ic p l t * b^t)"
    by (auto simp: sum_distrib_left mult.assoc cong: sum.cong)
  also have "... = 2^c * z l"
    by (auto simp: z_def ZLe_def mult.commute)
  finally have lhs: "(\<Sum>t = 0..q. 2^c * Z ic p l t * b^t) = 2^c * z l"
    by auto

  have "(\<Sum>t = 0..q. (R ic p l t + (2^c - 1)) * b^t)
      = (\<Sum>t = 0..q. R ic p l t * b^t + (2^c - 1) * b^t)"
    apply (rule sum.cong)
    apply (auto simp: add.commute mult.commute)
    subgoal for x using distrib_left[of "b^x" "R ic p l x" "2^c - 1"] by (auto simp: algebra_simps)
    done
  also have "... = (\<Sum>t = 0..q. (R ic p l t * b^t)) + (\<Sum>t = 0..q. (2^c - 1) * b^t)"
    by (rule sum.distrib)
  also have "... = r l + d"
    by (auto simp: r_def RLe_def d_def D_def mult.commute)
  finally have split_sums: "(\<Sum>t = 0..q. (R ic p l t + (2^c - 1)) * b^t) = r l + d"
    by auto

  have a1: "(2::nat) ^ c < (2::nat) ^ Suc c - 1" using c by (induct c, auto, fastforce)
  have a2: "\<forall>t. R ic p l t + 2 ^ c - 1 \<le> 2 ^ Suc c" using cells_bounded B_def
    by (simp add: less_imp_diff_less l) (simp add: Suc_leD l less_imp_le_nat numeral_Bit0)
  have "(\<Sum>t = 0..q. ((R ic p l t + 2^c - 1) && 2^c) * b^t)
      = (\<Sum>t = 0..q. (R ic p l t + 2^c - 1) * b^t) && (\<Sum>t = 0..q. 2^c * b^t)"
    using bitAND_linear_sum[of "\<lambda>t. R ic p l t + 2^c - 1" "c" "\<lambda>t. 2^c"]
          cells_bounded b_def B_def a1 a2
    apply auto
    by (smt One_nat_def Suc_less_eq Suc_pred a1 add.commute add_gr_0 l mult_2
        nat_add_left_cancel_less power_Suc zero_less_numeral zero_less_power)
  also have "... = (\<Sum>t = 0..q. (R ic p l t + 2^c - 1) * b^t) && f"
    by (auto simp: f_def F_def)
  also have "... = (r l + d) && f" using split_sums
    by auto
  finally have rhs: "(\<Sum>t = 0..q. ((R ic p l t + 2^c - 1) && 2^c) * b^t) = (r l + d) && f"
    by auto

  show ?thesis using raw_sums lhs rhs
    by auto
qed

lemma state_mask:
fixes c :: nat
  and l :: register
  and ic :: configuration
  and p :: program
  and q :: nat
  and a :: nat

defines "b \<equiv> B c"
    and "m \<equiv> length p - 1"

defines "e \<equiv> E q b"

assumes is_val: "is_valid_initial ic p a"
    and q: "q > 0"
    and "c > 0"

assumes terminate: "terminates ic p q"
  shows "SKe ic p b q k \<preceq> e"
proof -
  have "1 \<le> 2 ^ c - Suc 0" using \<open>c>0\<close> by (metis One_nat_def Suc_leI one_less_numeral_iff
                                           one_less_power semiring_norm(76) zero_less_diff)
  have Smask: "S ic p k t \<preceq> 1" for t by (simp add: S_def)
  have Sbound: "S ic p k t \<le> 2 ^ c - Suc 0" for t using \<open>1\<le>2^c-Suc 0\<close> by (simp add: S_def)
  have rlmasked: "(\<Sum>t = 0..q. S ic p k t * b^t) \<preceq> (\<Sum>t = 0..q. 1 * b^t)"
    using b_def B_def Smask Sbound mask_conserved_sum[of "S ic p k" 1] \<open>1 \<le> 2^c-Suc 0\<close> by auto

  thus ?thesis using SKe_def e_def E_def by (auto simp: mult.commute)
qed

lemma state_sum_mask:
fixes c :: nat
  and l :: register
  and ic :: configuration
  and p :: program
  and q :: nat
  and a :: nat

defines "b \<equiv> B c"
    and "m \<equiv> length p - 1"

defines "e \<equiv> E q b"

assumes is_val: "is_valid_initial ic p a"
    and q: "q > 0"
    and "c > 0"
    and "b > 1"

assumes "M\<le>m"

assumes terminate: "terminates ic p q"
shows "(\<Sum>k\<le>M. SKe ic p b q k) \<preceq> e"
proof -
  have e_aux: "nth_digit e t b = (if t\<le>q then 1 else 0)" for t
    unfolding e_def E_def b_def B_def
    using `b>1` b_def nth_digit_gen_power_series[of "\<lambda>k. Suc 0" "c" "q"]
    by (auto simp: b_def B_def)

  have state_unique: "\<forall>k\<le>m. S ic p k t = 1 \<longrightarrow> (\<forall>j\<noteq>k. S ic p j t = 0)" for t
    using S_def by (induction t, auto)

  have h1: "\<forall>t. nth_digit (\<Sum>k\<le>M. SKe ic p b q k) t b \<le> (if t\<le>q then 1 else 0)"
  proof - {
      fix t
      have aux_bound_1: "(\<Sum>k\<le>M. S ic p k t') \<le> 1" for t'
      proof (cases "\<exists>k\<le>M. S ic p k t' = 1")
        case True
        then obtain k where k: "k\<le>M \<and> S ic p k t' = 1" by auto
        moreover have "\<forall>j\<le>M. j \<noteq> k \<longrightarrow> S ic p j t' = 0"
          using state_unique `M<=m` k S_def
          by (auto) (presburger)
        ultimately have "(\<Sum>k\<le>M. S ic p k t') = 1"
          using S_def by auto
        then show ?thesis
          by auto
      next
        case False
        then show ?thesis using S_bounded
          by (auto) (metis (no_types, lifting) S_def atMost_iff eq_imp_le le_SucI sum_nonpos)
      qed
      hence aux_bound_2: "\<And>t'. (\<Sum>k\<le>M. S ic p k t') < 2^c"
        by (metis Suc_1 `c>0` le_less_trans less_Suc_eq one_less_power)

      have h2: "(\<Sum>k\<le>M. SKe ic p b q k) = (\<Sum>t = 0..q. \<Sum>k\<le>M. b ^ t * S ic p k t)"
        unfolding SKe_def using sum.swap by auto
      hence "(\<Sum>k\<le>M. SKe ic p b q k) = (\<Sum>t = 0..q. b^t * (\<Sum>k\<le>M. S ic p k t))"
        unfolding SKe_def by (simp add: sum_distrib_left)

      hence "nth_digit (\<Sum>k\<le>M. SKe ic p b q k) t b = (if t\<le>q then (\<Sum>k\<le>M. S ic p k t) else 0)"
        using `c>0` aux_bound_2 h2 unfolding SKe_def
        using nth_digit_gen_power_series[of "\<lambda>t. (\<Sum>k\<le>M. S ic p k t)" "c" "q" "t"]
        by (smt B_def Groups.mult_ac(2) assms(7) aux_bound_1 b_def le_less_trans sum.cong)
      hence "nth_digit (\<Sum>k\<le>M. SKe ic p b q k) t b \<le> (if t\<le>q then 1 else 0)"
        using aux_bound_1 by auto
    } thus ?thesis by auto
  qed
  moreover have "\<forall>t>q. nth_digit (\<Sum>k\<le>M. SKe ic p b q k) t b = 0"
    by (metis (full_types) h1 le_0_eq not_less)
  ultimately have "\<forall>t. \<forall>i<Suc c. nth_digit (\<Sum>k\<le>M. SKe ic p b q k) t b \<exclamdown> i
                          \<le> nth_digit e t b \<exclamdown> i"
    using aux_lt_implies_mask linorder_neqE_nat e_aux
    by (smt One_nat_def le_0_eq le_SucE less_or_eq_imp_le nat_zero_less_power_iff
            numeral_2_eq_2 zero_less_Suc)

  hence "\<forall>t. \<forall>i<Suc c. (\<Sum>k\<le>M. SKe ic p b q k) \<exclamdown> (Suc c * t + i) \<le> e \<exclamdown> (Suc c * t + i)"
    using digit_gen_pow2_reduct[where ?c = "Suc c" and ?a = "(\<Sum>k\<le>M. SKe ic p b q k)"]
    using digit_gen_pow2_reduct[where ?c = "Suc c" and ?a = e]
    by (simp add: b_def B_def)
  moreover have "\<forall>j. \<exists>t i. i < Suc c \<and> j = (Suc c * t + i)"
    using mod_less_divisor zero_less_Suc
    by (metis add.commute mod_mult_div_eq)
  ultimately have "\<forall>j. (\<Sum>k\<le>M. SKe ic p b q k) \<exclamdown> j \<le> e \<exclamdown> j"
    by metis

  thus ?thesis
    using masks_leq_equiv by auto
qed

end


(*  Author: Tobias Nipkow, Dmitriy Traytel *)

header {* Some Tests *}

(*<*)
theory Examples
imports Regex_Equivalence
begin
(*>*)

section {* Examples *}

(*<*)
text{* Test: B(n) = (One + a + aa + · · · + a^n-1 ) (a^n)^* = a^* (see Asperti) *}
(*>*)

fun pow where
  "pow 0 = One"
| "pow (Suc 0) = Atom True"
| "pow (Suc n) = Times (Atom True) (pow n)"

fun pow_left where
  "pow_left 0 = One"
| "pow_left (Suc 0) = Atom True"
| "pow_left (Suc n) = Times (pow_left n) (Atom True)"

fun Sum where
  "Sum f 0 = f 0"
| "Sum f (Suc n) = Plus (f (Suc n)) (Sum f n)"

definition "B n = (Times (Sum pow (n - 1)) (Star (pow n)), Star (Atom True))"
definition "B_left n = (Times (Sum pow_left (n - 1)) (Star (pow_left n)), Star (Atom True))"

definition "seq_left n r = foldr (\<lambda>r s. Times s r) (replicate n r) One"
definition "seq n r = foldr Times (replicate n r) One"
definition "re_left n = Times (seq_left n (Plus (Atom True) One)) (seq_left n (Atom True))"
definition "re n = Times (seq n (Plus (Atom True) One)) (seq n (Atom True))"
definition "M n = (re_left n, replicate n True)"

lemma "split match_brz (M 128)" by eval
lemma "split match_brzq (M 128)" by eval
lemma "split match_n (M 64)" by eval
lemma "split match_p (M 64)" by eval
lemma "split match_pn (M 64)" by eval
lemma "split match_a (M 512)" by eval
lemma "split match_b (M 512)" by eval
lemma "split match_a2 (M 2048)" by eval
lemma "split match_b2 (M 2048)" by eval

lemma "split check_eqv_brz (B 32)" by eval
lemma "split check_eqv_brzq (B 16)" by eval
lemma "split check_eqv_n (B 256)" by eval
lemma "split check_eqv_p (B 256)" by eval
lemma "split check_eqv_b (B 256)" by eval
lemma "split check_eqv_a (B 256)" by eval
lemma "split check_eqv_b2 (B 256)" by eval
lemma "split check_eqv_a2 (B 256)" by eval

(*<*)
end
(*>*)


theory cancel_at_props
imports Main  "HOL-Library.FuncSet" "HOL-Algebra.Group" "HOL-Proofs-Lambda.Commutation"
begin

datatype ('a,'b) monoidgentype = C 'a  'b (infix "!" 63)

datatype ('a,'b) groupgentype = P "('a,'b) monoidgentype"
                               | N  "('a,'b) monoidgentype"

type_synonym ('a,'b) word = "(('a,'b) groupgentype) list"

primrec inverse::"('a,'b) groupgentype \<Rightarrow> ('a,'b) groupgentype"
  where
"inverse (P x) = (N x)"
|"inverse (N x) = (P x)"

primrec wordinverse::"('a,'b) word \<Rightarrow> ('a, 'b) word"
  where
"wordinverse [] = []"
|"wordinverse (x#xs) =  (wordinverse xs)@[inverse x]"

inductive_set spanset::"('a,'b) word set\<Rightarrow> ('a,'b) word set" ("\<langle>_\<rangle>")
  for S::"('a,'b) word set"
  where
"x \<in> S \<Longrightarrow> x \<in> \<langle>S\<rangle>"
|"x \<in> inver ` S \<Longrightarrow> x \<in> \<langle>S\<rangle>"
|"x \<in> S \<Longrightarrow> y \<in> \<langle>S\<rangle>\<Longrightarrow> x@y \<in> \<langle>S\<rangle>"
|"x \<in> inver ` S \<Longrightarrow> ys \<in> \<langle>S\<rangle> \<Longrightarrow> x@ys \<in> \<langle>S\<rangle>"

definition setlistcross::"'a set \<Rightarrow> 'a list \<Rightarrow> 'a list set"
 where
"setlistcross S xs = {[s]@xs | s. s \<in> S}"

value "setlistcross {(1::nat), 2, 3} [(4::nat), 5, 6]"

primrec lengthword::"nat \<Rightarrow> 'a set \<Rightarrow> 'a list set"
  where
"lengthword 0 S = {[s] | s. s \<in> S}"
|"lengthword (Suc n) S = \<Union> {setlistcross S xs | xs. xs \<in> (lengthword n S)}"

abbreviation "ngroupword \<equiv> \<lambda> n (S::('a,'b) word set). lengthword n (S \<union> (wordinverse ` S))"

datatype char = G | H

value "ngroupword 1 {[P (C G (1::nat))], [N (C G (2::nat))], [P (C H (3::nat))]}"

(*reduction removes cancellations next to each other*)
fun reduction:: "('a,'b) word \<Rightarrow> ('a,'b) word"
 where
"reduction [] = []"
|"reduction [x] = [x]"
|"reduction (g1#g2#wrd) = (if (g1 = inverse g2)
                             then reduction wrd
                             else (g1#(reduction (g2#wrd))))"

value "reduction [P (C G (3::nat)), N (C G (3::nat)), (N (C G (2::nat)))]"

fun reduced::"('a,'b) word \<Rightarrow> bool"
  where
"reduced [] = True"
|"reduced [g] = True"
|"reduced (g#h#wrd) = (if (g \<noteq> inverse h) then reduced (h#wrd) else False)"

primrec iter::"nat \<Rightarrow>('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
  where
"iter 0 f = (\<lambda> x. x)"
|"iter (Suc n) f = (\<lambda> x. f ((iter n f) x))"

(*Prove the following*)
lemma fixedpt_iteration:
  assumes "f x = x"
  shows "iter (n+1) f x = x"
  using assms
proof(induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case by simp
qed

lemma iterative_fixed_pt:
  assumes "iter (n+1) f x = iter n f x"
  shows "iter (k+(n+1)) f x = iter (k+n) f x"
  using assms
proof(induction k)
  case 0
  then show ?case
    by force
next
  case (Suc m)
  have "iter (m + (n + 1)) f x = iter (Suc m + n) f x" by simp
  then show ?case using Suc.IH Suc.prems by fastforce
qed

(*prove converse of the following too*)
lemma assumes "reduced wrd"
  shows "reduction wrd = wrd"
  using assms
proof(induction wrd rule: reduction.induct)
  case 1
  then show ?case by simp
next
  case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
      then show ?thesis using 3
        by force
    next
    case False
    have "reduced (g2#wrd)" using False 3 by force
      then show ?thesis using False 3 by force
    qed
qed

lemma length_reduction:
 "length (reduction wrd) \<le> length wrd"
proof(induction wrd rule: reduction.induct)
case 1
  then show ?case by simp
next
case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
    then show ?thesis using 3 by force
  next
    case False
    then show ?thesis using 3
    by auto
 qed
qed

lemma decreasing_length:
  assumes "reduction wrd \<noteq> wrd"
  shows "length (reduction wrd) < length wrd"
  using assms
proof(induction wrd rule: reduction.induct)
case 1
  then show ?case by simp
next
  case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
    then have red_inv:"reduction (g1#g2#wrd) = reduction wrd" by auto
    then show ?thesis
    proof(cases "reduction wrd = wrd")
      case True
      then have "reduction (g1#g2#wrd) = wrd" using red_inv by auto
      then have "length (reduction (g1#g2#wrd)) = length wrd" by auto
      then show ?thesis
        by simp
    next
      case False
      then have "length (reduction wrd) < length wrd" using 3 True by argo
      then show ?thesis using red_inv by force
    qed
  next
    case False
    have prem:"reduction (g1#g2#wrd) \<noteq> (g1#g2#wrd)" using 3 by argo
    then have "reduction (g1#g2#wrd) = g1#reduction (g2#wrd)" using False by auto
    then have "reduction (g2#wrd) \<noteq> g2#wrd" using prem by fastforce
    then have "length (g2#wrd) > length (reduction (g2#wrd))" using 3 False by blast
    then have "length (g1#g2#wrd) > length (reduction (g1#g2#wrd))" using False by force
    then show ?thesis by fast
  qed
qed

lemma if_length_reduction_eq:
  assumes "length (reduction (wrd)) = length wrd"
  shows "reduction wrd = wrd"
  using assms
proof(induction wrd rule: reduction.induct)
case 1
  then show ?case
    by simp
next
  case (2 x)
  then show ?case by simp
next
case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
    then have "reduction (g1#g2#wrd) = reduction (wrd)" by simp
    then have "length (reduction (g1#g2#wrd)) = length (reduction (wrd))" by auto
    moreover have "length (wrd) > length (reduction wrd)" using 3 by (metis \<open>reduction (g1 # g2 # wrd) = reduction wrd\<close> decreasing_length impossible_Cons le_cases)
    then show ?thesis using 3 by auto
  next
    case False
    then show ?thesis using "3.prems" decreasing_length nat_neq_iff by blast
  qed
qed

lemma reduction_fixpt:
  assumes "reduction wrd = wrd"
  shows "reduced wrd"
  using assms
proof(induction wrd rule:reduction.induct)
case 1
then show ?case by simp
next
case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case by (metis decreasing_length impossible_Cons length_Cons less_Suc_eq less_or_eq_imp_le list.inject reduced.simps(3) reduction.simps(3))
qed

(*Show that length decreases if and only the word after reduction is not the same as the original word*)

(*show that if after reduction of a word it does not change, that subsequent reductions will be ineffective*)

(*use the word length argument decrement argument to show that the reduced word is finally reduced*)

value "reduced  [P (C G (1::nat)), N (C G (2::nat)), P (C G (1::nat))]"

inductive reln::"('a,'b) word \<Rightarrow> ('a,'b) word \<Rightarrow> bool" (infixr "~" 65)
  where
refl[intro!]: "a ~ a" |
sym: "a ~ b \<Longrightarrow> b ~ a" |
trans: "a ~ b \<Longrightarrow> b ~ c \<Longrightarrow> a ~ c" |
base: "[g, inverse g] ~ []" |
mult: "xs ~ xs' \<Longrightarrow> ys ~ ys' \<Longrightarrow> (xs@ys) ~ (xs'@ys')"

lemma assumes "h = inverse g"
  shows "[g, h] ~ []"
  using assms reln.base inverse.simps by simp

lemma relation: "(xs@ys) ~ xs@[g,inverse g]@ys"
  using reln.base reln.refl reln.mult
proof-
  have "(xs@[g, inverse g]) ~ xs" using reln.base reln.mult reln.refl by fastforce
  then show ?thesis using mult[of "xs@[g, inverse g]" "xs" "ys" "ys"] reln.refl reln.sym
    by auto
qed

lemma inverse_of_inverse:
  assumes "g = inverse h"
  shows "h = inverse g"
  using assms inverse.simps
  by (metis groupgentype.exhaust)

lemma rel_to_reduction:"xs ~ reduction xs"
proof(induction xs rule:reduction.induct )
  case 1
  then show ?case
    using reln.refl by auto
next
  case (2 x)
  then show ?case using reln.refl by auto
next
  case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
    have "[g1,  g2] ~ []" using reln.base[of "g1"] inverse_of_inverse[of "g1" "g2"] True
      by blast
    then have 1:"([g1,g2]@wrd) ~ wrd" using reln.mult refl by fastforce
    with 3(1) have 2:"reduction ([g1,g2]@wrd) ~ wrd" using reln.trans True
      using append_Cons append_Nil reduction.simps(3) reln.sym by auto
    then show ?thesis using 1 reln.sym reln.trans
      by (metis append_Cons append_Nil)
next
  case False
  then have "([g1]@(g2#wrd)) ~ ([g1]@(reduction (g2#wrd)))" using 3(2) reln.mult reln.refl
    by blast
  then have "([g1]@(g2#wrd)) ~ (reduction (g1#g2#wrd))" using False by simp
  then show ?thesis by simp
qed
qed

definition wordeq::"('a,'b) word \<Rightarrow> ('a,'b) word set" ("[[_]]")
  where
"wordeq wrd = {wrds. wrd ~ wrds}"

(*This is approach for normal form using newsmans lemma*)

definition cancel_at :: "nat \<Rightarrow> ('a,'b) word \<Rightarrow> ('a,'b) word"
  where "cancel_at i l = take i l @ drop (2+i) l"

lemma cancel_at_leftappend:
  assumes "i\<ge>0" "(1+i) < length a" "cancel_at i a = b"
  shows "cancel_at (length c + i) (c@a) = (c@b)"
proof-
  have "c@(take i a) = take (length c + i) (c@a)" using assms(1) assms(2) by auto
  moreover have "drop (i+2) a = drop (length c + (i+2)) (c@a)"using assms(1) assms(2) by simp
  ultimately show ?thesis unfolding cancel_at_def by (metis add.assoc add.commute append.assoc assms(3) cancel_at_def)
qed

lemma cancel_at_rightappend:
  assumes "i\<ge>0" "(1+i) < length a" "cancel_at i a = b"
  shows "cancel_at i (a@c) = (b@c)"
proof-
  have "take i (a@c) = take i a" using assms(1) assms (2) by simp
  moreover have "(drop (2+i) a)@c = drop (2+i) (a@c)" using assms(1) assms(2) by simp
  ultimately show ?thesis unfolding cancel_at_def by (metis append.assoc assms(3) cancel_at_def)
qed

definition cancels_to_1_at ::  "nat \<Rightarrow> ('a,'b) word \<Rightarrow> ('a,'b) word \<Rightarrow> bool"
where "cancels_to_1_at i l1 l2 = (0\<le>i \<and> (1+i) < length l1
                              \<and> (inverse (l1 ! i) = (l1 ! (1+i)))
                              \<and> (l2 = cancel_at i l1))"

lemma cancels_to_1_at_leftappend:
  assumes "i\<ge>0" "(1+i) < length a" "cancels_to_1_at i a b"
  shows "cancels_to_1_at (length c + i) (c@a) (c@b)"
  unfolding cancels_to_1_at_def
proof-
  have 1:"0 \<le> (length c + i)" using assms(1) by simp
  moreover have 2: "1 + (length c + i) < length (c @ a)" using assms(2) by auto
  have "(inverse (a ! i)) = (a ! (i+1))" using assms(3) by (metis add.commute cancels_to_1_at_def)
  moreover then have 3: "inverse ((c @ a) ! (length c + i)) = (c @ a) ! (1 + (length c + i))" by (metis add.commute add.left_commute nth_append_length_plus)
  have "(b = cancel_at i a)" using assms(3)using cancels_to_1_at_def by auto
  moreover then have 4: "c @ b = cancel_at (length c + i) (c @ a)" using cancel_at_leftappend assms(1) assms(2) by metis
  ultimately show "0 \<le> length c + i \<and>
    1 + (length c + i) < length (c @ a) \<and>
    inverse ((c @ a) ! (length c + i)) = (c @ a) ! (1 + (length c + i)) \<and>
    c @ b = cancel_at (length c + i) (c @ a)" using "2" "3" by blast
qed

lemma cancels_to_1_at_rightappend:
  assumes "i\<ge>0" "(1+i) < length a" "cancels_to_1_at i a b"
  shows "cancels_to_1_at i (a@c) (b@c)"
  unfolding cancels_to_1_at_def
proof-
  have 1:"0 \<le> i" using assms(1) by simp
  moreover have 2: "1 + i < length (a@c)" using assms(2) by auto
  have "(inverse (a ! i)) = (a ! (i+1))" using assms(3) by (metis add.commute cancels_to_1_at_def)
  moreover then have 3: "inverse ((a @ c) ! i) = (a @ c) ! (1 + i)" by (metis Suc_eq_plus1 Suc_lessD add.commute assms(2) nth_append)
  have "(b = cancel_at i a)" using assms(3)using cancels_to_1_at_def by auto
  moreover then have 4: "b@c = cancel_at i (a@c)" using cancel_at_rightappend assms(1) assms(2) by metis
  ultimately show "0 \<le> i \<and>
    1 + i < length (a @ c) \<and> inverse ((a @ c) ! i) = (a @ c) ! (1 + i) \<and> b @ c = cancel_at i (a @ c)" using "2" "3" by blast
qed

definition cancels_to_1 :: "('a,'b) word \<Rightarrow> ('a,'b) word \<Rightarrow> bool"
  where "cancels_to_1 l1 l2 = (\<exists>i. cancels_to_1_at i l1 l2)"

lemma cancels_to_1_leftappend:
  assumes "cancels_to_1 a b"
  shows "cancels_to_1 (c@a) (c@b)"
  using assms
  unfolding cancels_to_1_def
proof-
  obtain i where "cancels_to_1_at i a b" using assms cancels_to_1_def by auto
  then have "i\<ge>0 \<and> (1+i) < length a" using cancels_to_1_at_def by auto
  then have "cancels_to_1_at (length c + i) (c@a) (c@b)" using \<open>cancels_to_1_at i a b\<close> cancels_to_1_at_leftappend by auto
  then show "\<exists>i. cancels_to_1_at i (c @ a) (c @ b)" by auto
qed

lemma cancels_to_1_rightappend:
  assumes "cancels_to_1 a b"
  shows "cancels_to_1 (a@c) (b@c)"
  using assms
  unfolding cancels_to_1_def
proof-
 obtain i where "cancels_to_1_at i a b" using assms cancels_to_1_def by auto
  then have "i\<ge>0 \<and> (1+i) < length a" using cancels_to_1_at_def by auto
  then have "cancels_to_1_at i (a@c) (b@c)" by (simp add: cancels_to_1_at_rightappend \<open>cancels_to_1_at i a b\<close>)
  then show "\<exists>i. cancels_to_1_at i (a @ c) (b @ c)" by auto
qed

definition cancels_to  :: "('a,'b) word \<Rightarrow> ('a,'b) word \<Rightarrow> bool"
  where "cancels_to = (cancels_to_1)^**"

lemma cancels_to_leftappend:
 "cancels_to a b \<longrightarrow> cancels_to (z@a) (z@b)"
  unfolding cancels_to_def
  apply(rule impI)
proof(induction rule:rtranclp.induct)
  case (rtrancl_refl a)
  then show ?case by simp
next
  case (rtrancl_into_rtrancl a b c)
  then have 1:"cancels_to_1 (z@b) (z@c)"by (simp add: cancels_to_1_leftappend)
  have "cancels_to_1\<^sup>*\<^sup>* (z @ a) (z @ b)" by (simp add: rtrancl_into_rtrancl.IH)
  then show "cancels_to_1\<^sup>*\<^sup>* (z @ a) (z @ c)" using 1 by auto
qed

lemma cancels_to_rightappend:
 "cancels_to a b \<longrightarrow> cancels_to (a@z) (b@z)"
  unfolding cancels_to_def
  apply(rule impI)
proof(induction rule:rtranclp.induct)
  case (rtrancl_refl a)
  then show ?case by simp
next
  case (rtrancl_into_rtrancl a b c)
  then have 1:"cancels_to_1 (b@z) (c@z)"by (simp add: cancels_to_1_rightappend)
  have "cancels_to_1\<^sup>*\<^sup>* (a@z) (b@z)" by (simp add: rtrancl_into_rtrancl.IH)
  then show "cancels_to_1\<^sup>*\<^sup>* (a@z) (c@z)" using 1 by auto
qed

lemma "cancels_to x y \<Longrightarrow> x ~ y"
  unfolding cancels_to_def
proof(induction rule: rtranclp.induct)
  case (rtrancl_refl a)
  then show ?case by blast
next
  case (rtrancl_into_rtrancl a b c)
  then have "cancels_to_1 b c" by simp
  then obtain i where i:"cancels_to_1_at i b c" unfolding cancels_to_1_def by meson
  then have c_def:"(take i b)@(drop (i + 2) b) = c" unfolding cancels_to_1_at_def cancel_at_def
    by force
  moreover have "b!i = inverse (b!(i+1))" using i  unfolding cancels_to_1_at_def cancel_at_def
    using inverse_of_inverse
    by (simp add: inverse_of_inverse add.commute)
  then have "[b!i, b!(i+1)] ~ []"
    by (metis base inverse_of_inverse)
  then have "([b!i, b!(i+1)]@(drop (i+2) b)) ~ []@(drop (i+2) b)"
    using reln.refl reln.mult by fast
  then have "((take i b)@(([b!i, b!(i+1)]@(drop (i+2) b)))) ~ (take i b)@(drop (i+2) b)"
    using reln.refl reln.mult
    by (simp add: mult reln.refl)
  then have "b ~ c" using c_def
    by (metis Cons_nth_drop_Suc add.commute add_2_eq_Suc' append_Cons append_self_conv2 cancels_to_1_at_def i id_take_nth_drop linorder_not_less plus_1_eq_Suc trans_le_add2)
  then show ?case using reln.trans rtrancl_into_rtrancl(3) by fast
qed

definition cancels_eq::"('a,'b) word \<Rightarrow> ('a,'b) word \<Rightarrow> bool"
  where
"cancels_eq = (\<lambda> wrd1 wrd2. cancels_to wrd1 wrd2 \<or> cancels_to wrd2 wrd1)^**"

lemma cancels_eq_leftappend:
"cancels_eq a b \<longrightarrow> cancels_eq (z@a) (z@b)"
  unfolding cancels_eq_def
  apply(rule impI)
proof(induction rule:rtranclp.induct)
  case (rtrancl_refl a)
  then show ?case by simp
next
  case (rtrancl_into_rtrancl a b c)
  then have 1: "cancels_to (z@b) (z@c) \<or> cancels_to (z@c) (z@b)" using cancels_to_leftappend by blast
  have "(\<lambda> wrd1 wrd2. cancels_to wrd1 wrd2 \<or> cancels_to wrd2 wrd1)\<^sup>*\<^sup>* (z @ a) (z @ b)" by (simp add: rtrancl_into_rtrancl.IH)
  then show "(\<lambda> wrd1 wrd2. cancels_to wrd1 wrd2 \<or> cancels_to wrd2 wrd1)\<^sup>*\<^sup>* (z @ a) (z @ c)" unfolding cancels_eq_def using 1  by (metis (no_types, lifting) rtranclp.simps)
qed

lemma cancels_eq_rightappend:
"cancels_eq a b \<longrightarrow> cancels_eq (a@z) (b@z)"
  unfolding cancels_eq_def
  apply(rule impI)
proof(induction rule:rtranclp.induct)
case (rtrancl_refl a)
  then show ?case by simp
next
  case (rtrancl_into_rtrancl a b c)
  then have 1: "cancels_to (b@z) (c@z) \<or> cancels_to (c@z) (b@z)" using cancels_to_rightappend by auto
  have "(\<lambda> wrd1 wrd2. cancels_to wrd1 wrd2 \<or> cancels_to wrd2 wrd1)\<^sup>*\<^sup>* (a@z) (b@z)" by (simp add: rtrancl_into_rtrancl.IH)
  then show "(\<lambda> wrd1 wrd2. cancels_to wrd1 wrd2 \<or> cancels_to wrd2 wrd1)\<^sup>*\<^sup>* (a@z) (c@z)" unfolding cancels_eq_def using 1  by (metis (no_types, lifting) rtranclp.simps)
qed

lemma  "x ~ y \<Longrightarrow> cancels_eq x y"
proof(induction rule:reln.induct)
case (refl a)
then show ?case unfolding cancels_eq_def cancels_to_def by simp
next
  case (sym a b)
  then show ?case unfolding cancels_eq_def
    by (metis (no_types, lifting) sympD sympI symp_rtranclp)
next
  case (trans a b c)
  then show ?case by (metis (no_types, lifting) cancels_eq_def rtranclp_trans)
next
  case (base g)
  then have "cancels_to_1_at 0 [g, inverse g] []" unfolding cancels_to_1_at_def cancel_at_def by auto
  then have "cancels_to [g, inverse g] []" unfolding cancels_to_def using cancels_to_1_def by auto
  then show ?case unfolding cancels_eq_def by (simp add: r_into_rtranclp)
next
  case (mult xs xs' ys ys')
  have "cancels_eq xs xs'" by (simp add: mult.IH(1))
  then have 1:"cancels_eq (xs@ys) (xs'@ys)"  by (simp add: cancels_eq_rightappend)
  have "cancels_eq ys ys'"  by (simp add: mult.IH(2))
  then have 2:"cancels_eq (xs'@ys) (xs'@ys')" by (simp add: cancels_eq_leftappend)
  then show "cancels_eq (xs@ys) (xs'@ys')" using 1 2  by (metis (no_types, lifting) cancels_eq_def rtranclp_trans)
qed

lemma cancels_to_iter:
"cancels_to wrd (iter n reduction wrd)"
  unfolding cancels_to_def cancels_to_1_def
proof (induction wrd)
  case Nil
  have "iter n reduction [] = []" sorry
  then show ?case sorry
next
case (Cons a wrd)
then show ?case sorry
qed

lemma reduced_right_append:
  assumes "reduced (xs@ys)"
  shows "reduced xs"
  using assms
proof (induction xs rule : reduction.induct)
case 1
then show ?case try
  by simp
next
  case (2 x)
  then show ?case try
    by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof (cases "g1 =  inverse g2")
    case True
then show ?thesis
  using "3.prems" by force
next
  case False
  have "reduced ((g2 # wrd) @ ys)"
    by (metis "3.prems" append_Cons reduced.simps(3))
  then have "reduced (g2#wrd)"
    using "3.IH"(2) False by auto
  then show ?thesis by (simp add: False)
qed
qed

lemma reduced_append:
  assumes "reduced (ys@xs)"
  shows "reduced xs"
  using assms
  sorry

lemma reduced_no_cancels_to_1_at:
  assumes "reduced xs"
  shows "(\<nexists>i . cancels_to_1_at i xs ys)"
proof(rule ccontr)
  assume assm: "\<not>(\<nexists>i . cancels_to_1_at i xs ys)"
  hence "\<exists>i . cancels_to_1_at i xs ys" by auto
  then obtain i where "cancels_to_1_at i xs ys" by auto
  then have 1:"inverse (xs!i) = (xs!(i+1))" using cancels_to_1_at_def by (simp add: cancels_to_1_at_def)
  have 2: "i + 1 < length xs" by (metis \<open>cancels_to_1_at i xs ys\<close> add.commute cancels_to_1_at_def)
  then have "xs = (take i xs) @ ((xs!i)#(xs!(i+1))#(drop (i+2) xs))" by (metis Cons_nth_drop_Suc Suc_1 Suc_eq_plus1 add_Suc_right add_lessD1 append_take_drop_id)
  then have "reduced ((xs!i)#(xs!(i+1))#(drop (i+2) xs))" using assms reduced_append by metis
  then show "False" using reduced.simps  by (simp add: "1" inverse_of_inverse)
qed

lemma cancels_to_1_red:
  assumes "reduced x"
  shows "\<forall>y. \<not>(cancels_to_1 x y)"
proof(rule ccontr)
  assume assm : "\<not>(\<forall>y. \<not>(cancels_to_1 x y))"
  then have "\<exists>y. cancels_to_1 x y" by simp
  then obtain y where y : "cancels_to_1 x y" by auto
  then have 1: " \<exists>i\<ge>0. cancels_to_1_at i x y"
    unfolding cancels_to_1_def cancels_to_1_at_def by simp
  then have "\<exists>i. inverse (x ! i) = x ! (i + 1)" using cancels_to_1_at_def by auto
  then have "i + 1 < length x" using "1"  assms reduced_no_cancels_to_1_at by blast
  then have "x = (take i x) @ ((x!i)#(x!(i+1))#(drop (i+2) x))" by (metis Cons_nth_drop_Suc Suc_1 Suc_eq_plus1 add_Suc_right add_lessD1 append_take_drop_id)
  then have "reduced ((x!i)#(x!(i+1))#(drop (i+2) x))" by (metis assms reduced_append)
  then have "reduced x = False" using "1" using reduced_no_cancels_to_1_at by auto
  then show "False" using assms by simp
qed

lemma assumes "\<not>(reduced xs)"
  shows  "\<not>(reduced (ys@xs))"
proof-
  have 1: "reduced (ys@xs) \<longrightarrow> reduced xs" using reduced_append by auto
  then show ?thesis using not_mono [OF 1] assms by argo
qed

lemma inv_not_reduced:
  assumes "(i + 1) < length wrd"  "inverse (wrd ! i) = (wrd ! (i + 1))"
  shows "\<not>(reduced wrd)"
  using assms
proof-
  have "inverse (wrd ! i) = wrd ! (i + 1)" using assms by auto
  have "i + 1 < length wrd" using  assms reduced_no_cancels_to_1_at by blast
  then have 1: "wrd = (take i wrd) @ ((wrd ! i)#(wrd !(i + 1))#(drop (i + 2) wrd))" by (metis Cons_nth_drop_Suc Suc_1 Suc_eq_plus1 add_Suc_right add_lessD1 append_take_drop_id)
  then have "\<not>(reduced ((wrd ! i)#(wrd ! (i + 1))#(drop (i + 2) wrd)))" using assms by (metis inverse_of_inverse reduced.simps(3))
  then have "reduced wrd = False" using "1" by (metis reduced_append)
  then show ?thesis using assms by simp
qed

(*proof(induction wrd arbitrary : i)
  case Nil
  then show ?case by simp
next
  case (Cons a wrd)
  then show ?case
  proof (cases "i = 0")
case True
  then have "inverse((a # wrd) ! 0)  = (a # wrd) ! 1" using Cons reduced.simps by simp
    then have "(a # wrd) ! 0 = inverse((a # wrd) ! 1)" using inverse_of_inverse by metis
    then show ?thesis using True by (smt (z3) Cons.prems(1) One_nat_def add_cancel_right_left canonically_ordered_monoid_add_class.lessE diff_Suc_1 less_numeral_extra(1) list.discI list.size(3) list.size(4) nth_Cons_0 nth_Cons_pos plus_1_eq_Suc reduced.elims(2))
next
  case False
  have "i \<ge> 1" using False by linarith
  have "(i + 1) < length (a # wrd)" using  local.Cons(2) by simp
  then have "(i + 1) \<le> length wrd" by simp
  have "inverse ((a # wrd) ! i) = (a # wrd) ! (i + 1)" using local.Cons(3) by auto
  then show ?thesis sorry
qed
*)

lemma takei_cancelatj:
  assumes "i < j"  (*take i (cancel_at j xs) = take i xs*)
  shows  "take i ((take j xs)@(drop (j+2) xs)) = take i xs"
  using assms
proof(induction xs arbitrary: i j)
  case (Cons a xs)
  then show ?case
  proof(cases "i = 0")
    case True
    then show ?thesis by simp
  next
    case False
    hence j:"j > 1" using Cons(2) by arith
    then have "take j (a#xs) = a#(take (j - 1) xs)"
      by (simp add: take_Cons')
    moreover have "drop (j + 2) (a#xs) = drop (j + 1) xs" using j by force
    ultimately have 1:"(take j (a#xs))@(drop (j + 1) xs) = a#(take (j-1) xs)@(drop (j + 1) xs)"
      by simp
    with take_Cons' False
    have 2:"take i  (a#(take (j-1) xs)@(drop (j + 1) xs)) = a#(take (i - 1) ((take (j-1) xs)@(drop (j + 1) xs)))"
      by metis
    then have 3:"... = a#(take (i - 1) xs)" using Cons(1)[of "i-1" "j-1"] Cons(2) by force
    then have 4:"... = (take i (a#xs))" using False
      by (metis take_Cons')
    then show ?thesis
      by (metis "2" "3" Cons_eq_appendI \<open>drop (j + 2) (a # xs) = drop (j + 1) xs\<close> \<open>take j (a # xs) = a # take (j - 1) xs\<close>)
  qed
qed(auto)

lemma cancels_to_reduced :
  assumes "i\<ge>0" "(1+i)<length x" "cancels_to x y"  "cancels_to x z" "reduced y" "reduced z"
  shows "y = z"
  unfolding cancels_to_1_def
proof-
  have "cancels_to_1 \<^sup>*\<^sup>* x y" by (metis assms(3) cancels_to_def)
  moreover have "cancels_to_1 \<^sup>*\<^sup>* x z" by (metis assms(4) cancels_to_def)
  moreover have "\<forall>h. \<not>(cancels_to_1 y h)" using cancels_to_1_red assms (5) by auto
  moreover have "\<forall>h. \<not>(cancels_to_1 z h)" using cancels_to_1_red assms(6) by auto
  ultimately show "y = z"  sorry

qed

lemma "cancels_eq x y \<Longrightarrow> reduced x \<Longrightarrow> reduced y \<Longrightarrow> x = y" sorry

(*  define overlapping where
    "overlapping \<equiv> \<lambda> m (n :: nat). m \<in> {n, n + 1} \<or> n \<in> {m, m + 1}"
*)

lemma novl : assumes "i \<ge> 0" "i + 1 < j" "(1 + j) < length wrd"
  shows "cancel_at (j-2) (cancel_at i wrd) = cancel_at i (cancel_at j wrd)"
proof-
  have "(cancel_at i wrd) = take i wrd @ (drop (2 + i) wrd)" unfolding cancel_at_def by simp
  then show "cancel_at (j-2) (cancel_at i wrd) = cancel_at i (cancel_at j wrd)" sorry
qed

lemma "diamond (λ x y. (cancels_to_1 x y) ∨ x = y)"
  unfolding  diamond_def cancels_to_1_def commute_def square_def
  apply (rule allI, rule allI, rule impI, rule allI, rule impI)
proof-
  fix x y z :: "('a,'b) word"
  assume 1:"(∃i. cancels_to_1_at i x y) ∨ x = y"
  assume 2:"(∃i. cancels_to_1_at i x z) ∨ x = z"
  show "∃u. ((∃i. cancels_to_1_at i y u) ∨ y = u) ∧ ((∃i. cancels_to_1_at i z u) ∨ z = u)"
  proof (cases "x = y ∨ x = z")
  case True
  have "(∃i. cancels_to_1_at i y z) ∨ (∃i. cancels_to_1_at i z y) ∨ z = y" using "1" "2" True by auto
  then show ?thesis by auto
  next
  case False
  then have "x ≠ y" "x ≠ z" by auto
  then show ?thesis
  proof (cases "y = z")
case True
  then show ?thesis by auto
next
  case False
  then have asm1:"(∃i. cancels_to_1_at i x y)" using "1" False  ‹x ≠ y› by auto
  then obtain i where i: "cancels_to_1_at i x y" by auto
  have asm2 :"(∃i. cancels_to_1_at i x z)" using "2" False  ‹x ≠ z› by auto
  then obtain j where j: "cancels_to_1_at j x z" by auto
  define overlapping where "overlapping ≡ λ m (n :: nat). m ∈ {n, n + 1} ∨ n ∈ {m, m + 1}"
  then show ?thesis
      proof (cases "overlapping i j")
      case True
      then have ovl:"i ∈ {j, j + 1} ∨ j ∈ {i, i + 1}" using overlapping_def by auto
      then show ?thesis
        proof (cases "i = j")
        case True
        then have "y = z" using i j cancels_to_1_at_def by metis
        then show ?thesis by auto
        next
        case False
        then have "(i > j) ∨ (i < j)" by auto
        then have "i = j + 1 ∨ j = i + 1" using ovl by blast
        then show ?thesis
        proof (cases "j = i + 1")
        case True
        have t: "j = i + 1" using True by auto
        then have a: "inverse (x ! i) = x ! (i + 1)" using cancels_to_1_at_def i by fastforce
        have b : "inverse (x ! j) = x ! (j + 1)" by (metis add.commute cancels_to_1_at_def j)
        then have "inverse (x ! (i + 1)) =  x ! (i + 2)" using t by simp
        then have m: "((nth x (i + 2)) = (nth x i))" using a b t inverse_of_inverse by metis
        then have n: "cancel_at i x = y" using "1" i cancels_to_1_at_def cancel_at_def by metis
        have "cancel_at j x = z" using "1" i cancels_to_1_at_def cancel_at_def by (metis True j)
        then have "take i x @ drop (2 + i) x = take j x @ drop (2 + j) x" using a b m n sorry
        then have y: "y = z" using m n a b cancel_at_def by (metis ‹cancel_at j x = z›)
        then show ?thesis by auto
        next
        case False
        then have t: "i = j + 1" using ‹i = j + 1 ∨ j = i + 1› by blast
        then have a: "inverse (x ! j) = x ! (j + 1)" using cancels_to_1_at_def j by fastforce
        have b : "inverse (x ! i) = x ! (i + 1)" using cancels_to_1_at_def i by auto
        then have "inverse (x ! (j + 1)) =  x ! (j + 2)" using t by simp
        then have m: "((nth x (j + 2)) = (nth x j))" using a b t inverse_of_inverse by metis
        then have n: "cancel_at j x = z" using "1" j cancels_to_1_at_def cancel_at_def by metis
        have "cancel_at i x = y" using "1" i cancels_to_1_at_def cancel_at_def by (metis True j)
        then have "take i x @ drop (2 + i) x = take j x @ drop (2 + j) x" using a b m n sorry
        then have y: "y = z" using m n a b cancel_at_def by (metis ‹cancel_at i x = y›)
        then show ?thesis by auto
        qed
       qed
      next
      case False
      then have novl1:"¬(i ∈ {j, j + 1})" by (simp add: overlapping_def)
      have novl2: "¬(j ∈ {i, i + 1})" using False by (simp add: overlapping_def)
      then show ?thesis
        proof (cases "i<j")
        case True
        then have a:"(i + 1) < j" using i j True overlapping_def by (metis Nat.add_0_right add_Suc_right insertCI linorder_neqE_nat nat_1 nat_one_as_int not_less_eq novl2)
        have "cancels_to_1_at j x z" using j by auto
        then have b: "(j + 1) < length x" using cancels_to_1_at_def by auto
        have "cancels_to_1_at i x y" using i by auto
        then have c: "i ≥ 0" by simp
        then have  "cancel_at i (cancel_at j x) = cancel_at (j - 2) (cancel_at i x)" using a b novl[of i j x] by simp
        then have "cancel_at (j - 2) y = cancel_at i z" using cancels_to_1_at_def by (metis i j)
        then have "(nth x i) = (nth z i)" sorry
        then show ?thesis sorry
        next
        case False
        then have "i ≠ j" using novl1 by auto
        then have "i > j" using False by auto
        then have a:"(j + 1) < i" using i j overlapping_def using novl1 by force
        have "cancels_to_1_at i x y" using i by auto
        then have b: "(i + 1) < length x" using cancels_to_1_at_def by auto
        have "cancels_to_1_at j x z" using j by auto
        then have c: "j ≥ 0" by simp
        then have  "cancel_at j (cancel_at i x) = cancel_at (i - 2) (cancel_at j x)" using a b novl[of j i x] by simp
        then have "cancel_at (i - 2) z = cancel_at j y" using cancels_to_1_at_def by (metis i j)
        then have "(nth x j) = (nth z j)" sorry
        then show ?thesis using i j sorry
       qed
      qed
    qed
  qed
 qed