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

section \<open>Primitive recursive coding of lists of natural numbers\<close>

theory PRecList
imports PRecFun
begin

text \<open>
  We introduce a particular coding \<open>list_to_nat\<close> from lists of
  natural numbers to natural numbers.
\<close>

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"
    define ls where "ls = nat_to_list u"
    from ls_def 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 ls_def 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> []"
    define u where "u = list_to_nat ls"
    from u_def 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 u_def 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
  define ls where "ls = tl (nat_to_list u)"
  from ls_def S8 have S9: "length ls = ?k" by (simp add: c_unfold_len)
  from ls_def 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 ls_def 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)
  define ls where "ls = nat_to_list u"
  from ls_def 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 ls_def 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


\<^marker>\<open>creator Bernhard Pöttinger\<close>

chapter \<open>Nilpotent Flows\<close>
theory Nilpotent
  imports Flow_Base Chain Pigeonhole Auxiliary Approximations
begin

paragraph \<open>Summary\<close>
text \<open>This theory proves the existence of unique flows for flow graphs restricted to nilpotent
edge functions (see @{cite \<open>lem. 4\<close> krishna20}).\<close>

lemma fold_funpow:
  fixes f :: "'a \<Rightarrow> 'a"
  shows "fold (o) (map (\<lambda>_. f) xs) g = (f ^^ (length xs)) o g"
  apply (induction xs arbitrary: g)
  by (auto, metis comp_funpow funpow_swap1 o_assoc)

lemma nilpotent_flow_exists':
  fixes E :: "('m \<Rightarrow> 'm :: pos_cancel_comm_monoid_add) set"
  assumes "\<forall>x y. e x y \<in> E" "End_closed E" "nilpotent E" "finite N" "N \<noteq> {}" "(\<lambda>_. 0) \<in> E"
    "finite N"
  shows "\<exists>f. flow_eq (fg N e f) i \<and> (\<forall>f'. flow_eq (fg N e f') i \<longrightarrow> f = f' on N)"
