(*  Title:       Primitive recursive coding of lists of natural numbers
    Author:      Michael Nedzelsky <MichaelNedzelsky at yandex.ru>, 2008
    Maintainer:  Michael Nedzelsky <MichaelNedzelsky at yandex.ru>
*)

header {* Primitive recursive coding of lists of natural numbers *}

theory PRecList
imports PRecFun
begin

text {*
  We introduce a particular coding @{text "list_to_nat"} from lists of
  natural numbers to natural numbers.
*}

definition
  c_len :: "nat \<Rightarrow> nat" where
  "c_len = (\<lambda> (u::nat). (sgn1 u) * (c_fst(u-(1::nat))+1))"

lemma c_len_1: "c_len u = (case u of 0 \<Rightarrow> 0 | Suc v \<Rightarrow> c_fst(v)+1)" by (unfold c_len_def, cases u, auto)

lemma c_len_is_pr: "c_len \<in> PrimRec1" unfolding c_len_def by prec

lemma c_len_2: "u \<noteq> 0 \<Longrightarrow> c_len u = c_fst(u-(1::nat))+1" by (simp add: c_len_def)

lemma c_len_3: "u>0 \<Longrightarrow> c_len u > 0" by (simp add: c_len_2)

lemma c_len_4: "c_len u = 0 \<Longrightarrow> u = 0"
proof cases
  assume A1: "u = 0"
  thus ?thesis by simp
next
  assume A1: "c_len u = 0" and A2: "u \<noteq> 0"
  from A2 have "c_len u > 0" by (simp add: c_len_3)
  from A1 this show "u=0" by simp
qed

lemma c_len_5: "c_len u > 0 \<Longrightarrow> u > 0"
proof cases
  assume A1: "c_len u > 0" and A2: "u=0"
  from A2 have "c_len u = 0" by simp
  from A1 this show ?thesis by simp
next
  assume A1: "u \<noteq> 0"
  from A1 show "u>0" by simp
qed

fun c_fold :: "nat list \<Rightarrow> nat" where
    "c_fold [] = 0"
  | "c_fold [x] = x"
  | "c_fold (x#ls) = c_pair x (c_fold ls)"

lemma c_fold_0: "ls \<noteq> [] \<Longrightarrow> c_fold (x#ls) = c_pair x (c_fold ls)"
proof -
  assume A1: "ls \<noteq> []"
  then have S1: "ls = (hd ls)#(tl ls)" by simp
  then have S2: "x#ls = x#(hd ls)#(tl ls)" by simp
  have S3: "c_fold (x#(hd ls)#(tl ls)) = c_pair x (c_fold ((hd ls)#(tl ls)))" by simp
  from S1 S2 S3 show ?thesis by simp
qed

primrec
  c_unfold :: "nat \<Rightarrow> nat \<Rightarrow> nat list"
where
  "c_unfold 0 u = []"
| "c_unfold (Suc k) u = (if k = 0 then [u] else ((c_fst u) # (c_unfold k (c_snd u))))"

lemma c_fold_1: "c_unfold 1 (c_fold [x]) = [x]" by simp

lemma c_fold_2: "c_fold (c_unfold 1 u) = u" by simp

lemma c_unfold_1: "c_unfold 1 u = [u]" by simp

lemma c_unfold_2: "c_unfold (Suc 1) u = (c_fst u) # (c_unfold 1 (c_snd u))" by simp

lemma c_unfold_3: "c_unfold (Suc 1) u = [c_fst u, c_snd u]" by simp

lemma c_unfold_4: "k > 0 \<Longrightarrow> c_unfold (Suc k) u = (c_fst u) # (c_unfold k (c_snd u))" by simp

lemma c_unfold_4_1: "k > 0 \<Longrightarrow> c_unfold (Suc k) u \<noteq> []" by (simp add: c_unfold_4)

lemma two: "(2::nat) = Suc 1" by simp

lemma c_unfold_5: "c_unfold 2 u = [c_fst u, c_snd u]" by (simp add: two)

lemma c_unfold_6: "k>0 \<Longrightarrow> c_unfold k u \<noteq> []"
proof -
  assume A1: "k>0"
  let ?k1 = "k-(1::nat)"
  from A1 have S1: "k = Suc ?k1" by simp
  have S2: "?k1 = 0 \<Longrightarrow> ?thesis"
  proof -
    assume A2_1: "?k1=0"
    from A1 A2_1 have S2_1: "k=1" by simp
    from S2_1 show ?thesis by (simp add: c_unfold_1)
  qed
  have S3: "?k1 > 0 \<Longrightarrow> ?thesis"
  proof -
    assume A3_1: "?k1 > 0"
    from A3_1 have S3_1: "c_unfold (Suc ?k1) u \<noteq> []" by (rule c_unfold_4_1)
    from S1 S3_1 show ?thesis by simp
  qed
  from S2 S3 show ?thesis by arith
qed

lemma th_lm_1: "k=1 \<Longrightarrow> (\<forall> u. c_fold (c_unfold k u) = u)" by (simp add: c_fold_2)

lemma th_lm_2: "\<lbrakk>k>0; (\<forall> u. c_fold (c_unfold k u) = u)\<rbrakk> \<Longrightarrow> (\<forall> u. c_fold (c_unfold (Suc k) u) = u)"
proof
  assume A1: "k>0"
  assume A2: "\<forall> u. c_fold (c_unfold k u) = u"
  fix u
  from A1 have S1: "c_unfold (Suc k) u = (c_fst u) # (c_unfold k (c_snd u))" by (rule c_unfold_4)
  let ?ls = "c_unfold k (c_snd u)"
  from A1 have S2: "?ls \<noteq> []" by (rule c_unfold_6)
  from S2 have S3: "c_fold ( (c_fst u) # ?ls) = c_pair (c_fst u) (c_fold ?ls)" by (rule c_fold_0)
  from A2 have S4: "c_fold ?ls = c_snd u" by simp
  from S3 S4 have S5: "c_fold ( (c_fst u) # ?ls) = c_pair (c_fst u) (c_snd u)" by simp
  from S5 have S6: "c_fold ( (c_fst u) # ?ls) = u" by simp
  from S1 S6 have S7: "c_fold (c_unfold (Suc k) u) = u" by simp
  thus "c_fold (c_unfold (Suc k) u) = u" .
qed

lemma th_lm_3: "(\<forall> u. c_fold (c_unfold (Suc k) u) = u)\<Longrightarrow> (\<forall> u. c_fold (c_unfold (Suc (Suc k)) u) = u)"
proof -
  assume A1: "\<forall> u. c_fold (c_unfold (Suc k) u) = u"
  let ?k1 = "Suc k"
  have S1: "?k1 > 0" by simp
  from S1 A1 have S2: "\<forall> u. c_fold (c_unfold (Suc ?k1) u) = u" by (rule th_lm_2)
  thus ?thesis by simp
qed

theorem th_1: "\<forall> u. c_fold (c_unfold (Suc k) u) = u"
apply(induct k)
apply(simp add: c_fold_2)
apply(rule th_lm_3)
apply(assumption)
done

theorem th_2: "k > 0 \<Longrightarrow> (\<forall> u. c_fold (c_unfold k u) = u)"
proof -
  assume A1: "k>0"
  let ?k1 = "k-(1::nat)"
  from A1 have S1: "Suc ?k1 = k" by simp
  have S2: "\<forall> u. c_fold (c_unfold (Suc ?k1) u) = u" by (rule th_1)
  from S1 S2 show ?thesis by simp
qed

lemma c_fold_3: "c_unfold 2 (c_fold [x, y]) = [x, y]" by (simp add: two)

theorem c_unfold_len: "ALL u. length (c_unfold k u) = k"
apply(induct k)
apply(simp)
apply(subgoal_tac "n=(0::nat) \<or> n>0")
apply(drule disjE)
prefer 3
apply(simp_all)
apply(auto)
done

lemma th_3_lm_0: "\<lbrakk>c_unfold (length ls) (c_fold ls) = ls; ls = a # ls1; ls1 = aa # list\<rbrakk> \<Longrightarrow> c_unfold (length (x # ls)) (c_fold (x # ls)) = x # ls"
proof -
  assume A1: "c_unfold (length ls) (c_fold ls) = ls"
  assume A2: "ls = a # ls1"
  assume A3: "ls1 = aa # list"
  from A2 have S1: "ls \<noteq> []" by simp
  from S1 have S2: "c_fold (x#ls) = c_pair x (c_fold ls)" by (rule c_fold_0)
  have S3: "length (x#ls) = Suc (length ls)" by simp
  from S3 have S4: "c_unfold (length (x # ls)) (c_fold (x # ls)) = c_unfold (Suc (length ls)) (c_fold (x # ls))" by simp
  from A2 have S5: "length ls > 0" by simp
  from S5 have S6: "c_unfold (Suc (length ls)) (c_fold (x # ls)) = c_fst (c_fold (x # ls))#(c_unfold (length ls) (c_snd (c_fold (x#ls))))" by (rule c_unfold_4)
  from S2 have S7: "c_fst (c_fold (x#ls)) = x" by simp
  from S2 have S8: "c_snd (c_fold (x#ls)) = c_fold ls" by simp
  from S6 S7 S8 have S9: "c_unfold (Suc (length ls)) (c_fold (x # ls)) = x # (c_unfold (length ls) (c_fold ls))" by simp
  from A1 have S10: "x # (c_unfold (length ls) (c_fold ls)) = x # ls" by simp
  from S9 S10 have S11: "c_unfold (Suc (length ls)) (c_fold (x # ls)) = (x # ls)" by simp
  thus ?thesis by simp
qed

lemma th_3_lm_1: "\<lbrakk>c_unfold (length ls) (c_fold ls) = ls; ls = a # ls1\<rbrakk> \<Longrightarrow> c_unfold (length (x # ls)) (c_fold (x # ls)) = x # ls"
apply(cases ls1)
apply(simp add: c_fold_1)
apply(simp)
done

lemma th_3_lm_2: "c_unfold (length ls) (c_fold ls) = ls \<Longrightarrow> c_unfold (length (x # ls)) (c_fold (x # ls)) = x # ls"
apply(cases ls)
apply(simp add: c_fold_1)
apply(rule th_3_lm_1)
apply(assumption+)
done

theorem th_3: "c_unfold (length ls) (c_fold ls) = ls"
apply(induct ls)
apply(simp)
apply(rule th_3_lm_2)
apply(assumption)
done

definition
  list_to_nat :: "nat list \<Rightarrow> nat" where
  "list_to_nat = (\<lambda> ls. if ls=[] then 0 else (c_pair ((length ls) - 1) (c_fold ls))+1)"

