theory Cancellation
imports "FreeGroupMain"  "HOL-Proofs-Lambda.Commutation"
begin

text \<open>This file contains sections that are adapted from the Cancelation.thy,
available in the formalisation of Free Groups, by Joachim Breitner,
available in Archive of Formal Proofs.
 The formalisation is available on
 https://isa-afp.org/entries/Free-Groups.html.
Parts where they are either reproduced or adapted, as explicitly mentioned.\<close>

subsection \<open>Defining cancellation functions and some basic properties\<close>

text \<open>The following definitions are directly reproduced from Theory Cancellation.
They correspond to a term rewrite system on words, whose reflective symmetric
transitive close is the equivalence relation on words, involved in the definition
of free groups\<close>

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

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))"

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)"

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

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)^**"

text\<open>Cancellation with append\<close>

lemma cancel_at_leftappend:
  assumes "i\<ge>0"
      and "(1+i) < length xs"
      and "cancel_at i xs = ys"
    shows "cancel_at (length zs + i) (zs@xs) = (zs@ys)"
proof-
  have "zs@(take i xs) = take (length zs + i) (zs@xs)" using assms(1) assms(2) by auto
  moreover have "drop (i+2) xs = drop (length zs + (i+2)) (zs@xs)"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"
      and "(1+i) < length xs"
      and "cancel_at i xs = ys"
    shows "cancel_at i (xs@zs) = (ys@zs)"
proof-
  have "take i (xs@zs) = take i xs" using assms(1) assms (2) by simp
  moreover have "(drop (2 + i) xs)@zs = drop (2+i) (xs@zs)" using assms(1) assms(2) by simp
  ultimately show ?thesis unfolding cancel_at_def by (metis append.assoc assms(3) cancel_at_def)
qed

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

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

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

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

lemma cancels_to_leftappend:
  "cancels_to xs ys \<longrightarrow> cancels_to (zs@xs) (zs@ys)"
  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 (zs@b) (zs@c)"by (simp add: cancels_to_1_leftappend)
  have "cancels_to_1\<^sup>*\<^sup>* (zs @ a) (zs @ b)" by (simp add: rtrancl_into_rtrancl.IH)
  then show "cancels_to_1\<^sup>*\<^sup>* (zs @ a) (zs @ c)" using 1 by auto
qed

lemma cancels_to_rightappend:
 "cancels_to xs ys \<longrightarrow> cancels_to (xs@zs) (ys@zs)"
  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@zs) (c@zs)"by (simp add: cancels_to_1_rightappend)
  have "cancels_to_1\<^sup>*\<^sup>* (a@zs) (b@zs)" by (simp add: rtrancl_into_rtrancl.IH)
  then show "cancels_to_1\<^sup>*\<^sup>* (a@zs) (c@zs)" using 1 by auto
qed

lemma cancels_eq_leftappend:
"cancels_eq xs ys \<longrightarrow> cancels_eq (zs@xs) (zs@ys)"
  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 (zs@b) (zs@c) \<or> cancels_to (zs@c) (zs@b)" using cancels_to_leftappend by blast
  have "(\<lambda> wrd1 wrd2. cancels_to wrd1 wrd2 \<or> cancels_to wrd2 wrd1)\<^sup>*\<^sup>* (zs @ a) (zs @ b)" by (simp add: rtrancl_into_rtrancl.IH)
  then show "(\<lambda> wrd1 wrd2. cancels_to wrd1 wrd2 \<or> cancels_to wrd2 wrd1)\<^sup>*\<^sup>* (zs @ a) (zs @ c)" unfolding cancels_eq_def using 1  by (metis (no_types, lifting) rtranclp.simps)
qed

lemma cancels_eq_rightappend:
  "cancels_eq xs ys \<longrightarrow> cancels_eq (xs@zs) (ys@zs)"
  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@zs) (c@zs) \<or> cancels_to (c@zs) (b@zs)" using cancels_to_rightappend by auto
  have "(\<lambda> wrd1 wrd2. cancels_to wrd1 wrd2 \<or> cancels_to wrd2 wrd1)\<^sup>*\<^sup>* (a@zs) (b@zs)" by (simp add: rtrancl_into_rtrancl.IH)
  then show "(\<lambda> wrd1 wrd2. cancels_to wrd1 wrd2 \<or> cancels_to wrd2 wrd1)\<^sup>*\<^sup>* (a@zs) (c@zs)" unfolding cancels_eq_def using 1  by (metis (no_types, lifting) rtranclp.simps)
qed

text \<open>Relating cancellation and reduction.\<close>

lemma cancels_to_1_at_not_reduced:
  assumes "reduced xs"
    shows "\<not>(\<exists>i. i<(length xs - 1) \<and> xs!i = inverse (xs!(i+1)))"
  using assms
proof(induction xs)
  case Nil
  then show ?case  by auto
next
  case (Cons a xs)
  then have xs:"reduced xs" by (metis (mono_tags, lifting) reduced.elims(3) reduced.simps(3))
  then show ?case
  proof(cases "xs = []")
    case True
    then have "(a#xs) = [a]" by simp
    then have "length (a#xs) = 1" by simp
    then show ?thesis using Cons by auto
  next
    case False
    then have gnil: "xs \<noteq> []"  by auto
    then show ?thesis
    proof(cases "length xs = 1")
      case True
      then obtain b where "xs = [b]"  using length_Cons reduced.elims(2) xs by fastforce
      then have 1:"(a#xs) = (a#[b])" by simp
      then have 2:"length (a#xs) = 2" by auto
      then show ?thesis
      proof(cases "a = inverse b")
        case True
        then have "\<not> reduced (a#xs)" using 1 by auto
  then show ?thesis using Cons by blast
next
  case False
  then have "(a # xs) ! 0 \<noteq> inverse ((a # xs) ! (0 + 1))" using 1  by simp
  then show ?thesis using 2  by force
qed
next
  case False
  then have "1 < length xs" using gnil  nat_neq_iff by auto
  then have ix:"\<not> (\<exists>i<length xs - 1. xs ! i = inverse (xs ! (i + 1)))" using xs Cons by blast
  let ?x = "hd xs"
  show ?thesis
  proof(cases "a = inverse ?x")
    case True
    then have "\<not> reduced (a#xs)"  by (metis gnil list.exhaust_sel reduced.simps(3))
then show ?thesis using Cons by blast
next
  case False
  then show ?thesis using ix
    by (metis (no_types, opaque_lifting) Suc_eq_plus1 Suc_length_conv
            diff_Suc_1 gnil hd_conv_nth less_diff_conv nat_neq_iff
            nth_Cons_Suc nth_non_equal_first_eq old.nat.exhaust)
qed
qed
qed
qed

lemma not_reduced_cancels_to_1_at:
  assumes "\<not> reduced xs"
    shows "(\<exists>i .i<(length xs - 1)\<and> xs!i = inverse (xs!(i+1)))"
proof(rule ccontr)
  assume assm: "\<not>(\<exists>i .i<(length xs - 1)\<and>  xs!i = inverse (xs!(i+1)))"
  then have  "\<not>(\<exists>i .i<(length xs - 1)\<and> xs!i = inverse (xs!(i+1)))" by simp
  then have "reduced xs"
  proof(induction xs rule:reduced.induct)
    case 1
    then show ?case by simp
  next
    case (2 g)
    then show ?case by simp
  next
    case (3 g h wrd)
    then have 1: "g \<noteq> inverse h"  by force
    moreover have " \<not> (\<exists>i<length (h # wrd) - 1. (h # wrd) ! i = inverse ((h # wrd) ! (i + 1)))" using 3  using BNF_Greatest_Fixpoint.length_Cons add.commute add_diff_cancel_left' by auto
    ultimately have "reduced (h # wrd)" using 3 by simp
    then show ?case using 1 by simp
  qed
  then show False using assms by blast
qed

lemma cancels_imp_rel:
  "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

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

lemma reduced_rightappend:
  assumes "reduced (xs@ys)"
    shows "reduced xs"
  using assms
