theory cancel_at_lemmas
imports Main  "HOL-Library.FuncSet" "HOL-Algebra.Group"
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@y \<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

(*"reduction-reduced lemma"*)
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

(*Try proving this*)
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

definition
  square :: "['a => 'a => bool, 'a => 'a => bool, 'a => 'a => bool, 'a => 'a => bool] => bool" where
  "square R S T U =
    (\<forall>x y. R x y --> (\<forall>z. S x z --> (\<exists>u. T y u \<and> U z u)))"

definition
  commute :: "['a => 'a => bool, 'a => 'a => bool] => bool" where
  "commute R S = square R S S R"

definition
  diamond :: "('a => 'a => bool) => bool" where
  "diamond R = commute R R"

definition
  Church_Rosser :: "('a => 'a => bool) => bool" where
  "Church_Rosser R =
    (\<forall>x y. (sup R (R^--1))^** x y --> (\<exists>z. R^** x z \<and> R^** y z))"

abbreviation
  confluent :: "('a => 'a => bool) => bool" where
  "confluent R == diamond (R^**)"

lemma a1: assumes"j \<ge> 0" "j + 2 < length x"
  shows "take j x @ drop (2+j) x = take j x @ [nth x (2+j)] @  drop (2+(1+j)) x"
  using assms
proof(induction j)
case 0
  then show ?case by (metis Suc_1 add.left_neutral add.right_neutral add_2_eq_Suc append_Cons append_take_drop_id id_take_nth_drop same_append_eq self_append_conv2)
next
case (Suc j)
  then show ?case using Cons_nth_drop_Suc by fastforce
qed

lemma a2: assumes"j \<ge> 0" "j + 2 < length x"
  shows "take (j+1) x @ drop (2+(j+1)) x = take j x @ [nth x j] @  drop (2+(1+j)) x"
  using assms