definition
  nat_to_list :: "nat \<Rightarrow> nat list" where
  "nat_to_list = (\<lambda> u. if u=0 then [] else (c_unfold (c_len u) (c_snd (u-(1::nat)))))"

lemma nat_to_list_of_pos: "u>0 \<Longrightarrow> nat_to_list u = c_unfold (c_len u) (c_snd (u-(1::nat)))" by (simp add: nat_to_list_def)

theorem list_to_nat_th [simp]: "list_to_nat (nat_to_list u) = u"
proof -
  have S1: "u=0 \<Longrightarrow> ?thesis" by (simp add: list_to_nat_def nat_to_list_def)
  have S2: "u>0 \<Longrightarrow> ?thesis"
  proof -
    assume A1: "u>0"
    def D1: ls == "nat_to_list u"
    from D1 A1 have S2_1: "ls = c_unfold (c_len u) (c_snd (u-(1::nat)))" by (simp add: nat_to_list_def)
    let ?k = "c_len u"
    from A1 have S2_2: "?k > 0" by (rule c_len_3)
    from S2_1 have S2_3: "length ls = ?k" by (simp add: c_unfold_len)
    from S2_2 S2_3 have S2_4: "length ls > 0" by simp
    from S2_4 have S2_5: "ls \<noteq> []" by simp
    from S2_5 have S2_6: "list_to_nat ls = c_pair ((length ls)-(1::nat)) (c_fold ls)+1" by (simp add: list_to_nat_def)
    have S2_7: "c_fold ls = c_snd(u-(1::nat))"
    proof -
      from S2_1 have S2_7_1: "c_fold ls = c_fold (c_unfold (c_len u) (c_snd (u-(1::nat))))" by simp
      from S2_2 S2_7_1 show ?thesis by (simp add: th_2)
    qed
    have S2_8: "(length ls)-(1::nat) = c_fst (u-(1::nat))"
    proof -
      from S2_3 have S2_8_1: "length ls = c_len u" by simp
      from A1 S2_8_1 have S2_8_2: "length ls = c_fst(u-(1::nat)) + 1" by (simp add: c_len_2)
      from S2_8_2 show ?thesis by simp
    qed
    from S2_7 S2_8 have S2_9: "c_pair ((length ls)-(1::nat)) (c_fold ls) = c_pair (c_fst (u-(1::nat))) (c_snd (u-(1::nat)))" by simp
    from S2_9 have S2_10: "c_pair ((length ls)-(1::nat)) (c_fold ls) = u - (1::nat)" by simp
    from S2_6 S2_10 have S2_11: "list_to_nat ls = (u - (1::nat))+1" by simp
    from A1 have S2_12: "(u - (1::nat))+1 = u" by simp
    from D1 S2_11 S2_12 show ?thesis by simp
  qed
  from S1 S2 show ?thesis by arith
qed

theorem nat_to_list_th [simp]: "nat_to_list (list_to_nat ls) = ls"
proof -
  have S1: "ls=[] \<Longrightarrow> ?thesis" by (simp add: nat_to_list_def list_to_nat_def)
  have S2: "ls \<noteq> [] \<Longrightarrow> ?thesis"
  proof -
    assume A1: "ls \<noteq> []"
    def D1: u == "list_to_nat ls"
    from D1 A1 have S2_1: "u = (c_pair ((length ls)-(1::nat)) (c_fold ls))+1" by (simp add: list_to_nat_def)
    let ?k = "length ls"
    from A1 have S2_2: "?k > 0" by simp
    from S2_1 have S2_3: "u>0" by simp
    from S2_3 have S2_4: "nat_to_list u = c_unfold (c_len u) (c_snd (u-(1::nat)))" by (simp add: nat_to_list_def)
    have S2_5: "c_len u = length ls"
    proof -
      from S2_1 have S2_5_1: "u-(1::nat) = c_pair ((length ls)-(1::nat)) (c_fold ls)" by simp
      from S2_5_1 have S2_5_2: "c_fst (u-(1::nat)) = (length ls)-(1::nat)" by simp
      from S2_2 S2_5_2 have "c_fst (u-(1::nat))+1 = length ls" by simp
      from S2_3 this show ?thesis by (simp add: c_len_2)
    qed
    have S2_6: "c_snd (u-(1::nat)) = c_fold ls"
    proof -
      from S2_1 have S2_6_1: "u-(1::nat) = c_pair ((length ls)-(1::nat)) (c_fold ls)" by simp
      from S2_6_1 show ?thesis by simp
    qed
    from S2_4 S2_5 S2_6 have S2_7:"nat_to_list u = c_unfold (length ls) (c_fold ls)" by simp
    from S2_7 have "nat_to_list u = ls" by (simp add: th_3)
    from D1 this show ?thesis by simp
  qed
  have S3: "ls = [] \<or> ls \<noteq> []" by simp
  from S1 S2 S3 show ?thesis by auto
qed

lemma [simp]: "list_to_nat [] = 0" by (simp add: list_to_nat_def)

lemma [simp]: "nat_to_list 0 = []" by (simp add: nat_to_list_def)

theorem c_len_th_1: "c_len (list_to_nat ls) = length ls"
proof (cases)
  assume "ls=[]"
  from this show ?thesis by simp
next
  assume S1: "ls \<noteq> []"
  then have S2: "list_to_nat ls = c_pair ((length ls)-(1::nat)) (c_fold ls)+1" by (simp add: list_to_nat_def)
  let ?u = "list_to_nat ls"
  from S2 have u_not_zero: "?u > 0" by simp
  from S2 have S3: "?u-(1::nat) = c_pair ((length ls)-(1::nat)) (c_fold ls)" by simp
  then have S4: "c_fst(?u-(1::nat)) = (length ls)-(1::nat)" by simp
  from S1 this have S5: "c_fst(?u-(1::nat))+1=length ls" by simp
  from u_not_zero S5 have S6: "c_len (?u) = length ls" by (simp add: c_len_2)
  from S1 S6 show ?thesis by simp
qed

theorem "length (nat_to_list u) = c_len u"
proof -
  let ?ls = "nat_to_list u"
  have S1: "u = list_to_nat ?ls" by (rule list_to_nat_th [THEN sym])
  from c_len_th_1 have S2: "length ?ls = c_len (list_to_nat ?ls)" by (rule sym)
  from S1 S2 show ?thesis by (rule ssubst)
qed

definition
  c_hd :: "nat \<Rightarrow> nat" where
  "c_hd = (\<lambda> u. if u=0 then 0 else hd (nat_to_list u))"

definition
  c_tl :: "nat \<Rightarrow> nat" where
  "c_tl = (\<lambda> u. list_to_nat (tl (nat_to_list u)))"