proof (induction xs rule : reduced.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.prems" by force
next
  case False
  have "reduced ((g2 # wrd) @ ys)"
    by (metis "3.prems" append_Cons reduced.simps(3))
  then have "reduced (g2#wrd)"  by (simp add: "3.IH" False)
  then show ?thesis by (simp add: False)
qed
qed

lemma reduced_leftappend:
  assumes "reduced (xs@ys)"
    shows "reduced ys"
  using assms
proof(induction xs rule:reduced.induct)
  case (2 g)
  then show ?case using reduced.simps
    by (metis append_Cons append_Nil list.exhaust)
next
  case (3 g h wrd)
  then show ?case
    by force
qed (simp)

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

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

lemma cancels_to_1_red:
  assumes "reduced xs"
    shows "\<forall>ys. \<not>(cancels_to_1 xs ys)"
proof(rule ccontr)
  assume assm : "\<not>(\<forall>ys. \<not>(cancels_to_1 xs ys))"
  then have "\<exists>ys. cancels_to_1 xs ys" by simp
  then obtain ys where y: "cancels_to_1 xs ys" by auto
  then have 1: "\<exists>i\<ge>0. cancels_to_1_at i xs ys"
    unfolding cancels_to_1_def cancels_to_1_at_def by simp
  then have "reduced xs = False" using "1" using reduced_no_cancels_to_1_at by auto
  then show "False" using assms by simp
qed

lemma reduced_normal:
  assumes "reduced xs"
    shows "(\<not> Domainp cancels_to_1 xs)"
proof-
  show ?thesis using assms cancels_to_1_red by (simp add: cancels_to_1_red Domainp.simps)
qed

lemma eq_symp:
  "cancels_eq = (symclp cancels_to)^**"
  unfolding cancels_eq_def symclp_def
  by simp

lemma symp_sup:
  "(symclp cancels_to)^** = (sup cancels_to cancels_to^--1)^**"
proof-
  show ?thesis using symclp_pointfree[of "cancels_to"] by metis
qed

lemma sympstar:
  "(symclp cancels_to)^** = (symclp cancels_to_1)^**"
proof-
  have 1:"(symclp cancels_to)^** = (sup cancels_to cancels_to^--1)^**" using symp_sup by simp
  have 2: "... = (sup cancels_to_1^** (cancels_to_1^**)^--1)^**" using cancels_to_def by metis
  have 3: "... = (sup cancels_to_1 cancels_to_1^--1)^**" using rtranclp_sup_rtranclp rtranclp_conversep by metis
  have 4: "... = (symclp cancels_to_1)^**"  using symclp_pointfree[of "cancels_to_1"] by metis
  show ?thesis by(simp add: 1 2 3 4)
qed

text\<open>A few useful lemmas about order of cancellation\<close>

lemma a1:
  assumes "j \<ge> 0"
      and "j + 2 < length xs"
    shows "take j xs @ drop (2+j) xs = take j xs @ [nth xs (2+j)] @  drop (2+(1+j)) xs"
  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"
      and "j + 2 < length xs"
    shows "take (j+1) xs @ drop (2+(j+1)) xs = take j xs @ [nth xs j] @  drop (2+(1+j)) xs"
  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 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 False \<open>drop (j + 2) (a # xs) = drop (j + 1) xs\<close> ab_semigroup_add_class.add_ac(1) drop_Cons' 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"
    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"
      and "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, ccfv_SIG) Cons.prems(1) False Nat.add_diff_assoc2 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, opaque_lifting) False append_eq_Cons_conv linordered_nonzero_semiring_class.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 xs = take i ys" "i \<ge> 0" "j < i"
    shows "(nth xs j) = (nth ys j)"
  by (metis assms(1) assms(3) nth_take)

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

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

lemma cancel_atnth:
  assumes "j > i + 1"
      and "j < length xs"
    shows "(nth xs j) = (nth (cancel_at i xs) (j-2))"
  using assms
  unfolding cancel_at_def
  proof(induction xs 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_add_inverse2 diff_diff_left less_diff_conv less_nat_zero_code nat_1_add_1 nth_Cons')
  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: "(x#(ys@zs)) = ((x#ys)@zs)"
  by simp

lemma cancel_at_length:
  assumes "0 \<le> i"
      and "i + 1 < length xs"
    shows "length (cancel_at i xs) = (length xs) - 2"
  using assms
  unfolding cancel_at_def
proof(induction xs 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 Cancellation.length_Cons Cons.prems(2) True comm diff_add_inverse2 le_neq_implies_less nat_neq_iff)
  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) 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 rtrancancel:
  assumes "((\<exists>i. cancels_to_1_at i xs ys) \<or> xs = ys)"
    shows "cancels_to xs ys"
  by (metis assms cancels_to_1_def cancels_to_def rtranclp.simps)

text \<open>Some useful term re-writing lemmas. These are directly reproduced from
        Theory Cancellation.\<close>

theorem lconfluent_confluent:
  "\<lbrakk> wfP (R^--1); \<And>a b c. R a b \<Longrightarrow> R a c \<Longrightarrow> \<exists>d. R^** b d \<and> R^** c d  \<rbrakk> \<Longrightarrow> confluent R"
by(auto simp add: diamond_def commute_def square_def intro: newman)

lemma confluentD:
  "\<lbrakk> confluent R; R^** a b; R^** a c  \<rbrakk> \<Longrightarrow> \<exists>d. R^** b d \<and> R^** c d"
by(auto simp add: commute_def diamond_def square_def)

lemma tranclp_DomainP: "R^++ a b \<Longrightarrow> Domainp R a"
by(auto elim: converse_tranclpE)

lemma confluent_unique_normal_form:
  "\<lbrakk> confluent R; R^** a b; R^** a c; \<not> Domainp R b; \<not> Domainp R c  \<rbrakk> \<Longrightarrow> b = c"
  by(fastforce dest!: confluentD[of R a b c] dest: tranclp_DomainP rtranclpD[where a=b] rtranclpD[where a=c])

subsection\<open>Showing existence of the normal form. This part is original.\<close>

lemma Church_Rosser_unique_normal_form:
  assumes "Church_Rosser R"
      and "(sup R (R\<inverse>\<inverse>))\<^sup>*\<^sup>* a b"
      and "\<not> Domainp R a"
      and "\<not> Domainp R b"
    shows " a = b"
proof-
  have "\<exists>c. R^** a c \<and> R^** b c" using assms(1, 2)
    using Church_Rosser_def by fastforce
  then obtain c where "R^** a c \<and> R^** b c" by blast
  then have 1: "(a = c \<or> a \<noteq> c \<and> R\<^sup>+\<^sup>+ a c) \<and> (b = c \<or> b \<noteq> c \<and> R\<^sup>+\<^sup>+ b c)"
    by (simp add: rtranclpD)
  have a: "\<not> (R\<^sup>+\<^sup>+ a c)" using assms(3) tranclp_DomainP by metis
  have b: "\<not> (R\<^sup>+\<^sup>+ b c)" using assms(4) tranclp_DomainP by metis
  have "a = c \<and> b = c" using 1 a b by auto
  then show ?thesis by simp
qed

text\<open>We prove that cancelling terminates, that is, cancellation always returns a
    reduced word. adapted.\<close>

lemma canceling_terminates:
      "wfP (cancels_to_1^--1)"
proof-
  have "wf (measure length)" by auto
  moreover
  have "{(x, y). cancels_to_1 y x} \<subseteq> measure length"
    by (auto simp add: cancels_to_1_def cancel_at_def cancels_to_1_at_def)
  ultimately
  have "wf {(x, y). cancels_to_1 y x}"
    by(rule wf_subset)
  thus ?thesis by (simp add:wfP_def)
qed

text\<open>Showing confluence for cancels to 1. This statement is adapted from
Theory cancellation.\<close>

lemma diamond_cancel:
  shows "diamond (\<lambda> xs ys. (cancels_to_1 xs ys) \<or> xs = ys)"
  unfolding  diamond_def cancels_to_1_def commute_def square_def
  apply (rule allI, rule allI, rule impI, rule allI, rule impI)
proof-
  fix xs ys zs:: "('a,'b) word"
  assume 1:"(\<exists>i. cancels_to_1_at i xs ys) \<or> xs = ys"
  assume 2:"(\<exists>i. cancels_to_1_at i xs zs) \<or> xs = zs"
  show "\<exists>us. ((\<exists>i. cancels_to_1_at i ys us) \<or> ys = us) \<and> ((\<exists>i. cancels_to_1_at i zs us) \<or> zs = us)"
  proof(cases "xs = ys \<or> xs = zs")
    case True
    then have "(\<exists>i. cancels_to_1_at i ys zs) \<or> (\<exists>i. cancels_to_1_at i zs ys) \<or> ys = zs" using 1 2 by blast
  then show ?thesis by blast
  next
    case False
    have 3: "(\<exists>i. cancels_to_1_at i xs ys) \<and> (\<exists>j. cancels_to_1_at j xs zs)" using 1 2 False by blast
    obtain i where i:"cancels_to_1_at i xs ys" using 3 by auto
    obtain j where j:"cancels_to_1_at j xs zs" using 3 by auto
  then show ?thesis
    proof(cases "ys = zs")
      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: "ys \<noteq> zs"  by (simp add: False)
      then show ?thesis
        proof(cases "i = j")
          case True
          have y: "ys = cancel_at i xs" using cancels_to_1_at_def using i by auto
          have z: "zs = cancel_at i xs" using cancels_to_1_at_def True using j by auto
          have cont: "ys = zs" 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 blast
          have xi: "inverse (xs!i) = (xs!(1+i))" using cancels_to_1_at_def i by auto
          have xj: "inverse (xs!j) = (xs!(1+j))" using cancels_to_1_at_def j by auto
        then show ?thesis
          proof(cases "i = 1 + j")
            case True
            have xij: "((nth xs j) = (nth xs (2+j)))" using True xi xj inverse_of_inverse by (metis add_2_eq_Suc plus_1_eq_Suc)
            have y1: "ys = cancel_at (j+1) xs" by (metis True i add.commute cancels_to_1_at_def)
            have z1: "zs = cancel_at j xs" using cancels_to_1_at_def j by (simp add: cancels_to_1_at_def)
            have contr1: "ys = zs" using y1 z1 a1 z1 xij by (smt (z3) True i 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 xs i) = (nth xs (2+i)))" by (metis Suc_1 add.commute add_Suc_right inverse_of_inverse plus_1_eq_Suc xi xj)
            have y2: "ys = cancel_at i xs" using cancels_to_1_at_def i by auto
            have z2: "zs = cancel_at (i+1) xs" using xji cancels_to_1_at_def j by (simp add: cancels_to_1_at_def \<open>j = i + 1\<close>)
            have contr2: "ys = zs" using y2 z2 a2 z2 xji  by (smt (verit) j \<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 (xs!i) = (xs!(1+i))" using cancels_to_1_at_def i by auto
        have xj: "inverse (xs!j) = (xs!(1+j))" using cancels_to_1_at_def j 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: "zs = cancel_at j xs" using j cancels_to_1_at_def by auto
          have y: "ys = cancel_at i xs" using i cancels_to_1_at_def by auto
          have il: "1 + i < length xs" using i by (simp add: cancels_to_1_at_def)
          have m: "1 + j  < length xs" using j cancels_to_1_at_def by (simp add: cancels_to_1_at_def)
          then have jl: "j + 1 < length xs" by auto
          then have "i + 1 + 2 < length xs" using l  by linarith
          then have zz: "i + 1 < length xs - 2" by simp
          have "length xs - 2 = length (cancel_at i xs)" using cancel_at_length[of "i" "xs"] il i0 by presburger
          then have "length xs - 2 = length ys" using y by simp
          then have "j + 1 < length ys + 2" using jl  by linarith
          then have j2y: "(j - 2) + 1 < length ys" using l by linarith
          have "length xs - 2 = length (cancel_at j xs)" using cancel_at_length[of "j" "xs"]  jl j0 by metis
          then have "length xs - 2 = length zs" using z by simp
          then have iz: "i + 1 < length zs" using zz  by simp
          have j: "j < length xs" using m by linarith
          then have n: "cancel_at i (cancel_at j xs) = cancel_at (j-2) (cancel_at i xs)" using cancel_order l m by (metis add.commute)
          then have eq: "cancel_at i zs = cancel_at (j-2) ys" using \<open>cancels_to_1_at j xs zs\<close> \<open>cancels_to_1_at i xs ys\<close> cancels_to_1_at_def by (simp add: cancels_to_1_at_def)
          have take: "take j zs = take j xs" using take_assoc cancel_at_def l m by (metis \<open>cancels_to_1_at j xs zs\<close> add.commute cancels_to_1_at_def eq_imp_le)
          then have o: "(nth xs i) = (nth zs i)" using l i0 by (metis add_lessD1 nth_take)
          have p: "(nth xs (i+1)) = (nth zs (i+1))" using l i0 take takenth by (metis True order.trans)
          then have "inverse (nth zs i) = (nth xs (i+1))" using xi o by (smt (z3) add.commute)
          then have "inverse (nth zs i) = (nth zs (i+1))" using p by (smt (z3))
          then have inv1: "inverse (nth zs i) = (nth zs (1+i))" by simp
          have zeq: "(cancel_at i zs) = cancel_at i zs" by simp
          have zu: "cancels_to_1_at i zs (cancel_at i zs)"  using i0 iz inv1 zeq unfolding cancels_to_1_at_def by linarith
          have ys:"ys = cancel_at i xs" using  \<open>cancels_to_1_at i xs ys\<close> cancels_to_1_at_def by (simp add: cancels_to_1_at_def)
          then have q: "(nth xs j) = (nth ys (j - 2))" using cancel_atnth l j by blast
          have r: "(nth xs (j + 1)) = (nth ys ((j - 2) + 1))"  using cancel_atnth j1 m by (smt (verit) ys 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 ys (j - 2)) = (nth xs (j + 1))" using xj q  by auto
          then have inv2:"inverse (nth ys (j - 2)) = (nth ys ((j - 2) + 1))" using r  by fastforce
          have yeq: "cancel_at (j - 2) ys = cancel_at (j - 2) ys" by simp
          have yu: "cancels_to_1_at (j - 2) ys (cancel_at (j - 2) ys)" 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: "zs = cancel_at j xs" using j cancels_to_1_at_def by auto
          have y: "ys = cancel_at i xs"  using i cancels_to_1_at_def by auto
          have jl: "1 + j  < length xs" using j cancels_to_1_at_def by (simp add: cancels_to_1_at_def)
          have il: "1 + i < length xs" using i by (simp add: cancels_to_1_at_def)
          have "length xs - 2 = length (cancel_at j xs)" using cancel_at_length[of "j" "xs"] jl j0 by presburger
          then have  "length xs = length (cancel_at j xs) + 2" using jl by linarith
          then have "i + 1 < (length zs) + 2" using il i0 z by auto
          then have i2z: "(i - 2) + 1 < length zs" using j1i by linarith
          have "length xs - 2 = length (cancel_at i xs)" using cancel_at_length[of "i" "xs"] il i0 by presburger
          then have xy: "length xs - 2 = length ys" using y by simp
          have "j + 1 + 2 < length xs" using j1i il  by linarith
          then have "j + 1 < length xs - 2" using jl  by linarith
          then have jy: "j + 1 < length ys" using xy by simp
          have "cancel_at j (cancel_at i xs) = cancel_at (i-2) (cancel_at j xs)" using j1i il cancel_order by auto
          then have eq: "cancel_at j ys = cancel_at (i-2) zs" using y z by simp
          have take: "take i xs = take i ys" 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 xs j) = (nth ys j)" using takenth i0 j1i1 add_less_imp_less_right take by blast
          have nth1: "(nth xs (j+1)) = (nth ys (j+1))" using takenth i0 j1i1 j1i take by auto
          have "inverse (nth ys j) = (nth xs (j+1))" using xj nth by fastforce
          then have invj: "inverse (nth ys j) = (nth ys (j+1))" using nth1 by (smt (z3))
          have yu:  "cancels_to_1_at j ys (cancel_at j ys)" using j0 jy invj cancels_to_1_at_def by fastforce
          have nthi: "(nth xs i) = (nth zs (i - 2))" using z j1i  il cancel_atnth by (metis trans_le_add2 verit_comp_simplify1(3))
          have nthi1: "(nth xs (i+1)) = (nth zs ((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 zs (i - 2)) = (nth xs (i + 1))" using xi nthi by fastforce
          then have invi: "inverse (nth zs (i - 2)) = (nth zs ((i - 2) + 1))" using nthi1 by (smt (z3))
          have zu: "cancels_to_1_at (i - 2) zs (cancel_at (i - 2) zs)" 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
qed

lemma cancels_to_1_reduced :
  assumes "cancels_to_1 xs ys"
      and "cancels_to_1 xs zs"
      and "reduced ys"
      and "reduced zs"
    shows "ys = zs"
    using assms
  unfolding cancels_to_1_def
proof-
  have 1: "(\<exists>i. cancels_to_1_at i xs ys) \<or> xs = ys" using assms(1) cancels_to_1_def by blast
  have 2: "(\<exists>i. cancels_to_1_at i xs zs) \<or> xs = zs" using assms(2) cancels_to_1_def by blast
  have "diamond (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys)" using diamond_cancel by simp
  then have "commute (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys)" using diamond_def by auto
  then have "square (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys)  (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)  (\<lambda> x y . (cancels_to_1 x y) \<or> x = y)" using commute_def by blast
  then have "(\<forall>xs ys. (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) xs ys --> (\<forall>zs. (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) xs zs --> (\<exists>us. (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) ys us \<and> (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) zs us)))" using square_def[of "(\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys)" "(\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys)" "(\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys)" "(\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys)"] by blast
  then have "(\<exists>us. (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) ys us \<and> (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) zs us)" using 1 2 assms(1) assms(2) by blast
  then have "\<exists>us. (ys = us \<and> zs = us)" using cancels_to_1_red assms(3) assms(4) by (simp add: cancels_to_1_red)
  then show ?thesis by simp
qed

lemma diamondlemmaapp:
  assumes "(\<exists>i. cancels_to_1_at i xs ys) \<or> xs = ys"
      and "(\<exists>i. cancels_to_1_at i xs zs) \<or> xs = zs"
    shows "\<exists>us. ((\<exists>i. cancels_to_1_at i ys us) \<or> ys = us) \<and> ((\<exists>i. cancels_to_1_at i zs us) \<or> zs = us)"
proof-
  have "diamond (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys)" using diamond_cancel by simp
  then have "commute (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys)" using diamond_def by auto
  then have "square (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys)" using commute_def by blast
  then have "(\<forall>xs ys. (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) xs ys --> (\<forall>zs. (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) xs zs --> (\<exists>us. (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) ys us \<and> (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) zs us)))" using square_def[of "(\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys)" "(\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys)" "(\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys)" "(\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys)"] by blast
  then have "(\<exists>us. (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) ys us \<and> (\<lambda>xs ys. (cancels_to_1 xs ys) \<or> xs = ys) zs us)" by (metis assms(1) assms(2) cancels_to_1_def)
  then show ?thesis by (simp add: cancels_to_1_def)
qed

text \<open>This lemma is adapted from Theory Cancelation.\<close>

lemma confluent_cancels_to_1:
        "confluent cancels_to_1"
proof(rule lconfluent_confluent)
  show "wfP cancels_to_1\<inverse>\<inverse>" by (rule canceling_terminates)
next
  fix a b c
  assume "cancels_to_1 a b"
  then have 1: "(\<exists>i. cancels_to_1_at i a b)" by (simp add: cancels_to_1_def)
  assume "cancels_to_1 a c"
  then have 2: "\<exists>j. cancels_to_1_at j a c" by (simp add: cancels_to_1_def)
  show "\<exists>d. cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d"
  proof-
    have "\<exists>d. ((\<exists>i. cancels_to_1_at i b d) \<or> b = d) \<and> ((\<exists>i. cancels_to_1_at i c d) \<or> c = d)" using 1 2 diamondlemmaapp by blast
    then obtain d where "((\<exists>i. cancels_to_1_at i b d) \<or> b = d) \<and> ((\<exists>i. cancels_to_1_at i c d) \<or> c = d)" by force
    then have "((\<exists>i. cancels_to_1_at i b d) \<or> b = d) \<and> ((\<exists>i. cancels_to_1_at i c d) \<or> c = d)"  by simp
    then have "(cancels_to b d) \<and> (cancels_to c d)" by (simp add: rtrancancel)
    then have "cancels_to_1\<^sup>*\<^sup>* b d \<and> cancels_to_1\<^sup>*\<^sup>* c d" using cancels_to_def by metis
    then show ?thesis by auto
  qed
qed

text \<open>Finally, we show each reduced word has a unique normal form.
      This lemma is adapted from Theory Cancelation.\<close>

lemma unique_reduced_cancel:
  assumes "cancels_to xs ys"
      and "cancels_to xs zs"
      and "reduced ys" "reduced zs"
    shows "ys = zs"
proof(rule confluent_unique_normal_form)
  have "cancels_to_1^** = cancels_to" using cancels_to_def  by metis
  show "confluent cancels_to_1" using confluent_cancels_to_1 by simp
next
  show "cancels_to_1\<^sup>*\<^sup>* xs ys" using assms(1) cancels_to_def by metis
next
  show "cancels_to_1\<^sup>*\<^sup>* xs zs" using assms(2) cancels_to_def by metis
next
  show "\<not> Domainp cancels_to_1 ys" using assms(3) reduced_normal by blast
next
  show "\<not> Domainp cancels_to_1 zs" using assms(4) reduced_normal by blast
qed

lemma reduced_cancel_eq:
  assumes "cancels_eq xs ys"
      and "reduced xs"
      and "reduced ys"
    shows "xs = ys"
proof-
  have "confluent cancels_to_1" using confluent_cancels_to_1 by blast
  then have 1: "Church_Rosser cancels_to_1"
    using Church_Rosser_confluent by (simp add: Church_Rosser_confluent)
  have "(symclp cancels_to)^** xs ys" using assms(1) eq_symp by metis
  then have "(symclp cancels_to_1)^** xs ys" using sympstar by metis
  then have 2: "(sup cancels_to_1 cancels_to_1^--1)^** xs ys"
    using symclp_pointfree[of "cancels_to_1"] by metis
  have 3: "\<not> Domainp cancels_to_1 xs" using assms(2) reduced_normal by blast
  have 4: "\<not> Domainp cancels_to_1 ys" using assms(3) reduced_normal by blast
  show ?thesis
    using 1 2 3 4 Church_Rosser_unique_normal_form[of "cancels_to_1" "xs" "ys"] by blast
qed

end


chapter\<open>De Bruijn Syntax, Quotations, Codes, V-Codes\<close>

theory Coding
imports SyntaxN
begin

declare fresh_Nil [iff]

section \<open>de Bruijn Indices (locally-nameless version)\<close>

nominal_datatype dbtm = DBZero | DBVar name | DBInd nat | DBEats dbtm dbtm

nominal_datatype dbfm =
    DBMem dbtm dbtm
  | DBEq dbtm dbtm
  | DBDisj dbfm dbfm
  | DBNeg dbfm
  | DBEx dbfm

declare dbtm.supp [simp]
declare dbfm.supp [simp]

fun lookup :: "name list \<Rightarrow> nat \<Rightarrow> name \<Rightarrow> dbtm"
  where
    "lookup [] n x = DBVar x"
  | "lookup (y # ys) n x = (if x = y then DBInd n else (lookup ys (Suc n) x))"

lemma fresh_imp_notin_env: "atom name \<sharp> e \<Longrightarrow> name \<notin> set e"
  by (metis List.finite_set fresh_finite_set_at_base fresh_set)

lemma lookup_notin: "x \<notin> set e \<Longrightarrow> lookup e n x = DBVar x"
  by (induct e arbitrary: n) auto

lemma lookup_in:
  "x \<in> set e \<Longrightarrow> \<exists>k. lookup e n x = DBInd k \<and> n \<le> k \<and> k < n + length e"
apply (induct e arbitrary: n)
apply (auto intro: Suc_leD)
apply (metis Suc_leD add_Suc_right add_Suc_shift)
done

lemma lookup_fresh: "x \<sharp> lookup e n y \<longleftrightarrow> y \<in> set e \<or> x \<noteq> atom y"
  by (induct arbitrary: n rule: lookup.induct) (auto simp: pure_fresh fresh_at_base)

lemma lookup_eqvt[eqvt]: "(p \<bullet> lookup xs n x) = lookup (p \<bullet> xs) (p \<bullet> n) (p \<bullet> x)"
  by (induct xs arbitrary: n) (simp_all add: permute_pure)

lemma lookup_inject [iff]: "(lookup e n x = lookup e n y) \<longleftrightarrow> x = y"
apply (induct e n x arbitrary: y rule: lookup.induct, force, simp)
by (metis Suc_n_not_le_n dbtm.distinct(7) dbtm.eq_iff(3) lookup_in lookup_notin)

nominal_function trans_tm :: "name list \<Rightarrow> tm \<Rightarrow> dbtm"
  where
   "trans_tm e Zero = DBZero"
 | "trans_tm e (Var k) = lookup e 0 k"
 | "trans_tm e (Eats t u) = DBEats (trans_tm e t) (trans_tm e u)"
by (auto simp: eqvt_def trans_tm_graph_aux_def) (metis tm.strong_exhaust)

nominal_termination (eqvt)
  by lexicographic_order

lemma fresh_trans_tm_iff [simp]: "i \<sharp> trans_tm e t \<longleftrightarrow> i \<sharp> t \<or> i \<in> atom ` set e"
  by (induct t rule: tm.induct, auto simp: lookup_fresh fresh_at_base)

lemma trans_tm_forget: "atom i \<sharp> t \<Longrightarrow> trans_tm [i] t = trans_tm [] t"
  by (induct t rule: tm.induct, auto simp: fresh_Pair)

nominal_function (invariant "\<lambda>(xs, _) y. atom ` set xs \<sharp>* y")
  trans_fm :: "name list \<Rightarrow> fm \<Rightarrow> dbfm"
  where
   "trans_fm e (Mem t u) = DBMem (trans_tm e t) (trans_tm e u)"
 | "trans_fm e (Eq t u)  = DBEq (trans_tm e t) (trans_tm e u)"
 | "trans_fm e (Disj A B) = DBDisj (trans_fm e A) (trans_fm e B)"
 | "trans_fm e (Neg A)   = DBNeg (trans_fm e A)"
 | "atom k \<sharp> e \<Longrightarrow> trans_fm e (Ex k A) = DBEx (trans_fm (k#e) A)"
supply [[simproc del: defined_all]]
apply(simp add: eqvt_def trans_fm_graph_aux_def)
apply(erule trans_fm_graph.induct)
using [[simproc del: alpha_lst]]
apply(auto simp: fresh_star_def)
apply(rule_tac y=b and c=a in fm.strong_exhaust)
apply(auto simp: fresh_star_def)
apply(erule_tac c=ea in Abs_lst1_fcb2')
apply (simp_all add: eqvt_at_def)
apply (simp_all add: fresh_star_Pair perm_supp_eq)
apply (simp add: fresh_star_def)
done

nominal_termination (eqvt)
  by lexicographic_order

lemma fresh_trans_fm [simp]: "i \<sharp> trans_fm e A \<longleftrightarrow> i \<sharp> A \<or> i \<in> atom ` set e"
  by (nominal_induct A avoiding: e rule: fm.strong_induct, auto simp: fresh_at_base)

abbreviation DBConj :: "dbfm \<Rightarrow> dbfm \<Rightarrow> dbfm"
  where "DBConj t u \<equiv> DBNeg (DBDisj (DBNeg t) (DBNeg u))"

lemma trans_fm_Conj [simp]: "trans_fm e (Conj A B) = DBConj (trans_fm e A) (trans_fm e B)"
  by (simp add: Conj_def)

lemma trans_tm_inject [iff]: "(trans_tm e t = trans_tm e u) \<longleftrightarrow> t = u"
proof (induct t arbitrary: e u rule: tm.induct)
  case Zero show ?case
    apply (cases u rule: tm.exhaust, auto)
    apply (metis dbtm.distinct(1) dbtm.distinct(3) lookup_in lookup_notin)
    done
next
  case (Var i) show ?case
    apply (cases u rule: tm.exhaust, auto)
    apply (metis dbtm.distinct(1) dbtm.distinct(3) lookup_in lookup_notin)
    apply (metis dbtm.distinct(10) dbtm.distinct(11) lookup_in lookup_notin)
    done
next
  case (Eats tm1 tm2) thus ?case
    apply (cases u rule: tm.exhaust, auto)
    apply (metis dbtm.distinct(12) dbtm.distinct(9) lookup_in lookup_notin)
    done
qed

lemma trans_fm_inject [iff]: "(trans_fm e A = trans_fm e B) \<longleftrightarrow> A = B"
proof (nominal_induct A avoiding: e B rule: fm.strong_induct)
  case (Mem tm1 tm2) thus ?case
    by (rule fm.strong_exhaust [where y=B and c=e]) (auto simp: fresh_star_def)
next
  case (Eq tm1 tm2) thus ?case
    by (rule fm.strong_exhaust [where y=B and c=e]) (auto simp: fresh_star_def)
next
  case (Disj fm1 fm2) show ?case
    by (rule fm.strong_exhaust [where y=B and c=e]) (auto simp: Disj fresh_star_def)
next
  case (Neg fm) show ?case
    by (rule fm.strong_exhaust [where y=B and c=e]) (auto simp: Neg fresh_star_def)
next
  case (Ex name fm)
  thus ?case  using [[simproc del: alpha_lst]]
  proof (cases rule: fm.strong_exhaust [where y=B and c="(e, name)"], simp_all add: fresh_star_def)
    fix name'::name and fm'::fm
    assume name': "atom name' \<sharp> (e, name)"
    assume "atom name \<sharp> fm' \<or> name = name'"
    thus "(trans_fm (name # e) fm = trans_fm (name' # e) fm') = ([[atom name]]lst. fm = [[atom name']]lst. fm')"
         (is "?lhs = ?rhs")
    proof (rule disjE)
      assume "name = name'"
      thus "?lhs = ?rhs"
        by (metis fresh_Pair fresh_at_base(2) name')
    next
      assume name: "atom name \<sharp> fm'"
      have eq1: "(name \<leftrightarrow> name') \<bullet> trans_fm (name' # e) fm' = trans_fm (name' # e) fm'"
        by (simp add: flip_fresh_fresh name)
      have eq2: "(name \<leftrightarrow> name') \<bullet> ([[atom name']]lst. fm') = [[atom name']]lst. fm'"
        by (rule flip_fresh_fresh) (auto simp: Abs_fresh_iff name)
      show "?lhs = ?rhs" using name' eq1 eq2 Ex(1) Ex(3) [of "name#e" "(name \<leftrightarrow> name') \<bullet> fm'"]
        by (simp add: flip_fresh_fresh) (metis Abs1_eq(3))
    qed
  qed
qed

lemma trans_fm_perm:
  assumes c: "atom c \<sharp> (i,j,A,B)"
  and     t: "trans_fm [i] A = trans_fm [j] B"
  shows "(i \<leftrightarrow> c) \<bullet> A = (j \<leftrightarrow> c) \<bullet> B"
proof -
  have c_fresh1: "atom c \<sharp> trans_fm [i] A"
    using c by (auto simp: supp_Pair)
  moreover
  have i_fresh: "atom i \<sharp> trans_fm [i] A"
    by auto
  moreover
  have c_fresh2: "atom c \<sharp> trans_fm [j] B"
    using c by (auto simp: supp_Pair)
  moreover
  have j_fresh: "atom j \<sharp> trans_fm [j] B"
    by auto
  ultimately have "((i \<leftrightarrow> c) \<bullet> (trans_fm [i] A)) = ((j \<leftrightarrow> c) \<bullet> trans_fm [j] B)"
    by (simp only: flip_fresh_fresh t)
  then have "trans_fm [c] ((i \<leftrightarrow> c) \<bullet> A) = trans_fm [c] ((j \<leftrightarrow> c) \<bullet> B)"
    by simp
  then show "(i \<leftrightarrow> c) \<bullet> A = (j \<leftrightarrow> c) \<bullet> B" by simp
qed

section\<open>Characterising the Well-Formed de Bruijn Formulas\<close>

subsection\<open>Well-Formed Terms\<close>

inductive wf_dbtm :: "dbtm \<Rightarrow> bool"
  where
    Zero:  "wf_dbtm DBZero"
  | Var:   "wf_dbtm (DBVar name)"
  | Eats:  "wf_dbtm t1 \<Longrightarrow> wf_dbtm t2 \<Longrightarrow> wf_dbtm (DBEats t1 t2)"

equivariance wf_dbtm

inductive_cases Zero_wf_dbtm [elim!]: "wf_dbtm DBZero"
inductive_cases Var_wf_dbtm [elim!]:  "wf_dbtm (DBVar name)"
inductive_cases Ind_wf_dbtm [elim!]:  "wf_dbtm (DBInd i)"
inductive_cases Eats_wf_dbtm [elim!]: "wf_dbtm (DBEats t1 t2)"

declare wf_dbtm.intros [intro]

lemma wf_dbtm_imp_is_tm:
  assumes "wf_dbtm x"
  shows "\<exists>t::tm. x = trans_tm [] t"
using assms
proof (induct rule: wf_dbtm.induct)
  case Zero thus ?case
    by (metis trans_tm.simps(1))
next
  case (Var i) thus ?case
    by (metis lookup.simps(1) trans_tm.simps(2))
next
  case (Eats dt1 dt2) thus ?case
    by (metis trans_tm.simps(3))
qed

lemma wf_dbtm_trans_tm: "wf_dbtm (trans_tm [] t)"
  by (induct t rule: tm.induct) auto

theorem wf_dbtm_iff_is_tm: "wf_dbtm x \<longleftrightarrow> (\<exists>t::tm. x = trans_tm [] t)"
  by (metis wf_dbtm_imp_is_tm wf_dbtm_trans_tm)

nominal_function abst_dbtm :: "name \<Rightarrow> nat \<Rightarrow> dbtm \<Rightarrow> dbtm"
  where
   "abst_dbtm name i DBZero = DBZero"
 | "abst_dbtm name i (DBVar name') = (if name = name' then DBInd i else DBVar name')"
 | "abst_dbtm name i (DBInd j) = DBInd j"
 | "abst_dbtm name i (DBEats t1 t2) = DBEats (abst_dbtm name i t1) (abst_dbtm name i t2)"
apply (simp add: eqvt_def abst_dbtm_graph_aux_def, auto)
apply (metis dbtm.exhaust)
done

nominal_termination (eqvt)
  by lexicographic_order

nominal_function subst_dbtm :: "dbtm \<Rightarrow> name \<Rightarrow> dbtm \<Rightarrow> dbtm"
  where
   "subst_dbtm u i DBZero = DBZero"
 | "subst_dbtm u i (DBVar name) = (if i = name then u else DBVar name)"
 | "subst_dbtm u i (DBInd j) = DBInd j"
 | "subst_dbtm u i (DBEats t1 t2) = DBEats (subst_dbtm u i t1) (subst_dbtm u i t2)"
by (auto simp: eqvt_def subst_dbtm_graph_aux_def) (metis dbtm.exhaust)

nominal_termination (eqvt)
  by lexicographic_order

lemma fresh_iff_non_subst_dbtm: "subst_dbtm DBZero i t = t \<longleftrightarrow> atom i \<sharp> t"
  by (induct t rule: dbtm.induct) (auto simp: pure_fresh fresh_at_base(2))

lemma lookup_append: "lookup (e @ [i]) n j = abst_dbtm i (length e + n) (lookup e n j)"
  by (induct e arbitrary: n) (auto simp: fresh_Cons)

lemma trans_tm_abs: "trans_tm (e@[name]) t = abst_dbtm name (length e) (trans_tm e t)"
  by (induct t rule: tm.induct) (auto simp: lookup_notin lookup_append)

subsection\<open>Well-Formed Formulas\<close>

nominal_function abst_dbfm :: "name \<Rightarrow> nat \<Rightarrow> dbfm \<Rightarrow> dbfm"
  where
   "abst_dbfm name i (DBMem t1 t2) = DBMem (abst_dbtm name i t1) (abst_dbtm name i t2)"
 | "abst_dbfm name i (DBEq t1 t2) =  DBEq (abst_dbtm name i t1) (abst_dbtm name i t2)"
 | "abst_dbfm name i (DBDisj A1 A2) = DBDisj (abst_dbfm name i A1) (abst_dbfm name i A2)"
 | "abst_dbfm name i (DBNeg A) = DBNeg (abst_dbfm name i A)"
 | "abst_dbfm name i (DBEx A) = DBEx (abst_dbfm name (i+1) A)"
apply (simp add: eqvt_def abst_dbfm_graph_aux_def, auto)
apply (metis dbfm.exhaust)
done

nominal_termination (eqvt)
  by lexicographic_order

nominal_function subst_dbfm :: "dbtm \<Rightarrow> name \<Rightarrow> dbfm \<Rightarrow> dbfm"
  where
   "subst_dbfm u i (DBMem t1 t2) = DBMem (subst_dbtm u i t1) (subst_dbtm u i t2)"
 | "subst_dbfm u i (DBEq t1 t2) =  DBEq (subst_dbtm u i t1) (subst_dbtm u i t2)"
 | "subst_dbfm u i (DBDisj A1 A2) = DBDisj (subst_dbfm u i A1) (subst_dbfm u i A2)"
 | "subst_dbfm u i (DBNeg A) = DBNeg (subst_dbfm u i A)"
 | "subst_dbfm u i (DBEx A) = DBEx (subst_dbfm u i A)"
by (auto simp: eqvt_def subst_dbfm_graph_aux_def) (metis dbfm.exhaust)

nominal_termination (eqvt)
  by lexicographic_order

lemma fresh_iff_non_subst_dbfm: "subst_dbfm DBZero i t = t \<longleftrightarrow> atom i \<sharp> t"
  by (induct t rule: dbfm.induct) (auto simp: fresh_iff_non_subst_dbtm)

section\<open>Well formed terms and formulas (de Bruijn representation)\<close>

inductive wf_dbfm :: "dbfm \<Rightarrow> bool"
  where
    Mem:   "wf_dbtm t1 \<Longrightarrow> wf_dbtm t2 \<Longrightarrow> wf_dbfm (DBMem t1 t2)"
  | Eq:    "wf_dbtm t1 \<Longrightarrow> wf_dbtm t2 \<Longrightarrow> wf_dbfm (DBEq t1 t2)"
  | Disj:  "wf_dbfm A1 \<Longrightarrow> wf_dbfm A2 \<Longrightarrow> wf_dbfm (DBDisj A1 A2)"
  | Neg:   "wf_dbfm A \<Longrightarrow> wf_dbfm (DBNeg A)"
  | Ex:    "wf_dbfm A \<Longrightarrow> wf_dbfm (DBEx (abst_dbfm name 0 A))"

equivariance wf_dbfm

lemma atom_fresh_abst_dbtm [simp]: "atom i \<sharp> abst_dbtm i n t"
  by (induct t rule: dbtm.induct) (auto simp: pure_fresh)

text\<open>Setting up strong induction: "avoiding" for name. Necessary to allow some proofs to go through\<close>
nominal_inductive wf_dbfm
  avoids Ex: name
  by (auto simp: fresh_star_def)

inductive_cases Mem_wf_dbfm [elim!]:  "wf_dbfm (DBMem t1 t2)"
inductive_cases Eq_wf_dbfm [elim!]:   "wf_dbfm (DBEq t1 t2)"
inductive_cases Disj_wf_dbfm [elim!]: "wf_dbfm (DBDisj A1 A2)"
inductive_cases Neg_wf_dbfm [elim!]:  "wf_dbfm (DBNeg A)"
inductive_cases Ex_wf_dbfm [elim!]:   "wf_dbfm (DBEx z)"

declare wf_dbfm.intros [intro]

lemma trans_fm_abs: "trans_fm (e@[name]) A = abst_dbfm name (length e) (trans_fm e A)"
  apply (nominal_induct A avoiding: name e rule: fm.strong_induct)
  apply (auto simp: trans_tm_abs fresh_Cons fresh_append)
  apply (metis One_nat_def Suc_eq_plus1 append_Cons list.size(4))
  done

lemma abst_trans_fm: "abst_dbfm name 0 (trans_fm [] A) = trans_fm [name] A"
  by (metis append_Nil list.size(3) trans_fm_abs)

lemma abst_trans_fm2: "i \<noteq> j \<Longrightarrow> abst_dbfm i (Suc 0) (trans_fm [j] A) = trans_fm [j,i] A"
  using trans_fm_abs [where e="[j]" and name=i]
  by auto

lemma wf_dbfm_imp_is_fm:
  assumes "wf_dbfm x" shows "\<exists>A::fm. x = trans_fm [] A"
using assms
proof (induct rule: wf_dbfm.induct)
  case (Mem t1 t2) thus ?case
    by (metis trans_fm.simps(1) wf_dbtm_imp_is_tm)
next
  case (Eq t1 t2) thus ?case
    by (metis trans_fm.simps(2) wf_dbtm_imp_is_tm)
next
  case (Disj fm1 fm2) thus ?case
    by (metis trans_fm.simps(3))
next
  case (Neg fm) thus ?case
    by (metis trans_fm.simps(4))
next
  case (Ex fm name) thus ?case
    apply auto
    apply (rule_tac x="Ex name A" in exI)
    apply (auto simp: abst_trans_fm)
    done
qed

lemma wf_dbfm_trans_fm: "wf_dbfm (trans_fm [] A)"
  apply (nominal_induct A rule: fm.strong_induct)
  apply (auto simp: wf_dbtm_trans_tm abst_trans_fm)
  apply (metis abst_trans_fm wf_dbfm.Ex)
  done

lemma wf_dbfm_iff_is_fm: "wf_dbfm x \<longleftrightarrow> (\<exists>A::fm. x = trans_fm [] A)"
  by (metis wf_dbfm_imp_is_fm wf_dbfm_trans_fm)

lemma dbtm_abst_ignore [simp]:
  "abst_dbtm name i (abst_dbtm name j t) = abst_dbtm name j t"
  by (induct t rule: dbtm.induct) auto

lemma abst_dbtm_fresh_ignore [simp]: "atom name \<sharp> u \<Longrightarrow> abst_dbtm name j u = u"
  by (induct u rule: dbtm.induct) auto

lemma dbtm_subst_ignore [simp]:
  "subst_dbtm u name (abst_dbtm name j t) = abst_dbtm name j t"
  by (induct t rule: dbtm.induct) auto

lemma dbtm_abst_swap_subst:
  "name \<noteq> name' \<Longrightarrow> atom name' \<sharp> u \<Longrightarrow>
   subst_dbtm u name (abst_dbtm name' j t) = abst_dbtm name' j (subst_dbtm u name t)"
  by (induct t rule: dbtm.induct) auto

lemma dbfm_abst_swap_subst:
  "name \<noteq> name' \<Longrightarrow> atom name' \<sharp> u \<Longrightarrow>
   subst_dbfm u name (abst_dbfm name' j A) = abst_dbfm name' j (subst_dbfm u name A)"
  by (induct A arbitrary: j rule: dbfm.induct) (auto simp: dbtm_abst_swap_subst)

lemma subst_trans_commute [simp]:
  "atom i \<sharp> e \<Longrightarrow> subst_dbtm (trans_tm e u) i (trans_tm e t) = trans_tm e (subst i u t)"
  apply (induct t rule: tm.induct)
  apply (auto simp: lookup_notin fresh_imp_notin_env)
  apply (metis abst_dbtm_fresh_ignore dbtm_subst_ignore lookup_fresh lookup_notin subst_dbtm.simps(2))
  done

lemma subst_fm_trans_commute [simp]:
  "subst_dbfm (trans_tm [] u) name (trans_fm [] A) = trans_fm [] (A (name::= u))"
  apply (nominal_induct A avoiding: name u rule: fm.strong_induct)
  apply (auto simp: lookup_notin abst_trans_fm [symmetric])
  apply (metis dbfm_abst_swap_subst fresh_at_base(2) fresh_trans_tm_iff)
  done

lemma subst_fm_trans_commute_eq:
  "du = trans_tm [] u \<Longrightarrow> subst_dbfm du i (trans_fm [] A) = trans_fm [] (A(i::=u))"
  by (metis subst_fm_trans_commute)

section\<open>Quotations\<close>

fun HTuple :: "nat \<Rightarrow> tm"  where
   "HTuple 0 = HPair Zero Zero"
 | "HTuple (Suc k) = HPair Zero (HTuple k)"

lemma fresh_HTuple [simp]: "x \<sharp> HTuple n"
  by (induct n) auto

lemma HTuple_eqvt[eqvt]: "(p \<bullet> HTuple n) = HTuple (p \<bullet> n)"
  by (induct n, auto simp: HPair_eqvt permute_pure)

subsection \<open>Quotations of de Bruijn terms\<close>

definition nat_of_name :: "name \<Rightarrow> nat"
  where "nat_of_name x = nat_of (atom x)"

lemma nat_of_name_inject [simp]: "nat_of_name n1 = nat_of_name n2 \<longleftrightarrow> n1 = n2"
  by (metis nat_of_name_def atom_components_eq_iff atom_eq_iff sort_of_atom_eq)

definition name_of_nat :: "nat \<Rightarrow> name"
  where "name_of_nat n \<equiv> Abs_name (Atom (Sort ''SyntaxN.name'' []) n)"

lemma nat_of_name_Abs_eq [simp]: "nat_of_name (Abs_name (Atom (Sort ''SyntaxN.name'' []) n)) = n"
  by (auto simp: nat_of_name_def atom_name_def Abs_name_inverse)

lemma nat_of_name_name_eq [simp]: "nat_of_name (name_of_nat n) = n"
  by (simp add: name_of_nat_def)

lemma name_of_nat_nat_of_name [simp]: "name_of_nat (nat_of_name i) = i"
  by (metis nat_of_name_inject nat_of_name_name_eq)

lemma HPair_neq_ORD_OF [simp]: "HPair x y \<noteq> ORD_OF i"
  by (metis HPair_def ORD_OF.elims SUCC_def tm.distinct(3) tm.eq_iff(3))

text\<open>Infinite support, so we cannot use nominal primrec.\<close>
function quot_dbtm :: "dbtm \<Rightarrow> tm"
  where
   "quot_dbtm DBZero = Zero"
 | "quot_dbtm (DBVar name) = ORD_OF (Suc (nat_of_name name))"
 | "quot_dbtm (DBInd k) = HPair (HTuple 6) (ORD_OF k)"
 | "quot_dbtm (DBEats t u) = HPair (HTuple 1) (HPair (quot_dbtm t) (quot_dbtm u))"
by (rule dbtm.exhaust) auto

termination
  by lexicographic_order

subsection \<open>Quotations of de Bruijn formulas\<close>

text\<open>Infinite support, so we cannot use nominal primrec.\<close>
function quot_dbfm :: "dbfm \<Rightarrow> tm"
  where
   "quot_dbfm (DBMem t u) = HPair (HTuple 0) (HPair (quot_dbtm t) (quot_dbtm u))"
 | "quot_dbfm (DBEq t u) = HPair (HTuple 2) (HPair (quot_dbtm t) (quot_dbtm u))"
 | "quot_dbfm (DBDisj A B) = HPair (HTuple 3) (HPair (quot_dbfm A) (quot_dbfm B))"
 | "quot_dbfm (DBNeg A) = HPair (HTuple 4) (quot_dbfm A)"
 | "quot_dbfm (DBEx A) = HPair (HTuple 5) (quot_dbfm A)"
by (rule_tac y=x in dbfm.exhaust, auto)

termination
  by lexicographic_order

lemma HTuple_minus_1: "n > 0 \<Longrightarrow> HTuple n = HPair Zero (HTuple (n - 1))"
  by (metis Suc_diff_1 HTuple.simps(2))

lemmas HTS = HTuple_minus_1 HTuple.simps \<comment> \<open>for freeness reasoning on codes\<close>

class quot =
  fixes quot :: "'a \<Rightarrow> tm"  ("\<guillemotleft>_\<guillemotright>")

instantiation tm :: quot
begin
  definition quot_tm :: "tm \<Rightarrow> tm"
    where "quot_tm t = quot_dbtm (trans_tm [] t)"

  instance ..
end

lemma quot_dbtm_fresh [simp]: "s \<sharp> (quot_dbtm t)"
  by (induct t rule: dbtm.induct) auto

lemma quot_tm_fresh [simp]: fixes t::tm shows "s \<sharp> \<guillemotleft>t\<guillemotright>"
  by (simp add: quot_tm_def)

lemma quot_Zero [simp]: "\<guillemotleft>Zero\<guillemotright> = Zero"
  by (simp add: quot_tm_def)

lemma quot_Var: "\<guillemotleft>Var x\<guillemotright> = SUCC (ORD_OF (nat_of_name x))"
  by (simp add: quot_tm_def)

lemma quot_Eats: "\<guillemotleft>Eats x y\<guillemotright> = HPair (HTuple 1) (HPair \<guillemotleft>x\<guillemotright> \<guillemotleft>y\<guillemotright>)"
  by (simp add: quot_tm_def)

instantiation fm :: quot
begin
  definition quot_fm :: "fm \<Rightarrow> tm"
    where "quot_fm A = quot_dbfm (trans_fm [] A)"

  instance ..
end

lemma quot_dbfm_fresh [simp]: "s \<sharp> (quot_dbfm A)"
  by (induct A rule: dbfm.induct) auto

lemma quot_fm_fresh [simp]: fixes A::fm shows "s \<sharp> \<guillemotleft>A\<guillemotright>"
  by (simp add: quot_fm_def)

lemma quot_fm_permute [simp]: fixes A:: fm shows "p \<bullet> \<guillemotleft>A\<guillemotright> = \<guillemotleft>A\<guillemotright>"
  by (metis fresh_star_def perm_supp_eq quot_fm_fresh)

lemma quot_Mem: "\<guillemotleft>x IN y\<guillemotright> = HPair (HTuple 0) (HPair (\<guillemotleft>x\<guillemotright>) (\<guillemotleft>y\<guillemotright>))"
  by (simp add: quot_fm_def quot_tm_def)

lemma quot_Eq: "\<guillemotleft>x EQ y\<guillemotright> = HPair (HTuple 2) (HPair (\<guillemotleft>x\<guillemotright>) (\<guillemotleft>y\<guillemotright>))"
  by (simp add: quot_fm_def quot_tm_def)

lemma quot_Disj: "\<guillemotleft>A OR B\<guillemotright> = HPair (HTuple 3) (HPair (\<guillemotleft>A\<guillemotright>) (\<guillemotleft>B\<guillemotright>))"
  by (simp add: quot_fm_def)

lemma quot_Neg: "\<guillemotleft>Neg A\<guillemotright> = HPair (HTuple 4) (\<guillemotleft>A\<guillemotright>)"
  by (simp add: quot_fm_def)

lemma quot_Ex: "\<guillemotleft>Ex i A\<guillemotright> = HPair (HTuple 5) (quot_dbfm (trans_fm [i] A))"
  by (simp add: quot_fm_def)

lemmas quot_simps = quot_Var quot_Eats quot_Eq quot_Mem quot_Disj quot_Neg quot_Ex

section\<open>Definitions Involving Coding\<close>

abbreviation Q_Eats :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Eats t u \<equiv> HPair (HTuple (Suc 0)) (HPair t u)"

abbreviation Q_Succ :: "tm \<Rightarrow> tm"
  where "Q_Succ t \<equiv> Q_Eats t t"

lemma quot_Succ: "\<guillemotleft>SUCC x\<guillemotright> = Q_Succ \<guillemotleft>x\<guillemotright>"
  by (auto simp: SUCC_def quot_Eats)

abbreviation Q_HPair :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_HPair t u \<equiv>
           Q_Eats (Q_Eats Zero (Q_Eats (Q_Eats Zero u) t))
                  (Q_Eats (Q_Eats Zero t) t)"

abbreviation Q_Mem :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Mem t u \<equiv> HPair (HTuple 0) (HPair t u)"

abbreviation Q_Eq :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Eq t u \<equiv> HPair (HTuple 2) (HPair t u)"

abbreviation Q_Disj :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Disj t u \<equiv> HPair (HTuple 3) (HPair t u)"

abbreviation Q_Neg :: "tm \<Rightarrow> tm"
  where "Q_Neg t \<equiv> HPair (HTuple 4) t"

abbreviation Q_Conj :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Conj t u \<equiv> Q_Neg (Q_Disj (Q_Neg t) (Q_Neg u))"

abbreviation Q_Imp :: "tm \<Rightarrow> tm \<Rightarrow> tm"
  where "Q_Imp t u \<equiv> Q_Disj (Q_Neg t) u"

abbreviation Q_Ex :: "tm \<Rightarrow> tm"
  where "Q_Ex t \<equiv> HPair (HTuple 5) t"

abbreviation Q_All :: "tm \<Rightarrow> tm"
  where "Q_All t \<equiv> Q_Neg (Q_Ex (Q_Neg t))"

lemma quot_subst_eq: "\<guillemotleft>A(i::=t)\<guillemotright> = quot_dbfm (subst_dbfm (trans_tm [] t) i (trans_fm [] A))"
  by (metis quot_fm_def subst_fm_trans_commute)

lemma Q_Succ_cong: "H \<turnstile> x EQ x' \<Longrightarrow> H \<turnstile> Q_Succ x EQ Q_Succ x'"
  by (metis HPair_cong Refl)

subsection\<open>The set \<open>\<Gamma>\<close> of Definition 1.1, constant terms used for coding\<close>

inductive coding_tm :: "tm \<Rightarrow> bool"
  where
    Ord:    "\<exists>i. x = ORD_OF i \<Longrightarrow> coding_tm x"
  | HPair:  "coding_tm x \<Longrightarrow> coding_tm y \<Longrightarrow> coding_tm (HPair x y)"

declare coding_tm.intros [intro]

lemma coding_tm_Zero [intro]: "coding_tm Zero"
  by (metis ORD_OF.simps(1) Ord)

lemma coding_tm_HTuple [intro]: "coding_tm (HTuple k)"
  by (induct k, auto)

inductive_simps coding_tm_HPair [simp]: "coding_tm (HPair x y)"

lemma quot_dbtm_coding [simp]: "coding_tm (quot_dbtm t)"
  apply (induct t rule: dbtm.induct, auto)
  apply (metis ORD_OF.simps(2) Ord)
  done

lemma quot_dbfm_coding [simp]: "coding_tm (quot_dbfm fm)"
  by (induct fm rule: dbfm.induct, auto)

lemma quot_fm_coding: fixes A::fm shows "coding_tm \<guillemotleft>A\<guillemotright>"
  by (metis quot_dbfm_coding quot_fm_def)

section \<open>V-Coding for terms and formulas, for the Second Theorem\<close>

text\<open>Infinite support, so we cannot use nominal primrec.\<close>
function vquot_dbtm :: "name set \<Rightarrow> dbtm \<Rightarrow> tm"
  where
   "vquot_dbtm V DBZero = Zero"
 | "vquot_dbtm V (DBVar name) = (if name \<in> V then Var name
                                 else ORD_OF (Suc (nat_of_name name)))"
 | "vquot_dbtm V (DBInd k) = HPair (HTuple 6) (ORD_OF k)"
 | "vquot_dbtm V (DBEats t u) = HPair (HTuple 1) (HPair (vquot_dbtm V t) (vquot_dbtm V u))"
by (auto, rule_tac y=b in dbtm.exhaust, auto)

termination
  by lexicographic_order

lemma fresh_vquot_dbtm [simp]: "i \<sharp> vquot_dbtm V tm \<longleftrightarrow> i \<sharp> tm \<or> i \<notin> atom ` V"
  by (induct tm rule: dbtm.induct) (auto simp: fresh_at_base pure_fresh)

text\<open>Infinite support, so we cannot use nominal primrec.\<close>
function vquot_dbfm :: "name set \<Rightarrow> dbfm \<Rightarrow> tm"
  where
   "vquot_dbfm V (DBMem t u) = HPair (HTuple 0) (HPair (vquot_dbtm V t) (vquot_dbtm V u))"
 | "vquot_dbfm V (DBEq t u) = HPair (HTuple 2) (HPair (vquot_dbtm V t) (vquot_dbtm V u))"
 | "vquot_dbfm V (DBDisj A B) = HPair (HTuple 3) (HPair (vquot_dbfm V A) (vquot_dbfm V B))"
 | "vquot_dbfm V (DBNeg A) = HPair (HTuple 4) (vquot_dbfm V A)"
 | "vquot_dbfm V (DBEx A) = HPair (HTuple 5) (vquot_dbfm V A)"
by (auto, rule_tac y=b in dbfm.exhaust, auto)

termination
  by lexicographic_order

lemma fresh_vquot_dbfm [simp]: "i \<sharp> vquot_dbfm V fm \<longleftrightarrow> i \<sharp> fm \<or> i \<notin> atom ` V"
  by (induct fm rule: dbfm.induct) (auto simp: HPair_def HTuple_minus_1)

class vquot =
  fixes vquot :: "'a \<Rightarrow> name set \<Rightarrow> tm"  ("\<lfloor>_\<rfloor>_"  [0,1000]1000)

instantiation tm :: vquot
begin
  definition vquot_tm :: "tm \<Rightarrow> name set \<Rightarrow> tm"
    where "vquot_tm t V = vquot_dbtm V (trans_tm [] t)"
  instance ..
end

lemma vquot_dbtm_empty [simp]: "vquot_dbtm {} t = quot_dbtm t"
  by (induct t rule: dbtm.induct) auto

lemma vquot_tm_empty [simp]: fixes t::tm shows "\<lfloor>t\<rfloor>{} = \<guillemotleft>t\<guillemotright>"
  by (simp add: vquot_tm_def quot_tm_def)

lemma vquot_dbtm_eq: "atom ` V \<inter> supp t = atom ` W \<inter> supp t \<Longrightarrow> vquot_dbtm V t = vquot_dbtm W t"
  by (induct t rule: dbtm.induct) (auto simp: image_iff, blast+)

instantiation fm :: vquot
begin
  definition vquot_fm :: "fm \<Rightarrow> name set \<Rightarrow> tm"
    where "vquot_fm A V = vquot_dbfm V (trans_fm [] A)"
  instance ..
end

lemma vquot_fm_fresh [simp]: fixes A::fm shows "i \<sharp> \<lfloor>A\<rfloor>V \<longleftrightarrow> i \<sharp> A \<or> i \<notin> atom ` V"
  by (simp add: vquot_fm_def)

lemma vquot_dbfm_empty [simp]: "vquot_dbfm {} A = quot_dbfm A"
  by (induct A rule: dbfm.induct) auto

lemma vquot_fm_empty [simp]: fixes A::fm shows "\<lfloor>A\<rfloor>{} = \<guillemotleft>A\<guillemotright>"
  by (simp add: vquot_fm_def quot_fm_def)

lemma vquot_dbfm_eq: "atom ` V \<inter> supp A = atom ` W \<inter> supp A \<Longrightarrow> vquot_dbfm V A = vquot_dbfm W A"
  by (induct A rule: dbfm.induct) (auto simp: intro!: vquot_dbtm_eq, blast+)

lemma vquot_fm_insert:
  fixes A::fm shows "atom i \<notin> supp A \<Longrightarrow> \<lfloor>A\<rfloor>(insert i V) = \<lfloor>A\<rfloor>V"
  by (auto simp: vquot_fm_def supp_conv_fresh intro: vquot_dbfm_eq)

declare HTuple.simps [simp del]

end


(*  Author:     Tobias Nipkow, 2007  *)

theory FRE
imports LinArith
begin

subsection\<open>Ferrante-Rackoff \label{sec:FRE}\<close>

text\<open>This section formalizes a slight variant of Ferrante and
Rackoff's algorithm~\<^cite>\<open>"FerranteR-SIAM75"\<close>. We consider equalities
separately, which improves performance.\<close>

fun between :: "real * real list \<Rightarrow> real * real list \<Rightarrow> real * real list"
where "between (r,cs) (s,ds) = ((r+s)/2, (1/2) *\<^sub>s (cs+ds))"

definition FR\<^sub>1 :: "atom fm \<Rightarrow> atom fm" where
"FR\<^sub>1 \<phi> =
(let as = R.atoms\<^sub>0 \<phi>; lbs = lbounds as; ubs = ubounds as; ebs = ebounds as;
     intrs = [subst \<phi> (between l u) . l \<leftarrow> lbs, u \<leftarrow> ubs]
 in list_disj (inf\<^sub>- \<phi> # inf\<^sub>+ \<phi> # intrs @ map (subst \<phi>) ebs))"

lemma dense:
  "\<lbrakk> nqfree f; \<forall>y\<in>{l<..<x}. y \<notin> LB f xs; \<forall>y\<in>{x<..<u}. y \<notin> UB f xs;
     l < x; x < u; x \<notin> EQ f xs;  R.I f (x#xs); l < y; y < u\<rbrakk>
   \<Longrightarrow> R.I f (y#xs)"
proof(induct f)
  case (Atom a)
  show ?case
  proof (cases a)
    case (Less r cs)
    show ?thesis
    proof (cases cs)
      case Nil thus ?thesis using Atom Less by (simp add:depends\<^sub>R_def)
    next
      case (Cons c cs)
      hence "r < c*x + \<langle>cs,xs\<rangle>" using Atom Less by simp
      { assume "c=0" hence ?thesis using Atom Less Cons by simp }
      moreover
      { assume "c<0"
        hence "x < (r - \<langle>cs,xs\<rangle>)/c" (is "_ < ?u") using \<open>r < c*x + \<langle>cs,xs\<rangle>\<close>
          by (simp add: field_simps)
        have ?thesis
        proof (rule ccontr)
          assume "\<not> R.I (Atom a) (y#xs)"
          hence "?u \<le> y" using Atom Less Cons \<open>c<0\<close>
            by (auto simp add: field_simps)
          hence "?u < u" using \<open>y<u\<close> by simp
          with \<open>x<?u\<close> show False using Atom Less Cons \<open>c<0\<close>
            by(auto simp:depends\<^sub>R_def)
        qed } moreover
      { assume "c>0"
        hence "x > (r - \<langle>cs,xs\<rangle>)/c" (is "_ > ?l") using \<open>r < c*x + \<langle>cs,xs\<rangle>\<close>
          by (simp add: field_simps)
        have ?thesis
        proof (rule ccontr)
          assume "\<not> R.I (Atom a) (y#xs)"
          hence "?l \<ge> y" using Atom Less Cons \<open>c>0\<close>
            by (auto simp add: field_simps)
          hence "?l > l" using \<open>y>l\<close> by simp
          with \<open>?l<x\<close> show False using Atom Less Cons \<open>c>0\<close>
            by (auto simp:depends\<^sub>R_def)
        qed }
      ultimately show ?thesis by force
    qed
  next
    case (Eq r cs)
    show ?thesis
    proof (cases cs)
      case Nil thus ?thesis using Atom Eq by (simp add:depends\<^sub>R_def)
    next
      case (Cons c cs)
      hence "r = c*x + \<langle>cs,xs\<rangle>" using Atom Eq by simp
      { assume "c=0" hence ?thesis using Atom Eq Cons by simp }
      moreover
      { assume "c\<noteq>0"
        hence ?thesis using \<open>r = c*x + \<langle>cs,xs\<rangle>\<close> Atom Eq Cons \<open>l<y\<close> \<open>y<u\<close>
          by (auto simp: depends\<^sub>R_def split: if_splits) }
      ultimately show ?thesis by force
    qed
  qed
next
  case (And f1 f2) thus ?case
    by auto (metis (no_types, opaque_lifting))+
next
  case (Or f1 f2) thus ?case
    by auto (metis (no_types, opaque_lifting))+
qed fastforce+

theorem I_FR\<^sub>1:
assumes "nqfree \<phi>" shows "R.I (FR\<^sub>1 \<phi>) xs = (\<exists>x. R.I \<phi> (x#xs))"
  (is "?FR = ?EX")
proof
  assume ?FR
  { assume "R.I (inf\<^sub>- \<phi>) xs"
    hence ?EX using \<open>?FR\<close> min_inf[OF \<open>nqfree \<phi>\<close>, where xs=xs]
      by(auto simp add:FR\<^sub>1_def)
  } moreover
  { assume "R.I (inf\<^sub>+ \<phi>) xs"
    hence ?EX using \<open>?FR\<close> plus_inf[OF \<open>nqfree \<phi>\<close>, where xs=xs]
      by(auto simp add:FR\<^sub>1_def)
  } moreover
  { assume "\<exists>x \<in> EQ \<phi> xs. R.I \<phi> (x#xs)"
    hence ?EX using \<open>?FR\<close> by(auto simp add:FR\<^sub>1_def)
  } moreover
  { assume "\<not>R.I (inf\<^sub>- \<phi>) xs \<and> \<not>R.I (inf\<^sub>+ \<phi>) xs \<and>
            (\<forall>x\<in>EQ \<phi> xs. \<not>R.I \<phi> (x#xs))"
    with \<open>?FR\<close> obtain r cs s ds
      where "R.I (subst \<phi> (between (r,cs) (s,ds))) xs"
      by(auto simp: FR\<^sub>1_def eval_def
        diff_divide_distrib set_ebounds I_subst \<open>nqfree \<phi>\<close>) blast
    hence "R.I \<phi> (eval (between (r,cs) (s,ds)) xs # xs)"
      by(simp add:I_subst \<open>nqfree \<phi>\<close>)
    hence ?EX .. }
  ultimately show ?EX by blast
next
  assume ?EX
  then obtain x where x: "R.I \<phi> (x#xs)" ..
  { assume "R.I (inf\<^sub>- \<phi>) xs \<or> R.I (inf\<^sub>+ \<phi>) xs"
    hence ?FR by(auto simp:FR\<^sub>1_def)
  } moreover
  { assume "x \<in> EQ \<phi> xs"
    then obtain r cs
      where "(r,cs) \<in> set(ebounds(R.atoms\<^sub>0 \<phi>)) \<and> x = r + \<langle>cs,xs\<rangle>"
      by(force simp:set_ebounds field_simps)
    moreover hence "R.I (subst \<phi> (r,cs)) xs" using x
      by(auto simp: I_subst \<open>nqfree \<phi>\<close> eval_def)
    ultimately have ?FR by(force simp:FR\<^sub>1_def) } moreover
  { assume "\<not> R.I (inf\<^sub>- \<phi>) xs" and "\<not> R.I (inf\<^sub>+ \<phi>) xs" and "x \<notin> EQ \<phi> xs"
    obtain l where "l \<in> LB \<phi> xs" "l < x"
      using LBex[OF \<open>nqfree \<phi>\<close> x \<open>\<not> R.I (inf\<^sub>- \<phi>) xs\<close> \<open>x \<notin> EQ \<phi> xs\<close>] ..
    obtain u where "u \<in> UB \<phi> xs" "x < u"
      using UBex[OF \<open>nqfree \<phi>\<close> x \<open>\<not> R.I (inf\<^sub>+ \<phi>) xs\<close> \<open>x \<notin> EQ \<phi> xs\<close>] ..
    have "\<exists>l\<in>LB \<phi> xs. \<exists>u\<in>UB \<phi> xs. l<u \<and> (\<forall>y. l < y \<and> y < u \<longrightarrow> R.I \<phi> (y#xs))"
      using dense_interval[where P = "\<lambda>x. R.I \<phi> (x#xs)", OF finite_LB finite_UB \<open>l:LB \<phi> xs\<close> \<open>u:UB \<phi> xs\<close> \<open>l<x\<close> \<open>x<u\<close> x] x dense[OF \<open>nqfree \<phi>\<close> _ _ _ _ \<open>x \<notin> EQ \<phi> xs\<close>] by simp
    then obtain r c cs s d ds
      where "Less r (c # cs) \<in> set (R.atoms\<^sub>0 \<phi>)" "Less s (d # ds) \<in> set (R.atoms\<^sub>0 \<phi>)"
          "\<And>y. (r - \<langle>cs,xs\<rangle>) / c < y \<Longrightarrow> y < (s - \<langle>ds,xs\<rangle>) / d \<Longrightarrow> R.I \<phi> (y # xs)"
        and *: "c > 0" "d < 0" "(r - \<langle>cs,xs\<rangle>) / c < (s - \<langle>ds,xs\<rangle>) / d"
      by blast
    moreover
      have "(r - \<langle>cs,xs\<rangle>) / c < eval (between (r / c, (-1 / c) *\<^sub>s cs) (s / d, (-1 / d) *\<^sub>s ds)) xs" (is ?P)
        and "eval (between (r / c, (-1 / c) *\<^sub>s cs) (s / d, (-1 / d) *\<^sub>s ds)) xs < (s - \<langle>ds,xs\<rangle>) / d" (is ?Q)
    proof -
      from * have [simp]: "c * (c * (d * (d * 4))) > 0"
        by (simp add: algebra_split_simps)
      from * have "c * s + d * \<langle>cs,xs\<rangle> < d * r + c * \<langle>ds,xs\<rangle>"
        by (simp add: field_simps)
      with * have "(2 * c * c * d) * (d * r + c * \<langle>ds,xs\<rangle>)
        < (2 * c * c * d) * (c * s + d * \<langle>cs,xs\<rangle>)"
        and "(2 * c * d * d) * (c * s + d * \<langle>cs,xs\<rangle>)
        < (2 * c * d * d) * (d * r + c * \<langle>ds,xs\<rangle>)" by simp_all
      with * show ?P and ?Q by (auto simp add: field_simps eval_def iprod_left_add_distrib)
    qed
    ultimately have ?FR
      by (fastforce simp: FR\<^sub>1_def bex_Un set_lbounds set_ubounds set_ebounds I_subst \<open>nqfree \<phi>\<close>)
  } ultimately show ?FR by blast
qed

definition "FR = R.lift_nnf_qe FR\<^sub>1"

lemma qfree_FR\<^sub>1: "nqfree \<phi> \<Longrightarrow> qfree (FR\<^sub>1 \<phi>)"
apply(simp add:FR\<^sub>1_def)
apply(rule qfree_list_disj)
apply(auto simp:qfree_min_inf qfree_plus_inf set_ubounds set_lbounds set_ebounds image_def qfree_map_fm)
done

theorem I_FR: "R.I (FR \<phi>) xs = R.I \<phi> xs"
by(simp add:I_FR\<^sub>1 FR_def R.I_lift_nnf_qe qfree_FR\<^sub>1)

theorem qfree_FR: "qfree (FR \<phi>)"
by(simp add:FR_def R.qfree_lift_nnf_qe qfree_FR\<^sub>1)

end