proof -
  obtain p where nilp: "p > 1" "\<forall>e \<in> E. e^^p = (\<lambda>_. 0)"
    using assms unfolding nilpotent_def by blast

  let ?l = "p * card N + 1"
  let ?f = "\<lambda>n. i n + (\<Sum>ns \<in> l_lists N ?l. chain e ns n (i (hd ns)))"

  have endo_e: "\<forall>x y. endo (e x y)"
    using assms unfolding End_closed_def End_closed_def by blast

  let ?g = "\<lambda>xs n. if n < length xs then Some (xs!n) else None"

  have reoccur:
    "\<forall>xs \<in> k_lists N ?l. \<exists>y \<in> ran (?g xs). card ((?g xs) -` {Some y}) \<ge> p + 1"
  proof
    fix xs
    assume *: "xs \<in> k_lists N ?l"
    then obtain x where "x \<in> set xs" using k_lists_nonempty(1)[of ?l xs N] by fastforce
    then obtain i where EX: "?g xs i = Some x" "i < length xs" by (metis in_set_conv_nth)
    have RANDOM: "ran (?g xs) \<subseteq> N" "dom (?g xs) = {0..<?l}"
      unfolding ran_def using * unfolding k_lists_def by (auto split: if_splits)
    show "\<exists>y \<in> ran (?g xs). card ((?g xs) -` {Some y}) \<ge> p + 1"
      apply (rule generalized_pigeonhole[of "?g xs" p])
      subgoal unfolding dom_def using EX by blast
      subgoal unfolding dom_def by auto
      subgoal using * assms RANDOM card_mono[of N] unfolding k_lists_def by auto
      done
  qed

  have "\<And>n i ns. ns \<in> k_lists N ?l \<Longrightarrow> chain e ns n = 0"
  proof -
    fix n ns
    assume A: "ns \<in> k_lists N ?l"
    then obtain m where card:
      "m \<in> ran (?g ns)" "card ((?g ns) -` {Some m}) \<ge> p + 1"
      using reoccur by blast
    moreover have fin: "finite ((?g ns) -` {Some m})"
      by (fact finite_index_fun_vimage)
    ultimately obtain xs where xs:
      "length xs = card ((?g ns) -` {Some m}) \<and> set xs = ((?g ns) -` {Some m})"
      using set_to_list[of "(?g ns) -` {Some m}"] by auto

    have L: "\<forall>x \<in> (?g ns) -` {Some m}. x < length ns"
      by (auto split: if_splits)

    have "\<And>n. n \<in> (?g ns) -` {Some m} \<Longrightarrow> ?g ns n = Some m"
      by auto
    then have "\<forall>n \<in> (?g ns) -` {Some m}. ns!n = m"
      by (metis (no_types, lifting) option.inject option.simps(3))
    moreover have "card ((?g ns) -` {Some m}) \<le> length ns"
    proof -
      have "?g ns -` {Some m} \<subseteq> {0..<length ns}" unfolding vimage_def by auto
      then have "card (?g ns -` {Some m} ) \<le> card {0..<length ns}"
        using card_mono by blast
      also have "... = length ns" by simp
      finally show ?thesis .
    qed
    ultimately have "count_list ns m \<ge> p + 1"
      using card card_count_list[of "(?g ns) -` {Some m}" ns m] fin L by linarith
    then obtain ms mss where decomp: "ns = ms @ concat mss" "\<forall>ms \<in> set mss. hd ms = m"
        "\<forall>ms \<in> set mss. set ms \<subseteq> set ns" "length mss = p + 1" "\<forall>ms \<in> set mss. ms \<noteq> []"
      using decompose_list_count_list_multi[of "p + 1" ns m] by auto
    then have b_bb: "chain e ns n = chains e (ms#mss) n"
      by (subst chain_chains[of ns "ms#mss" e n], simp_all)
    have len_ns: "length ns = sum_list (map length (ms#mss))"
      using length_concat decomp by auto
    then have len: "\<And>ms'. ms' \<in> set (ms#mss) \<Longrightarrow> length ms' \<le> length ns"
      subgoal for ms'
        using length_length_concat_in[of "ms#mss" ms'] decomp by auto
      done
    let ?bound = "\<Sum>ns \<in> l_lists' N (length ns). chain2 e m ns m"
    have bound_in_E: "?bound \<in> E"
      using chain2_endo[of e E m _ m] l_lists'_finite[of N "length ns"]
        End_closed_sumE[of "l_lists' N (length ns)" E "\<lambda>ns. chain2 e m ns m"] assms
        by blast
    then have "?bound ^^ p = 0"
      using nilp by auto

    have bound_in_End: "?bound \<in> End"
      using bound_in_E assms unfolding End_closed_def by auto

    have "mss \<noteq> []"
      using decomp by auto
    then obtain mss' ms' where decomp_mss: "mss = mss' @ [ms']"
      using list_decompose_last[of mss] by auto
    then have mss'_ne: "mss' \<noteq> []"
      using nilp decomp by auto

    have ms_ne: "\<And>ms. ms \<in> set mss' \<Longrightarrow> ms \<noteq> []"
      using decomp decomp_mss by simp
    then have ms_ne': "\<And>ms. ms \<in> set (tl mss') \<Longrightarrow> ms \<noteq> []"
      by (simp add: list.set_sel(2) mss'_ne)

    have ineq: "\<And>ms. ms \<in> set mss' \<Longrightarrow> chain e ms m \<le> ?bound"
      subgoal premises prems for ms'
      proof -
        have XXX: "set (tl ms') \<subseteq> N"
        proof -
          have "ms' \<in> set mss'" using prems by simp
          with decomp_mss have "ms' \<in> set mss" by simp
          with decomp have "set ms' \<subseteq> set ns" by auto
          with A have "set ms' \<subseteq> N" unfolding k_lists_def by auto
          then show ?thesis by (simp add: list.set_sel(2) ms_ne prems subset_iff)
        qed

        have hdm: "hd ms' = m"
          using decomp decomp_mss prems by simp
        have tlm: "tl ms' \<in> l_lists' N (length ns)"
          using prems assms decomp decomp_mss length_length_concat_in[of "ms#mss" ms'] mss'_ne
          unfolding l_lists'_def apply clarsimp
          apply (intro conjI)
          using XXX apply simp
          by (metis diff_Suc_less le_neq_implies_less length_greater_0_conv less_imp_diff_less)
        have "(\<Sum>ns \<in> l_lists' N (length ns) - {tl ms'}. chain2 e m ns m) \<ge> 0"
          using sum_nonneg
          by (subst sum_nonneg, simp_all add: le_fun_def)
        then have"chain e ms' m \<le>
          chain e ms' m + (\<Sum>ns \<in> l_lists' N (length ns) - {tl ms'}. chain2 e m ns m)"
          by (metis add.commute add_increasing order_refl)
        also have "... = (\<Sum>ns \<in> l_lists' N (length ns). chain2 e m ns m)"
          apply (subst chain_chain2[of ms' e m])
          using decomp decomp_mss len[of ms'] sum.insert prems apply simp
          apply (subst hdm)
          apply (subst sum.insert[symmetric])
          using l_lists'_finite[of N "length ns"] assms tlm
            insert_absorb[of "tl ms'" "l_lists' N (length ns)"]
          by simp_all
        finally show ?thesis .
      qed
      done
    have **: "chain e ns n = chain e ms' n o chains e mss' (hd ms') o chain e ms (hd (hd mss))"
      by (subst b_bb, subst chains_prepend_append, simp_all add: decomp_mss mss'_ne)
    then have *: "chains e mss' (hd ms') \<le> fold (o) (map (\<lambda>_. ?bound) mss') id"
      apply (subst chains_le_fold[where E=E])
      using ineq decomp decomp_mss bound_in_End assms ms_ne apply (simp_all)
      apply (rule End_closed_sumE[OF l_lists'_finite[OF \<open>finite N\<close>]])
      using assms apply simp_all
      by (intro allI, rule chain2_endo, simp_all add: assms)
    have chain_ge0: "chains e mss' (hd ms') \<ge> 0"
      by (simp add: le_fun_def)
    have "fold (o) (map (\<lambda>_. ?bound) mss') id = ?bound ^^ (length mss')"
      by (simp add: fold_funpow)
    then have "chains e mss' (hd ms') \<le> (?bound ^^ (length mss'))"
      using * by auto
    also have "... = (\<lambda>_. 0)"
      using nilp bound_in_E decomp decomp_mss by auto
    finally have "chains e mss' (hd ms') = 0"
      using chain_ge0 unfolding zero_fun_def by simp
    then show "chain e ns n = 0"
      using ** chain_chains[of "concat mss'" "mss'" e n] ms_ne' A
       endo_f_0_0_closed_comp[of "chain e ms' n" E] endo_chain_closed_nonempty[of ns e E n] assms
      unfolding k_lists_def
      apply simp
      apply (subst endo_f_0_0_closed_comp[of "chain e ms' n" E])
      by (auto simp: decomp decomp_mss endo_chain_closed_nonempty)
  qed
  then have **: "\<And>n i. (\<Sum>ns \<in> k_lists N ?l. chain e ns n (i (hd ns))) = 0"
    by (subst sum.neutral, simp_all)

  have F: "flow_eq (fg N e ?f) i"
  proof (rule flow_eqI, safe, goal_cases)
    case (1 n)

    let ?ll = "l_lists N ?l"

    have xs_props: "\<forall>xs \<in> k_lists N ?l. set xs \<subseteq> N \<and> length xs = ?l"
      unfolding k_lists_def by auto

    have "i n + (\<Sum>n'\<in>N. e n' n (?f n')) =
      i n + (\<Sum>n'\<in>N. e n' n (i n') + e n' n (\<Sum>ns \<in> ?ll. chain e ns n' (i (hd ns))))"
      using assms
      apply (simp, intro sum.cong, simp)
      using endo_e unfolding endo_def by auto
    also have "... = i n + (\<Sum>n'\<in>N. e n' n (i n')
                         + (\<Sum>ns \<in> ?ll. e n' n (chain e ns n' (i (hd ns)))))"
      apply (simp, intro sum.cong, simp, simp)
      apply (rule endo_iterated_sum_closed[OF l_lists_finite[OF \<open>finite N\<close>], where E=E])
      using assms by auto
    also have "... = i n + (\<Sum>n'\<in>N. e n' n (i n')
                         + (\<Sum>ns \<in> ?ll. chain e (ns@[n']) n (i (hd ns))))"
      apply (simp, intro sum.cong, simp, simp, intro sum.cong, simp)
      using chain_extend_right by auto
    also have "... = i n + (\<Sum>n'\<in>N. chain e [n'] n (i n')
                         + (\<Sum>ns \<in> ?ll. chain e (ns@[n']) n (i (hd ns))))"
      by simp
    also have "... = i n + (\<Sum>n'\<in>N. chain e [n'] n (i n'))
                         + (\<Sum>n' \<in> N. (\<Sum>ns \<in>?ll. chain e (ns@[n']) n (i (hd ns))))"
      by (simp add: algebra_simps sum.distrib)
    also have "... = i n + (\<Sum>n'\<in>N. chain e [n'] n (i n'))
                         + (\<Sum>(n',ns) \<in> N \<times> ?ll. chain e (ns@[n']) n (i (hd ns)))"
      by (simp add: sum.cartesian_product)
    also have "... = i n + (\<Sum>n'\<in>N. chain e [n'] n (i n'))
                         + (\<Sum>ns \<in> (\<lambda>(n,ns). ns@[n]) ` (N \<times> ?ll). chain e ns n (i (hd ns)))"
      apply (subst sum.reindex, auto intro: inj_onI, subst sum.cong, auto)
      unfolding l_lists_def
      by (auto simp: hd_def split: list.splits)
    also have "... = i n + (\<Sum>ns\<in>k_lists N 1. chain e ns n (i (hd ns)))
                         + (\<Sum>ns \<in> (\<lambda>(n,ns). ns@[n]) ` (N \<times> ?ll). chain e ns n (i (hd ns)))"
      apply (simp del: chain.simps) unfolding k_lists_def
      apply (subst sum.reindex_cong[symmetric, where l="\<lambda>x. [x]"], auto intro: inj_onI)
      by (metis (no_types, lifting) One_nat_def Suc_length_conv image_iff
          length_0_conv list.sel(1) order_refl set_hd_in)
    also have
      "... = i n + (\<Sum>ns \<in> k_lists N 1 \<union> (\<lambda>(n,ns). ns@[n]) ` (N \<times> ?ll). chain e ns n (i (hd ns)))"
      apply (simp add: algebra_simps del: chain.simps, rule sum.union_disjoint[symmetric])
        apply (auto simp: assms k_lists_finite l_lists_finite)
      unfolding l_lists_def k_lists_def by auto
    also have "... = i n + (\<Sum>ns \<in> l_lists N (Suc ?l). chain e ns n (i (hd ns)))"
      by (subst merge_k_list_1, simp_all)
    also have "... = i n + (\<Sum>ns \<in> l_lists N ?l. chain e ns n (i (hd ns)))
                         + (\<Sum>ns \<in> k_lists N ?l. chain e ns n (i (hd ns)))"
      apply (subst l_lists_k_lists_union[symmetric,of ?l N], simp)
      by (subst sum.union_disjoint,
          simp_all add: l_lists_k_lists_disjoint l_lists_finite k_lists_finite algebra_simps assms)
    finally show "?f n = i n + (\<Sum>n'\<in>N. e n' n (?f n'))"
      using ** by simp
  next
    case 2
    show ?case using assms by simp
  qed

  have FF: "\<forall>f'. flow_eq (fg N e f') i \<longrightarrow> ?f = f' on N"
  proof safe
    fix f' x
    assume "flow_eq (fg N e f') i" "x \<in> N"

    then have "f' x = i x + (\<Sum>ns\<in>l_lists N (p * card N + 1). chain e ns x (i (hd ns)))
                          + (\<Sum>ns\<in>k_lists N (p * card N + 1). chain e ns x (f' (hd ns)))"
      by (subst unroll_flow_eq'[of ?l N e f' i E x], simp_all add: assms)
    also have "... = i x + (\<Sum>ns\<in>l_lists N (p * card N + 1). chain e ns x (i (hd ns)))"
      using **[of x] by simp
    finally show "?f x = f' x"
      by simp
  qed

  from F FF show ?thesis by auto
qed

text \<open>@{cite \<open>lem. 4\<close> krishna20}\<close>

lemma nilpotent_flow_exists:
  fixes E :: "('m \<Rightarrow> 'm :: pos_cancel_comm_monoid_add) set"
  assumes "\<forall>x y. e x y \<in> E" "End_closed E" "nilpotent E" "finite N"
    "(\<lambda>_. 0) \<in> E" "finite N"
  shows "\<exists>f. flow_eq (fg N e f) i \<and> (\<forall>f'. flow_eq (fg N e f') i \<longrightarrow> f = f' on N)"
  proof (cases "N \<noteq> {}")
case True
  then show ?thesis using nilpotent_flow_exists' assms by blast
next
  case False
  show ?thesis
    apply (rule exI[where x="\<lambda>_. 0"])
    using False by (auto intro!: flow_eqI)
qed

end


(* Author: Joshua Schneider, ETH Zurich *)

subsection \<open>Sum types\<close>

theory Applicative_Sum imports
  Applicative
  "HOL-Library.Adhoc_Overloading"
begin

text \<open>
  There are several ways to define an applicative functor based on sum types. First, we can choose
  whether the left or the right type is fixed. Both cases are isomorphic, of course. Next, what
  should happen if two values of the fixed type are combined? The corresponding operator must be
  associative, or the idiom laws don't hold true.

  We focus on the cases where the right type is fixed. We define two concrete functors: One based
  on Haskell's \textsf{Either} datatype, which prefers the value of the left operand, and a generic
  one using the @{class semigroup_add} class. Only the former lifts the \textbf{W} combinator,
  though.
\<close>

fun ap_sum :: "('e \<Rightarrow> 'e \<Rightarrow> 'e) \<Rightarrow> ('a \<Rightarrow> 'b) + 'e \<Rightarrow> 'a + 'e \<Rightarrow> 'b + 'e"
where
    "ap_sum _ (Inl f) (Inl x) = Inl (f x)"
  | "ap_sum _ (Inl _) (Inr e) = Inr e"
  | "ap_sum _ (Inr e) (Inl _) = Inr e"
  | "ap_sum c (Inr e1) (Inr e2) = Inr (c e1 e2)"

abbreviation "ap_either \<equiv> ap_sum (\<lambda>x _. x)"
abbreviation "ap_plus \<equiv> ap_sum (plus :: 'a :: semigroup_add \<Rightarrow> _)"

abbreviation (input) pure_sum where "pure_sum \<equiv> Inl"
adhoc_overloading Applicative.pure pure_sum
adhoc_overloading Applicative.ap ap_either (* ap_plus *)

lemma ap_sum_id: "ap_sum c (Inl id) x = x"
by (cases x) simp_all

lemma ap_sum_ichng: "ap_sum c f (Inl x) = ap_sum c (Inl (\<lambda>f. f x)) f"
by (cases f) simp_all

lemma (in semigroup) ap_sum_comp:
  "ap_sum f (ap_sum f (ap_sum f (Inl (o)) h) g) x = ap_sum f h (ap_sum f g x)"
by(cases h g x rule: sum.exhaust[case_product sum.exhaust, case_product sum.exhaust])
  (simp_all add: local.assoc)

lemma semigroup_const: "semigroup (\<lambda>x y. x)"
by unfold_locales simp

locale either_af =
  fixes B :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
  assumes B_refl: "reflp B"
begin

applicative either (W)
for
  pure: Inl
  ap: ap_either
  rel: "\<lambda>A. rel_sum A B"
proof -
  include applicative_syntax
  { fix f :: "('c \<Rightarrow> 'c \<Rightarrow> 'd) + 'a" and x
    show "pure (\<lambda>f x. f x x) \<diamondop> f \<diamondop> x = f \<diamondop> x \<diamondop> x"
      by (cases f x rule: sum.exhaust[case_product sum.exhaust]) simp_all
  next
    interpret semigroup "\<lambda>x y. x" by(rule semigroup_const)
    fix g :: "('d \<Rightarrow> 'e) + 'a" and f :: "('c \<Rightarrow> 'd) + 'a" and x
    show "pure (\<lambda>g f x. g (f x)) \<diamondop> g \<diamondop> f \<diamondop> x = g \<diamondop> (f \<diamondop> x)"
      by(rule ap_sum_comp[simplified comp_def[abs_def]])
  next
    fix R and f :: "('c \<Rightarrow> 'd) + 'b" and g :: "('c \<Rightarrow> 'e) + 'b" and x
    assume "rel_sum (rel_fun (eq_on UNIV) R) B f g"
    then show "rel_sum R B (f \<diamondop> x) (g \<diamondop> x)"
      by (cases f g x rule: sum.exhaust[case_product sum.exhaust, case_product sum.exhaust])
        (auto intro: B_refl[THEN reflpD] elim: rel_funE)
  }
qed (auto intro: ap_sum_id[simplified id_def] ap_sum_ichng)

end  (* locale *)

interpretation either_af "(=)" by unfold_locales simp

applicative semigroup_sum
for
  pure: Inl
  ap: ap_plus
using
  ap_sum_id[simplified id_def]
  ap_sum_ichng
  add.ap_sum_comp[simplified comp_def[abs_def]]
by auto

no_adhoc_overloading Applicative.pure pure_sum

end


(*
    $Id: ex.thy,v 1.2 2004/11/23 15:14:34 webertj Exp $
*)

header {* SNOC *}

(*<*) theory ex imports Main begin (*>*)

text {*
Define a primitive recursive function @{text snoc} that appends an element
at the \emph{right} end of a list. Do not use @{text"@"} itself.
*}

consts
  snoc :: "'a list => 'a => 'a list"

text {*
Prove the following theorem:
*}

theorem rev_cons: "rev (x # xs) = snoc (rev xs) x"
(*<*)oops(*>*)

text {*
Hint: you need to prove a suitable lemma first.
*}

(*<*) end (*>*)