definition
  c_cons :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_cons = (\<lambda> x u. list_to_nat (x # (nat_to_list u)))"

lemma [simp]: "c_hd 0 = 0" by (simp add: c_hd_def)

lemma c_hd_aux0: "c_len u = 1 \<Longrightarrow> nat_to_list u = [c_snd (u-(1::nat))]" by (simp add: nat_to_list_def c_len_5)

lemma c_hd_aux1: "c_len u = 1 \<Longrightarrow> c_hd u = c_snd (u-(1::nat))"
proof -
  assume A1: "c_len u = 1"
  then have S1: "nat_to_list u = [c_snd (u-(1::nat))]" by (simp add: nat_to_list_def c_len_5)
  from A1 have "u > 0" by (simp add: c_len_5)
  with S1 show ?thesis by (simp add: c_hd_def)
qed

lemma c_hd_aux2: "c_len u > 1 \<Longrightarrow> c_hd u = c_fst (c_snd (u-(1::nat)))"
proof -
  assume A1: "c_len u > 1"
  let ?k = "(c_len u) - 1"
  from A1 have S1: "c_len u = Suc ?k" by simp
  from A1 have S2: "c_len u > 0" by simp
  from S2 have S3: "u > 0" by (rule c_len_5)
  from S3 have S4: "c_hd u = hd (nat_to_list u)" by (simp add: c_hd_def)
  from S3 have S5: "nat_to_list u = c_unfold (c_len u) (c_snd (u-(1::nat)))" by (rule nat_to_list_of_pos)
  from S1 S5 have S6: "nat_to_list u = c_unfold (Suc ?k) (c_snd (u-(1::nat)))" by simp
  from A1 have S7: "?k > 0" by simp
  from S7 have S8: "c_unfold (Suc ?k) (c_snd (u-(1::nat))) = (c_fst (c_snd (u-(1::nat)))) # (c_unfold ?k (c_snd (c_snd (u-(1::nat)))))" by (rule c_unfold_4)
  from S6 S8 have S9: "nat_to_list u = (c_fst (c_snd (u-(1::nat)))) # (c_unfold ?k (c_snd (c_snd (u-(1::nat)))))" by simp
  from S9 have S10: "hd (nat_to_list u) = c_fst (c_snd (u-(1::nat)))" by simp
  from S4 S10 show ?thesis by simp
qed

lemma c_hd_aux3: "u > 0 \<Longrightarrow> c_hd u = (if (c_len u) = 1 then c_snd (u-(1::nat)) else c_fst (c_snd (u-(1::nat))))"
proof -
  assume A1: "u > 0"
  from A1 have "c_len u > 0" by (rule c_len_3)
  then have S1: "c_len u = 1 \<or> c_len u > 1" by arith
  let ?tmp = "if (c_len u) = 1 then c_snd (u-(1::nat)) else c_fst (c_snd (u-(1::nat)))"
  have S2: "c_len u = 1 \<Longrightarrow> ?thesis"
  proof -
    assume A2_1: "c_len u = 1"
    then have S2_1: "c_hd u = c_snd (u-(1::nat))" by (rule c_hd_aux1)
    from A2_1 have S2_2: "?tmp = c_snd(u-(1::nat))" by simp
    from S2_1 this show ?thesis by simp
  qed
  have S3: "c_len u > 1 \<Longrightarrow> ?thesis"
  proof -
    assume A3_1: "c_len u > 1"
    from A3_1 have S3_1: "c_hd u = c_fst (c_snd (u-(1::nat)))" by (rule c_hd_aux2)
    from A3_1 have S3_2: "?tmp = c_fst (c_snd (u-(1::nat)))" by simp
    from S3_1 this show ?thesis by simp
  qed
  from S1 S2 S3 show ?thesis by auto
qed

lemma c_hd_aux4: "c_hd u = (if u=0 then 0 else (if (c_len u) = 1 then c_snd (u-(1::nat)) else c_fst (c_snd (u-(1::nat)))))"
proof cases
  assume "u=0" then show ?thesis by simp
next
  assume "u \<noteq> 0" then have A1: "u > 0" by simp
  then show ?thesis by (simp add: c_hd_aux3)
qed

lemma [simp]: "c_tl 0 = 0" by (simp add: c_tl_def)

lemma c_tl_eq_tl: "c_tl (list_to_nat ls) = list_to_nat (tl ls)" by (simp add: c_tl_def)

lemma tl_eq_c_tl: "tl (nat_to_list x) = nat_to_list (c_tl x)" by (simp add: c_tl_def)

lemma c_tl_aux1: "c_len u = 1 \<Longrightarrow> c_tl u = 0" by (unfold c_tl_def, simp add: c_hd_aux0)

lemma c_tl_aux2: "c_len u > 1 \<Longrightarrow> c_tl u = (c_pair (c_len u - (2::nat)) (c_snd (c_snd (u-(1::nat))))) + 1"
proof -
  assume A1: "c_len u > 1"
  let ?k = "(c_len u) - 1"
  from A1 have S1: "c_len u = Suc ?k" by simp
  from A1 have S2: "c_len u > 0" by simp
  from S2 have S3: "u > 0" by (rule c_len_5)
  from S3 have S4: "nat_to_list u = c_unfold (c_len u) (c_snd (u-(1::nat)))" by (rule nat_to_list_of_pos)
  from A1 have S5: "?k > 0" by simp
  from S5 have S6: "c_unfold (Suc ?k) (c_snd (u-(1::nat))) = (c_fst (c_snd (u-(1::nat)))) # (c_unfold ?k (c_snd (c_snd (u-(1::nat)))))" by (rule c_unfold_4)
  from S6 have S7: "tl (c_unfold (Suc ?k) (c_snd (u-(1::nat)))) = c_unfold ?k (c_snd (c_snd (u-(1::nat))))" by simp
  from S2 S4 S7 have S8: "tl (nat_to_list u) = c_unfold ?k (c_snd (c_snd (u-(1::nat))))" by simp
  def D1: ls == "tl (nat_to_list u)"
  from D1 S8 have S9: "length ls = ?k" by (simp add: c_unfold_len)
  from D1 have S10: "c_tl u = list_to_nat ls" by (simp add: c_tl_def)
  from S5 S9 have S11: "length ls > 0" by simp
  from S11 have S12: "ls \<noteq> []" by simp
  from S12 have S13: "list_to_nat ls = (c_pair ((length ls) - 1) (c_fold ls))+1" by (simp add: list_to_nat_def)
  from S10 S13 have S14: "c_tl u = (c_pair ((length ls) - 1) (c_fold ls))+1" by simp
  from S9 have S15: "(length ls)-(1::nat) = ?k-(1::nat)" by simp
  from A1 have S16: "?k-(1::nat) = c_len u - (2::nat)" by arith
  from S15 S16 have S17: "(length ls)-(1::nat) = c_len u - (2::nat)" by simp
  from D1 S8 have S18: "ls = c_unfold ?k (c_snd (c_snd (u-(1::nat))))" by simp
  from S5 have S19: "c_fold (c_unfold ?k (c_snd (c_snd (u-(1::nat))))) = c_snd (c_snd (u-(1::nat)))" by (simp add: th_2)
  from S18 S19 have S20: "c_fold ls = c_snd (c_snd (u-(1::nat)))" by simp
  from S14 S17 S20 show ?thesis by simp
qed

lemma c_tl_aux3: "c_tl u = (sgn1 ((c_len u) - 1))*((c_pair (c_len u - (2::nat)) (c_snd (c_snd (u-(1::nat))))) + 1)" (is "_ = ?R")
proof -
  have S1: "u=0 \<Longrightarrow> ?thesis" by simp
  have S2: "u>0 \<Longrightarrow> ?thesis"
  proof -
    assume A1: "u>0"
    have S2_1: "c_len u = 1 \<Longrightarrow> ?thesis" by (simp add: c_tl_aux1)
    have S2_2: "c_len u \<noteq> 1 \<Longrightarrow> ?thesis"
    proof -
      assume A2_2_1: "c_len u \<noteq> 1"
      from A1 have S2_2_1: "c_len u > 0" by (rule c_len_3)
      from A2_2_1 S2_2_1 have S2_2_2: "c_len u > 1" by arith
      from this have S2_2_3: "c_len u - 1 > 0" by simp
      from this have S2_2_4: "sgn1 (c_len u - 1)=1" by simp
      from S2_2_4 have S2_2_5: "?R = (c_pair (c_len u - (2::nat)) (c_snd (c_snd (u-(1::nat))))) + 1" by simp
      from S2_2_2 have S2_2_6: "c_tl u = (c_pair (c_len u - (2::nat)) (c_snd (c_snd (u-(1::nat))))) + 1" by (rule c_tl_aux2)
      from S2_2_5 S2_2_6 show ?thesis by simp
    qed
  from S2_1 S2_2 show ?thesis by blast
  qed
  from S1 S2 show ?thesis by arith
qed

lemma c_tl_less: "u > 0 \<Longrightarrow> c_tl u < u"
proof -
  assume A1: "u > 0"
  then have S1: "c_len u > 0" by (rule c_len_3)
  then show ?thesis
  proof cases
    assume "c_len u = 1"
    from this A1 show ?thesis by (simp add: c_tl_aux1)
  next
    assume "\<not> c_len u = 1" with S1 have A2: "c_len u > 1" by simp
    then have S2: "c_tl u = (c_pair (c_len u - (2::nat)) (c_snd (c_snd (u-(1::nat))))) + 1" by (rule c_tl_aux2)
    from A1 have S3: "c_len u = c_fst(u-(1::nat))+1" by (simp add: c_len_def)
    from A2 S3 have S4: "c_len u - (2::nat) < c_fst(u-(1::nat))" by simp
    then have S5: "(c_pair (c_len u - (2::nat)) (c_snd (c_snd (u-(1::nat))))) < (c_pair (c_fst(u-(1::nat))) (c_snd (c_snd (u-(1::nat)))))" by (rule c_pair_strict_mono1)
    have S6: "c_snd (c_snd (u-(1::nat))) \<le> c_snd (u-(1::nat))" by (rule c_snd_le_arg)
    then have S7: "(c_pair (c_fst(u-(1::nat))) (c_snd (c_snd (u-(1::nat))))) \<le> (c_pair (c_fst(u-(1::nat))) (c_snd (u-(1::nat))))" by (rule c_pair_mono2)
    then have S8: "(c_pair (c_fst(u-(1::nat))) (c_snd (c_snd (u-(1::nat))))) \<le> u-(1::nat)" by simp
    with S5 have "(c_pair (c_len u - (2::nat)) (c_snd (c_snd (u-(1::nat))))) < u - (1::nat)" by simp
    with S2 have "c_tl u < (u-(1::nat))+1" by simp
    with A1 show ?thesis by simp
  qed
qed

lemma c_tl_le: "c_tl u \<le> u"
proof (cases u)
  assume "u=0"
  then show ?thesis by simp
next
  fix v assume A1: "u = Suc v"
  then have S1: "u > 0" by simp
  then have S2: "c_tl u < u" by (rule c_tl_less)
  with A1 show "c_tl u \<le> u" by simp
qed

theorem c_tl_is_pr: "c_tl \<in> PrimRec1"
proof -
  have "c_tl = (\<lambda> u. (sgn1 ((c_len u) - 1))*((c_pair (c_len u - (2::nat)) (c_snd (c_snd (u-(1::nat))))) + 1))" (is "_ = ?R") by (simp add: c_tl_aux3 ext)
  moreover from c_len_is_pr c_pair_is_pr have "?R \<in> PrimRec1" by prec
  ultimately show ?thesis by simp
qed

lemma c_cons_aux1: "c_cons x 0 = (c_pair 0 x) + 1"
apply(unfold c_cons_def)
apply(simp)
apply(unfold list_to_nat_def)
apply(simp)
done

lemma c_cons_aux2: "u > 0 \<Longrightarrow> c_cons x u = (c_pair (c_len u) (c_pair x (c_snd (u-(1::nat))))) + 1"
proof -
  assume A1: "u > 0"
  from A1 have S1: "c_len u > 0" by (rule c_len_3)
  from A1 have S2: "nat_to_list u = c_unfold (c_len u) (c_snd (u-(1::nat)))" by (rule nat_to_list_of_pos)
  def D1: ls == "nat_to_list u"
  from D1 S2 have S3: "ls = c_unfold (c_len u) (c_snd (u-(1::nat)))" by simp
  from S3 have S4: "length ls = c_len u" by (simp add: c_unfold_len)
  from S4 S1 have S5: "length ls > 0" by simp
  from S5 have S6: "ls \<noteq> []" by simp
  from D1 have S7: "c_cons x u = list_to_nat (x # ls)" by (simp add: c_cons_def)
  have S8: "list_to_nat (x # ls) = (c_pair ((length (x#ls))-(1::nat)) (c_fold (x#ls)))+1" by (simp add: list_to_nat_def)
  have S9: "(length (x#ls))-(1::nat) = length ls" by simp
  from S9 S4 S8 have S10: "list_to_nat (x # ls) = (c_pair (c_len u) (c_fold (x#ls)))+1" by simp
  have S11: "c_fold (x#ls) = c_pair x (c_snd (u-(1::nat)))"
  proof -
    from S6 have S11_1: "c_fold (x#ls) = c_pair x (c_fold ls)" by (rule c_fold_0)
    from S3 have S11_2: "c_fold ls = c_fold (c_unfold (c_len u) (c_snd (u-(1::nat))))" by simp
    from S1 S11_2 have S11_3: "c_fold ls = c_snd (u-(1::nat))" by (simp add: th_2)
    from S11_1 S11_3 show ?thesis by simp
  qed
  from S7 S10 S11 show ?thesis by simp
qed

lemma c_cons_aux3: "c_cons = (\<lambda> x u. (sgn2 u)*((c_pair 0 x)+1) + (sgn1 u)*((c_pair (c_len u) (c_pair x (c_snd (u-(1::nat))))) + 1))"
proof (rule ext, rule ext)
  fix x u show "c_cons x u = (sgn2 u)*((c_pair 0 x)+1) + (sgn1 u)*((c_pair (c_len u) (c_pair x (c_snd (u-(1::nat))))) + 1)" (is "_ = ?R")
  proof cases
    assume A1: "u=0"
    then have "?R = (c_pair 0 x)+1" by simp
    moreover from A1 have "c_cons x u = (c_pair 0 x)+1" by (simp add: c_cons_aux1)
    ultimately show ?thesis by simp
  next
    assume A1: "u\<noteq>0"
    then have S1: "?R = (c_pair (c_len u) (c_pair x (c_snd (u-(1::nat))))) + 1" by simp
    from A1 have S2: "c_cons x u = (c_pair (c_len u) (c_pair x (c_snd (u-(1::nat))))) + 1" by (simp add: c_cons_aux2)
    from S1 S2 have "c_cons x u = ?R" by simp
    then show ?thesis .
  qed
qed

lemma c_cons_pos: "c_cons x u > 0"
proof cases
  assume "u=0"
  then show "c_cons x u > 0" by (simp add: c_cons_aux1)
next
  assume "\<not> u=0" then have "u>0" by simp
  then show "c_cons x u > 0" by (simp add: c_cons_aux2)
qed

theorem c_cons_is_pr: "c_cons \<in> PrimRec2"
proof -
  have "c_cons = (\<lambda> x u. (sgn2 u)*((c_pair 0 x)+1) + (sgn1 u)*((c_pair (c_len u) (c_pair x (c_snd (u-(1::nat))))) + 1))" (is "_ = ?R") by (simp add: c_cons_aux3)
  moreover from c_pair_is_pr c_len_is_pr have "?R \<in> PrimRec2" by prec
  ultimately show ?thesis by simp
qed

definition
  c_drop :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_drop = PrimRecOp (\<lambda> x. x) (\<lambda> x y z. c_tl y)"

lemma c_drop_at_0 [simp]: "c_drop 0 x = x" by (simp add: c_drop_def)

lemma c_drop_at_Suc: "c_drop (Suc y) x = c_tl (c_drop y x)" by (simp add: c_drop_def)

theorem c_drop_is_pr: "c_drop \<in> PrimRec2"
proof -
  have "(\<lambda> x. x) \<in> PrimRec1" by (rule pr_id1_1)
  moreover from c_tl_is_pr have "(\<lambda> x y z. c_tl y) \<in> PrimRec3" by prec
  ultimately show ?thesis by (simp add: c_drop_def pr_rec)
qed

lemma c_tl_c_drop: "c_tl (c_drop y x) = c_drop y (c_tl x)"
apply(induct y)
apply(simp)
apply(simp add: c_drop_at_Suc)
done

lemma c_drop_at_Suc1: "c_drop (Suc y) x = c_drop y (c_tl x)"
apply(simp add: c_drop_at_Suc c_tl_c_drop)
done

lemma c_drop_df: "\<forall> ls. drop n ls = nat_to_list (c_drop n (list_to_nat ls))"
proof (induct n)
  show "\<forall> ls. drop 0 ls = nat_to_list (c_drop 0 (list_to_nat ls))" by (simp add: c_drop_def)
next
  fix n assume A1: "\<forall> ls. drop n ls = nat_to_list (c_drop n (list_to_nat ls))"
  then show "\<forall> ls. drop (Suc n) ls = nat_to_list (c_drop (Suc n) (list_to_nat ls))"
  proof -
    {
    fix ls::"nat list"
    have S1: "drop (Suc n) ls = drop n (tl ls)" by (rule drop_Suc)
    from A1 have S2: "drop n (tl ls) = nat_to_list (c_drop n (list_to_nat (tl ls)))" by simp
    also have "\<dots> = nat_to_list (c_drop n (c_tl (list_to_nat ls)))" by  (simp add: c_tl_eq_tl)
    also have "\<dots> = nat_to_list (c_drop (Suc n) (list_to_nat ls))" by  (simp add: c_drop_at_Suc1)
    finally have "drop n (tl ls) = nat_to_list (c_drop (Suc n) (list_to_nat ls))" by simp
    with S1 have "drop (Suc n) ls = nat_to_list (c_drop (Suc n) (list_to_nat ls))" by simp
    }
    then show ?thesis by blast
  qed
qed

definition
  c_nth :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_nth = (\<lambda> x n. c_hd (c_drop n x))"

lemma c_nth_is_pr: "c_nth \<in> PrimRec2"
proof (unfold c_nth_def)
  from c_hd_is_pr c_drop_is_pr show "(\<lambda>x n. c_hd (c_drop n x)) \<in> PrimRec2" by prec
qed

lemma c_nth_at_0: "c_nth x 0 = c_hd x" by (simp add: c_nth_def)

lemma c_hd_c_cons [simp]: "c_hd (c_cons x y) = x"
proof -
  have "c_cons x y > 0" by (rule c_cons_pos)
  then show ?thesis by (simp add: c_hd_def c_cons_def)
qed

lemma c_tl_c_cons [simp]: "c_tl (c_cons x y) = y" by (simp add: c_tl_def c_cons_def)

definition
  c_f_list :: "(nat \<Rightarrow> nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "c_f_list = (\<lambda> f.
    let g = (%x. c_cons (f 0 x) 0); h = (%a b c. c_cons (f (Suc a) c) b) in PrimRecOp g h)"

lemma c_f_list_at_0: "c_f_list f 0 x = c_cons (f 0 x) 0" by (simp add: c_f_list_def Let_def)

lemma c_f_list_at_Suc: "c_f_list f (Suc y) x = c_cons (f (Suc y) x) (c_f_list f y x)" by ((simp add: c_f_list_def Let_def))

lemma c_f_list_is_pr: "f \<in> PrimRec2 \<Longrightarrow> c_f_list f \<in> PrimRec2"
proof -
  assume A1: "f \<in> PrimRec2"
  let ?g = "(%x. c_cons (f 0 x) 0)"
  from A1 c_cons_is_pr have S1: "?g \<in> PrimRec1" by prec
  let ?h = "(%a b c. c_cons (f (Suc a) c) b)"
  from A1 c_cons_is_pr have S2: "?h \<in> PrimRec3" by prec
  from S1 S2 show ?thesis by (simp add: pr_rec c_f_list_def Let_def)
qed

lemma c_f_list_to_f_0: "f y x = c_hd (c_f_list f y x)"
apply(induct y)
apply(simp add: c_f_list_at_0)
apply(simp add: c_f_list_at_Suc)
done

lemma c_f_list_to_f: "f = (\<lambda> y x. c_hd (c_f_list f y x))"
apply(rule ext, rule ext)
apply(rule c_f_list_to_f_0)
done

lemma c_f_list_f_is_pr: "c_f_list f \<in> PrimRec2 \<Longrightarrow> f \<in> PrimRec2"
proof -
  assume A1: "c_f_list f \<in> PrimRec2"
  have S1: "f = (\<lambda> y x. c_hd (c_f_list f y x))" by (rule c_f_list_to_f)
  from A1 c_hd_is_pr have S2: "(\<lambda> y x. c_hd (c_f_list f y x)) \<in> PrimRec2" by prec
  with S1 show ?thesis by simp
qed

lemma c_f_list_lm_1: "c_nth (c_cons x y) (Suc z) = c_nth y z" by (simp add: c_nth_def c_drop_at_Suc1)

lemma c_f_list_lm_2: " z < Suc n \<Longrightarrow> c_nth (c_f_list f (Suc n) x) (Suc n - z) = c_nth (c_f_list f n x) (n - z)"
proof -
  assume "z < Suc n"
  then have "Suc n - z = Suc (n-z)" by arith
  then have "c_nth (c_f_list f (Suc n) x) (Suc n - z) = c_nth (c_f_list f (Suc n) x) (Suc (n - z))" by simp
  also have "\<dots> = c_nth (c_cons (f (Suc n) x) (c_f_list f n x)) (Suc (n - z))" by (simp add: c_f_list_at_Suc)
  also have "\<dots> = c_nth (c_f_list f n x) (n - z)" by (simp add: c_f_list_lm_1)
  finally show ?thesis by simp
qed

lemma c_f_list_nth: "z \<le> y \<longrightarrow> c_nth (c_f_list f y x) (y-z) = f z x"
proof (induct y)
  show "z \<le> 0 \<longrightarrow> c_nth (c_f_list f 0 x) (0 - z) = f z x"
  proof
    assume "z \<le> 0" then have A1: "z=0" by simp
    then have "c_nth (c_f_list f 0 x) (0 - z) = c_nth (c_f_list f 0 x) 0" by simp
    also have "\<dots> = c_hd (c_f_list f 0 x)" by (simp add: c_nth_at_0)
    also have "\<dots> = c_hd (c_cons (f 0 x) 0)" by (simp add: c_f_list_at_0)
    also have "\<dots> = f 0 x" by simp
    finally show "c_nth (c_f_list f 0 x) (0 - z) = f z x" by (simp add: A1)
  qed
next
  fix n assume A2: " z \<le> n \<longrightarrow> c_nth (c_f_list f n x) (n - z) = f z x" show "z \<le> Suc n \<longrightarrow> c_nth (c_f_list f (Suc n) x) (Suc n - z) = f z x"
  proof
    assume A3: "z \<le> Suc n"
    show " z \<le> Suc n \<Longrightarrow> c_nth (c_f_list f (Suc n) x) (Suc n - z) = f z x"
    proof cases
      assume AA1: "z \<le> n"
      then have AA2: "z < Suc n" by simp
      from A2 this have S1: "c_nth (c_f_list f n x) (n - z) = f z x" by auto
      from AA2 have "c_nth (c_f_list f (Suc n) x) (Suc n - z) = c_nth (c_f_list f n x) (n - z)" by (rule c_f_list_lm_2)
      with S1 show "c_nth (c_f_list f (Suc n) x) (Suc n - z) = f z x" by simp
    next
      assume "\<not> z \<le> n"
      from A3 this have S1: "z = Suc n" by simp
      then have S2: "Suc n - z = 0" by simp
      then have "c_nth (c_f_list f (Suc n) x) (Suc n - z) = c_nth (c_f_list f (Suc n) x) 0" by simp
      also have "\<dots> = c_hd (c_f_list f (Suc n) x)" by (simp add: c_nth_at_0)
      also have "\<dots> = c_hd (c_cons (f (Suc n) x) (c_f_list f n x))" by (simp add: c_f_list_at_Suc)
      also have "\<dots> = f (Suc n) x" by simp
      finally show "c_nth (c_f_list f (Suc n) x) (Suc n - z) = f z x" by (simp add: S1)
    qed
  qed
qed

theorem th_pr_rec: "\<lbrakk> g \<in> PrimRec1; h \<in> PrimRec3; (\<forall> x. (f 0 x) = (g x)); (\<forall> x y. (f (Suc y) x) = h y (f y x) x) \<rbrakk> \<Longrightarrow> f \<in> PrimRec2"
proof -
  assume g_is_pr: "g \<in> PrimRec1"
  assume h_is_pr: "h \<in> PrimRec3"
  assume f_0: "\<forall> x. f 0 x = g x"
  assume f_1: "\<forall> x y. (f (Suc y) x) = h y (f y x) x"
  let ?f = "PrimRecOp g h"
  from g_is_pr h_is_pr have S1: "?f \<in> PrimRec2" by (rule pr_rec)
  have f_2:"\<forall> x. ?f 0 x = g x" by simp
  have f_3: "\<forall> x y. (?f (Suc y) x) = h y (?f y x) x" by simp
  have S2: "f = ?f"
  proof -
    have "\<And> x y. f y x = ?f y x"
    apply(induct_tac y)
    apply(insert f_0 f_1)
    apply(auto)
    done
    then show "f = ?f" by (simp add: ext)
  qed
  from S1 S2 show ?thesis by simp
qed

theorem th_rec: "\<lbrakk> g \<in> PrimRec1; \<alpha> \<in> PrimRec2; h \<in> PrimRec3; (\<forall> x y. \<alpha> y x \<le> y); (\<forall> x. (f 0 x) = (g x)); (\<forall> x y. (f (Suc y) x) = h y (f (\<alpha> y x) x) x) \<rbrakk> \<Longrightarrow> f \<in> PrimRec2"
proof -
  assume g_is_pr: "g \<in> PrimRec1"
  assume a_is_pr: "\<alpha> \<in> PrimRec2"
  assume h_is_pr: "h \<in> PrimRec3"
  assume a_le: "(\<forall> x y. \<alpha> y x \<le> y)"
  assume f_0: "\<forall> x. f 0 x = g x"
  assume f_1: "\<forall> x y. (f (Suc y) x) = h y (f (\<alpha> y x) x) x"
  let ?g' = "\<lambda> x. c_cons (g x) 0"
  let ?h' = "\<lambda> a b c. c_cons (h a (c_nth b (a - (\<alpha> a c))) c) b"
  let ?r = "c_f_list f"
  from g_is_pr c_cons_is_pr have g'_is_pr: "?g' \<in> PrimRec1" by prec
  from h_is_pr c_cons_is_pr c_nth_is_pr a_is_pr have h'_is_pr: "?h' \<in> PrimRec3" by prec
  have S1: "\<forall> x. ?r 0 x = ?g' x"
  proof
    fix x have "?r 0 x = c_cons (f 0 x) 0" by (rule c_f_list_at_0)
    with f_0 have "?r 0 x = c_cons (g x) 0" by simp
    then show "?r 0 x = ?g' x" by simp
  qed
  have S2: "\<forall> x y. ?r (Suc y) x = ?h' y (?r y x) x"
  proof (rule allI, rule allI)
    fix x y show "?r (Suc y) x = ?h' y (?r y x) x"
    proof -
      have S2_1: "?r (Suc y) x = c_cons (f (Suc y) x) (?r y x)" by (rule c_f_list_at_Suc)
      with f_1 have S2_2: "f (Suc y) x = h y (f (\<alpha> y x) x) x" by simp
      from a_le have S2_3: "\<alpha> y x \<le> y" by simp
      then have S2_4: "f (\<alpha> y x) x = c_nth (?r y x) (y-(\<alpha> y x))" by (simp add: c_f_list_nth)
      from S2_1 S2_2 S2_4 show ?thesis by simp
    qed
  qed
  from g'_is_pr h'_is_pr S1 S2 have S3: "?r \<in> PrimRec2" by (rule th_pr_rec)
  then show "f \<in> PrimRec2" by (rule c_f_list_f_is_pr)
qed

declare c_tl_less [termination_simp]

fun c_assoc_have_key :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  c_assoc_have_key_df [simp del]: "c_assoc_have_key y x = (if y = 0 then 1 else
    (if c_fst (c_hd y) = x then 0 else c_assoc_have_key (c_tl y) x))"

lemma c_assoc_have_key_lm_1: "y \<noteq> 0 \<Longrightarrow> c_assoc_have_key y x = (if c_fst (c_hd y) = x then 0 else c_assoc_have_key (c_tl y) x)" by (simp add: c_assoc_have_key_df)

theorem c_assoc_have_key_is_pr: "c_assoc_have_key \<in> PrimRec2"
proof -
  let ?h = "\<lambda> a b c. if c_fst (c_hd (Suc a)) = c then 0 else b"
  let ?a = "\<lambda> y x. c_tl (Suc y)"
  let ?g = "\<lambda> x. (1::nat)"
  have g_is_pr: "?g \<in> PrimRec1" by (rule const_is_pr)
  from c_tl_is_pr have a_is_pr: "?a \<in> PrimRec2" by prec
  have h_is_pr: "?h \<in> PrimRec3"
  proof (rule if_eq_is_pr3)
    from c_fst_is_pr c_hd_is_pr show "(\<lambda>x y z. c_fst (c_hd (Suc x))) \<in> PrimRec3" by prec
  next
    show "(\<lambda>x y z. z) \<in> PrimRec3" by (rule pr_id3_3)
  next
    show "(\<lambda>x y z. 0) \<in> PrimRec3" by prec
  next
    show "(\<lambda>x y z. y) \<in> PrimRec3" by (rule pr_id3_2)
  qed
  have a_le: "\<forall> x y. ?a y x \<le> y"
  proof (rule allI, rule allI)
    fix x y show "?a y x \<le> y"
    proof -
      have "Suc y > 0" by simp
      then have "?a y x < Suc y" by (rule c_tl_less)
      then show ?thesis by simp
    qed
  qed
  have f_0: "\<forall> x. c_assoc_have_key 0 x = ?g x" by (simp add: c_assoc_have_key_df)
  have f_1: "\<forall> x y. c_assoc_have_key (Suc y) x = ?h y (c_assoc_have_key (?a y x) x) x" by (simp add: c_assoc_have_key_df)
  from g_is_pr a_is_pr h_is_pr a_le f_0 f_1 show ?thesis by (rule th_rec)
qed

fun c_assoc_value :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  c_assoc_value_df [simp del]: "c_assoc_value y x = (if y = 0 then 0 else
    (if c_fst (c_hd y) = x then c_snd (c_hd y) else c_assoc_value (c_tl y) x))"