proof(induction j)
case 0
  then show ?case by (metis Suc_1 Suc_inject add.commute add_2_eq_Suc' add_lessD1 append_Nil id_take_nth_drop plus_nat.add_0 take_Suc_Cons take_eq_Nil)
next
case (Suc j)
  then show ?case by (metis add.commute add_lessD1 append_assoc plus_1_eq_Suc take_Suc_conv_app_nth)
qed

lemma assumes "j\<le>0" "j + 2 < Suc i" "Suc i + 1 \<le> length x"
  shows "cancel_at j (cancel_at (Suc i) x) = take (i - 2) (cancel_at j (cancel_at i x)) @ [(nth x i)] @ drop (i - 1) (cancel_at j (cancel_at i x))"
  unfolding cancel_at_def
  using assms
proof(induction j arbitrary: i)
case 0
  then show ?case sorry
next
  case (Suc j)
then show ?case sorry
qed

lemma drop_assoc: assumes "i \<le> j"
  shows  "drop i ((take j xs)@(drop (j+2) xs)) =  (drop i (take j xs)) @(drop (j+2) xs)"
  using assms
proof(induction xs arbitrary: i j)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case
  proof(cases "i = 0")
    case True
    then show ?thesis by simp
  next
    case False
    have i: "i > 0" using False by simp
    have j:"j \<ge> 1" using False 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 False
    have 2: "drop i (a#(take (j-1) xs)@(drop (j + 1) xs)) = (drop (i-1) ((take (j-1) xs)@(drop (j + 1) xs)))"using  drop_Cons' by metis
    have 3: "drop i (a#(take (j-1) xs)@(drop (j + 1) xs)) = (drop (i-1) ((take (j-1) xs)@(drop ((j - 1) + 2) xs)))" using "2" j by auto
    then have 4: "... = (drop (i-1) (take (j-1) xs) @ drop ((j-1) + 2) xs)" using Cons(1)[of "i-1" "j-1"] Cons(2) i j by linarith
    then have 5: "... = drop i (a#(take (j-1) xs)) @ drop (j + 2) (a#xs)" by (metis (no_types, hide_lams) False \<open>drop (j + 2) (a # xs) = drop (j + 1) xs\<close> drop_Cons' drop_drop j le_add_diff_inverse2 nat_1_add_1)
    then have 6: "... = drop i (take j (a#xs)) @  drop (j + 2) (a#xs)"  using \<open>take j (a # xs) = a # take (j - 1) xs\<close> by presburger
    then show ?thesis by (metis "1" "3" "4" "5" \<open>drop (j + 2) (a # xs) = drop (j + 1) xs\<close>)
  qed
qed

lemma take_assoc:
  assumes "i \<le> 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 \<ge> 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) using j by auto
    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 cancel_order: assumes "i +1 < j" "j + 1 < length xs"
  shows "cancel_at i (cancel_at j xs) = (cancel_at (j-2) (cancel_at i xs))"
  using assms
proof(induction xs arbitrary: i j)
  case Nil
  then show ?case unfolding cancel_at_def by force
next
  case (Cons a xs)
  then show ?case
  proof(cases "i \<le> 1")
    case True
    show ?thesis
    proof(cases "i = 0")
      case True
      have 1: "take i (take j (a # xs) @ drop (2 + j) (a # xs)) = []" using True by simp
      have 2: "take (j - 2) (take i (a # xs) @ drop (2 + i) (a # xs)) =  take (j - 2) (drop (2 + i) (a # xs))" using True by simp
      have 3: "drop (2 + (j - 2)) (take i (a # xs) @ drop (2 + i) (a # xs)) = drop (2 + (j - 2)) (drop (2 + i) (a # xs))" using True by simp
      then have 4: "... = drop (j + 2) (a#xs)" using True using Cons.prems(1) canonically_ordered_monoid_add_class.lessE by fastforce
      have ij: "2 + i \<le> j" using assms(1) using Cons.prems(1) by linarith
      have 5: "drop (2 + i) ((take j (a # xs)) @ drop (2 + j) (a # xs)) = (drop (2 + i) (take j (a # xs))) @ (drop (2 + j) (a # xs))" using drop_assoc[of "2+i" "j"] ij by (smt (z3) add.commute)
      have 6: "(drop (2 + i) (take j (a # xs))) = (drop 2 (take j (a # xs)))" using True by auto
      then have 7: "... =  take (j - 2) (drop (2 + i) (a # xs))" by (simp add: "6" True drop_take)
      then have 8: "... = take (j - 2) (drop (2 + i) (a # xs))" using True by blast
      show ?thesis unfolding cancel_at_def by (metis "1" "2" "3" "4" "5" "6" "7" add.commute append_self_conv2)
    next
      case False
      then have i1: "i = 1" using True by linarith
      have 1: "take i (take j (a # xs)) = take 1 (a#(take (j - 1) xs))" using i1 take_Cons' by (metis Cons.prems(1) less_nat_zero_code)
      then have 2: "... = (a#(take 0 (take (j - 1) xs)))" using take_Cons' by simp
      then have 3: "... = [a]" by simp
      have 4: "drop (2 + i) (take j (a # xs) @ drop (2 + j) (a # xs)) = (drop (2 + i) (take j (a # xs))) @ drop (2 + j) (a # xs)" using drop_assoc by (metis Cons.prems(1) add.commute discrete i1 nat_1_add_1)
      then have 5: "... =  (drop (1 + i) (take (j - 1) xs)) @ drop (1 + j) xs" using take_Cons' drop_Cons' by (simp add: "4" drop_Cons' take_Cons' Cons.prems(1) add.assoc add_diff_cancel_left' add_eq_0_iff_both_eq_0 gr_implies_not_zero less_one nat_1_add_1)
      have 6: "take (j - 2) (take i (a # xs) @ drop (2 + i) (a # xs)) = take (j - 2) (a#(drop (1 + i) xs))"  by (metis (no_types, lifting) True append_Cons append_eq_append_conv2 append_self_conv diff_add_inverse2 diff_is_0_eq' drop_Cons' i1 nat_1_add_1 numerals(1) take_0 take_Cons_numeral zero_le_one)
      then have 7: "... = (a#(take (j - 3) (drop (1 + i) xs)))" using take_Cons' by (metis Cons.prems(1) diff_diff_left i1 less_numeral_extra(3) nat_1_add_1 numeral_Bit1 numerals(1) zero_less_diff)
      then have 8: "... = [a] @ (take (j - 3) (drop (1 + i) xs))"  by simp
      have 9: "drop (2 + (j - 2)) (take i (a # xs) @ drop (2 + i) (a # xs)) = drop j (a#(drop (1 + i) xs))" using i1 drop_Cons' by (smt (z3) "7" "8" Cons.prems(1) Nat.diff_add_assoc add_diff_cancel_left' add_diff_cancel_right' append.assoc append_take_drop_id diff_diff_left diff_is_0_eq' le_numeral_extra(4) less_imp_le_nat list.distinct(1) nat_1_add_1 numeral_One numeral_plus_one semiring_norm(5) take0 take_0 take_Cons' take_Cons_numeral)
      then have 10: "... = drop (j - 1) (drop (1 + i) xs)" using drop_Cons' by (metis "1" "2" list.distinct(1) take_eq_Nil)
      then have 11: "... = drop (j - 1 + 1 + i) xs" by simp
      then have 12: "... = drop (j + 1) xs" using i1 Cons.prems(1) by force
      have 13: "(take (j - 3) (drop (1 + i) xs)) = (drop (1 + i) (take (j - 1) xs))" using drop_take by (simp add: drop_take i1 numeral_Bit1)
      then have 14: "[a] @ (take (j - 3) (drop (1 + i) xs)) = [a] @ (drop (1 + i) (take (j - 1) xs))" by blast
      then have 15: "take (j - 2) (take i (a # xs) @ drop (2 + i) (a # xs)) = take i (take j (a # xs)) @ (drop (1 + i) (take (j - 1) xs))" using "1" "2" "3" "6" "7" "8" by presburger
      have 16: "take i (take j (a # xs)) = take i (take j (a # xs) @ drop (2 + j) (a # xs))" using Cons.prems(1) i1 by auto
      then have 17: "take (j - 2) (take i (a # xs) @ drop (2 + i) (a # xs)) = take i (take j (a # xs) @ drop (2 + j) (a # xs)) @ (drop (1 + i) (take (j - 1) xs))" using 15 16  by presburger
      then have 18: "take (j - 2) (take i (a # xs) @ drop (2 + i) (a # xs)) @ drop (2 + (j - 2)) (take i (a # xs) @ drop (2 + i) (a # xs)) = take i (take j (a # xs) @ drop (2 + j) (a # xs)) @ (drop (1 + i) (take (j - 1) xs)) @ drop (j + 1) xs" by (metis "10" "11" "12" "9" append_assoc)
      then have 19: "take (j - 2) (take i (a # xs) @ drop (2 + i) (a # xs)) @ drop (2 + (j - 2)) (take i (a # xs) @ drop (2 + i) (a # xs)) = take i (take j (a # xs) @ drop (2 + j) (a # xs)) @ drop (2 + i) (take j (a # xs) @ drop (2 + j) (a # xs))" by (metis "4" "5" add.commute)
      then show ?thesis unfolding cancel_at_def by presburger
    qed
  next
    case False
    hence "i \<ge> 2" by simp
    with Cons(1)[of "i-1" "j-1"]
    have "cancel_at (i - 1) (cancel_at (j - 1) xs) =  cancel_at (j - 1 - 2) (cancel_at (i - 1) xs)" using Cons(2,3) by fastforce
    then have A: "take (i - 1) (take (j - 1) xs @ drop (2 + (j - 1)) xs) @
               drop (2 + (i - 1)) (take (j - 1) xs @ drop (2 + (j - 1)) xs) =
               take (j - 1 - 2) (take (i - 1) xs @ drop (2 + (i - 1)) xs) @
               drop (2 + (j - 1 - 2)) (take (i - 1) xs @ drop (2 + (i - 1)) xs)" unfolding cancel_at_def by blast
    have 1: "drop (2 + (j - 1)) xs = drop (2 + j) (a#xs)" using drop_Cons' Cons.prems(1) by auto
    have 2: "drop (2 + (i - 1)) xs = drop (2 + i) (a#xs)" using drop_Cons' False by auto
    have 3: "(a#(take (i - 1) (take (j - 1) xs @ drop (2 + (j - 1)) xs))) @
               drop (2 + (i - 1)) (take (j - 1) xs @ drop (2 + (j - 1)) xs) =
               (a#(take (j - 1 - 2) (take (i - 1) xs @ drop (2 + (i - 1)) xs))) @
               drop (2 + (j - 1 - 2)) (take (i - 1) xs @ drop (2 + (i - 1)) xs)" using A by (metis append_Cons)
    then have 4: "take i (a#(take (j - 1) xs @ drop (2 + (j - 1)) xs)) @
               drop (2 + (i - 1)) (take (j - 1) xs @ drop (2 + (j - 1)) xs) =
               take (j - 2) (a#(take (i - 1) xs @ drop (2 + (i - 1)) xs)) @
               drop (2 + (j - 1 - 2)) (take (i - 1) xs @ drop (2 + (i - 1)) xs)" using take_Cons' by (smt (verit) Cons.prems(1) False Nat.add_diff_assoc2 add_less_same_cancel2 diff_add_inverse2 diff_diff_left diff_is_0_eq less_diff_conv nat_1_add_1 nat_le_linear not_add_less2)
    then have 5: "take i (take j (a#xs) @ drop (2 + (j - 1)) xs) @
               drop (2 + (i - 1)) (take (j - 1) xs @ drop (2 + (j - 1)) xs) =
               take (j - 2) (take i (a#xs) @ drop (2 + (i - 1)) xs) @
               drop (2 + (j - 1 - 2)) (take (i - 1) xs @ drop (2 + (i - 1)) xs)" using take_Cons' by (smt (z3) Cons.prems(1) False Nat.add_diff_assoc2 add_is_0 append_Cons diff_add_inverse2 less_nat_zero_code nat_le_linear)
    have 6:  "drop (2 + (i - 1)) (take (j - 1) xs @ drop (2 + (j - 1)) xs) =  drop (2 + i) (a#(take (j - 1) xs @ drop (2 + (j - 1)) xs))" using drop_Cons' False by auto
    then have 7: "... =  drop (2 + i) (take j (a#xs) @ drop (2 + (j - 1)) xs)" using take_Cons' by (metis Cons.prems(1) Cons_eq_appendI gr_implies_not_zero)
    have 8: "drop (2 + (j - 1 - 2)) (take (i - 1) xs @ drop (2 + (i - 1)) xs) =  drop (2 + (j - 2)) (a#(take (i - 1) xs @ drop (2 + (i - 1)) xs))" using drop_Cons' False by (smt (z3) Cons.prems(1) Nat.add_diff_assoc \<open>2 \<le> i\<close> diff_add_inverse diff_le_self le_eq_less_or_eq le_trans less_diff_conv not_numeral_le_zero)
    then have 9: "... =  drop (2 + (j - 2)) (take i (a#xs) @ drop (2 + (i - 1)) xs)" using take_Cons' by (metis (no_types, hide_lams) False append_eq_Cons_conv zero_le_one)
    then show ?thesis unfolding cancel_at_def by (metis "1" "2" "5" "6" "7" "8")
  qed
qed

lemma takenth: assumes  "take i x = take i y" "i \<ge> 0" "j < i"
  shows "(nth x j) = (nth y j)"
  by (metis assms(1) assms(3) nth_take)

lemma Con_nth: assumes "(nth x i) = (nth y j)"
  shows "(nth (a#x) (i+1)) = (nth (a#y) (j+1))"
  by (simp add: assms)

lemma zero:"(a::nat) + 1 - 1 = a"
  by simp

lemma comm: assumes "a > 0"
  shows "(a::nat) - 1 + 1 = a + 1 - 1"
  by (simp add: assms)

lemma cancel_atnth: assumes "j > i + 1" "j < length x"
  shows "(nth x j) = (nth (cancel_at i x) (j-2))"
  using assms
  unfolding cancel_at_def
  proof(induction x arbitrary: i j)
    case Nil
    have "j < 0" using Nil assms(2) by auto
    then show ?case by simp
next
  case (Cons a x)
  then show ?case
  proof(cases "i > 0")
    case True
  have i: "i > 0" using True by simp
  have a:"(j - 1) < length x" using Cons(3) Cons.prems(1) by auto
  have b: "(i - 1) + 1 < (j - 1)" using Cons True i by linarith
  have "(nth x (j - 1)) = nth (take (i - 1) x @ drop (2 + (i - 1)) x) ((j - 1) - 2)" using Cons(1)[of "i - 1" "j - 1"]  a b by metis
  then have c: "(nth (a#x) (j - 1 + 1)) = nth (a#(take (i - 1) x @ drop (2 + (i - 1)) x)) ((j - 1 - 2 + 1))" using Con_nth[of "x" "j - 1" "(take (i - 1) x @ drop (2 + (i - 1)) x)" "j - 1 - 2" "a"] by metis
  then have "(nth (a#x) j) = nth (a#(take (i - 1) x @ drop (2 + (i - 1)) x)) ((j - 2))" by (smt (z3) add_eq_0_iff_both_eq_0 b diff_diff_left less_diff_conv less_nat_zero_code nat_1_add_1 nth_Cons' zero)
  then have "(nth (a#x) j) = nth ((a#(take (i-1) x)) @ drop (2 + (i - 1)) x) ((j - 2))" by (smt (z3) append_Cons)
  then have "(nth (a#x) j) = nth ((take i (a#x)) @ drop (2 + (i - 1)) x) ((j - 2))" using take_Cons' i  by (smt (z3) not_gr_zero)
  then have "(nth (a#x) j) = nth ((take i (a#x)) @ drop (2 + i) (a#x)) (j - 2)" using drop_Cons' i  by (smt (z3) drop_drop gr_implies_not0)
  then show ?thesis by metis
  next
    case False
    then have i: "i = 0" by blast
    then have a:"nth ((take i (a#x)) @ drop (2 + i) (a#x)) (j - 2) = nth (drop (2 + i) (a#x)) (j - 2)" by simp
    have b:"... = nth (drop 2 (a#x)) (j - 2)" using i  by auto
    have c:"... = nth (drop 1 x) (j - 2)" using drop_Cons' by simp
    then have d: "... =  nth (tl x) (j - 2)" by (simp add: drop_Suc)
    then have e: "... = nth x (j - 1)" using nth_tl by (smt (verit, ccfv_threshold) Cons.prems(1) Cons.prems(2) Suc_1 Suc_diff_Suc add_cancel_right_left add_diff_inverse_nat diff_diff_left drop_Suc_Cons i length_drop length_tl not_less_eq zero_less_diff)
    have f: "(nth (a#x) j) = (nth x (j - 1))" by (metis Cons.prems(1) add_lessD1 i nth_Cons_pos)
    then show ?thesis using a b c d e by presburger
  qed
qed

lemma length_Cons: "(length xs) + 1 = (length (a#xs))"
  by auto

lemma assoc_Cons: "(a#(b@c)) = ((a#b)@c)"
  by simp

lemma cancel_at_length: assumes "0 \<le> i" "i + 1 < length x"
  shows "length (cancel_at i x) = (length x) - 2"
  using assms
  unfolding cancel_at_def
proof(induction x arbitrary: i)
case Nil
  then show ?case by auto
next
  case (Cons a x)
  then show ?case
  proof(cases "length x \<ge> 1")
    case True
    then have lx: "length x \<ge> 1" by simp
    then show ?thesis
  proof(cases "i > 0")
    case True
    have a: "0 \<le> i - 1" using Cons.prems(1) by simp
  have b: "(i - 1) + 1 \<le> length x" using Cons.prems(2) True by fastforce
  have "length (take (i - 1) x @ drop (2 + (i - 1)) x) = length x - 2" using a b Cons(1)[of "i - 1"] by (metis Cons.prems(2) True cancel_at_lemmas.length_Cons comm le_neq_implies_less less_not_refl3 zero)
  then have "(length (take (i - 1) x @ drop (2 + (i - 1)) x)) + 1 = (length x - 2) + 1" by presburger
  then have "(length (take (i - 1) x @ drop (2 + (i - 1)) x)) + 1 = (length x + 1) - 2" using lx Nat.add_diff_assoc2 Cons.prems(1) True  by (smt (z3) Cons.prems(2) cancel_at_lemmas.length_Cons comm diff_add diff_diff_left diff_is_0_eq' less_diff_conv nat_1_add_1 nat_less_le zero_less_diff)
  then have "(length (take (i - 1) x @ drop (2 + (i - 1)) x)) + 1 = (length (a#x)) - 2" using length_Cons[of "x" "a"] by argo
  then have "(length (a#(take (i - 1) x @ drop (2 + (i - 1)) x))) = (length (a#x)) - 2" using length_Cons[of  "(take (i - 1) x @ drop (2 + (i - 1)) x)" "a"] by argo
  then have "(length ((a#take (i - 1) x) @ drop (2 + (i - 1)) x)) = (length (a#x)) - 2" using assoc_Cons[of "a" "take (i - 1) x" "drop (2 + (i - 1)) x"] by argo
  then have "length ((take i (a#x)) @ drop (2 + (i - 1)) x) = (length (a#x)) - 2" using True take_Cons' [of "i" "a" "x"] by presburger
  then have "length ((take i (a#x)) @ drop (2 + i) (a#x)) = (length (a#x)) - 2" using True drop_Cons' Cons.prems(1) by simp
  then show ?thesis  by blast
  next
    case False
    have i: "i = 0" using Cons.prems(1) False by auto
    then have 1: "length ((take i (a#x)) @ drop (2 + i) (a#x)) = length (drop (2 + i) (a#x))" by simp
    have 2: "... = length (drop 2 (a#x))"  using i by simp
    have 3: "... = length (drop 1 (a#x)) - 1"  by simp
    have 4: "... = length (drop 0 (a#x)) - 2" by simp
    have 5: "... = (length (a#x)) - 2" by auto
    then show ?thesis using "1" "2" "3" "4" by presburger
  qed
  next
    case False
    then have 1: "length x < 1" by linarith
    then have 2: "length x = 0"  by auto
    then have 3: "x = []" by auto
    then have 4: "(a#x) = [a]" by simp
    have "i + 1 \<ge> 1" using Cons.prems(2) by simp
    then have "i + 1 \<ge> length (a#x)" using 4 by simp
    then show ?thesis using Cons(3) by linarith
  qed
qed

lemma diamond_cancel:
  shows "diamond (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)"
  unfolding diamond_def cancels_to_1_def commute_def square_def
  apply(rule allI)
  apply(rule allI)
  apply(rule impI)
  apply(rule allI)
  apply(rule impI)
proof-
  fix x y z :: "('a, 'b) word"
  assume 1: "(\<exists>i. cancels_to_1_at i x y) \<or> x = y"
  assume 2: "(\<exists>i. cancels_to_1_at i x z) \<or> x = z"
  show "\<exists>u. ((\<exists>i. cancels_to_1_at i y u) \<or> y = u) \<and> ((\<exists>i. cancels_to_1_at i z u) \<or> z = u)"
  proof(cases "x = y \<or> x = z")
    case True
    then have "(\<exists>i. cancels_to_1_at i y z) \<or> (\<exists>i. cancels_to_1_at i z y) \<or> y = z " using 1 2 by blast
  then show ?thesis by blast
  next
    case False
    have 3: "(\<exists>i. cancels_to_1_at i x y) \<and> (\<exists>j. cancels_to_1_at j x z)" using 1 2 False by blast
    obtain i where "cancels_to_1_at i x y" using 3 by auto
    obtain j where "cancels_to_1_at j x z" using 3 by auto
  then show ?thesis
    proof(cases "y = z")
      case True
    then show ?thesis by auto
    next
      case False
      then show ?thesis
      proof(cases "i \<in> {j, j + 1} \<or> j \<in> {i, i+1}")
        case True
        have a: "y \<noteq> z"  by (simp add: False)
      then show ?thesis
        proof(cases "i = j")
          case True
          have y: "y = cancel_at i x" using cancels_to_1_at_def using \<open>cancels_to_1_at i x y\<close> by auto
          have z: "z = cancel_at i x" using cancels_to_1_at_def True using \<open>cancels_to_1_at j x z\<close> by auto
          have cont: "y = z" using y z by simp
        then show ?thesis using a by auto
        next
          case False
          then have ij: "i = j + 1 \<or> j = i + 1" using True by auto
          have xi: "inverse (x!i) = (x!(1+i))" using cancels_to_1_at_def \<open>cancels_to_1_at i x y\<close> by auto
          have xj: "inverse (x!j) = (x!(1+j))" using cancels_to_1_at_def \<open>cancels_to_1_at j x z\<close> by auto
        then show ?thesis
          proof(cases "i = 1 + j")
            case True
            have xij: "((nth x j) = (nth x (2+j)))" using True xi xj inverse_of_inverse by (metis add_2_eq_Suc plus_1_eq_Suc)
            have y1: "y = cancel_at (j+1) x" by (metis True \<open>cancels_to_1_at i x y\<close> add.commute cancels_to_1_at_def)
            have z1: "z = cancel_at j x" using cancels_to_1_at_def \<open>cancels_to_1_at j x z\<close> by (simp add: cancels_to_1_at_def)
            have contr1: "y = z" using y1 z1 a1 z1 xij by (smt (z3) True \<open>cancels_to_1_at i x y\<close> a2 add.commute cancel_at_def cancels_to_1_at_def group_cancel.add1 nat_1_add_1 zero_le)
          show ?thesis using a contr1 by auto
          next
            case False
            have "j = i + 1" using False ij by auto
            then have xji: "((nth x i) = (nth x (2+i)))" by (metis Suc_1 add.commute add_Suc_right inverse_of_inverse plus_1_eq_Suc xi xj)
            have y2: "y = cancel_at i x" using cancels_to_1_at_def \<open>cancels_to_1_at i x y\<close> by auto
            have z2: "z = cancel_at (i+1) x" using xji cancels_to_1_at_def \<open>cancels_to_1_at j x z\<close> by (simp add: cancels_to_1_at_def \<open>j = i + 1\<close>)
            have contr2: "y = z" using y2 z2 a2 z2 xji  by (smt (verit) \<open>cancels_to_1_at j x z\<close> \<open>j = i + 1\<close> a1 add.left_commute cancel_at_def cancels_to_1_at_def le_add2 le_add_same_cancel2 nat_1_add_1)
          then show ?thesis using a contr2 by auto
          qed
        qed
      next
        case False
        then have ij: " \<not> (i \<in> {j, j + 1} \<or> j \<in> {i, i + 1})" by auto
        have xi: "inverse (x!i) = (x!(1+i))" using cancels_to_1_at_def \<open>cancels_to_1_at i x y\<close> by auto
        have xj: "inverse (x!j) = (x!(1+j))" using cancels_to_1_at_def \<open>cancels_to_1_at j x z\<close> by auto
        then show ?thesis
        proof(cases "i \<le> j")
          case True
          then have l: "i + 1 < j"  by (metis False discrete insert_iff le_neq_implies_less)
          then have j1: "i + 1 < j + 1" by linarith
          have i0: "i\<ge>0" by simp
          have j0: "j \<ge> 0"  by simp
          then have j20: "j - 2 \<ge> 0" by simp
          have z: "z = cancel_at j x" using \<open>cancels_to_1_at j x z\<close> cancels_to_1_at_def by auto
          have y: "y = cancel_at i x"  using \<open>cancels_to_1_at i x y\<close> cancels_to_1_at_def by auto
          have il: "1 + i < length x" using  \<open>cancels_to_1_at i x y\<close> by (simp add: cancels_to_1_at_def)
          have m: "1 + j  < length x" using \<open>cancels_to_1_at j x z\<close> cancels_to_1_at_def by (simp add: cancels_to_1_at_def)
          then have jl: "j + 1 < length x" by auto
          then have "i + 1 + 2 < length x" using l  by linarith
          then have zz: "i + 1 < length x - 2" by simp
          have "length x - 2 = length (cancel_at i x)" using cancel_at_length[of "i" "x"] il i0 by presburger
          then have "length x - 2 = length y" using y by simp
          then have "j + 1 < length y + 2" using jl  by linarith
          then have j2y: "(j - 2) + 1 < length y" using l by linarith
          have "length x - 2 = length (cancel_at j x)" using cancel_at_length[of "j" "x"]  jl j0 by metis
          then have "length x - 2 = length z" using z by simp
          then have iz: "i + 1 < length z" using zz  by simp
          have j: "j < length x" using m by linarith
          then have n: "cancel_at i (cancel_at j x) = cancel_at (j-2) (cancel_at i x)" using cancel_order l m by (metis add.commute)
          then have eq: "cancel_at i z = cancel_at (j-2) y" using \<open>cancels_to_1_at j x z\<close> \<open>cancels_to_1_at i x y\<close> cancels_to_1_at_def by (simp add: cancels_to_1_at_def)
          have take: "take j z = take j x" using take_assoc cancel_at_def l m by (metis \<open>cancels_to_1_at j x z\<close> add.commute cancels_to_1_at_def eq_imp_le)
          then have o: "(nth x i) = (nth z i)" using l i0 by (metis add_lessD1 nth_take)
          have p: "(nth x (i+1)) = (nth z (i+1))" using l i0 take takenth by (metis True order.trans)
          then have "inverse (nth z i) = (nth x (i+1))" using xi o by (smt (z3) add.commute)
          then have "inverse (nth z i) = (nth z (i+1))" using p by (smt (z3))
          then have inv1: "inverse (nth z i) = (nth z (1+i))" by simp
          have zeq: "(cancel_at i z) = cancel_at i z" by simp
          have zu: "cancels_to_1_at i z (cancel_at i z)"  using i0 iz inv1 zeq unfolding cancels_to_1_at_def by linarith
          have "y = cancel_at i x" using  \<open>cancels_to_1_at i x y\<close> cancels_to_1_at_def by (simp add: cancels_to_1_at_def)
          then have q: "(nth x j) = (nth y (j - 2))" using cancel_atnth l j by blast
          have r: "(nth x (j + 1)) = (nth y ((j - 2) + 1))"  using cancel_atnth j1 m by (smt (verit) \<open>y = cancel_at i x\<close> add.commute comm diff_add_inverse diff_diff_left diff_is_0_eq' l le_add2 nat_1_add_1 nat_less_le zero_less_diff)
          have s: "inverse (nth y (j - 2)) = (nth x (j + 1))" using xj q  by auto
          then have inv2:"inverse (nth y (j - 2)) = (nth y ((j - 2) + 1))" using r  by fastforce
          have yeq: "cancel_at (j - 2) y = cancel_at (j - 2) y" by simp
          have yu: "cancels_to_1_at (j - 2) y (cancel_at (j - 2) y)" using j20 j2y  inv2 yeq unfolding cancels_to_1_at_def by auto
          then show ?thesis using yu zu eq by auto
        next
          case False
          then have j1i: "j + 1 < i" using ij by (metis discrete insertCI leI le_neq_implies_less)
          then have j1i1: "j + 1 < i + 1" by linarith
          have i0: "i\<ge>0" by simp
          then have i20: "i - 2 \<ge> 0" by simp
          have j0: "j \<ge> 0"  by simp
          have z: "z = cancel_at j x" using \<open>cancels_to_1_at j x z\<close> cancels_to_1_at_def by auto
          have y: "y = cancel_at i x"  using \<open>cancels_to_1_at i x y\<close> cancels_to_1_at_def by auto
          have jl: "1 + j  < length x" using \<open>cancels_to_1_at j x z\<close> cancels_to_1_at_def by (simp add: cancels_to_1_at_def)
          have il: "1 + i < length x" using  \<open>cancels_to_1_at i x y\<close> by (simp add: cancels_to_1_at_def)
          have "length x - 2 = length (cancel_at j x)" using cancel_at_length[of "j" "x"] jl j0 by presburger
          then have  "length x = length (cancel_at j x) + 2" using jl by linarith
          then have "i + 1 < (length z) + 2" using il i0 z  by auto
          then have i2z: "(i - 2) + 1 < length z" using j1i by linarith
          have "length x - 2 = length (cancel_at i x)" using cancel_at_length[of "i" "x"] il i0 by presburger
          then have xy: "length x - 2 = length y" using y  by simp
          have "j + 1 + 2 < length x" using j1i il  by linarith
          then have "j + 1 < length x - 2" using jl  by linarith
          then have jy: "j + 1 < length y" using xy by simp
          have "cancel_at j (cancel_at i x) = cancel_at (i-2) (cancel_at j x)" using j1i il cancel_order by auto
          then have eq: "cancel_at j y = cancel_at (i-2) z" using y z by simp
          have take: "take i x = take i y" using take_assoc cancel_at_def j1i by (metis add_diff_inverse_nat diff_add_inverse diff_add_inverse2 diff_le_self less_imp_diff_less less_nat_zero_code y zero_less_diff)
          have nth: "(nth x j) = (nth y j)" using takenth i0 j1i1 add_less_imp_less_right take by blast
          have nth1: "(nth x (j+1)) = (nth y (j+1))" using takenth i0 j1i1 j1i take by auto
          have "inverse (nth y j) = (nth x (j+1))" using xj nth by fastforce
          then have invj: "inverse (nth y j) = (nth y (j+1))" using nth1 by (smt (z3))
          have yu:  "cancels_to_1_at j y (cancel_at j y)" using j0 jy invj cancels_to_1_at_def by fastforce
          have nthi: "(nth x i) = (nth z (i - 2))" using z j1i  il cancel_atnth by (metis trans_le_add2 verit_comp_simplify1(3))
          have nthi1: "(nth x (i+1)) = (nth z ((i - 2) + 1))"  using z j1i1 il by (metis Nat.add_diff_assoc2 add.commute add_lessD1 cancel_atnth discrete j1i nat_1_add_1)
          then have "inverse (nth z (i - 2)) = (nth x (i + 1))" using xi nthi by fastforce
          then have invi: "inverse (nth z (i - 2)) = (nth z ((i - 2) + 1))" using nthi1 by (smt (z3))
          have zu: "cancels_to_1_at (i - 2) z (cancel_at (i - 2) z)" using i20 i2z invi cancels_to_1_at_def by (metis add.commute)
          then show ?thesis using eq yu zu by auto
       qed
    qed
  qed
qed


theory BExp
  imports AExp
begin

subsection "Boolean Expressions"

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

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool"
  where "bval (Bc v) s = v"
  | "bval (Not b) s = (\<not> bval b s)"
  | "bval (And b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s \<and> bval b\<^sub>2 s)"
  | "bval (Less a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"

value "bval (Less (V ''x'') (Plus (N 3) (V ''y'')))
            <''x'' := 3, ''y'' := 1>"

subsection "Constant Folding"

text{* Optimizing constructors: *}

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp"
  where "less (N n\<^sub>1) (N n\<^sub>2) = Bc(n\<^sub>1 < n\<^sub>2)"
  | "less a\<^sub>1 a\<^sub>2 = Less a\<^sub>1 a\<^sub>2"

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp"
  where "and (Bc True) b = b"
  | "and b (Bc True) = b"
  | "and (Bc False) b = Bc False"
  | "and b (Bc False) = Bc False"
  | "and b\<^sub>1 b\<^sub>2 = And b\<^sub>1 b\<^sub>2"

lemma bval_and[simp]: "bval (and b1 b2) s = (bval b1 s \<and> bval b2 s)"
apply(induction b1 b2 rule: and.induct)
apply(simp_all)
done

fun not :: "bexp \<Rightarrow> bexp"
  where "not (Bc True) = Bc False"
  | "not (Bc False) = Bc True"
  | "not b = Not b"

lemma bval_not[simp]: "bval (not b) s = (\<not> bval b s)"
apply(induction b rule: not.induct)
apply(simp_all)
done

text{* Now the overall optimizer: *}

fun bsimp :: "bexp \<Rightarrow> bexp"
  where "bsimp (Bc v) = Bc v"
  | "bsimp (Not b) = not(bsimp b)"
  | "bsimp (And b\<^sub>1 b\<^sub>2) = and (bsimp b\<^sub>1) (bsimp b\<^sub>2)"
  | "bsimp (Less a\<^sub>1 a\<^sub>2) = less (asimp a\<^sub>1) (asimp a\<^sub>2)"

value "bsimp (And (Less (N 0) (N 1)) b)"

value "bsimp (And (Less (N 1) (N 0)) (Bc True))"

theorem "bval (bsimp b) s = bval b s"
 apply(induction b)
 apply(auto)
done

text{* Exercises *}
text{*
Exercise 3.7. Define functions Eq, Le :: aexp => aexp => bexp and prove
              bval (Eq a1 a2) s = (aval a1 s = aval a2 s) and
              bval (Le a1 a2) s = (aval a1 s <= aval a2 s)
*}
fun Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp"
  where "Eq l r = And (Not (Less l r)) (Not ((Less r l)))"

fun Le :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp"
  where "Le l r = Not (Less r l)"

lemma "bval (Eq a\<^sub>1 a\<^sub>2) state = (aval a\<^sub>1 state = aval a\<^sub>2 state)"
  apply(induction a\<^sub>1 arbitrary: a\<^sub>2)
  apply(auto)
  done

lemma "bval (Le a\<^sub>1 a\<^sub>2) state = (aval a\<^sub>1 state \<le> aval a\<^sub>2 state)"
  apply(induction a\<^sub>1 arbitrary: a\<^sub>2)
  apply(auto)
  done

text{*
Exercise 3.8. Consider an alternative type of boolean expressions featuring a
              conditional:
              datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp
              First define an evaluation function
              ifval :: ifexp => state => bool analogously to bval. Then define two
              functions b2ifexp :: bexp => ifexp and if2bexp :: ifexp => bexp and
              prove their correctness, i.e., that they preserve the value of an exp.
*}
datatype ifexp
  = Bc2 bool
  | If ifexp ifexp ifexp
  | Less2 aexp aexp

fun ifval :: "ifexp \<Rightarrow> state \<Rightarrow> bool"
  where "ifval (Bc2 b) s = b"
  | "ifval (If e\<^sub>1 e\<^sub>2 e\<^sub>3) s = (if (ifval e\<^sub>1 s) then (ifval e\<^sub>2 s) else (ifval e\<^sub>3 s))"
  | "ifval (Less2 a\<^sub>1 a\<^sub>2) s = (aval a\<^sub>1 s < aval a\<^sub>2 s)"

fun b2ifexp :: "bexp \<Rightarrow> ifexp"
  where "b2ifexp (Bc b) = (Bc2 b)"
  | "b2ifexp (Not b) = (If (b2ifexp b) (Bc2 False) (Bc2 True))"
  | "b2ifexp (And l r) = (If (b2ifexp l) (b2ifexp r) (Bc2 False))"
  | "b2ifexp (Less l r) = (Less2 l r)"

fun if2bexp :: "ifexp \<Rightarrow> bexp"
  where "if2bexp (Bc2 b) = (Bc b)"
  | "if2bexp (If t l r) = (Not (And (Not (And (if2bexp t) (if2bexp l)))
                                  (Not (And (Not (if2bexp t)) (if2bexp r)))))"
  | "if2bexp (Less2 l r) = (Less l r)"

lemma "ifval (b2ifexp bexpr) state = bval bexpr state"
  apply(induction bexpr)
  apply(auto)
  done

text{*
Exercise 3.9. Define a new type of purely boolean expressions
              datatype pbexp = Var vname | Not pbexp | And pbexp pbexp | Or pbexp pbexp
              where variables range over values of type bool.
              Define a function is_nnf :: pbexp => bool that checks whether a boolean
              expression is in NNF (negation normal form), i.e, if NOT is only applied
              directly to VARs. Also define a function nnf :: pbexp => pbexp that
              converts a pbexp into NNF by pushing NOT inwards as much as possible.
              Prove that nnf preserves the value (pbval (nnf b) s = pbval b s) and
              returns a NNF (is_nnf (nnf b)).

              An expression is DNF (disjunctive normal form) if it is in NNF and if
              no OR occurs below and AND. Define a corresponding test
              is_dnf :: pbexp => bool. An NNF can be converted into a DNF in a
              bottom-up manner. The critical case is the conversion AND b1 b2.
              Having converted b1 and b2, apply distributivity of AND over OR.
              Define a conversion function dnf_of_nnf :: pbexp => pbexp from NNF
              to DNF. Prove that your function preservers the value
              (pbval (dnf_of_nnf b) s = pbval b s) and converts an NNF into a DNF
              (is_nnf b ==> is_dnf (dnf_of_nnf b)).
*}
datatype pbexp
  = VAR vname
  | NOT pbexp
  | AND pbexp pbexp
  | OR pbexp pbexp

fun pbval :: "pbexp \<Rightarrow> (vname \<Rightarrow> bool) \<Rightarrow> bool"
  where "pbval (VAR x) s = s x"
  | "pbval (NOT b) s = (\<not> pbval b s)"
  | "pbval (AND b\<^sub>1 b\<^sub>2) s = (pbval b\<^sub>1 s \<and> pbval b\<^sub>2 s)"
  | "pbval (OR b\<^sub>1 b\<^sub>2) s = (pbval b\<^sub>1 s \<or> pbval b\<^sub>2 s)"

end


section \<open> Quantities \<close>

theory ISQ_Quantities
  imports ISQ_Dimensions
begin

subsection \<open> Quantity Semantic Domain \<close>

text \<open> Here, we give a semantic domain for particular values of physical quantities. A quantity
  is usually expressed as a number and a measurement unit, and the goal is to support this. First,
  though, we give a more general semantic domain where a quantity has a magnitude and a dimension. \<close>

record ('a, 'd::enum) Quantity =
  mag  :: 'a                 \<comment> \<open> Magnitude of the quantity. \<close>
  dim  :: "(int, 'd) dimvec" \<comment> \<open> Dimension of the quantity -- denotes the kind of quantity. \<close>

text \<open> The quantity type is parametric as we permit the magnitude to be represented using any kind
  of numeric type, such as \<^typ>\<open>int\<close>, \<^typ>\<open>rat\<close>, or \<^typ>\<open>real\<close>, though we usually minimally expect
  a field. \<close>

lemma Quantity_eq_intro:
  assumes "mag x = mag y" "dim x = dim y" "more x = more y"
  shows "x = y"
  by (simp add: assms eq_unit)

text \<open> We can define several arithmetic operators on quantities. Multiplication takes multiplies
  both the magnitudes and the dimensions. \<close>

instantiation Quantity_ext :: (times, enum, times) times
begin
definition times_Quantity_ext ::
    "('a, 'b, 'c) Quantity_scheme \<Rightarrow> ('a, 'b, 'c) Quantity_scheme \<Rightarrow> ('a, 'b, 'c) Quantity_scheme"
    where  [si_def]: "times_Quantity_ext x y = \<lparr> mag = mag x \<cdot> mag y, dim = dim x \<cdot> dim y,
                                                 \<dots> = more x \<cdot> more y \<rparr>"
instance ..
end

lemma mag_times  [simp]: "mag (x \<cdot> y) = mag x \<cdot> mag y" by (simp add: times_Quantity_ext_def)
lemma dim_times  [simp]: "dim (x \<cdot> y) = dim x \<cdot> dim y" by (simp add: times_Quantity_ext_def)
lemma more_times [simp]: "more (x \<cdot> y) = more x \<cdot> more y" by (simp add: times_Quantity_ext_def)

text \<open> The zero and one quantities are both dimensionless quantities with magnitude of \<^term>\<open>0\<close> and
  \<^term>\<open>1\<close>, respectively. \<close>

instantiation Quantity_ext :: (zero, enum, zero) zero
begin
  definition "zero_Quantity_ext = \<lparr> mag = 0, dim = 1, \<dots> = 0 \<rparr>"
instance ..
end

lemma mag_zero  [simp]:  "mag 0 = 0" by (simp add: zero_Quantity_ext_def)
lemma dim_zero  [simp]:  "dim 0 = 1" by (simp add: zero_Quantity_ext_def)
lemma more_zero [simp]: "more 0 = 0" by (simp add: zero_Quantity_ext_def)

instantiation Quantity_ext :: (one, enum, one) one
begin
  definition    [si_def]: "one_Quantity_ext = \<lparr> mag = 1, dim = 1, \<dots> = 1 \<rparr>"
instance ..
end

lemma mag_one  [simp]: "mag 1 = 1" by (simp add: one_Quantity_ext_def)
lemma dim_one  [simp]: "dim 1 = 1" by (simp add: one_Quantity_ext_def)
lemma more_one [simp]: "more 1 = 1" by (simp add: one_Quantity_ext_def)

text \<open> Quantity inversion inverts both the magnitude and the dimension. Similarly, division of
  one quantity by another, divides both the magnitudes and the dimensions. \<close>

instantiation Quantity_ext :: (inverse, enum, inverse) inverse
begin
definition inverse_Quantity_ext :: "('a, 'b, 'c) Quantity_scheme \<Rightarrow> ('a, 'b, 'c) Quantity_scheme" where
  [si_def]: "inverse_Quantity_ext x = \<lparr> mag = inverse (mag x), dim = inverse (dim x), \<dots> = inverse (more x) \<rparr>"
definition divide_Quantity_ext :: "('a, 'b, 'c) Quantity_scheme \<Rightarrow> ('a, 'b, 'c) Quantity_scheme \<Rightarrow> ('a, 'b, 'c) Quantity_scheme" where
  [si_def]: "divide_Quantity_ext x y = \<lparr> mag = mag x / mag y, dim = dim x / dim y, \<dots> = more x / more y \<rparr>"
instance ..
end

lemma mag_inverse [simp]: "mag (inverse x) = inverse (mag x)"
  by (simp add: inverse_Quantity_ext_def)

lemma dim_inverse [simp]: "dim (inverse x) = inverse (dim x)"
  by (simp add: inverse_Quantity_ext_def)

lemma more_inverse [simp]: "more (inverse x) = inverse (more x)"
  by (simp add: inverse_Quantity_ext_def)

lemma mag_divide [simp]: "mag (x / y) = mag x / mag y"
  by (simp add: divide_Quantity_ext_def)

lemma dim_divide [simp]: "dim (x / y) = dim x / dim y"
  by (simp add: divide_Quantity_ext_def)

lemma more_divide [simp]: "more (x / y) = more x / more y"
  by (simp add: divide_Quantity_ext_def)

text \<open> As for dimensions, quantities form a commutative monoid and an abelian group. \<close>

instance Quantity_ext :: (comm_monoid_mult, enum, comm_monoid_mult) comm_monoid_mult
  by (intro_classes, simp_all add: eq_unit one_Quantity_ext_def times_Quantity_ext_def mult.assoc
     ,simp add: mult.commute)

instance Quantity_ext :: (ab_group_mult, enum, ab_group_mult) ab_group_mult
  by (intro_classes, rule Quantity_eq_intro, simp_all add: eq_unit)

text \<open> We can also define a partial order on quantities. \<close>

instantiation Quantity_ext :: (ord, enum, ord) ord
begin
  definition less_eq_Quantity_ext :: "('a, 'b, 'c) Quantity_scheme \<Rightarrow> ('a, 'b, 'c) Quantity_scheme \<Rightarrow> bool"
    where "less_eq_Quantity_ext x y = (mag x \<le> mag y \<and> dim x = dim y \<and> more x \<le> more y)"
  definition less_Quantity_ext :: "('a, 'b, 'c) Quantity_scheme \<Rightarrow> ('a, 'b, 'c) Quantity_scheme \<Rightarrow> bool"
    where "less_Quantity_ext x y = (x \<le> y \<and> \<not> y \<le> x)"

instance ..

end

instance Quantity_ext :: (order, enum, order) order
  by (intro_classes, auto simp add: less_Quantity_ext_def less_eq_Quantity_ext_def eq_unit)

text \<open> We can define plus and minus as well, but these are partial operators as they are defined
  only when the quantities have the same dimension. \<close>

instantiation Quantity_ext :: (plus, enum, plus) plus
begin
definition plus_Quantity_ext :: "('a, 'b, 'c) Quantity_scheme \<Rightarrow> ('a, 'b, 'c) Quantity_scheme \<Rightarrow> ('a, 'b, 'c) Quantity_scheme"
    where [si_def]:
    "dim x = dim y \<Longrightarrow>
     plus_Quantity_ext x y = \<lparr> mag = mag x + mag y, dim = dim x, \<dots> = more x + more y \<rparr>"
instance ..
end

instantiation Quantity_ext :: (uminus, enum, uminus) uminus
begin
  definition uminus_Quantity_ext :: "('a, 'b, 'c) Quantity_scheme \<Rightarrow> ('a, 'b, 'c) Quantity_scheme" where
  [si_def]: "uminus_Quantity_ext x = \<lparr> mag = - mag x , dim = dim x, \<dots> = - more x \<rparr>"
instance ..
end

instantiation Quantity_ext :: (minus, enum, minus) minus
begin
  definition minus_Quantity_ext :: "('a, 'b, 'c) Quantity_scheme \<Rightarrow> ('a, 'b, 'c) Quantity_scheme \<Rightarrow> ('a, 'b, 'c) Quantity_scheme" where
  [si_def]:
    "dim x = dim y \<Longrightarrow>
      minus_Quantity_ext x y = \<lparr> mag = mag x - mag y, dim = dim x, \<dots> = more x - more y \<rparr>"
instance ..
end

subsection \<open> Measurement Systems \<close>

class unit_system = unitary

lemma unit_system_intro: "(UNIV::'s set) = {a} \<Longrightarrow> OFCLASS('s, unit_system_class)"
  by (simp add: unit_system_class_def, rule unitary_intro)

record ('a, 'd::enum, 's::unit_system) Measurement_System = "('a, 'd::enum) Quantity" +
  unit_sys  :: 's \<comment> \<open> The system of units being employed \<close>

definition "mmore = Record.iso_tuple_snd Measurement_System_ext_Tuple_Iso"

lemma mmore [simp]: "mmore \<lparr> unit_sys = x, \<dots> = y \<rparr> = y"
  by (metis Measurement_System.ext_inject Measurement_System.ext_surjective comp_id mmore_def)

lemma mmore_ext [simp]: "\<lparr>unit_sys = unit, \<dots> = mmore a\<rparr> = a"
  apply (case_tac a, rename_tac b, case_tac b)
  apply (simp add: Measurement_System_ext_def mmore_def Measurement_System_ext_Tuple_Iso_def Record.iso_tuple_snd_def Record.iso_tuple_cons_def Abs_Measurement_System_ext_inverse)
  apply (rename_tac x y z)
  apply (subgoal_tac "unit = y")
   apply (simp)
  apply (simp add: eq_unit)
  done

lemma Measurement_System_eq_intro:
  assumes "mag x = mag y" "dim x = dim y" "more x = more y"
  shows "x = y"
  by (rule Quantity_eq_intro, simp_all add: assms)
     (metis Measurement_System.surjective Quantity.select_convs(3) assms(3) mmore mmore_ext)

instantiation Measurement_System_ext :: (unit_system, "zero") "zero"
begin
definition zero_Measurement_System_ext :: "('a, 'b) Measurement_System_ext"
    where  [si_def]: "zero_Measurement_System_ext = \<lparr> unit_sys = unit, \<dots> = 0 \<rparr>"
instance ..
end

instantiation Measurement_System_ext :: (unit_system, "one") "one"
begin
definition one_Measurement_System_ext :: "('a, 'b) Measurement_System_ext"
    where  [si_def]: "one_Measurement_System_ext = \<lparr> unit_sys = unit, \<dots> = 1 \<rparr>"
instance ..
end

instantiation Measurement_System_ext :: (unit_system, times) times
begin
definition times_Measurement_System_ext ::
    "('a, 'b) Measurement_System_ext \<Rightarrow> ('a, 'b) Measurement_System_ext \<Rightarrow> ('a, 'b) Measurement_System_ext"
    where  [si_def]: "times_Measurement_System_ext x y = \<lparr> unit_sys = unit, \<dots> = mmore x \<cdot> mmore y \<rparr>"
instance ..
end

instantiation Measurement_System_ext :: (unit_system, inverse) inverse
begin
definition inverse_Measurement_System_ext :: "('a, 'b) Measurement_System_ext \<Rightarrow> ('a, 'b) Measurement_System_ext" where
  [si_def]: "inverse_Measurement_System_ext x = \<lparr> unit_sys = unit, \<dots> = inverse (mmore x) \<rparr>"
definition divide_Measurement_System_ext ::
  "('a, 'b) Measurement_System_ext \<Rightarrow> ('a, 'b) Measurement_System_ext \<Rightarrow> ('a, 'b) Measurement_System_ext"
  where [si_def]: "divide_Measurement_System_ext x y = \<lparr> unit_sys = unit, \<dots> = mmore x / mmore y \<rparr>"
instance ..
end

instance Measurement_System_ext :: (unit_system, comm_monoid_mult) comm_monoid_mult
  by (intro_classes, simp_all add: eq_unit one_Measurement_System_ext_def times_Measurement_System_ext_def mult.assoc, simp add: mult.commute)

instance Measurement_System_ext :: (unit_system, ab_group_mult) ab_group_mult
  by (intro_classes, simp_all add: si_def)

instantiation Measurement_System_ext :: (unit_system, ord) ord
begin
  definition less_eq_Measurement_System_ext :: "('a, 'b) Measurement_System_ext \<Rightarrow> ('a, 'b) Measurement_System_ext \<Rightarrow> bool"
    where "less_eq_Measurement_System_ext x y = (mmore x \<le> mmore y)"
  definition less_Measurement_System_ext :: "('a, 'b) Measurement_System_ext \<Rightarrow> ('a, 'b) Measurement_System_ext \<Rightarrow> bool"
    where "less_Measurement_System_ext x y = (x \<le> y \<and> \<not> y \<le> x)"
instance ..

end

instance Measurement_System_ext :: (unit_system, order) order
  by (intro_classes, simp_all add: less_eq_Measurement_System_ext_def less_Measurement_System_ext_def, metis mmore_ext)

instantiation Measurement_System_ext :: (unit_system, plus) plus
begin
definition plus_Measurement_System_ext ::
  "('a, 'b) Measurement_System_ext \<Rightarrow> ('a, 'b) Measurement_System_ext \<Rightarrow> ('a, 'b) Measurement_System_ext"
    where [si_def]:
    "plus_Measurement_System_ext x y = \<lparr> unit_sys = unit, \<dots> = mmore x + mmore y \<rparr>"
instance ..
end

instantiation Measurement_System_ext :: (unit_system, uminus) uminus
begin
  definition uminus_Measurement_System_ext :: "('a, 'b) Measurement_System_ext \<Rightarrow> ('a, 'b) Measurement_System_ext" where
  [si_def]: "uminus_Measurement_System_ext x = \<lparr> unit_sys = unit, \<dots> = - mmore x \<rparr>"
instance ..
end

instantiation Measurement_System_ext :: (unit_system, minus) minus
begin
  definition minus_Measurement_System_ext ::
    "('a, 'b) Measurement_System_ext \<Rightarrow> ('a, 'b) Measurement_System_ext \<Rightarrow> ('a, 'b) Measurement_System_ext" where
  [si_def]:
    "minus_Measurement_System_ext x y = \<lparr> unit_sys = unit, \<dots> = mmore x - mmore y \<rparr>"
instance ..
end

subsection \<open> Dimension Typed Quantities \<close>

text \<open> We can now define the type of quantities with parametrised dimension types. \<close>

typedef (overloaded) ('n, 'd::dim_type, 's::unit_system) QuantT ("_[_, _]" [999,0,0] 999)
                     = "{x :: ('n, sdim, 's) Measurement_System. dim x = QD('d)}"
  morphisms fromQ toQ by (rule_tac x="\<lparr> mag = undefined, dim = QD('d), unit_sys = unit \<rparr>" in exI, simp)

setup_lifting type_definition_QuantT

text \<open> A dimension typed quantity is parameterised by two types: \<^typ>\<open>'a\<close>, the numeric type for the
  magntitude, and \<^typ>\<open>'d\<close> for the dimension expression, which is an element of \<^class>\<open>dim_type\<close>.
  The type \<^typ>\<open>('n, 'd, 's) QuantT\<close> is to \<^typ>\<open>('n, 'd, 's) Measurement_System\<close> as dimension types
  are to \<^typ>\<open>Dimension\<close>. Specifically, an element of \<^typ>\<open>('n', 'd, 's) QuantT\<close> is a quantity whose
  dimension is \<^typ>\<open>'d\<close>.

  Intuitively, the formula \<^term>\<open>x :: 'n['d, 's]\<close> can be read as ``$x$ is a quantity of \<^typ>\<open>'d\<close>'',
  for example it might be a quantity of length, or a quantity of mass. \<close>

text \<open> Since quantities can have dimension type expressions that are distinct, but denote the same
  dimension, it is necessary to define the following function for coercion between two dimension
  expressions. This requires that the underlying dimensions are the same. \<close>

definition coerceQuantT :: "'d\<^sub>2 itself \<Rightarrow> 'a['d\<^sub>1::dim_type, 's::unit_system] \<Rightarrow> 'a['d\<^sub>2::dim_type, 's]" where
[si_def]: "QD('d\<^sub>1) = QD('d\<^sub>2) \<Longrightarrow> coerceQuantT t x = (toQ (fromQ x))"

syntax
  "_QCOERCE" :: "type \<Rightarrow> logic \<Rightarrow> logic" ("QCOERCE[_]")

translations
  "QCOERCE['t]" == "CONST coerceQuantT TYPE('t)"

subsection \<open> Predicates on Typed Quantities \<close>

text \<open> The standard HOL order \<^term>\<open>(\<le>)\<close> and equality \<^term>\<open>(=)\<close> have the homogeneous type
  \<^typ>\<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close> and so they cannot compare values of different types. Consequently,
  we define a heterogeneous order and equivalence on typed quantities. \<close>

lift_definition qless_eq :: "'n::order['a::dim_type, 's::unit_system] \<Rightarrow> 'n['b::dim_type, 's] \<Rightarrow> bool" (infix "\<lesssim>\<^sub>Q" 50)
  is "(\<le>)" .

lift_definition qequiv :: "'n['a::dim_type, 's::unit_system] \<Rightarrow> 'n['b::dim_type, 's] \<Rightarrow> bool" (infix "\<cong>\<^sub>Q" 50)
  is "(=)" .

text \<open> These are both fundamentally the same as the usual order and equality relations, but they
  permit potentially different dimension types, \<^typ>\<open>'a\<close> and \<^typ>\<open>'b\<close>. Two typed quantities are
  comparable only when the two dimension types have the same semantic dimension.
\<close>

lemma qequiv_refl [simp]: "a \<cong>\<^sub>Q a"
  by (simp add: qequiv_def)

lemma qequiv_sym: "a \<cong>\<^sub>Q b \<Longrightarrow> b \<cong>\<^sub>Q a"
  by (simp add: qequiv_def)

lemma qequiv_trans: "\<lbrakk> a \<cong>\<^sub>Q b; b \<cong>\<^sub>Q c \<rbrakk> \<Longrightarrow> a \<cong>\<^sub>Q c"
  by (simp add: qequiv_def)

theorem qeq_iff_same_dim:
  fixes x y :: "'a['d::dim_type, 's::unit_system]"
  shows "x \<cong>\<^sub>Q y \<longleftrightarrow> x = y"
  by (transfer, simp)

lemma coerceQuant_eq_iff:
  fixes x :: "'a['d\<^sub>1::dim_type, 's::unit_system]"
  assumes "QD('d\<^sub>1) = QD('d\<^sub>2::dim_type)"
  shows "(coerceQuantT TYPE('d\<^sub>2) x) \<cong>\<^sub>Q x"
  by (metis qequiv.rep_eq assms coerceQuantT_def toQ_cases toQ_inverse)

lemma coerceQuant_eq_iff2:
  fixes x :: "'a['d\<^sub>1::dim_type, 's::unit_system]"
  assumes "QD('d\<^sub>1) = QD('d\<^sub>2::dim_type)" and "y = (coerceQuantT TYPE('d\<^sub>2) x)"
  shows "x \<cong>\<^sub>Q y"
  using qequiv_sym assms(1) assms(2) coerceQuant_eq_iff by blast

lemma updown_eq_iff:
  fixes x :: "'a['d\<^sub>1::dim_type, 's::unit_system]" fixes y :: "'a['d\<^sub>2::dim_type, 's]"
  assumes "QD('d\<^sub>1) = QD('d\<^sub>2::dim_type)" and "y = (toQ (fromQ x))"
  shows "x \<cong>\<^sub>Q y"
  by (simp add: assms(1) assms(2) coerceQuant_eq_iff2 coerceQuantT_def)

text\<open>This is more general that \<open>y = x \<Longrightarrow> x \<cong>\<^sub>Q y\<close>, since x and y may have different type.\<close>

lemma qeq:
  fixes x :: "'a['d\<^sub>1::dim_type, 's::unit_system]" fixes y :: "'a['d\<^sub>2::dim_type, 's]"
  assumes "x \<cong>\<^sub>Q y"
  shows "QD('d\<^sub>1) = QD('d\<^sub>2)"
  by (metis (full_types) qequiv.rep_eq assms fromQ mem_Collect_eq)

subsection\<open> Operators on Typed Quantities \<close>

text \<open> We define several operators on typed quantities. These variously compose the dimension types
  as well. Multiplication composes the two dimension types. Inverse constructs and inverted
  dimension type. Division is defined in terms of multiplication and inverse. \<close>

lift_definition
  qtimes :: "('n::comm_ring_1)['a::dim_type, 's::unit_system] \<Rightarrow> 'n['b::dim_type, 's] \<Rightarrow> 'n['a \<cdot>'b, 's]" (infixl "\<^bold>\<cdot>" 69)
  is "(*)" by (simp add: dim_ty_sem_DimTimes_def times_Quantity_ext_def)

lift_definition
  qinverse :: "('n::field)['a::dim_type, 's::unit_system] \<Rightarrow> 'n['a\<^sup>-\<^sup>1, 's]" ("(_\<^sup>-\<^sup>\<one>)" [999] 999)
  is "inverse" by (simp add: inverse_Quantity_ext_def dim_ty_sem_DimInv_def)

abbreviation (input)
  qdivide :: "('n::field)['a::dim_type, 's::unit_system] \<Rightarrow> 'n['b::dim_type, 's] \<Rightarrow> 'n['a/'b, 's]" (infixl "\<^bold>'/" 70) where
"qdivide x y \<equiv> x \<^bold>\<cdot> y\<^sup>-\<^sup>\<one>"

text \<open> We also provide some helpful notations for expressing heterogeneous powers. \<close>

abbreviation qsq         ("(_)\<^sup>\<two>"  [999] 999) where "u\<^sup>\<two> \<equiv> u\<^bold>\<cdot>u"
abbreviation qcube       ("(_)\<^sup>\<three>"  [999] 999) where "u\<^sup>\<three> \<equiv> u\<^bold>\<cdot>u\<^bold>\<cdot>u"
abbreviation qquart      ("(_)\<^sup>\<four>"  [999] 999) where "u\<^sup>\<four> \<equiv> u\<^bold>\<cdot>u\<^bold>\<cdot>u\<^bold>\<cdot>u"

abbreviation qneq_sq     ("(_)\<^sup>-\<^sup>\<two>" [999] 999) where "u\<^sup>-\<^sup>\<two> \<equiv> (u\<^sup>\<two>)\<^sup>-\<^sup>\<one>"
abbreviation qneq_cube   ("(_)\<^sup>-\<^sup>\<three>" [999] 999) where "u\<^sup>-\<^sup>\<three> \<equiv> (u\<^sup>\<three>)\<^sup>-\<^sup>\<one>"
abbreviation qneq_quart  ("(_)\<^sup>-\<^sup>\<four>" [999] 999) where "u\<^sup>-\<^sup>\<four> \<equiv> (u\<^sup>\<three>)\<^sup>-\<^sup>\<one>"

text \<open> Analogous to the \<^const>\<open>scaleR\<close> operator for vectors, we define the following scalar
  multiplication that scales an existing quantity by a numeric value. This operator is
  especially important for the representation of quantity values, which consist of a numeric
  value and a unit. \<close>

lift_definition scaleQ :: "'a \<Rightarrow> 'a::comm_ring_1['d::dim_type, 's::unit_system] \<Rightarrow> 'a['d, 's]" (infixr "*\<^sub>Q" 63)
  is "\<lambda> r x. \<lparr> mag = r * mag x, dim = QD('d), unit_sys = unit \<rparr>" by simp

text \<open> Finally, we instantiate the arithmetic types classes where possible. We do not instantiate
  \<^class>\<open>times\<close> because this results in a nonsensical homogeneous product on quantities. \<close>

instantiation QuantT :: (zero, dim_type, unit_system) zero
begin
lift_definition zero_QuantT :: "('a, 'b, 'c) QuantT" is "\<lparr> mag = 0, dim = QD('b), unit_sys = unit \<rparr>"
  by simp
instance ..
end

instantiation QuantT :: (one, dim_type, unit_system) one
begin
lift_definition one_QuantT :: "('a, 'b, 'c) QuantT" is "\<lparr> mag = 1, dim = QD('b), unit_sys = unit \<rparr>"
  by simp
instance ..
end

text \<open> The following specialised one element has both magnitude and dimension 1: it is a
  dimensionless quantity. \<close>

abbreviation qone :: "'n::one[\<one>, 's::unit_system]" ("\<one>") where "qone \<equiv> 1"

text \<open> Unlike for semantic quantities, the plus operator on typed quantities is total, since the
  type system ensures that the dimensions (and the dimension types) must be the same. \<close>

instantiation QuantT :: (plus, dim_type, unit_system) plus
begin
lift_definition plus_QuantT :: "'a['b, 'c] \<Rightarrow> 'a['b, 'c] \<Rightarrow> 'a['b, 'c]"
  is "\<lambda> x y. \<lparr> mag = mag x + mag y, dim = QD('b), unit_sys = unit \<rparr>"
  by (simp)
instance ..
end

text \<open> We can also show that typed quantities are commutative \<^emph>\<open>additive\<close> monoids. Indeed, addition
  is a much easier operator to deal with in typed quantities, unlike product. \<close>

instance QuantT :: (semigroup_add,dim_type,unit_system) semigroup_add
  by (intro_classes, transfer, simp add: add.assoc)

instance QuantT :: (ab_semigroup_add,dim_type,unit_system) ab_semigroup_add
  by (intro_classes, transfer, simp add: add.commute)

instance QuantT :: (monoid_add,dim_type,unit_system) monoid_add
  by (intro_classes; (transfer, simp add: eq_unit))

instance QuantT :: (comm_monoid_add,dim_type,unit_system) comm_monoid_add
  by (intro_classes; transfer, simp)

instantiation QuantT :: (uminus,dim_type,unit_system) uminus
begin
lift_definition uminus_QuantT :: "'a['b,'c] \<Rightarrow> 'a['b,'c]"
  is "\<lambda> x. \<lparr> mag = - mag x, dim = dim x, unit_sys = unit \<rparr>" by (simp)
instance ..
end

instantiation QuantT :: (minus,dim_type,unit_system) minus
begin
lift_definition minus_QuantT :: "'a['b,'c] \<Rightarrow> 'a['b,'c] \<Rightarrow> 'a['b,'c]"
  is "\<lambda> x y. \<lparr> mag = mag x - mag y, dim = dim x, unit_sys = unit \<rparr>" by (simp)

instance ..
end

instance QuantT :: (numeral,dim_type,unit_system) numeral ..

text \<open> Moreover, types quantities also form an additive group. \<close>

instance QuantT :: (ab_group_add,dim_type,unit_system) ab_group_add
  by (intro_classes, (transfer, simp)+)

text \<open> Typed quantities helpfully can be both partially and a linearly ordered. \<close>

instantiation QuantT :: (order,dim_type,unit_system) order
begin
  lift_definition less_eq_QuantT :: "'a['b,'c] \<Rightarrow> 'a['b,'c] \<Rightarrow> bool" is "\<lambda> x y. mag x \<le> mag y" .
  lift_definition less_QuantT :: "'a['b,'c] \<Rightarrow> 'a['b,'c] \<Rightarrow> bool" is "\<lambda> x y. mag x < mag y" .
instance by (intro_classes, (transfer, simp add: unit_eq less_le_not_le Measurement_System_eq_intro)+)
end

instance QuantT :: (linorder,dim_type,unit_system) linorder
  by (intro_classes, transfer, auto)

instantiation QuantT :: (scaleR,dim_type,unit_system) scaleR
begin
lift_definition scaleR_QuantT :: "real \<Rightarrow> 'a['b,'c] \<Rightarrow> 'a['b,'c]"
is "\<lambda> n q. \<lparr> mag = n *\<^sub>R mag q, dim = dim q, unit_sys = unit \<rparr>" by (simp)
instance ..
end

instance QuantT :: (real_vector,dim_type,unit_system) real_vector
  by (intro_classes, (transfer, simp add: eq_unit scaleR_add_left scaleR_add_right)+)

instantiation QuantT :: (norm,dim_type,unit_system) norm
begin
lift_definition norm_QuantT :: "'a['b,'c] \<Rightarrow> real"
is "\<lambda> x. norm (mag x)" .
instance ..
end

instantiation QuantT :: (sgn_div_norm,dim_type,unit_system) sgn_div_norm
begin
definition sgn_QuantT :: "'a['b,'c] \<Rightarrow> 'a['b,'c]" where
"sgn_QuantT x = x /\<^sub>R norm x"
instance by (intro_classes, simp add: sgn_QuantT_def)
end

instantiation QuantT :: (dist_norm,dim_type,unit_system) dist_norm
begin
definition dist_QuantT :: "'a['b,'c] \<Rightarrow> 'a['b,'c] \<Rightarrow> real" where
"dist_QuantT x y = norm (x - y)"
instance
  by (intro_classes, simp add: dist_QuantT_def)
end

instantiation QuantT :: ("{uniformity_dist,dist_norm}",dim_type,unit_system) uniformity_dist
begin
definition uniformity_QuantT :: "('a['b,'c] \<times> 'a['b,'c]) filter" where
"uniformity_QuantT = (INF e\<in>{0 <..}. principal {(x, y). dist x y < e})"
instance
  by (intro_classes, simp add: uniformity_QuantT_def)
end

instantiation QuantT :: ("{dist_norm,open_uniformity,uniformity_dist}",dim_type,unit_system)
                        open_uniformity
begin

definition open_QuantT :: "('a['b,'c]) set \<Rightarrow> bool" where
"open_QuantT U = (\<forall>x\<in>U. eventually (\<lambda>(x', y). x' = x \<longrightarrow> y \<in> U) uniformity)"
instance by (intro_classes, simp add: open_QuantT_def)
end

text \<open> Quantities form a real normed vector space. \<close>

instance QuantT :: (real_normed_vector,dim_type,unit_system) real_normed_vector
  by (intro_classes; transfer, auto simp add: eq_unit norm_triangle_ineq)

end


(* Title:      Kleene Algebra
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

header {* Omega Algebras *}

theory Omega_Algebra
imports "$AFP/Kleene_Algebra/Kleene_Algebra"
begin

text {*
\emph{Omega algebras}~\cite{cohen00omega} extend Kleene algebras by an
$\omega$-operation that axiomatizes infinite iteration (just like the
Kleene star axiomatizes finite iteration).
*}

subsection {* Left Omega Algebras *}

text {*
In this section we consider \emph{left omega algebras}, i.e., omega
algebras based on left Kleene algebras. Surprisingly, we are still
looking for statements mentioning~$\omega$ that are true in omega
algebras, but do not already hold in left omega algebras.
*}

class left_omega_algebra_zerol = left_kleene_algebra_zerol + omega_op +
  assumes omega_unfold_eq [simp]: "x \<cdot> x\<^sup>\<omega> = x\<^sup>\<omega>"
  and omega_coinduct: "y \<le> z + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
begin

lemma omega_unfold: "x\<cdot>x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
  by (metis omega_unfold_eq order_refl)

lemma omega_zeror: "x\<^sup>\<star>\<cdot>0 \<le> x\<^sup>\<omega>"
  apply (rule star_inductl[rule_format])
  by (simp add: omega_unfold)

text {* First we prove some variants of the coinduction axiom. *}

lemma omega_coinduct_var2: "y \<le> x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega>"
  by (auto intro: omega_coinduct[where z = 0, simplified, rule_format])

lemma omega_coinduct_var1: "y \<le> 1 + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star>"
  by (metis mult_oner omega_coinduct)

lemma omega_coinduct_eq: "y = z + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
  by (metis eq_refl omega_coinduct)

lemma omega_coinduct_eq_var1: "y = 1 + x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega> + x\<^sup>\<star>"
  by (metis eq_refl omega_coinduct_var1)

lemma  omega_coinduct_eq_var2: "y = x \<cdot> y \<Longrightarrow> y \<le> x\<^sup>\<omega>"
  by (metis eq_refl omega_coinduct_var2)

text {* Next we strengthen the unfold law to an equation. *}

lemma omega_unfold_var: "z + x \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
  by (metis add_lub add_ub1 omega_coinduct omega_unfold_eq)

text {* We now prove subdistributivity and isotonicity of omega. *}

lemma omega_subdist: "x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
proof -
  have "x\<^sup>\<omega> \<le> (x + y) \<cdot> x\<^sup>\<omega>"
    by (metis add_ub1 mult_isor omega_unfold_eq)
  thus ?thesis
    by (metis omega_coinduct_var2)
qed

lemma omega_iso: "x \<le> y \<longrightarrow> x\<^sup>\<omega> \<le> y\<^sup>\<omega>"
  by (metis less_eq_def omega_subdist)

lemma omega_subdist_var: "x\<^sup>\<omega> + y\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
  by (metis add.commute add_lub omega_subdist)

lemma zero_omega [simp]: "0\<^sup>\<omega> = 0"
  by (metis annil omega_unfold_eq)

text {* The next lemma is another variant of omega unfold *}

lemma star_omega_1 [simp]: "x\<^sup>\<star> \<cdot> x\<^sup>\<omega> = x\<^sup>\<omega>"
proof (rule antisym)
  have "x \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
    by (metis eq_refl omega_unfold_eq)
  thus "x\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
    by (metis star_inductl_var)
  show "x\<^sup>\<omega> \<le> x\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
    by (metis star_ref mult_isor mult_onel)
qed

text {* The next lemma says that~@{term "1\<^sup>\<omega>"} is the maximal element
of omega algebra. We therefore baptise it~$\top$. *}

lemma max_element: "x \<le> 1\<^sup>\<omega>"
  by (metis eq_refl mult_onel omega_coinduct_var2)

definition omega_top ("\<top>")
  where "\<top> = 1\<^sup>\<omega>"

lemma star_omega_3 [simp]: "(x\<^sup>\<star>)\<^sup>\<omega> = \<top>"
proof -
  have "1 \<le> x\<^sup>\<star>"
    by (fact star_ref)
  hence "\<top> \<le> (x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis omega_iso omega_top_def)
  thus ?thesis
    by (metis eq_iff max_element omega_top_def)
qed

text {* The following lemma is strange since it is counterintuitive
that one should be able to append something after an infinite
iteration. *}

lemma omega_1: "x\<^sup>\<omega> \<cdot> y \<le> x\<^sup>\<omega>"
proof -
  have "x\<^sup>\<omega> \<cdot> y \<le> x \<cdot> x\<^sup>\<omega> \<cdot> y"
    by (metis eq_refl omega_unfold_eq)
  thus ?thesis
    by (metis mult.assoc omega_coinduct_var2)
qed

lemma omega_sup_id: "1 \<le> y \<longrightarrow> x\<^sup>\<omega> \<cdot> y = x\<^sup>\<omega>"
  by (metis eq_iff mult_isol mult_oner omega_1)

lemma omega_top [simp]: "x\<^sup>\<omega> \<cdot> \<top> = x\<^sup>\<omega>"
  by (metis max_element omega_sup_id omega_top_def)

lemma supid_omega: "1 \<le> x \<longrightarrow> x\<^sup>\<omega> = \<top>"
  by (metis eq_iff max_element omega_iso omega_top_def)

text {* Next we prove a simulation law for the omega operation *}

lemma omega_simulation: "z \<cdot> x \<le> y \<cdot> z \<longrightarrow> z \<cdot> x\<^sup>\<omega> \<le> y\<^sup>\<omega>"
proof
  assume "z \<cdot> x \<le> y \<cdot> z"
  also have "z \<cdot> x\<^sup>\<omega> = z \<cdot> x \<cdot> x\<^sup>\<omega>"
    by (metis mult.assoc omega_unfold_eq)
  moreover have "... \<le> y \<cdot> z \<cdot> x\<^sup>\<omega>"
    by (metis mult_isor calculation)
  thus "z \<cdot> x\<^sup>\<omega> \<le> y\<^sup>\<omega>"
    by (metis calculation mult.assoc omega_coinduct_var2)
qed

text {* Next we prove transitivity of omega elements. *}

lemma omega_trans: "x\<^sup>\<omega> \<cdot> x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
  by (fact omega_1)

lemma omega_omega: "(x\<^sup>\<omega>)\<^sup>\<omega> \<le> x\<^sup>\<omega>"
  by (metis omega_1 omega_unfold_eq)

text {* The next lemmas are axioms of Wagner's complete axiomatisation
for omega-regular languages~\cite{Wagner77omega}, but in a slightly
different setting.  *}

lemma wagner_1 [simp]: "(x \<cdot> x\<^sup>\<star>)\<^sup>\<omega> = x\<^sup>\<omega>"
proof (rule antisym)
  have "(x \<cdot> x\<^sup>\<star>)\<^sup>\<omega> = x \<cdot> x\<^sup>\<star> \<cdot> x \<cdot> x\<^sup>\<star> \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis mult.assoc omega_unfold_eq)
  also have "... = x \<cdot> x \<cdot> x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis mult.assoc star_slide_var)
  also have "... = x \<cdot> x \<cdot> x\<^sup>\<star> \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis mult.assoc star_trans_eq)
  also have "... = x \<cdot> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis mult.assoc omega_unfold_eq)
  thus "(x \<cdot> x\<^sup>\<star>)\<^sup>\<omega> \<le> x\<^sup>\<omega>"
    by (metis calculation eq_refl omega_coinduct_var2)
   show "x\<^sup>\<omega> \<le> (x \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis mult_isol mult_oner omega_iso star_ref)
qed

lemma wagner_2_var: "x \<cdot> (y \<cdot> x)\<^sup>\<omega> \<le> (x \<cdot> y)\<^sup>\<omega>"
proof -
  have "x \<cdot> y \<cdot> x \<le> x \<cdot> y \<cdot> x"
    by auto
  thus "x \<cdot> (y \<cdot> x)\<^sup>\<omega> \<le> (x \<cdot> y)\<^sup>\<omega>"
    by (metis mult.assoc omega_simulation)
qed

lemma wagner_2 [simp]: "x \<cdot> (y \<cdot> x)\<^sup>\<omega> = (x \<cdot> y)\<^sup>\<omega>"
proof (rule antisym)
  show "x \<cdot> (y \<cdot> x)\<^sup>\<omega> \<le> (x \<cdot> y)\<^sup>\<omega>"
    by (rule wagner_2_var)
  have "(x \<cdot> y)\<^sup>\<omega> = x \<cdot> y \<cdot> (x \<cdot> y)\<^sup>\<omega>"
    by (metis omega_unfold_eq)
  thus "(x \<cdot> y)\<^sup>\<omega> \<le> x \<cdot> (y \<cdot> x)\<^sup>\<omega>"
    by (metis mult.assoc mult_isol wagner_2_var)
qed

text {*
This identity is called~(A8) in Wagner's paper.
*}

lemma wagner_3:
assumes "x \<cdot> (x + y)\<^sup>\<omega> + z = (x + y)\<^sup>\<omega>"
shows "(x + y)\<^sup>\<omega> = x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
proof (rule antisym)
  show  "(x + y)\<^sup>\<omega> \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
    by (metis add.commute assms omega_coinduct_eq)
  have "x\<^sup>\<star> \<cdot> z \<le> (x + y)\<^sup>\<omega>"
    by (metis add.commute assms star_inductl_eq)
  thus "x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z \<le> (x + y)\<^sup>\<omega>"
    by (metis add_lub omega_subdist)
qed

text {*
This identity is called~(R4) in Wagner's paper.
*}

lemma wagner_1_var [simp]: "(x\<^sup>\<star> \<cdot> x)\<^sup>\<omega> = x\<^sup>\<omega>"
  by (metis star_slide_var wagner_1)

lemma star_omega_4 [simp]: "(x\<^sup>\<omega>)\<^sup>\<star> = 1 + x\<^sup>\<omega>"
proof (rule antisym)
  have "(x\<^sup>\<omega>)\<^sup>\<star> = 1 + x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star>"
    by simp
  also have "... \<le> 1 + x\<^sup>\<omega> \<cdot> \<top>"
    by (metis add_iso_var eq_refl omega_1 omega_top)
  thus "(x\<^sup>\<omega>)\<^sup>\<star> \<le> 1 + x\<^sup>\<omega>"
    by (metis calculation omega_top)
  show "1 + x\<^sup>\<omega> \<le> (x\<^sup>\<omega>)\<^sup>\<star>"
    by (metis star2 star_ext)
qed

lemma star_omega_5 [simp]: "x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star> = x\<^sup>\<omega>"
proof (rule antisym)
  show "x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star> \<le> x\<^sup>\<omega>"
    by (rule omega_1)
  show "x\<^sup>\<omega> \<le> x\<^sup>\<omega> \<cdot> (x\<^sup>\<omega>)\<^sup>\<star>"
    by (metis mult_oner star_ref mult_isol)
qed

text {* The next law shows how omegas below a sum can be unfolded. *}

lemma omega_sum_unfold: "x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y \<cdot> (x + y)\<^sup>\<omega> = (x + y)\<^sup>\<omega>"
proof -
  have "(x + y)\<^sup>\<omega> = x \<cdot> (x + y)\<^sup>\<omega> + y \<cdot> (x+y)\<^sup>\<omega>"
    by (metis distrib_right omega_unfold_eq)
  thus ?thesis
    by (metis mult.assoc wagner_3)
qed

text {*
The next two lemmas apply induction and coinduction to this law.
*}

lemma omega_sum_unfold_coind: "(x + y)\<^sup>\<omega> \<le> (x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
  by (metis omega_coinduct_eq omega_sum_unfold)

lemma omega_sum_unfold_ind: "(x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
  by (metis omega_sum_unfold star_inductl_eq)

lemma wagner_1_gen: "(x \<cdot> y\<^sup>\<star>)\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
proof -
  have "(x \<cdot> y\<^sup>\<star>)\<^sup>\<omega> \<le> ((x + y) \<cdot> (x + y)\<^sup>\<star>)\<^sup>\<omega>"
    by (metis add_ub1 add_ub2 mult_isol_var omega_iso star_iso)
  thus ?thesis
    by (metis wagner_1)
qed

lemma wagner_1_var_gen: "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
proof -
  have "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> = x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<omega>"
    by (metis wagner_2)
  also have "... \<le> x\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
    by (metis add.commute mult_isol wagner_1_gen)
  also have "... \<le> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
    by (metis add_ub1 mult_isor star_iso)
  thus ?thesis
    by (metis calculation order_trans star_omega_1)
qed

text {* The next lemma is a variant of the denest law for the star at
the level of omega. *}

lemma omega_denest [simp]: "(x + y)\<^sup>\<omega> = (x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
proof (rule antisym)
  show "(x + y)\<^sup>\<omega> \<le> (x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega>"
    by (rule omega_sum_unfold_coind)
  have "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> \<le>  (x + y)\<^sup>\<omega>"
    by (rule wagner_1_var_gen)
  hence "(x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
    by (metis omega_sum_unfold_ind)
  thus "(x\<^sup>\<star> \<cdot> y)\<^sup>\<omega> + (x\<^sup>\<star> \<cdot> y)\<^sup>\<star> \<cdot> x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
    by (metis add_lub wagner_1_var_gen)
qed

text {* The next lemma yields a separation theorem for infinite
iteration in the presence of a quasicommutation property. A
nondeterministic loop over~@{term x} and~@{term y} can be refined into
separate infinite loops over~@{term x} and~@{term y}.  *}

lemma omega_sum_refine:
  assumes "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  shows "(x + y)\<^sup>\<omega> = x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y\<^sup>\<omega>"
proof (rule antisym)
  have "y\<^sup>\<star> \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
    by (metis assms quasicomm_var)
  also have "(x + y)\<^sup>\<omega> = y\<^sup>\<omega> + y\<^sup>\<star> \<cdot> x \<cdot> (x + y)\<^sup>\<omega>"
    by (metis add.commute omega_sum_unfold)
  moreover have "... \<le> x \<cdot> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega> + y\<^sup>\<omega>"
    by (metis add_iso add_lub add_ub2 calculation(1) mult_isor)
  moreover have "... \<le> x \<cdot> (x + y)\<^sup>\<omega> + y\<^sup>\<omega>"
    by (metis mult.assoc order_refl star_omega_1)
  thus "(x + y)\<^sup>\<omega> \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y\<^sup>\<omega>"
    by (metis add.commute calculation mult.assoc omega_coinduct star_omega_1)
  have "x\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
    by (rule omega_subdist)
  moreover have "x\<^sup>\<star> \<cdot> y\<^sup>\<omega> \<le> x\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
    by (metis calculation add_ub1 mult_isol)
  moreover have"... \<le> (x + y)\<^sup>\<star> \<cdot> (x + y)\<^sup>\<omega>"
    by (metis add_ub1 star_iso mult_isor)
  moreover have "... = (x + y)\<^sup>\<omega>"
     by (rule star_omega_1)
   thus "x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> y\<^sup>\<omega> \<le> (x + y)\<^sup>\<omega>"
     by (metis add.commute add_lub calculation mult_isol omega_subdist order_trans star_omega_1)
qed

text {* The following theorem by Bachmair and
Dershowitz~\cite{bachmair86commutation} is a corollary. *}

lemma bachmair_dershowitz:
  assumes "y \<cdot> x \<le> x \<cdot> (x + y)\<^sup>\<star>"
  shows "(x + y)\<^sup>\<omega> = 0 \<longleftrightarrow> x\<^sup>\<omega> + y\<^sup>\<omega> = 0"
proof
  assume "(x + y)\<^sup>\<omega> = 0"
  show "x\<^sup>\<omega> + y\<^sup>\<omega> = 0"
    by (metis `(x + y)\<^sup>\<omega> = (0\<Colon>'a)` omega_subdist_var zero_unique)
next
  assume "x\<^sup>\<omega> + y\<^sup>\<omega> = 0"
  show "(x + y)\<^sup>\<omega> = 0"
    by (metis `x\<^sup>\<omega> + y\<^sup>\<omega> = (0\<Colon>'a)` assms no_trivial_inverse omega_sum_refine distrib_left star_omega_1)
qed

text {*
The next lemmas consider an abstract variant of the empty word
property from language theory and match it with the absence of
infinite iteration~\cite{struth12regeq}.
*}

definition (in dioid_one_zerol) ewp
where "ewp x \<equiv> \<not>(\<forall>y. y \<le> x \<cdot> y \<longrightarrow> y = 0)"

lemma ewp_super_id1: "0 \<noteq> 1 \<longrightarrow> 1 \<le> x \<longrightarrow> ewp x"
  by (metis ewp_def mult_1_right)

text {* The next facts relate the absence of the empty word property
with the absence of infinite iteration. *}

lemma ewp_neg_and_omega: "\<not> ewp x \<longleftrightarrow> x\<^sup>\<omega> = 0"
proof
  assume "\<not> ewp x"
  hence a: "\<forall>y. y \<le> x \<cdot> y \<longrightarrow> y = 0"
    by (metis ewp_def)
  thus "x\<^sup>\<omega> = 0"
    by (metis eq_refl omega_unfold_eq)
next
  assume "x\<^sup>\<omega> = 0"
  hence "\<forall> y. y \<le> x \<cdot> y \<longrightarrow> y = 0"
    by (metis omega_coinduct_var2 zero_unique)
  thus "\<not> ewp x"
    by (metis ewp_def)
qed

lemma ewp_alt1: "(\<forall>z. x\<^sup>\<omega> \<le> x\<^sup>\<star> \<cdot> z) \<longleftrightarrow> (\<forall>y z. y \<le> x \<cdot> y + z \<longrightarrow> y \<le> x\<^sup>\<star> \<cdot> z)"
  by (metis add_comm less_eq_def omega_coinduct omega_unfold_eq order_prop)

(*
lemma ewp_alt: "x\<^sup>\<omega> = 0 \<longleftrightarrow> (\<forall>y z. y \<le> x \<cdot> y + z \<longrightarrow> y \<le> x\<^sup>\<star> \<cdot> z)"
  nitpick [expect = genuine]
oops
*)

text {* So we have obtained a condition for Arden's lemma in omega
algebra.  *}

lemma omega_super_id1: "0 \<noteq> 1 \<longrightarrow> 1 \<le> x \<longrightarrow> x\<^sup>\<omega> \<noteq> 0"
  by (metis eq_iff max_element omega_iso zero_least)

lemma omega_super_id2: "0 \<noteq> 1 \<longrightarrow> x\<^sup>\<omega> = 0 \<longrightarrow> \<not>(1 \<le> x)"
  by (metis omega_super_id1)

text {* The next lemmas are abstract versions of Arden's lemma from
language theory.  *}

lemma ardens_lemma_var:
  assumes "x\<^sup>\<omega> = 0" and  "z + x \<cdot> y = y"
  shows "x\<^sup>\<star> \<cdot> z = y"
proof -
  have "y \<le> x\<^sup>\<omega> + x\<^sup>\<star> \<cdot> z"
    by (metis assms omega_coinduct order_refl)
  hence "y \<le> x\<^sup>\<star> \<cdot> z"
    by (metis add_zero_l assms)
  thus "x\<^sup>\<star> \<cdot> z = y"
    by (metis assms eq_iff star_inductl_eq)
qed

lemma ardens_lemma: "\<not> ewp x \<longrightarrow> z + x \<cdot> y = y \<longrightarrow> x\<^sup>\<star> \<cdot> z = y"
  by (metis ardens_lemma_var ewp_neg_and_omega)

lemma ardens_lemma_equiv:
  assumes "\<not> ewp x"
  shows "z + x \<cdot> y = y \<longleftrightarrow> x\<^sup>\<star> \<cdot> z = y"
proof
  assume "z + x \<cdot> y = y"
  thus "x\<^sup>\<star> \<cdot> z = y"
    by (metis ardens_lemma assms)
next
  assume "x\<^sup>\<star> \<cdot> z = y"
  also have "z + x \<cdot> y = z + x \<cdot> x\<^sup>\<star> \<cdot> z"
    by (metis calculation mult.assoc)
  moreover have "... = (1 + x \<cdot> x\<^sup>\<star>) \<cdot> z"
    by (metis distrib_right mult_onel)
  moreover have "... = x\<^sup>\<star> \<cdot> z"
    by (metis star_unfoldl_eq)
  thus "z + x \<cdot> y = y"
    by (metis calculation)
qed

lemma ardens_lemma_var_equiv: "x\<^sup>\<omega> = 0 \<longrightarrow> (z + x \<cdot> y = y \<longleftrightarrow> x\<^sup>\<star> \<cdot> z = y)"
  by (metis ardens_lemma_equiv ewp_neg_and_omega)

lemma inf_star [simp]: "(x\<cdot>0)\<^sup>\<star> = 1 + x\<cdot>0"
  apply (rule antisym)
  apply (rule star_inductl_one[rule_format])
  apply (metis annil mult_assoc order_refl)
  by (metis add_lub star_ext star_ref)

lemma [simp]: "x \<cdot> 0 \<cdot> y = x \<cdot> 0"
  by (metis annil mult_assoc)

lemma inf_part_star1: "(y + x\<cdot>0)\<^sup>\<star> \<le> y\<^sup>\<star>\<cdot>x\<cdot>0 + y\<^sup>\<star>"
  apply (rule star_inductl_one[rule_format])
  apply (subst star_unfoldl_eq[symmetric]) back back
  apply (subst star_unfoldl_eq[symmetric]) back back back
  apply (simp only: distrib_right distrib_left mult_assoc[symmetric])
  apply (simp add: distrib_left)
  by (metis add_assoc' add_idem' add_iso add_left_commute combine_common_factor distrib_right' star_unfoldl)

lemma inf_part_star [simp]: "(y + x\<cdot>0)\<^sup>\<star> = y\<^sup>\<star>\<cdot>x\<cdot>0 + y\<^sup>\<star>"
  apply (rule antisym)
  apply (metis inf_part_star1)
  by (metis add_commute add_lub mult_assoc prod_star_closure star_subdist star_subdist_var_1)

(*
lemma arden_conv1: "(\<forall>y z. z + x \<cdot> y = y \<longrightarrow> x\<^sup>\<star> \<cdot> z = y) \<longrightarrow> \<not> ewp x"
  nitpick [expect = genuine]
oops

lemma arden_conv2: "(\<forall>y z. z + x \<cdot> y = y \<longrightarrow> x\<^sup>\<star> \<cdot> z = y) \<longrightarrow> x\<^sup>\<omega> = 0"
  nitpick [expect = genuine]
oops

lemma arden_var3: "(\<forall>y z. z + x \<cdot> y = y \<longrightarrow> x\<^sup>\<star> \<cdot> z = y) \<longleftrightarrow> x\<^sup>\<omega> = 0"
  nitpick [expect = genuine]
oops
*)

end

end