lemma c_assoc_value_lm_1: "y \<noteq> 0 \<Longrightarrow> c_assoc_value y x = (if c_fst (c_hd y) = x then c_snd (c_hd y) else c_assoc_value (c_tl y) x)" by (simp add: c_assoc_value_df)

theorem c_assoc_value_is_pr: "c_assoc_value \<in> PrimRec2"
proof -
  let ?h = "\<lambda> a b c. if c_fst (c_hd (Suc a)) = c then c_snd (c_hd (Suc a)) else b"
  let ?a = "\<lambda> y x. c_tl (Suc y)"
  let ?g = "\<lambda> x. (0::nat)"
  have g_is_pr: "?g \<in> PrimRec1" by (rule const_is_pr)
  from c_tl_is_pr have a_is_pr: "?a \<in> PrimRec2" by prec
  have h_is_pr: "?h \<in> PrimRec3"
  proof (rule if_eq_is_pr3)
    from c_fst_is_pr c_hd_is_pr show "(\<lambda>x y z. c_fst (c_hd (Suc x))) \<in> PrimRec3" by prec
  next
    show "(\<lambda>x y z. z) \<in> PrimRec3" by (rule pr_id3_3)
  next
    from c_snd_is_pr c_hd_is_pr show "(\<lambda>x y z. c_snd (c_hd (Suc x))) \<in> PrimRec3" by prec
  next
    show "(\<lambda>x y z. y) \<in> PrimRec3" by (rule pr_id3_2)
  qed
  have a_le: "\<forall> x y. ?a y x \<le> y"
  proof (rule allI, rule allI)
    fix x y show "?a y x \<le> y"
    proof -
      have "Suc y > 0" by simp
      then have "?a y x < Suc y" by (rule c_tl_less)
      then show ?thesis by simp
    qed
  qed
  have f_0: "\<forall> x. c_assoc_value 0 x = ?g x" by (simp add: c_assoc_value_df)
  have f_1: "\<forall> x y. c_assoc_value (Suc y) x = ?h y (c_assoc_value (?a y x) x) x" by (simp add: c_assoc_value_df)
  from g_is_pr a_is_pr h_is_pr a_le f_0 f_1 show ?thesis by (rule th_rec)
qed

lemma c_assoc_lm_1: "c_assoc_have_key (c_cons (c_pair x y) z) x = 0"
apply(simp add: c_assoc_have_key_df)
apply(simp add: c_cons_pos)
done

lemma c_assoc_lm_2: "c_assoc_value (c_cons (c_pair x y) z) x = y"
apply(simp add: c_assoc_value_df)
apply(rule impI)
apply(insert c_cons_pos [where x="(c_pair x y)" and u="z"])
apply(auto)
done

lemma c_assoc_lm_3: "x1 \<noteq> x \<Longrightarrow> c_assoc_have_key (c_cons (c_pair x y) z) x1 = c_assoc_have_key z x1"
proof -
  assume A1: "x1 \<noteq> x"
  let ?ls = "(c_cons (c_pair x y) z)"
  have S1: "?ls \<noteq> 0" by (simp add: c_cons_pos)
  then have S2: "c_assoc_have_key ?ls x1 = (if c_fst (c_hd ?ls) = x1 then 0 else c_assoc_have_key (c_tl ?ls) x1)" (is "_ = ?R")  by (rule c_assoc_have_key_lm_1)
  have S3: "c_fst (c_hd ?ls) = x" by simp
  with A1 have S4: "\<not> (c_fst (c_hd ?ls) = x1)" by simp
  from S4 have S5: "?R = c_assoc_have_key (c_tl ?ls) x1" by (rule if_not_P)
  from S2 S5 show ?thesis by simp
qed

lemma c_assoc_lm_4: "x1 \<noteq> x \<Longrightarrow> c_assoc_value (c_cons (c_pair x y) z) x1 = c_assoc_value z x1"
proof -
  assume A1: "x1 \<noteq> x"
  let ?ls = "(c_cons (c_pair x y) z)"
  have S1: "?ls \<noteq> 0" by (simp add: c_cons_pos)
  then have S2: "c_assoc_value ?ls x1 = (if c_fst (c_hd ?ls) = x1 then c_snd (c_hd ?ls) else c_assoc_value (c_tl ?ls) x1)" (is "_ = ?R")  by (rule c_assoc_value_lm_1)
  have S3: "c_fst (c_hd ?ls) = x" by simp
  with A1 have S4: "\<not> (c_fst (c_hd ?ls) = x1)" by simp
  from S4 have S5: "?R = c_assoc_value (c_tl ?ls) x1" by (rule if_not_P)
  from S2 S5 show ?thesis by simp
qed

end


(*<*)
(***********************************************************************
* HiVe theory files
*
* Copyright (C) 2015 Commonwealth of Australia as represented by Defence Science and Technology
* Group (DST Group)
*
* All rights reserved.
*
* The HiVe theory files are free software: released for redistribution and use, and/or modification,
* under the BSD License, details of which can be found in the LICENSE file included in the
* distribution.
************************************************************************)

theory
  Z_Numbers_Chap

imports
  Z_Fun
  Orders
  Equipotence

begin(*>*)

lemma fin_card_dom:
  assumes
    a1: "finite f" and
    a2: "card (\<zdom> f) = card f"
  shows
    "functional f"
proof -
  from a1 have
    b1: "card (\<zdom> f) = card f \<Rightarrow> functional f" (is "?P f")
  proof (induct f set: finite)
    show
      "?P \<emptyset>"
      by (simp add: empty_functional)
  next
  apply_end (tactic {* split_all_tac @{context} 1 *} )
    fix
      f x y
    assume
      c1: "finite f" and
      c2: "(x \<mapsto> y) \<notin> f" and
      c3: "?P f"
    show
      "?P (insert (x \<mapsto> y) f)"
    proof
      assume
        d1: "card (\<zdom> (insert (x \<mapsto> y) f)) = card (insert (x \<mapsto> y) f)"
      from c1 c2 have
        d2: "card (insert (x \<mapsto> y) f) = card f + 1"
        by (simp)
      have
        d3: "\<zdom> f \<subseteq> \<fst>\<lparr>f\<rparr>"
        by (auto simp add: image_def)
      from c1 c1 [THEN fun_finite_dom] have
        d4: "card (\<zdom> (insert (x \<mapsto> y) f)) \<le> card (\<zdom> f) + 1"
        by (simp add: insert_dom card_insert_if)
      with c1 c2 have
        "card f \<le> card (\<zdom> f)"
        apply (simp only: d1)
        apply (simp)
        done
      moreover from c1 c1 [THEN fun_finite_dom] subepIsurj [OF d3] have
        "card (\<zdom> f) \<le> card f"
        by (simp add: finite_subequipotent_card)
      ultimately have
        d5: "card (\<zdom> f) = card f"
        by (auto)
      with c1 c2 have
        d6: "card (\<zdom> (insert (x \<mapsto> y) f)) = card (\<zdom> f) + 1"
        apply (simp only: d1)
        apply (auto)
        done
      from d5 c3 have
        "functional f"
        by (simp)
      then show
        "functional (insert (x \<mapsto> y) f)"
        apply (rule insert_functionalI)
        using d6 c1 [THEN fun_finite_dom]
        apply (simp add: card_insert_if)
        apply (cases "x \<in> \<zdom> f")
        apply (auto)
        done
    qed
  qed
  with a2 show
    "?thesis"
    by (simp)
qed

chapter {* The Z Mathkit: Numbers *}

(*<*)end(*>*)


theory ex_LFUs
  imports topo_derivative_algebra sse_operation_negative
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Example application: Logics of Formal Undeterminedness (LFUs)\<close>
text\<open>\noindent{The LFUs \<^cite>\<open>LFU\<close> \<^cite>\<open>LFI\<close> are a family of paracomplete logics featuring a 'determinedness'
operator @{text "\<^bold>\<circ>"} that can be used to recover some classical properties of negation (in particular TND).
LFUs behave in a sense dually to LFIs. Both can be semantically embedded as extensions of Boolean algebras.
Here we show how to semantically embed LFUs as derivative algebras.}\<close>

text\<open>\noindent{(We rename (classical) meta-logical negation to avoid terminological confusion)}\<close>
abbreviation cneg::"bool\<Rightarrow>bool" ("\<sim>_" [40]40) where "\<sim>\<phi> \<equiv> \<not>\<phi>"

text\<open>\noindent{Logical validity can be defined as truth in all worlds/points (i.e. as denoting the top element)}\<close>
abbreviation gtrue::"\<sigma>\<Rightarrow>bool" ("[\<^bold>\<turnstile> _]") where  "[\<^bold>\<turnstile>  A] \<equiv> \<forall>w. A w"
lemma gtrue_def: "[\<^bold>\<turnstile> A] \<equiv> A \<^bold>\<approx> \<^bold>\<top>"  by (simp add: top_def)

text\<open>\noindent{As for LFIs, we focus on the local (truth-degree preserving) notion of logical consequence.}\<close>
abbreviation conseq_local1::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" ("[_ \<^bold>\<turnstile> _]") where "[A \<^bold>\<turnstile> B] \<equiv> A \<^bold>\<preceq> B"
abbreviation conseq_local2::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" ("[_,_ \<^bold>\<turnstile> _]") where "[A\<^sub>1, A\<^sub>2 \<^bold>\<turnstile> B] \<equiv> A\<^sub>1 \<^bold>\<and> A\<^sub>2 \<^bold>\<preceq> B"
abbreviation conseq_local12::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" ("[_ \<^bold>\<turnstile> _,_]") where "[A \<^bold>\<turnstile> B\<^sub>1, B\<^sub>2] \<equiv> A \<^bold>\<preceq> B\<^sub>1 \<^bold>\<or> B\<^sub>2"
(*add more as the need arises...*)

text\<open>\noindent{For LFUs we use the interior-based negation previously defined (taking derivative as primitive). }\<close>
definition ineg::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>")  where  "\<^bold>\<not>A \<equiv> \<I>(\<^bold>\<midarrow>A)"
declare ineg_def[conn]

text\<open>\noindent{In terms of the derivative operator the negation looks as follows:}\<close>
lemma ineg_prop: "\<^bold>\<not>A \<^bold>\<approx> \<^bold>\<midarrow>(\<D> A) \<^bold>\<leftharpoonup> A" using Cl_der_def IB_rel Int_br_def eq_ext' pB4 conn by fastforce

text\<open>\noindent{This negation is of course paracomplete.}\<close>
lemma "[\<^bold>\<turnstile> a \<^bold>\<or> \<^bold>\<not>a]" nitpick oops (*countermodel*)

text\<open>\noindent{We define two pairs of in/determinedness operators and show how they relate to each other.}\<close>
abbreviation op_det::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<circ>_" [57]58) where "\<^bold>\<circ>A  \<equiv> \<B>\<^sup>d A"
abbreviation op_ind::"\<sigma>\<Rightarrow>\<sigma>" ("\<bullet>_" [57]58) where "\<bullet>A  \<equiv> \<^bold>\<midarrow>\<^bold>\<circ>A"

lemma op_det_def: "\<^bold>\<circ>a \<^bold>\<approx> a \<^bold>\<or> \<^bold>\<not>a" by (simp add: compl_def diff_def dual_def ineg_def join_def pB1)
lemma Prop1: "\<^bold>\<circ>A \<^bold>\<approx> \<C>\<^sup>f\<^sup>p A" by (metis dimp_def eq_ext' fp3)
lemma Prop2: "Op A \<longleftrightarrow> \<^bold>\<circ>\<^bold>\<midarrow>A \<^bold>\<approx> \<^bold>\<top>" by (metis dual_def dual_symm pB1 pI1 top_def compl_def diff_def)
lemma Prop3: "Op A \<longleftrightarrow> \<bullet>\<^bold>\<midarrow>A \<^bold>\<approx> \<^bold>\<bottom>" by (metis Op_Bzero dual_def dual_symm)
lemma Prop4: "Cl A \<longleftrightarrow> \<^bold>\<circ>A \<^bold>\<approx> \<^bold>\<top>" by (metis Prop1 dimp_def top_def)
lemma Prop5: "Cl A \<longleftrightarrow> \<bullet>A \<^bold>\<approx> \<^bold>\<bottom>" by (simp add: Prop4 bottom_def compl_def top_def)

text\<open>\noindent{Analogously as for LFIs, LFUs provide means for recovering the principle of excluded middle.}\<close>
lemma "[\<Gamma> \<^bold>\<turnstile> \<bullet>a, a \<^bold>\<or> \<^bold>\<not>a]" using IB_rel Int_br_def compl_def diff_def dual_def eq_ext' ineg_def join_def by fastforce
lemma "[\<Gamma>, \<^bold>\<circ>a \<^bold>\<turnstile> a \<^bold>\<or> \<^bold>\<not>a]" using dual_def pB1 unfolding conn by auto

lemma "TNDm(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "ECQ(\<^bold>\<not>)" by (simp add: ECQ_def bottom_def diff_def ineg_prop meet_def)
lemma "Der_3 \<D> \<Longrightarrow> LNC(\<^bold>\<not>)" using ineg_prop ECQ_def ID3 LNC_def dNOR_def unfolding conn by auto
lemma "\<DD> \<D> \<Longrightarrow> DNI(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "\<DD> \<D> \<Longrightarrow> DNE(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "Der_1b \<D> \<Longrightarrow> CoPw(\<^bold>\<not>)" by (smt CoPw_def MONO_ADDIb PD1 compl_def ineg_def monI)
lemma "\<DD> \<D> \<Longrightarrow> CoP1(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "\<DD> \<D> \<Longrightarrow> CoP2(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "\<DD> \<D> \<Longrightarrow> CoP3(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "\<DD> \<D> \<Longrightarrow> DM3(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "Der_1a \<D> \<Longrightarrow> DM4(\<^bold>\<not>)" unfolding Defs using ADDI_a_def ineg_prop compl_def diff_def  join_def meet_def by auto
lemma "Der_3 \<D> \<Longrightarrow> nNor(\<^bold>\<not>)" by (simp add: NOR_def ineg_prop nNor_def bottom_def compl_def diff_def top_def)
lemma "nDNor(\<^bold>\<not>)" by (simp add: bottom_def diff_def ineg_prop nDNor_def top_def)
lemma "Der_1b \<D> \<Longrightarrow> MT0(\<^bold>\<not>)" unfolding Defs by (metis (mono_tags, opaque_lifting) CD1b Disj_I OpCldual PD1 bottom_def compl_def ineg_def meet_def top_def)
lemma "Der_1b \<D> \<Longrightarrow> Der_3 \<D> \<Longrightarrow> MT1(\<^bold>\<not>)" unfolding Defs by (metis (full_types) NOR_def PD1 bottom_def compl_def diff_def ineg_prop top_def)
lemma "\<DD> \<D> \<Longrightarrow> MT2(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma "\<DD> \<D> \<Longrightarrow> MT3(\<^bold>\<not>)" nitpick oops (*countermodel*)

text\<open>\noindent{We show how all local contraposition variants (lCoP) can be recovered using the determinedness operator.
Observe that we can recover in the same way other (weaker) properties: CoP, MT and DNI/DNE (local \& global).}\<close>
lemma "\<DD> \<D> \<Longrightarrow> lCoPw(\<^bold>\<rightarrow>)(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma det_lcop1: "[\<^bold>\<circ>a, a \<^bold>\<rightarrow> b \<^bold>\<turnstile> \<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a]" using dual_def pI1 conn by auto
lemma "\<DD> \<D> \<Longrightarrow> lCoP1(\<^bold>\<rightarrow>)(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma det_lcop2: "[\<^bold>\<circ>a, a \<^bold>\<rightarrow> \<^bold>\<not>b \<^bold>\<turnstile> b \<^bold>\<rightarrow> \<^bold>\<not>a]" using dual_def pI1 conn by auto
lemma "\<DD> \<D> \<Longrightarrow> lCoP2(\<^bold>\<rightarrow>)(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma det_lcop3: "[\<^bold>\<circ>a, \<^bold>\<not>a \<^bold>\<rightarrow> b \<^bold>\<turnstile> \<^bold>\<not>b \<^bold>\<rightarrow> a]" using dual_def pI1 conn by auto
lemma "\<DD> \<D> \<Longrightarrow> lCoP3(\<^bold>\<rightarrow>)(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma det_lcop4: "[\<^bold>\<circ>a, \<^bold>\<not>a \<^bold>\<rightarrow> \<^bold>\<not>b \<^bold>\<turnstile> b \<^bold>\<rightarrow> a]" using dual_def pI1 conn by auto

text\<open>\noindent{Disjunctive syllogism (DS).}\<close>
lemma "DS1(\<^bold>\<rightarrow>)(\<^bold>\<not>)" by (simp add: DS1_def diff_def impl_def ineg_prop join_def)
lemma "\<DD> \<D> \<Longrightarrow> DS2(\<^bold>\<rightarrow>)(\<^bold>\<not>)" nitpick oops (*countermodel*)
lemma det_ds2: "[\<^bold>\<circ>a, \<^bold>\<not>a \<^bold>\<rightarrow> b \<^bold>\<turnstile> a \<^bold>\<or> b]" using pB1 dual_def conn by auto

end


section \<open>Library additions\<close>

theory Library_Additions
  imports "ZFC_in_HOL.Ordinal_Exp" "HOL-Library.Ramsey" "Nash_Williams.Nash_Williams"

begin

lemma finite_enumerate_Diff_singleton:
  fixes S :: "'a::wellorder set"
  assumes "finite S" and i: "i < card S" "enumerate S i < x"
  shows "enumerate (S - {x}) i = enumerate S i"
  using i
proof (induction i)
  case 0
  have "(LEAST i. i \<in> S \<and> i\<noteq>x) = (LEAST i. i \<in> S)"
  proof (rule Least_equality)
    have "\<exists>t. t \<in> S \<and> t\<noteq>x"
      using 0 \<open>finite S\<close> finite_enumerate_in_set by blast
    then show "(LEAST i. i \<in> S) \<in> S \<and> (LEAST i. i \<in> S) \<noteq> x"
      by (metis "0.prems"(2) LeastI enumerate_0 not_less_Least)
  qed (simp add: Least_le)
  then show ?case
    by (auto simp: enumerate_0)
next
  case (Suc i)
  then have x: "enumerate S i < x"
    by (meson enumerate_step finite_enumerate_step less_trans)
  have cardSx: "Suc i < card (S - {x})" and "i < card S"
    using Suc \<open>finite S\<close> card_Diff_singleton_if[of S] finite_enumerate_Ex by fastforce+
  have "(LEAST s. s \<in> S \<and> s\<noteq>x \<and> enumerate (S - {x}) i < s) = (LEAST s. s \<in> S \<and> enumerate S i < s)"
       (is "_ = ?r")
  proof (intro Least_equality conjI)
    show "?r \<in> S"
      by (metis (lifting) LeastI Suc.prems(1) assms(1) finite_enumerate_in_set finite_enumerate_step)
    show "?r \<noteq> x"
      using Suc.prems not_less_Least [of _ "\<lambda>t. t \<in> S \<and> enumerate S i < t"]
       \<open>finite S\<close> finite_enumerate_in_set finite_enumerate_step by blast
    show "enumerate (S - {x}) i < ?r"
      by (metis (full_types) Suc.IH Suc.prems(1) \<open>i < card S\<close> enumerate_Suc'' enumerate_step finite_enumerate_Suc'' finite_enumerate_step x)
    show "\<And>y. y \<in> S \<and> y \<noteq> x \<and> enumerate (S - {x}) i < y \<Longrightarrow> ?r \<le> y"
      by (simp add: Least_le Suc.IH \<open>i < card S\<close> x)
  qed
  then show ?case
    using Suc assms by (simp add: finite_enumerate_Suc'' cardSx)
qed

lemma hd_lex: "\<lbrakk>hd ms < hd ns; length ms = length ns; ns \<noteq> []\<rbrakk> \<Longrightarrow> (ms, ns) \<in> lex less_than"
  by (metis hd_Cons_tl length_0_conv less_than_iff lexord_cons_cons lexord_lex)

lemma sorted_hd_le:
  assumes "sorted xs" "x \<in> list.set xs"
  shows "hd xs \<le> x"
  using assms by (induction xs) (auto simp: less_imp_le)

lemma sorted_le_last:
  assumes "sorted xs" "x \<in> list.set xs"
  shows "x \<le> last xs"
  using assms by (induction xs) (auto simp: less_imp_le)

lemma hd_list_of:
  assumes "finite A" "A \<noteq> {}"
  shows "hd (sorted_list_of_set A) = Min A"
proof (rule antisym)
  have "Min A \<in> A"
    by (simp add: assms)
  then show "hd (sorted_list_of_set A) \<le> Min A"
    by (simp add: sorted_hd_le \<open>finite A\<close>)
next
  show "Min A \<le> hd (sorted_list_of_set A)"
    by (metis Min_le assms hd_in_set set_sorted_list_of_set sorted_list_of_set_eq_Nil_iff)
qed

lemma sorted_hd_le_last:
  assumes "sorted xs" "xs \<noteq> []"
  shows "hd xs \<le> last xs"
  using assms by (simp add: sorted_hd_le)

lemma sorted_list_of_set_set_of [simp]: "strict_sorted l \<Longrightarrow> sorted_list_of_set (list.set l) = l"
  by (simp add: strict_sorted_equal)

lemma range_strict_mono_ext:
  fixes f::"nat \<Rightarrow> 'a::linorder"
  assumes eq: "range f = range g"
      and sm: "strict_mono f" "strict_mono g"
    shows "f = g"
proof
  fix n
  show "f n = g n"
  proof (induction n rule: less_induct)
    case (less n)
    obtain x y where xy: "f n = g y" "f x = g n"
      by (metis eq imageE rangeI)
    then have "n = y"
      by (metis (no_types) less.IH neq_iff sm strict_mono_less xy)
    then show ?case using xy by auto
  qed
qed

subsection \<open>Other material\<close>

definition strict_mono_sets :: "['a::order set, 'a::order \<Rightarrow> 'b::order set] \<Rightarrow> bool" where
  "strict_mono_sets A f \<equiv> \<forall>x\<in>A. \<forall>y\<in>A. x < y \<longrightarrow> less_sets (f x) (f y)"

lemma strict_mono_setsD:
  assumes "strict_mono_sets A f" "x < y" "x \<in> A" "y \<in> A"
  shows "less_sets (f x) (f y)"
  using assms by (auto simp: strict_mono_sets_def)

lemma strict_mono_sets_imp_disjoint:
  fixes A :: "'a::linorder set"
  assumes "strict_mono_sets A f"
  shows "pairwise (\<lambda>x y. disjnt (f x) (f y)) A"
  using assms unfolding strict_mono_sets_def pairwise_def
  by (meson antisym_conv3 disjnt_sym less_sets_imp_disjnt)

lemma strict_mono_sets_subset:
  assumes "strict_mono_sets B f" "A \<subseteq> B"
  shows "strict_mono_sets A f"
  using assms by (auto simp: strict_mono_sets_def)

lemma strict_mono_less_sets_Min:
  assumes "strict_mono_sets I f" "finite I" "I \<noteq> {}"
  shows "less_sets (f (Min I)) (\<Union> (f ` (I - {Min I})))"
  using assms by (simp add: strict_mono_sets_def less_sets_UN2 dual_order.strict_iff_order)

lemma pair_less_iff1 [simp]: "((x,y), (x,z)) \<in> pair_less \<longleftrightarrow> y<z"
  by (simp add: pair_less_def)

lemma infinite_finite_Inter:
  assumes "finite \<A>" "\<A>\<noteq>{}" "\<And>A. A \<in> \<A> \<Longrightarrow> infinite A"
    and "\<And>A B. \<lbrakk>A \<in> \<A>; B \<in> \<A>\<rbrakk> \<Longrightarrow> A \<inter> B \<in> \<A>"
  shows "infinite (\<Inter>\<A>)"
  by (simp add: assms finite_Inf_in)

lemma atLeast_less_sets: "\<lbrakk>less_sets A {x}; B \<subseteq> {x..}\<rbrakk> \<Longrightarrow> less_sets A B"
  by (force simp: less_sets_def subset_iff)

subsection \<open>The list-of function\<close>

lemma sorted_list_of_set_insert_remove_cons:
  assumes "finite A" "less_sets {a} A"
  shows "sorted_list_of_set (insert a A) = a # sorted_list_of_set A"
proof -
  have "strict_sorted (a # sorted_list_of_set A)"
    using assms less_setsD by auto
  moreover have "list.set (a # sorted_list_of_set A) = insert a A"
    using assms by force
  moreover have "length (a # sorted_list_of_set A) = card (insert a A)"
    using assms card_insert_if less_setsD by fastforce
  ultimately show ?thesis
    by (metis \<open>finite A\<close> finite_insert sorted_list_of_set_unique)
qed

lemma sorted_list_of_set_Un:
  assumes AB: "less_sets A B" and fin: "finite A" "finite B"
  shows "sorted_list_of_set (A \<union> B) = sorted_list_of_set A @ sorted_list_of_set B"
proof -
  have "strict_sorted (sorted_list_of_set A @ sorted_list_of_set B)"
    using AB unfolding less_sets_def
    by (metis fin set_sorted_list_of_set sorted_wrt_append strict_sorted_list_of_set)
  moreover have "card A + card B = card (A \<union> B)"
    using less_sets_imp_disjnt [OF AB]
    by (simp add: assms card_Un_disjoint disjnt_def)
  ultimately show ?thesis
    by (simp add: assms strict_sorted_equal)
qed

lemma sorted_list_of_set_UN_lessThan:
  fixes k::nat
  assumes sm: "strict_mono_sets {..<k} A" and "\<And>i. i < k \<Longrightarrow> finite (A i)"
  shows "sorted_list_of_set (\<Union>i<k. A i) = concat (map (sorted_list_of_set \<circ> A) (sorted_list_of_set {..<k}))"
  using assms
proof (induction k)
  case 0
  then show ?case
    by auto
next
  case (Suc k)
  have ls: "less_sets (\<Union> (A ` {..<k})) (A k)"
    using sm Suc.prems(1) strict_mono_setsD by (force simp: less_sets_UN1)
  have "sorted_list_of_set (\<Union> (A ` {..<Suc k})) = sorted_list_of_set (\<Union> (A ` {..<k}) \<union> A k)"
    by (simp add: Un_commute lessThan_Suc)
  also have "\<dots> = sorted_list_of_set (\<Union> (A ` {..<k})) @ sorted_list_of_set (A k)"
    by (rule sorted_list_of_set_Un) (auto simp: Suc.prems ls)
  also have "\<dots> = concat (map (sorted_list_of_set \<circ> A) (sorted_list_of_set {..<k})) @ sorted_list_of_set (A k)"
    using Suc strict_mono_sets_def by fastforce
  also have "\<dots> = concat (map (sorted_list_of_set \<circ> A) (sorted_list_of_set {..<Suc k}))"
    using strict_mono_sets_def by fastforce
  finally show ?case .
qed

lemma sorted_list_of_set_UN_atMost:
  fixes k::nat
  assumes "strict_mono_sets {..k} A" and "\<And>i. i \<le> k \<Longrightarrow> finite (A i)"
  shows "sorted_list_of_set (\<Union>i\<le>k. A i) = concat (map (sorted_list_of_set \<circ> A) (sorted_list_of_set {..k}))"
  by (metis assms lessThan_Suc_atMost less_Suc_eq_le sorted_list_of_set_UN_lessThan)

subsection \<open>Monotonic enumeration of a countably infinite set\<close>

abbreviation "enum \<equiv> enumerate"

text \<open>Could be generalised to infinite countable sets of any type\<close>
lemma nat_infinite_iff:
  fixes N :: "nat set"
  shows "infinite N \<longleftrightarrow> (\<exists>f::nat\<Rightarrow>nat. N = range f \<and> strict_mono f)"
proof safe
  assume "infinite N"
  then show "\<exists>f. N = range (f::nat \<Rightarrow> nat) \<and> strict_mono f"
    by (metis bij_betw_imp_surj_on bij_enumerate enumerate_mono strict_mono_def)
next
  fix f :: "nat \<Rightarrow> nat"
  assume "strict_mono f" and "N = range f" and "finite (range f)"
  then show False
    using range_inj_infinite strict_mono_imp_inj_on by blast
qed

lemma enum_works:
  fixes N :: "nat set"
  assumes "infinite N"
  shows "N = range (enum N) \<and> strict_mono (enum N)"
  by (metis assms bij_betw_imp_surj_on bij_enumerate enumerate_mono strict_monoI)

lemma range_enum: "range (enum N) = N" and strict_mono_enum: "strict_mono (enum N)"
  if "infinite N" for N :: "nat set"
  using enum_works [OF that] by auto

lemma enum_works_finite:
  fixes N :: "nat set"
  assumes "finite N"
  shows "N = enum N ` {..<card N} \<and> strict_mono_on {..<card N} (enum N)"
  using assms
  by (metis bij_betw_imp_surj_on finite_bij_enumerate finite_enumerate_mono lessThan_iff strict_mono_onI)

lemma enum_obtain_index_finite:
  fixes N :: "nat set"
  assumes "x \<in> N" "finite N"
  obtains i where "i < card N" "x = enum N i"
  by (metis \<open>x \<in> N\<close> \<open>finite N\<close> enum_works_finite imageE lessThan_iff)

lemma enum_0_eq_Inf_finite:
  fixes N :: "nat set"
  assumes "finite N" "N \<noteq> {}"
  shows "enum N 0 = Inf N"
proof -
  have "enum N 0 \<in> N"
    by (metis Nat.neq0_conv assms empty_is_image enum_works_finite image_eqI lessThan_empty_iff lessThan_iff)
  moreover have "enum N 0 \<le> x" if "x \<in> N" for x
  proof -
    obtain i where "i < card N" "x = enum N i"
      by (metis \<open>x \<in> N\<close> \<open>finite N\<close> enum_obtain_index_finite)
    with assms show ?thesis
      by (metis Nat.neq0_conv finite_enumerate_mono less_or_eq_imp_le)
  qed
  ultimately show ?thesis
    by (metis cInf_eq_minimum)
qed

lemma greaterThan_less_enum:
  fixes N :: "nat set"
  assumes "N \<subseteq> {x<..}" "infinite N"
  shows "x < enum N i"
  using assms range_enum by fastforce

lemma atLeast_le_enum:
  fixes N :: "nat set"
  assumes "N \<subseteq> {x..}" "infinite N"
  shows "x \<le> enum N i"
  using assms range_enum by fastforce

lemma less_sets_empty1 [simp]: "less_sets {} A" and less_sets_empty2 [simp]: "less_sets A {}"
  by (simp_all add: less_sets_def)

lemma less_sets_singleton1 [simp]: "less_sets {a} A \<longleftrightarrow> (\<forall>x\<in>A. a < x)"
  and less_sets_singleton2 [simp]: "less_sets A {a} \<longleftrightarrow> (\<forall>x\<in>A. x < a)"
  by (simp_all add: less_sets_def)

lemma less_sets_atMost [simp]: "less_sets {..a} A \<longleftrightarrow> (\<forall>x\<in>A. a < x)"
  and less_sets_alLeast [simp]: "less_sets A {a..} \<longleftrightarrow> (\<forall>x\<in>A. x < a)"
  by (auto simp: less_sets_def)

lemma less_sets_imp_strict_mono_sets:
  assumes "\<And>i. less_sets (A i) (A (Suc i))" "\<And>i. i>0 \<Longrightarrow> A i \<noteq> {}"
  shows "strict_mono_sets UNIV A"
proof (clarsimp simp: strict_mono_sets_def)
  fix i j::nat
  assume "i < j"
  then show "less_sets (A i) (A j)"
  proof (induction "j-i" arbitrary: i j)
    case (Suc x)
    then show ?case
      by (metis Suc_diff_Suc Suc_inject Suc_mono assms less_Suc_eq less_sets_trans zero_less_Suc)
  qed auto
qed

lemma less_sets_Suc_Max:
  assumes "finite A"
  shows "less_sets A {Suc (Max A)..}"
proof (cases "A = {}")
  case False
  then show ?thesis
    by (simp add: assms less_Suc_eq_le)
qed auto

lemma infinite_nat_greaterThan:
  fixes m::nat
  assumes "infinite N"
  shows "infinite (N \<inter> {m<..})"
proof -
  have "N \<subseteq> -{m<..} \<union> (N \<inter> {m<..})"
    by blast
  moreover have "finite (-{m<..})"
    by simp
  ultimately show ?thesis
    using assms finite_subset by blast
qed

end


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

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3acc :: "Nat => Nat => Nat => Nat" where
  "add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
  "mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S x2) (S x3) (S x4) =
     (let fail :: Nat =
       plus
         (S Z)
         (add3acc
            (mul3acc x2 x3 x4)
            (add3acc
               (mul3acc (S Z) x3 x4) (mul3acc x2 (S Z) x4) (mul3acc x2 x3 (S Z)))
            (add3acc (S x2) (S x3) (S x4)))
     in (if (x2 = Z) then
           (if (x3 = Z) then (if (x4 = Z) then S Z else fail) else fail)
           else
           fail))"

theorem property0 :
  "((mul3acc x y z) = (mul3acc y x z))"
  oops

end


theory prop_03
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
  | "le (S z) (Z) = False"
  | "le (S z) (S x2) = le z x2"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun count :: "Nat => Nat list => Nat" where
  "count x (Nil2) = Z"
  | "count x (Cons2 z ys) =
       (if equal2 x z then S (count x ys) else count x ys)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster le equal2 count append *)

hipster_cond le equal2
lemma lemma_a [thy_expl]: "equal2 x2 y2 = equal2 y2 x2"
apply(induction x2 arbitrary: y2)
apply simp_all
sledgehammer
apply(metis equal2.simps)
by (hipster_induct_schemes le.simps equal2.simps)

lemma lemm_a [thy_expl]: "equal2 x2 y2 = equal2 y2 x2"
apply(induction x2 y2 rule: equal2.induct)

lemma lemma_aa [thy_expl]: "le x2 x2 = True"
by (hipster_induct_schemes le.simps equal2.simps)

lemma lemma_ab [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes le.simps equal2.simps)

lemma lemma_ac [thy_expl]: "equal2 x2 Z = le x2 Z"
by (hipster_induct_schemes le.simps equal2.simps)

lemma lemma_ad [thy_expl]: "le x2 (S x2) = True"
by (hipster_induct_schemes le.simps equal2.simps)

lemma lemma_ae [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes le.simps equal2.simps)

lemma lemma_af [thy_expl]: "le (S x2) x2 = False"
by (hipster_induct_schemes le.simps equal2.simps)

lemma lemma_ag [thy_expl]: "le x14 y14 \<Longrightarrow> equal2 x14 y14 = le y14 x14"
by (hipster_induct_schemes le.simps equal2.simps)

lemma lemma_ah [thy_expl]: "le x2 y2 \<Longrightarrow> le x2 (S y2) = True"
by (hipster_induct_schemes le.simps equal2.simps)

lemma lemma_ai [thy_expl]: "le x2 y2 \<Longrightarrow> equal2 x2 (S y2) = False"
by (hipster_induct_schemes le.simps equal2.simps)

lemma unknown [thy_expl]: "le y x \<and> le x y \<Longrightarrow> x = y"
oops
thm Nat.exhaust
lemma unknown [thy_expl]: "le z y \<and> le x z \<Longrightarrow> le x y = True"
oops

lemma unknown [thy_expl]: "le z x \<and> le y z \<Longrightarrow> equal2 x y = le x y"
oops

lemma unknown [thy_expl]: "le z y \<and> le x z \<Longrightarrow> equal2 x y = le y x"
oops

lemma unknown [thy_expl]: "le z y \<and> le x z \<Longrightarrow> le x (S y) = True"
oops

lemma unknown [thy_expl]: "le z y \<and> le x z \<Longrightarrow> equal2 x (S y) = False"
oops

lemma unknown [thy_expl]: "le z x \<and> le y z \<Longrightarrow> le (S x) y = False"
oops

lemma unknown [thy_expl]: "le z x \<and> le y z \<Longrightarrow> equal2 (S x) y = False"
oops

lemma unknown [thy_expl]: "le z y \<and> le x z \<Longrightarrow> le (S x) (S y) = True"
oops

lemma unknown [thy_expl]: "le z x \<and> le y z \<Longrightarrow> equal2 (S x) (S y) = le x y"
oops

lemma unknown [thy_expl]: "le z y \<and> le x z \<Longrightarrow> equal2 (S x) (S y) = le y x"
oops

  theorem x0 :
    "le (count n xs) (count n (append xs ys))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end