(*  Title:       Primitive recursive functions of one variable
    Author:      Michael Nedzelsky <MichaelNedzelsky at yandex.ru>, 2008
    Maintainer:  Michael Nedzelsky <MichaelNedzelsky at yandex.ru>
*)

section \<open>Primitive recursive functions of one variable\<close>

theory PRecFun2
imports PRecFun
begin

subsection \<open>Alternative definition of primitive recursive functions of one variable\<close>

definition
  UnaryRecOp :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat)" where
  "UnaryRecOp = (\<lambda> g h. pr_conv_2_to_1 (PrimRecOp g (pr_conv_1_to_3 h)))"

lemma unary_rec_into_pr: "\<lbrakk> g \<in> PrimRec1; h \<in> PrimRec1 \<rbrakk> \<Longrightarrow> UnaryRecOp g h \<in> PrimRec1" by (simp add: UnaryRecOp_def pr_conv_1_to_3_lm pr_conv_2_to_1_lm pr_rec)

definition
  c_f_pair :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat)" where
  "c_f_pair = (\<lambda> f g x. c_pair (f x) (g x))"

lemma c_f_pair_to_pr: "\<lbrakk> f \<in> PrimRec1; g \<in> PrimRec1 \<rbrakk> \<Longrightarrow> c_f_pair f g \<in> PrimRec1"
  unfolding c_f_pair_def by prec

inductive_set PrimRec1' :: "(nat \<Rightarrow> nat) set"
where
  zero: "(\<lambda> x. 0) \<in> PrimRec1'"
  | suc:  "Suc \<in> PrimRec1'"
  | fst:  "c_fst \<in> PrimRec1'"
  | snd:  "c_snd \<in> PrimRec1'"
  | comp: "\<lbrakk> f \<in> PrimRec1'; g \<in> PrimRec1' \<rbrakk> \<Longrightarrow> (\<lambda> x. f (g x)) \<in> PrimRec1'"
  | pair: "\<lbrakk> f \<in> PrimRec1'; g \<in> PrimRec1' \<rbrakk> \<Longrightarrow> c_f_pair f g \<in> PrimRec1'"
  | un_rec: "\<lbrakk> f \<in> PrimRec1'; g \<in> PrimRec1' \<rbrakk> \<Longrightarrow> UnaryRecOp f g \<in> PrimRec1'"

lemma primrec'_into_primrec: "f \<in> PrimRec1' \<Longrightarrow> f \<in> PrimRec1"
proof (induct f rule: PrimRec1'.induct)
  case zero show ?case by (rule pr_zero)
next
  case suc show ?case by (rule pr_suc)
next
  case fst show ?case by (rule c_fst_is_pr)
next
  case snd show ?case by (rule c_snd_is_pr)
next
  case comp from comp show ?case by (simp add: pr_comp1_1)
next
  case pair from pair show ?case by (simp add: c_f_pair_to_pr)
next
  case un_rec from un_rec show ?case by (simp add: unary_rec_into_pr)
qed

lemma pr_id1_1': "(\<lambda> x. x) \<in> PrimRec1'"
proof -
  have "c_f_pair c_fst c_snd \<in> PrimRec1'" by (simp add: PrimRec1'.fst PrimRec1'.snd PrimRec1'.pair)
  moreover have "c_f_pair c_fst c_snd = (\<lambda> x. x)" by (simp add: c_f_pair_def)
  ultimately show ?thesis by simp
qed

lemma pr_id2_1': "pr_conv_2_to_1 (\<lambda> x y. x) \<in> PrimRec1'" by (simp add: pr_conv_2_to_1_def PrimRec1'.fst)

lemma pr_id2_2': "pr_conv_2_to_1 (\<lambda> x y. y) \<in> PrimRec1'" by (simp add: pr_conv_2_to_1_def PrimRec1'.snd)

lemma pr_id3_1': "pr_conv_3_to_1 (\<lambda> x y z. x) \<in> PrimRec1'"
proof -
  have "pr_conv_3_to_1 (\<lambda> x y z. x) = (\<lambda>x. c_fst (c_fst x))" by (simp add: pr_conv_3_to_1_def)
  moreover from PrimRec1'.fst PrimRec1'.fst have "(\<lambda>x. c_fst (c_fst x)) \<in> PrimRec1'" by (rule PrimRec1'.comp)
  ultimately show ?thesis by simp
qed

lemma pr_id3_2': "pr_conv_3_to_1 (\<lambda> x y z. y) \<in> PrimRec1'"
proof -
  have "pr_conv_3_to_1 (\<lambda> x y z. y) = (\<lambda>x. c_snd (c_fst x))" by (simp add: pr_conv_3_to_1_def)
  moreover from PrimRec1'.snd PrimRec1'.fst have "(\<lambda>x. c_snd (c_fst x)) \<in> PrimRec1'" by (rule PrimRec1'.comp)
  ultimately show ?thesis by simp
qed

lemma pr_id3_3': "pr_conv_3_to_1 (\<lambda> x y z. z) \<in> PrimRec1'"
proof -
  have "pr_conv_3_to_1 (\<lambda> x y z. z) = (\<lambda>x. c_snd x)" by (simp add: pr_conv_3_to_1_def)
  thus ?thesis by (simp add: PrimRec1'.snd)
qed

lemma pr_comp2_1': "\<lbrakk> pr_conv_2_to_1 f \<in> PrimRec1'; g \<in> PrimRec1'; h \<in> PrimRec1' \<rbrakk> \<Longrightarrow> (\<lambda> x. f (g x) (h x)) \<in> PrimRec1'"
proof -
  assume A1: "pr_conv_2_to_1 f \<in> PrimRec1'"
  assume A2: "g \<in> PrimRec1'"
  assume A3: "h \<in> PrimRec1'"
  let ?f1 = "pr_conv_2_to_1 f"
  have S1: "(%x. ?f1 ((c_f_pair g h) x)) = (\<lambda> x. f (g x) (h x))" by (simp add: c_f_pair_def pr_conv_2_to_1_def)
  from A2 A3 have S2: "c_f_pair g h \<in> PrimRec1'" by (rule PrimRec1'.pair)
  from A1 S2 have S3: "(%x. ?f1 ((c_f_pair g h) x)) \<in> PrimRec1'" by (rule PrimRec1'.comp)
  with S1 show ?thesis by simp
qed

lemma pr_comp3_1': "\<lbrakk> pr_conv_3_to_1 f \<in> PrimRec1'; g \<in> PrimRec1'; h \<in> PrimRec1'; k \<in> PrimRec1' \<rbrakk> \<Longrightarrow> (\<lambda> x. f (g x) (h x) (k x)) \<in> PrimRec1'"
proof -
  assume A1: "pr_conv_3_to_1 f \<in> PrimRec1'"
  assume A2: "g \<in> PrimRec1'"
  assume A3: "h \<in> PrimRec1'"
  assume A4: "k \<in> PrimRec1'"
  from A2 A3 have "c_f_pair g h \<in> PrimRec1'" by (rule PrimRec1'.pair)
  from this A4 have "c_f_pair (c_f_pair g h) k \<in> PrimRec1'" by (rule PrimRec1'.pair)
  from A1 this have "(%x. (pr_conv_3_to_1 f) ((c_f_pair (c_f_pair g h) k) x)) \<in> PrimRec1'" by (rule PrimRec1'.comp)
  then show ?thesis by (simp add: c_f_pair_def pr_conv_3_to_1_def)
qed

lemma pr_comp1_2': "\<lbrakk> f \<in> PrimRec1'; pr_conv_2_to_1 g \<in> PrimRec1' \<rbrakk> \<Longrightarrow> pr_conv_2_to_1 (\<lambda> x y. f (g x y)) \<in> PrimRec1'"
proof -
  assume "f \<in> PrimRec1'"
  and "pr_conv_2_to_1 g \<in> PrimRec1'" (is "?g1 \<in> PrimRec1'")
  then have "(\<lambda> x. f (?g1 x)) \<in> PrimRec1'" by (rule PrimRec1'.comp)
  then show ?thesis by (simp add: pr_conv_2_to_1_def)
qed

lemma pr_comp1_3': "\<lbrakk> f \<in> PrimRec1'; pr_conv_3_to_1 g \<in> PrimRec1' \<rbrakk> \<Longrightarrow> pr_conv_3_to_1 (\<lambda> x y z. f (g x y z)) \<in> PrimRec1'"
proof -
  assume "f \<in> PrimRec1'"
  and "pr_conv_3_to_1 g \<in> PrimRec1'" (is "?g1 \<in> PrimRec1'")
  then have "(\<lambda> x. f (?g1 x)) \<in> PrimRec1'" by (rule PrimRec1'.comp)
  then show ?thesis by (simp add: pr_conv_3_to_1_def)
qed

lemma pr_comp2_2': "\<lbrakk> pr_conv_2_to_1 f \<in> PrimRec1'; pr_conv_2_to_1 g \<in> PrimRec1'; pr_conv_2_to_1 h \<in> PrimRec1' \<rbrakk> \<Longrightarrow> pr_conv_2_to_1 (\<lambda> x y. f (g x y) (h x y)) \<in> PrimRec1'"
proof -
  assume "pr_conv_2_to_1 f \<in> PrimRec1'"
  and "pr_conv_2_to_1 g \<in> PrimRec1'" (is "?g1 \<in> PrimRec1'")
  and "pr_conv_2_to_1 h \<in> PrimRec1'" (is "?h1 \<in> PrimRec1'")
  then have "(\<lambda> x. f (?g1 x) (?h1 x)) \<in> PrimRec1'" by (rule pr_comp2_1')
  then show ?thesis by (simp add: pr_conv_2_to_1_def)
qed

lemma pr_comp2_3': "\<lbrakk> pr_conv_2_to_1 f \<in> PrimRec1'; pr_conv_3_to_1 g \<in> PrimRec1'; pr_conv_3_to_1 h \<in> PrimRec1' \<rbrakk> \<Longrightarrow> pr_conv_3_to_1 (\<lambda> x y z. f (g x y z) (h x y z)) \<in> PrimRec1'"
proof -
  assume "pr_conv_2_to_1 f \<in> PrimRec1'"
  and "pr_conv_3_to_1 g \<in> PrimRec1'" (is "?g1 \<in> PrimRec1'")
  and "pr_conv_3_to_1 h \<in> PrimRec1'" (is "?h1 \<in> PrimRec1'")
  then have "(\<lambda> x. f (?g1 x) (?h1 x)) \<in> PrimRec1'" by (rule pr_comp2_1')
  then show ?thesis by (simp add: pr_conv_3_to_1_def)
qed

lemma pr_comp3_2': "\<lbrakk> pr_conv_3_to_1 f \<in> PrimRec1'; pr_conv_2_to_1 g \<in> PrimRec1'; pr_conv_2_to_1 h \<in> PrimRec1'; pr_conv_2_to_1 k \<in> PrimRec1' \<rbrakk> \<Longrightarrow> pr_conv_2_to_1 (\<lambda> x y. f (g x y) (h x y) (k x y)) \<in> PrimRec1'"
proof -
  assume "pr_conv_3_to_1 f \<in> PrimRec1'"
  and "pr_conv_2_to_1 g \<in> PrimRec1'" (is "?g1 \<in> PrimRec1'")
  and "pr_conv_2_to_1 h \<in> PrimRec1'" (is "?h1 \<in> PrimRec1'")
  and "pr_conv_2_to_1 k \<in> PrimRec1'" (is "?k1 \<in> PrimRec1'")
  then have "(\<lambda> x. f (?g1 x) (?h1 x) (?k1 x)) \<in> PrimRec1'" by (rule pr_comp3_1')
  then show ?thesis by (simp add: pr_conv_2_to_1_def)
qed

lemma pr_comp3_3': "\<lbrakk> pr_conv_3_to_1 f \<in> PrimRec1'; pr_conv_3_to_1 g \<in> PrimRec1'; pr_conv_3_to_1 h \<in> PrimRec1'; pr_conv_3_to_1 k \<in> PrimRec1' \<rbrakk> \<Longrightarrow> pr_conv_3_to_1 (\<lambda> x y z. f (g x y z) (h x y z) (k x y z)) \<in> PrimRec1'"
proof -
  assume "pr_conv_3_to_1 f \<in> PrimRec1'"
  and "pr_conv_3_to_1 g \<in> PrimRec1'" (is "?g1 \<in> PrimRec1'")
  and "pr_conv_3_to_1 h \<in> PrimRec1'" (is "?h1 \<in> PrimRec1'")
  and "pr_conv_3_to_1 k \<in> PrimRec1'" (is "?k1 \<in> PrimRec1'")
  then have "(\<lambda> x. f (?g1 x) (?h1 x) (?k1 x)) \<in> PrimRec1'" by (rule pr_comp3_1')
  then show ?thesis by (simp add: pr_conv_3_to_1_def)
qed

lemma lm': "(f1 \<in> PrimRec1 \<longrightarrow> f1 \<in> PrimRec1') \<and> (g1 \<in> PrimRec2 \<longrightarrow> pr_conv_2_to_1 g1 \<in> PrimRec1') \<and> (h1 \<in> PrimRec3 \<longrightarrow> pr_conv_3_to_1 h1 \<in> PrimRec1')"
proof (induct rule: PrimRec1_PrimRec2_PrimRec3.induct)
     case zero show ?case by (rule PrimRec1'.zero)
next case suc show ?case by (rule PrimRec1'.suc)
next case id1_1 show ?case by (rule pr_id1_1')
next case id2_1 show ?case by (rule pr_id2_1')
next case id2_2 show ?case by (rule pr_id2_2')
next case id3_1 show ?case by (rule pr_id3_1')
next case id3_2 show ?case by (rule pr_id3_2')
next case id3_3 show ?case by (rule pr_id3_3')
next case comp1_1 from comp1_1 show ?case by (simp add: PrimRec1'.comp)
next case comp1_2 from comp1_2 show ?case by (simp add: pr_comp1_2')
next case comp1_3 from comp1_3 show ?case by (simp add: pr_comp1_3')
next case comp2_1 from comp2_1 show ?case by (simp add: pr_comp2_1')
next case comp2_2 from comp2_2 show ?case by (simp add: pr_comp2_2')
next case comp2_3 from comp2_3 show ?case by (simp add: pr_comp2_3')
next case comp3_1 from comp3_1 show ?case by (simp add: pr_comp3_1')
next case comp3_2 from comp3_2 show ?case by (simp add: pr_comp3_2')
next case comp3_3 from comp3_3 show ?case by (simp add: pr_comp3_3')
next case prim_rec
  fix g h assume A1: "g \<in> PrimRec1'" and "pr_conv_3_to_1 h \<in> PrimRec1'"
  then have "UnaryRecOp g (pr_conv_3_to_1 h) \<in> PrimRec1'" by (rule PrimRec1'.un_rec)
  moreover have "UnaryRecOp g (pr_conv_3_to_1 h) = pr_conv_2_to_1 (PrimRecOp g h)" by (simp add: UnaryRecOp_def)
  ultimately show "pr_conv_2_to_1 (PrimRecOp g h) \<in> PrimRec1'" by simp
qed

theorem pr_1_eq_1': "PrimRec1 = PrimRec1'"
proof -
  have S1: "\<And> f. f \<in> PrimRec1 \<longrightarrow> f \<in> PrimRec1'" by (simp add: lm')
  have S2: "\<And> f. f \<in> PrimRec1' \<longrightarrow> f \<in> PrimRec1" by (simp add: primrec'_into_primrec)
  from S1 S2 show ?thesis by blast
qed

subsection \<open>The scheme datatype\<close>

datatype PrimScheme = Base_zero | Base_suc | Base_fst | Base_snd
                      | Comp_op PrimScheme PrimScheme
                      | Pair_op PrimScheme PrimScheme
                      | Rec_op PrimScheme PrimScheme

primrec
  sch_to_pr :: "PrimScheme \<Rightarrow> (nat \<Rightarrow> nat)"
where
  "sch_to_pr Base_zero = (\<lambda> x. 0)"
| "sch_to_pr Base_suc = Suc"
| "sch_to_pr Base_fst = c_fst"
| "sch_to_pr Base_snd = c_snd"
| "sch_to_pr (Comp_op t1 t2)  = (\<lambda> x. (sch_to_pr t1) ((sch_to_pr t2) x))"
| "sch_to_pr (Pair_op t1 t2)  = c_f_pair (sch_to_pr t1) (sch_to_pr t2)"
| "sch_to_pr (Rec_op t1 t2)  = UnaryRecOp (sch_to_pr t1) (sch_to_pr t2)"

lemma sch_to_pr_into_pr: "sch_to_pr sch \<in> PrimRec1" by (simp add: pr_1_eq_1', induct sch, simp_all add: PrimRec1'.intros)

lemma sch_to_pr_srj: "f \<in> PrimRec1 \<Longrightarrow> (\<exists> sch. f = sch_to_pr sch)"
proof -
  assume "f \<in> PrimRec1" then have A1: "f \<in> PrimRec1'" by (simp add: pr_1_eq_1')
  from A1 show ?thesis
  proof (induct f rule: PrimRec1'.induct)
    have "(\<lambda> x. 0) = sch_to_pr Base_zero" by simp
    then show "\<exists>sch. (\<lambda>u. 0) = sch_to_pr sch" by (rule exI)
  next
    have "Suc = sch_to_pr Base_suc" by simp
    then show "\<exists>sch. Suc = sch_to_pr sch" by (rule exI)
  next
    have "c_fst = sch_to_pr Base_fst" by simp
    then show "\<exists>sch. c_fst = sch_to_pr sch" by (rule exI)
  next
    have "c_snd = sch_to_pr Base_snd" by simp
    then show "\<exists>sch. c_snd = sch_to_pr sch" by (rule exI)
  next
    fix f1 f2 assume B1: "\<exists>sch. f1 = sch_to_pr sch" and B2: "\<exists>sch. f2 = sch_to_pr sch"
    from B1 obtain sch1 where S1: "f1 = sch_to_pr sch1" ..
    from B2 obtain sch2 where S2: "f2 = sch_to_pr sch2" ..
    from S1 S2 have "(\<lambda> x. f1 (f2 x)) = sch_to_pr (Comp_op sch1 sch2)" by simp
    then show "\<exists>sch. (\<lambda>x. f1 (f2 x)) = sch_to_pr sch" by (rule exI)
  next
    fix f1 f2 assume B1: "\<exists>sch. f1 = sch_to_pr sch" and B2: "\<exists>sch. f2 = sch_to_pr sch"
    from B1 obtain sch1 where S1: "f1 = sch_to_pr sch1" ..
    from B2 obtain sch2 where S2: "f2 = sch_to_pr sch2" ..
    from S1 S2 have "c_f_pair f1 f2 = sch_to_pr (Pair_op sch1 sch2)" by simp
    then show "\<exists>sch. c_f_pair f1 f2 = sch_to_pr sch" by (rule exI)
  next
    fix f1 f2 assume B1: "\<exists>sch. f1 = sch_to_pr sch" and B2: "\<exists>sch. f2 = sch_to_pr sch"
    from B1 obtain sch1 where S1: "f1 = sch_to_pr sch1" ..
    from B2 obtain sch2 where S2: "f2 = sch_to_pr sch2" ..
    from S1 S2 have "UnaryRecOp f1 f2 = sch_to_pr (Rec_op sch1 sch2)" by simp
    then show "\<exists>sch. UnaryRecOp f1 f2 = sch_to_pr sch" by (rule exI)
  qed
qed

definition
  loc_f :: "nat \<Rightarrow> PrimScheme \<Rightarrow> PrimScheme \<Rightarrow> PrimScheme" where
  "loc_f n sch1 sch2 =
    (if n=0 then Base_zero else
     if n=1 then Base_suc else
     if n=2 then Base_fst else
     if n=3 then Base_snd else
     if n=4 then (Comp_op sch1 sch2) else
     if n=5 then (Pair_op sch1 sch2) else
     if n=6 then (Rec_op sch1 sch2) else
     Base_zero)"

definition
  mod7 :: "nat \<Rightarrow> nat" where
  "mod7 = (\<lambda> x. x mod 7)"

lemma c_snd_snd_lt [termination_simp]: "c_snd (c_snd (Suc (Suc x))) < Suc (Suc x)"
proof -
  let ?y = "Suc (Suc x)"
  have "?y > 1" by simp
  then have "c_snd ?y < ?y" by (rule c_snd_less_arg)
  moreover have "c_snd (c_snd ?y) \<le> c_snd ?y" by (rule c_snd_le_arg)
  ultimately show ?thesis by simp
qed

lemma c_fst_snd_lt [termination_simp]: "c_fst (c_snd (Suc (Suc x))) < Suc (Suc x)"
proof -
  let ?y = "Suc (Suc x)"
  have "?y > 1" by simp
  then have "c_snd ?y < ?y" by (rule c_snd_less_arg)
  moreover have "c_fst (c_snd ?y) \<le> c_snd ?y" by (rule c_fst_le_arg)
  ultimately show ?thesis by simp
qed

fun nat_to_sch :: "nat \<Rightarrow> PrimScheme" where
  "nat_to_sch 0 = Base_zero"
| "nat_to_sch (Suc 0) = Base_zero"
| "nat_to_sch x = (let u=mod7 (c_fst x); v=c_snd x; v1=c_fst v; v2 = c_snd v; sch1=nat_to_sch v1; sch2=nat_to_sch v2 in loc_f u sch1 sch2)"

primrec sch_to_nat :: "PrimScheme \<Rightarrow> nat" where
  "sch_to_nat Base_zero = 0"
| "sch_to_nat Base_suc = c_pair 1 0"
| "sch_to_nat Base_fst = c_pair 2 0"
| "sch_to_nat Base_snd = c_pair 3 0"
| "sch_to_nat (Comp_op t1 t2) = c_pair 4 (c_pair (sch_to_nat t1) (sch_to_nat t2))"
| "sch_to_nat (Pair_op t1 t2) = c_pair 5 (c_pair (sch_to_nat t1) (sch_to_nat t2))"
| "sch_to_nat (Rec_op t1 t2)  = c_pair 6 (c_pair (sch_to_nat t1) (sch_to_nat t2))"

lemma loc_srj_lm_1: "nat_to_sch (Suc (Suc x)) = (let u=mod7 (c_fst (Suc (Suc x))); v=c_snd (Suc (Suc x)); v1=c_fst v; v2 = c_snd v; sch1=nat_to_sch v1; sch2=nat_to_sch v2 in loc_f u sch1 sch2)" by simp

lemma loc_srj_lm_2: "x > 1 \<Longrightarrow> nat_to_sch x = (let u=mod7 (c_fst x); v=c_snd x; v1=c_fst v; v2 = c_snd v; sch1=nat_to_sch v1; sch2=nat_to_sch v2 in loc_f u sch1 sch2)"
proof -
  assume A1: "x > 1"
  let ?y = "x-(2::nat)"
  from A1 have S1: "x = Suc (Suc ?y)" by arith
  have S2: "nat_to_sch (Suc (Suc ?y)) = (let u=mod7 (c_fst (Suc (Suc ?y))); v=c_snd (Suc (Suc ?y)); v1=c_fst v; v2 = c_snd v; sch1=nat_to_sch v1; sch2=nat_to_sch v2 in loc_f u sch1 sch2)" by (rule loc_srj_lm_1)
  from S1 S2 show ?thesis by simp
qed

lemma loc_srj_0: "nat_to_sch (c_pair 1 0) = Base_suc"
proof -
  let ?x = "c_pair 1 0"
  have S1: "?x = 2" by (simp add: c_pair_def sf_def)
  then have S2: "?x = Suc (Suc 0)" by simp
  let ?y = "Suc (Suc 0)"
  have S3: "nat_to_sch ?y = (let u=mod7 (c_fst ?y); v=c_snd ?y; v1=c_fst v; v2 = c_snd v; sch1=nat_to_sch v1; sch2=nat_to_sch v2 in loc_f u sch1 sch2)" (is "_ = ?R") by (rule loc_srj_lm_1)
  have S4: "c_fst ?y = 1"
  proof -
    from S2 have "c_fst ?y = c_fst ?x" by simp
    then show ?thesis by simp
  qed
  have S5: "c_snd ?y = 0"
  proof -
    from S2 have "c_snd ?y = c_snd ?x" by simp
    then show ?thesis by simp
  qed
  from S4 have S6: "mod7 (c_fst ?y) = 1" by (simp add: mod7_def)
  from S3 S5 S6 have S9: "?R = loc_f 1 Base_zero Base_zero" by (simp add: Let_def c_fst_at_0 c_snd_at_0)
  then have S10: "?R = Base_suc" by (simp add: loc_f_def)
  with S3 have S11: "nat_to_sch ?y = Base_suc" by simp
  from S2 this show ?thesis by simp
qed

lemma nat_to_sch_at_2: "nat_to_sch 2 = Base_suc"
proof -
  have S1: "c_pair 1 0 = 2" by (simp add: c_pair_def sf_def)
  have S2: "nat_to_sch (c_pair 1 0) = Base_suc" by (rule loc_srj_0)
  from S1 S2 show ?thesis by simp
qed

lemma loc_srj_1: "nat_to_sch (c_pair 2 0) = Base_fst"
proof -
  let ?x = "c_pair 2 0"
  have S1: "?x = 5" by (simp add: c_pair_def sf_def)
  then have S2: "?x = Suc (Suc 3)" by simp
  let ?y = "Suc (Suc 3)"
  have S3: "nat_to_sch ?y = (let u=mod7 (c_fst ?y); v=c_snd ?y; v1=c_fst v; v2 = c_snd v; sch1=nat_to_sch v1; sch2=nat_to_sch v2 in loc_f u sch1 sch2)" (is "_ = ?R") by (rule loc_srj_lm_1)
  have S4: "c_fst ?y = 2"
  proof -
    from S2 have "c_fst ?y = c_fst ?x" by simp
    then show ?thesis by simp
  qed
  have S5: "c_snd ?y = 0"
  proof -
    from S2 have "c_snd ?y = c_snd ?x" by simp
    then show ?thesis by simp
  qed
  from S4 have S6: "mod7 (c_fst ?y) = 2" by (simp add: mod7_def)
  from S3 S5 S6 have S9: "?R = loc_f 2 Base_zero Base_zero" by (simp add: Let_def c_fst_at_0 c_snd_at_0)
  then have S10: "?R = Base_fst" by (simp add: loc_f_def)
  with S3 have S11: "nat_to_sch ?y = Base_fst" by simp
  from S2 this show ?thesis by simp
qed

lemma loc_srj_2: "nat_to_sch (c_pair 3 0) = Base_snd"
proof -
  let ?x = "c_pair 3 0"
  have S1: "?x > 1" by (simp add: c_pair_def sf_def)
  from S1 have S2: "nat_to_sch ?x = (let u=mod7 (c_fst ?x); v=c_snd ?x; v1=c_fst v; v2 = c_snd v; sch1=nat_to_sch v1; sch2=nat_to_sch v2 in loc_f u sch1 sch2)" (is "_ = ?R") by (rule loc_srj_lm_2)
  have S3: "c_fst ?x = 3" by simp
  have S4: "c_snd ?x = 0" by simp
  from S3 have S6: "mod7 (c_fst ?x) = 3" by (simp add: mod7_def)
  from S3 S4 S6 have S7: "?R = loc_f 3 Base_zero Base_zero" by (simp add: Let_def c_fst_at_0 c_snd_at_0)
  then have S8: "?R = Base_snd" by (simp add: loc_f_def)
  with S2 have S10: "nat_to_sch ?x = Base_snd" by simp
  from S2 this show ?thesis by simp
qed

lemma loc_srj_3: "\<lbrakk>nat_to_sch (sch_to_nat sch1) = sch1; nat_to_sch (sch_to_nat sch2) = sch2\<rbrakk>
       \<Longrightarrow> nat_to_sch (c_pair 4 (c_pair (sch_to_nat sch1) (sch_to_nat sch2))) = Comp_op sch1 sch2"
proof -
  assume A1: "nat_to_sch (sch_to_nat sch1) = sch1"
  assume A2: "nat_to_sch (sch_to_nat sch2) = sch2"
  let ?x = "c_pair 4 (c_pair (sch_to_nat sch1) (sch_to_nat sch2))"
  have S1: "?x > 1" by (simp add: c_pair_def sf_def)
  from S1 have S2: "nat_to_sch ?x = (let u=mod7 (c_fst ?x); v=c_snd ?x; v1=c_fst v; v2 = c_snd v; sch1=nat_to_sch v1; sch2=nat_to_sch v2 in loc_f u sch1 sch2)" (is "_ = ?R") by (rule loc_srj_lm_2)
  have S3: "c_fst ?x = 4" by simp
  have S4: "c_snd ?x = c_pair (sch_to_nat sch1) (sch_to_nat sch2)" by simp
  from S3 have S5: "mod7 (c_fst ?x) = 4" by (simp add: mod7_def)
  from A1 A2 S4 S5 have "?R = Comp_op sch1 sch2" by (simp add: Let_def c_fst_at_0 c_snd_at_0 loc_f_def)
  with S2 show ?thesis by simp
qed

lemma loc_srj_3_1: "nat_to_sch (c_pair 4 (c_pair n1 n2)) = Comp_op (nat_to_sch n1) (nat_to_sch n2)"
proof -
  let ?x = "c_pair 4 (c_pair n1 n2)"
  have S1: "?x > 1" by (simp add: c_pair_def sf_def)
  from S1 have S2: "nat_to_sch ?x = (let u=mod7 (c_fst ?x); v=c_snd ?x; v1=c_fst v; v2 = c_snd v; sch1=nat_to_sch v1; sch2=nat_to_sch v2 in loc_f u sch1 sch2)" (is "_ = ?R") by (rule loc_srj_lm_2)
  have S3: "c_fst ?x = 4" by simp
  have S4: "c_snd ?x = c_pair n1 n2" by simp
  from S3 have S5: "mod7 (c_fst ?x) = 4" by (simp add: mod7_def)
  from S4 S5 have "?R = Comp_op (nat_to_sch n1) (nat_to_sch n2)" by (simp add: Let_def c_fst_at_0 c_snd_at_0 loc_f_def)
  with S2 show ?thesis by simp
qed

lemma loc_srj_4: "\<lbrakk>nat_to_sch (sch_to_nat sch1) = sch1; nat_to_sch (sch_to_nat sch2) = sch2\<rbrakk>
       \<Longrightarrow> nat_to_sch (c_pair 5 (c_pair (sch_to_nat sch1) (sch_to_nat sch2))) = Pair_op sch1 sch2"
proof -
  assume A1: "nat_to_sch (sch_to_nat sch1) = sch1"
  assume A2: "nat_to_sch (sch_to_nat sch2) = sch2"
  let ?x = "c_pair 5 (c_pair (sch_to_nat sch1) (sch_to_nat sch2))"
  have S1: "?x > 1" by (simp add: c_pair_def sf_def)
  from S1 have S2: "nat_to_sch ?x = (let u=mod7 (c_fst ?x); v=c_snd ?x; v1=c_fst v; v2 = c_snd v; sch1=nat_to_sch v1; sch2=nat_to_sch v2 in loc_f u sch1 sch2)" (is "_ = ?R") by (rule loc_srj_lm_2)
  have S3: "c_fst ?x = 5" by simp
  have S4: "c_snd ?x = c_pair (sch_to_nat sch1) (sch_to_nat sch2)" by simp
  from S3 have S5: "mod7 (c_fst ?x) = 5" by (simp add: mod7_def)
  from A1 A2 S4 S5 have "?R = Pair_op sch1 sch2" by (simp add: Let_def c_fst_at_0 c_snd_at_0 loc_f_def)
  with S2 show ?thesis by simp
qed

lemma loc_srj_4_1: "nat_to_sch (c_pair 5 (c_pair n1 n2)) = Pair_op (nat_to_sch n1) (nat_to_sch n2)"
proof -
  let ?x = "c_pair 5 (c_pair n1 n2)"
  have S1: "?x > 1" by (simp add: c_pair_def sf_def)
  from S1 have S2: "nat_to_sch ?x = (let u=mod7 (c_fst ?x); v=c_snd ?x; v1=c_fst v; v2 = c_snd v; sch1=nat_to_sch v1; sch2=nat_to_sch v2 in loc_f u sch1 sch2)" (is "_ = ?R") by (rule loc_srj_lm_2)
  have S3: "c_fst ?x = 5" by simp
  have S4: "c_snd ?x = c_pair n1 n2" by simp
  from S3 have S5: "mod7 (c_fst ?x) = 5" by (simp add: mod7_def)
  from S4 S5 have "?R = Pair_op (nat_to_sch n1) (nat_to_sch n2)" by (simp add: Let_def c_fst_at_0 c_snd_at_0 loc_f_def)
  with S2 show ?thesis by simp
qed

lemma loc_srj_5: "\<lbrakk>nat_to_sch (sch_to_nat sch1) = sch1; nat_to_sch (sch_to_nat sch2) = sch2\<rbrakk>
       \<Longrightarrow> nat_to_sch (c_pair 6 (c_pair (sch_to_nat sch1) (sch_to_nat sch2))) = Rec_op sch1 sch2"
proof -
  assume A1: "nat_to_sch (sch_to_nat sch1) = sch1"
  assume A2: "nat_to_sch (sch_to_nat sch2) = sch2"
  let ?x = "c_pair 6 (c_pair (sch_to_nat sch1) (sch_to_nat sch2))"
  have S1: "?x > 1" by (simp add: c_pair_def sf_def)
  from S1 have S2: "nat_to_sch ?x = (let u=mod7 (c_fst ?x); v=c_snd ?x; v1=c_fst v; v2 = c_snd v; sch1=nat_to_sch v1; sch2=nat_to_sch v2 in loc_f u sch1 sch2)" (is "_ = ?R") by (rule loc_srj_lm_2)
  have S3: "c_fst ?x = 6" by simp
  have S4: "c_snd ?x = c_pair (sch_to_nat sch1) (sch_to_nat sch2)" by simp
  from S3 have S5: "mod7 (c_fst ?x) = 6" by (simp add: mod7_def)
  from A1 A2 S4 S5 have "?R = Rec_op sch1 sch2" by (simp add: Let_def c_fst_at_0 c_snd_at_0 loc_f_def)
  with S2 show ?thesis by simp
qed

lemma loc_srj_5_1: "nat_to_sch (c_pair 6 (c_pair n1 n2)) = Rec_op (nat_to_sch n1) (nat_to_sch n2)"
proof -
  let ?x = "c_pair 6 (c_pair n1 n2)"
  have S1: "?x > 1" by (simp add: c_pair_def sf_def)
  from S1 have S2: "nat_to_sch ?x = (let u=mod7 (c_fst ?x); v=c_snd ?x; v1=c_fst v; v2 = c_snd v; sch1=nat_to_sch v1; sch2=nat_to_sch v2 in loc_f u sch1 sch2)" (is "_ = ?R") by (rule loc_srj_lm_2)
  have S3: "c_fst ?x = 6" by simp
  have S4: "c_snd ?x = c_pair n1 n2" by simp
  from S3 have S5: "mod7 (c_fst ?x) = 6" by (simp add: mod7_def)
  from S4 S5 have "?R = Rec_op (nat_to_sch n1) (nat_to_sch n2)" by (simp add: Let_def c_fst_at_0 c_snd_at_0 loc_f_def)
  with S2 show ?thesis by simp
qed

subsection \<open>Indexes of primitive recursive functions of one variables\<close>

definition
  nat_to_pr :: "nat \<Rightarrow> (nat \<Rightarrow> nat)" where
  "nat_to_pr = (\<lambda> x. sch_to_pr (nat_to_sch x))"

theorem nat_to_pr_into_pr: "nat_to_pr n \<in> PrimRec1" by (simp add: nat_to_pr_def sch_to_pr_into_pr)

lemma nat_to_pr_srj: "f \<in> PrimRec1 \<Longrightarrow> (\<exists> n. f = nat_to_pr n)"
proof -
  assume "f \<in> PrimRec1"
  then have S1: "(\<exists> t. f = sch_to_pr t)" by (rule sch_to_pr_srj)
  from S1 obtain t where S2: "f = sch_to_pr t" ..
  let ?n = "sch_to_nat t"
  have S3: "nat_to_pr ?n = sch_to_pr (nat_to_sch ?n)" by (simp add: nat_to_pr_def)
  have S4: "nat_to_sch ?n = t" by (rule nat_to_sch_srj)
  from S3 S4 have S5: "nat_to_pr ?n = sch_to_pr t" by simp
  from S2 S5 have "nat_to_pr ?n = f" by simp
  then have "f = nat_to_pr ?n" by simp
  then show ?thesis ..
qed

lemma nat_to_pr_at_0: "nat_to_pr 0 = (\<lambda> x. 0)" by (simp add: nat_to_pr_def)

definition
  index_of_pr :: "(nat \<Rightarrow> nat) \<Rightarrow> nat" where
  "index_of_pr f = (SOME n. f = nat_to_pr n)"

theorem index_of_pr_is_real: "f \<in> PrimRec1 \<Longrightarrow> nat_to_pr (index_of_pr f) = f"
proof -
  assume "f \<in> PrimRec1"
  hence "\<exists> n. f = nat_to_pr n" by (rule nat_to_pr_srj)
  hence "f = nat_to_pr (SOME n. f = nat_to_pr n)" by (rule someI_ex)
  thus ?thesis by (simp add: index_of_pr_def)
qed

definition
  comp_by_index :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "comp_by_index = (\<lambda> n1 n2. c_pair 4 (c_pair n1 n2))"

definition
  pair_by_index :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "pair_by_index = (\<lambda> n1 n2. c_pair 5 (c_pair n1 n2))"

definition
  rec_by_index :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "rec_by_index = (\<lambda> n1 n2. c_pair 6 (c_pair n1 n2))"

lemma comp_by_index_is_pr: "comp_by_index \<in> PrimRec2"
  unfolding comp_by_index_def
  using const_is_pr_2 [of 4] by prec

lemma comp_by_index_inj: "comp_by_index x1 y1 = comp_by_index x2 y2 \<Longrightarrow> x1=x2 \<and> y1=y2"
proof -
  assume "comp_by_index x1 y1 = comp_by_index x2 y2"
  hence "c_pair 4 (c_pair x1 y1) = c_pair 4 (c_pair x2 y2)" by (unfold comp_by_index_def)
  hence "c_pair x1 y1 = c_pair x2 y2" by (rule c_pair_inj2)
  thus ?thesis by (rule c_pair_inj)
qed

lemma comp_by_index_inj1: "comp_by_index x1 y1 = comp_by_index x2 y2 \<Longrightarrow> x1 = x2" by (frule comp_by_index_inj, drule conjunct1)

lemma comp_by_index_inj2: "comp_by_index x1 y1 = comp_by_index x2 y2 \<Longrightarrow> y1 = y2" by (frule comp_by_index_inj, drule conjunct2)

lemma comp_by_index_main: "nat_to_pr (comp_by_index n1 n2) = (\<lambda> x. (nat_to_pr n1) ((nat_to_pr n2) x))" by (unfold comp_by_index_def, unfold nat_to_pr_def, simp add: loc_srj_3_1)

lemma pair_by_index_is_pr: "pair_by_index \<in> PrimRec2" by (unfold pair_by_index_def, insert const_is_pr_2 [where ?n="(5::nat)"], prec)

lemma pair_by_index_inj1: "pair_by_index x1 y1 = pair_by_index x2 y2 \<Longrightarrow> x1 = x2" by (frule pair_by_index_inj, drule conjunct1)

lemma pair_by_index_inj2: "pair_by_index x1 y1 = pair_by_index x2 y2 \<Longrightarrow> y1 = y2" by (frule pair_by_index_inj, drule conjunct2)

lemma pair_by_index_main: "nat_to_pr (pair_by_index n1 n2) = c_f_pair (nat_to_pr n1) (nat_to_pr n2)" by (unfold pair_by_index_def, unfold nat_to_pr_def, simp add: loc_srj_4_1)

lemma nat_to_sch_of_pair_by_index [simp]: "nat_to_sch (pair_by_index n1 n2) = Pair_op (nat_to_sch n1) (nat_to_sch n2)"
  by (simp add: pair_by_index_def loc_srj_4_1)

lemma rec_by_index_is_pr: "rec_by_index \<in> PrimRec2" by (unfold rec_by_index_def, insert const_is_pr_2 [where ?n="(6::nat)"], prec)

lemma rec_by_index_inj: "rec_by_index x1 y1 = rec_by_index x2 y2 \<Longrightarrow> x1=x2 \<and> y1=y2"
proof -
  assume "rec_by_index x1 y1 = rec_by_index x2 y2"
  hence "c_pair 6 (c_pair x1 y1) = c_pair 6 (c_pair x2 y2)" by (unfold rec_by_index_def)
  hence "c_pair x1 y1 = c_pair x2 y2" by (rule c_pair_inj2)
  thus ?thesis by (rule c_pair_inj)
qed

lemma rec_by_index_inj1: "rec_by_index x1 y1 = rec_by_index x2 y2 \<Longrightarrow> x1 = x2" by (frule rec_by_index_inj, drule conjunct1)

lemma rec_by_index_inj2: "rec_by_index x1 y1 = rec_by_index x2 y2 \<Longrightarrow> y1 = y2" by (frule rec_by_index_inj, drule conjunct2)

lemma rec_by_index_main: "nat_to_pr (rec_by_index n1 n2) = UnaryRecOp (nat_to_pr n1) (nat_to_pr n2)" by (unfold rec_by_index_def, unfold nat_to_pr_def, simp add: loc_srj_5_1)

subsection \<open>s-1-1 theorem for primitive recursive functions of one variable\<close>

definition
  index_of_const :: "nat \<Rightarrow> nat" where
  "index_of_const = PrimRecOp1 0 (\<lambda> x y. c_pair 4 (c_pair 2 y))"

lemma index_of_const_is_pr: "index_of_const \<in> PrimRec1"
proof -
  have "(\<lambda> x y. c_pair (4::nat) (c_pair (2::nat) y)) \<in> PrimRec2" by (insert const_is_pr_2 [where ?n="(4::nat)"], prec)
  then show ?thesis by (simp add: index_of_const_def pr_rec1)
qed

lemma index_of_const_at_0: "index_of_const 0 = 0" by (simp add: index_of_const_def)

lemma index_of_const_at_suc: "index_of_const (Suc u) = c_pair 4 (c_pair 2 (index_of_const u))" by (unfold index_of_const_def, induct u, auto)

lemma index_of_const_main: "nat_to_pr (index_of_const n) = (\<lambda> x. n)" (is "?P n")
proof (induct n)
  show "?P 0" by (simp add: index_of_const_at_0 nat_to_pr_at_0)
next
  fix n assume "?P n"
  then show "?P (Suc n)" by ((simp add: index_of_const_at_suc nat_to_sch_at_2 nat_to_pr_def loc_srj_3_1))
qed

lemma index_of_const_lm_1: "(nat_to_pr (index_of_const n)) 0 = n" by (simp add: index_of_const_main)

lemma index_of_const_inj: "index_of_const n1 = index_of_const n2 \<Longrightarrow> n1 = n2"
proof -
  assume "index_of_const n1 = index_of_const n2"
  then have "(nat_to_pr (index_of_const n1)) 0  = (nat_to_pr (index_of_const n2)) 0" by simp
  thus ?thesis by (simp add: index_of_const_lm_1)
qed

definition "index_of_zero = sch_to_nat Base_zero"
definition "index_of_suc = sch_to_nat Base_suc"
definition "index_of_c_fst = sch_to_nat Base_fst"
definition "index_of_c_snd = sch_to_nat Base_snd"
definition "index_of_id = pair_by_index index_of_c_fst index_of_c_snd"

lemma index_of_suc_main: "nat_to_pr index_of_suc = Suc"
apply(simp add: index_of_suc_def nat_to_pr_def)
apply(insert loc_srj_0)
apply(simp)
done

lemma index_of_c_fst_main: "nat_to_pr index_of_c_fst = c_fst" by (simp add: index_of_c_fst_def nat_to_pr_def loc_srj_1)

lemma index_of_c_snd_main: "nat_to_pr index_of_c_snd = c_snd" by (simp add: index_of_c_snd_def nat_to_pr_def loc_srj_2)

lemma [simp]: "nat_to_sch index_of_c_snd = Base_snd" by (unfold index_of_c_snd_def, rule nat_to_sch_srj)

lemma index_of_id_main: "nat_to_pr index_of_id = (\<lambda> x. x)" by (simp add: index_of_id_def nat_to_pr_def c_f_pair_def)

definition
  index_of_c_pair_n :: "nat \<Rightarrow> nat" where
  "index_of_c_pair_n = (\<lambda> n. pair_by_index (index_of_const n) index_of_id)"

lemma index_of_c_pair_n_is_pr: "index_of_c_pair_n \<in> PrimRec1"
proof -
  have "(\<lambda> x. index_of_id) \<in> PrimRec1" by (rule const_is_pr)
  with pair_by_index_is_pr index_of_const_is_pr have "(\<lambda> n. pair_by_index (index_of_const n) index_of_id) \<in> PrimRec1" by prec
  then show ?thesis by (fold index_of_c_pair_n_def)
qed

lemma index_of_c_pair_n_main: "nat_to_pr (index_of_c_pair_n n) = (\<lambda> x. c_pair n x)"
proof -
  have "nat_to_pr (index_of_c_pair_n n) = nat_to_pr (pair_by_index (index_of_const n) index_of_id)" by (simp add: index_of_c_pair_n_def)
  also have "\<dots> = c_f_pair (nat_to_pr (index_of_const n)) (nat_to_pr index_of_id)" by (simp add: pair_by_index_main)
  also have "\<dots> = c_f_pair (\<lambda> x. n) (\<lambda> x. x)" by (simp add: index_of_const_main index_of_id_main)
  finally show ?thesis by (simp add: c_f_pair_def)
qed

lemma index_of_c_pair_n_inj: "index_of_c_pair_n x1 = index_of_c_pair_n x2 \<Longrightarrow> x1=x2"
proof -
  assume "index_of_c_pair_n x1 = index_of_c_pair_n x2"
  hence "pair_by_index (index_of_const x1) index_of_id = pair_by_index (index_of_const x2) index_of_id" by (unfold index_of_c_pair_n_def)
  hence "index_of_const x1 = index_of_const x2" by (rule pair_by_index_inj1)
  thus ?thesis by (rule index_of_const_inj)
qed

definition
  s1_1 :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "s1_1 = (\<lambda> n x. comp_by_index n (index_of_c_pair_n x))"

lemma s1_1_is_pr: "s1_1 \<in> PrimRec2" by (unfold s1_1_def, insert comp_by_index_is_pr index_of_c_pair_n_is_pr, prec)

theorem s1_1_th: "(\<lambda> y. (nat_to_pr n) (c_pair x y)) = nat_to_pr (s1_1 n x)"
proof -
  have "nat_to_pr (s1_1 n x) = nat_to_pr (comp_by_index n (index_of_c_pair_n x))" by (simp add: s1_1_def)
  also have "\<dots> = (\<lambda> z. (nat_to_pr n) ((nat_to_pr (index_of_c_pair_n x)) z))" by (simp add: comp_by_index_main)
  also have "\<dots> = (\<lambda> z. (nat_to_pr n) ((\<lambda> u. c_pair x u) z))" by (simp add: index_of_c_pair_n_main)
  finally show ?thesis by simp
qed

lemma s1_1_inj: "s1_1 x1 y1 = s1_1 x2 y2 \<Longrightarrow> x1=x2 \<and> y1=y2"
proof -
  assume "s1_1 x1 y1 = s1_1 x2 y2"
  then have "comp_by_index x1 (index_of_c_pair_n y1) = comp_by_index x2 (index_of_c_pair_n y2)" by (unfold s1_1_def)
  then have S1: "x1=x2 \<and> index_of_c_pair_n y1 = index_of_c_pair_n y2" by (rule comp_by_index_inj)
  then have S2: "x1=x2" ..
  from S1 have "index_of_c_pair_n y1 = index_of_c_pair_n y2" ..
  then have "y1 = y2" by (rule index_of_c_pair_n_inj)
  with S2 show ?thesis ..
qed

lemma s1_1_inj1: "s1_1 x1 y1 = s1_1 x2 y2 \<Longrightarrow> x1=x2" by (frule s1_1_inj, drule conjunct1)

lemma s1_1_inj2: "s1_1 x1 y1 = s1_1 x2 y2 \<Longrightarrow> y1=y2" by (frule s1_1_inj, drule conjunct2)

primrec
  pr_index_enumerator :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "pr_index_enumerator n 0 = n"
| "pr_index_enumerator n (Suc m) = comp_by_index index_of_id (pr_index_enumerator n m)"

theorem pr_index_enumerator_is_pr: "pr_index_enumerator \<in> PrimRec2"
proof -
  define g where "g x = x" for x :: nat
  have g_is_pr: "g \<in> PrimRec1" by (unfold g_def, rule pr_id1_1)
  define h where "h a b c = comp_by_index index_of_id b" for a b c :: nat
  from comp_by_index_is_pr have h_is_pr: "h \<in> PrimRec3" unfolding h_def by prec
  let ?f = "pr_index_enumerator"
  from g_def have f_at_0: "\<forall> x. ?f x 0 = g x" by auto
  from h_def have f_at_Suc: "\<forall> x y. ?f x (Suc y) = h x (?f x y) y" by auto
  from g_is_pr h_is_pr f_at_0 f_at_Suc show ?thesis by (rule pr_rec_last_scheme)
qed

lemma pr_index_enumerator_increase1: "pr_index_enumerator n m < pr_index_enumerator (n+1) m"
proof (induct m)
  show "pr_index_enumerator n 0 < pr_index_enumerator (n + 1) 0" by simp
  next fix na assume A: "pr_index_enumerator n na < pr_index_enumerator (n + 1) na"
  show "pr_index_enumerator n (Suc na) < pr_index_enumerator (n + 1) (Suc na)"
  proof -
    let ?a = "pr_index_enumerator n na"
    let ?b = "pr_index_enumerator (n+1) na"
    have S1: "pr_index_enumerator n (Suc na) = comp_by_index index_of_id ?a" by simp
    have L1: "pr_index_enumerator (n+1) (Suc na) = comp_by_index index_of_id ?b" by simp
    from A have "c_pair index_of_id ?a < c_pair index_of_id ?b" by (rule c_pair_strict_mono2)
    then have "c_pair 4 (c_pair index_of_id ?a) < c_pair 4 (c_pair index_of_id ?b)" by (rule c_pair_strict_mono2)
    then have "comp_by_index index_of_id ?a < c_pair 4 (c_pair index_of_id ?b)" by (simp add: comp_by_index_def)
    then have "comp_by_index index_of_id ?a < comp_by_index index_of_id ?b" by (simp add: comp_by_index_def)
    with S1 L1 show ?thesis by auto
  qed
qed

lemma pr_index_enumerator_increase2: "pr_index_enumerator n m < pr_index_enumerator n (m + 1)"
proof -
  let ?a = "pr_index_enumerator n m"
  have S1: "pr_index_enumerator n (m + 1) = comp_by_index index_of_id ?a" by simp
  have S2: "comp_by_index index_of_id ?a = c_pair 4 (c_pair index_of_id ?a)" by (simp add: comp_by_index_def)
  have S3: "4 + c_pair index_of_id ?a \<le> c_pair 4 (c_pair index_of_id ?a)" by (rule sum_le_c_pair)
  then have S4: "c_pair index_of_id ?a < c_pair 4 (c_pair index_of_id ?a)" by auto
  have S5: "?a \<le> c_pair index_of_id ?a" by (rule arg2_le_c_pair)
  from S4 S5 have S6: "?a < c_pair 4 (c_pair index_of_id ?a)" by auto
  with S1 S2 show ?thesis by auto
qed

lemma f_inc_mono: "(\<forall> (x::nat). (f::nat\<Rightarrow>nat) x < f (x+1)) \<Longrightarrow> \<forall> (x::nat) (y::nat). (x < y \<longrightarrow> f x < f y)"
proof (rule allI, rule allI)
  fix x y assume A: "\<forall> (x::nat). f x < f (x+1)" show " x < y \<longrightarrow> f x < f y"
  proof
    assume A1: "x < y"
    have L1: "\<And> u v. f u < f (u + (v+1))"
    proof -
      fix u v show "f u < f (u + (v+1))"
      proof (induct v)
        from A show "f u < f (u + (0 + 1))" by auto
      next
        fix v n
        assume A2: "f u < f (u + (n + 1))"
        from A have S1: "f (u + (n + 1)) < f (u + (Suc n + 1))" by auto
        from A2 S1 show " f u < f (u + (Suc n + 1))" by (rule less_trans)
      qed
    qed
  let ?v = "(y - x) - 1"
  from A1 have S2: "y = x + (?v + 1)" by auto
  have "f x < f (x + (?v + 1))" by (rule L1)
  with S2 show "f x < f y" by auto
  qed
qed

lemma pr_index_enumerator_mono1: "n1 < n2 \<Longrightarrow> pr_index_enumerator n1 m < pr_index_enumerator n2 m"
proof -
  assume A: "n1 < n2"
  define f where "f x = pr_index_enumerator x m" for x
  have f_inc: "\<forall> x. f x < f (x+1)"
  proof
    fix x show "f x < f (x+1)" by (unfold f_def, rule pr_index_enumerator_increase1)
  qed
  from f_inc have "\<forall> x y. (x < y \<longrightarrow> f x < f y)" by (rule f_inc_mono)
  with A f_def show ?thesis by auto
qed

lemma pr_index_enumerator_mono2: "m1 < m2 \<Longrightarrow> pr_index_enumerator n m1 < pr_index_enumerator n m2"
proof -
  assume A: "m1 < m2"
  define f where "f x = pr_index_enumerator n x" for x
  have f_inc: "\<forall> x. f x < f (x+1)"
  proof
    fix x show "f x < f (x+1)" by (unfold f_def, rule pr_index_enumerator_increase2)
  qed
  from f_inc have "\<forall> x y. (x < y \<longrightarrow> f x < f y)" by (rule f_inc_mono)
  with A f_def show ?thesis by auto
qed

theorem pr_index_enumerator_inj1: "pr_index_enumerator n1 m = pr_index_enumerator n2 m \<Longrightarrow> n1 = n2"
proof -
  assume A: "pr_index_enumerator n1 m = pr_index_enumerator n2 m"
  define f where "f x = pr_index_enumerator x m" for x
  have f_mono: "\<forall> x y. (x < y \<longrightarrow> f x < f y)"
  proof (rule allI, rule allI)
    fix x y show "x < y \<longrightarrow> f x < f y" by (unfold f_def, simp add: pr_index_enumerator_mono1)
  qed
  from f_mono have "\<forall> x y. (f x = f y \<longrightarrow> x = y)" by (rule f_mono_inj)
  with A f_def show ?thesis by auto
qed

theorem pr_index_enumerator_inj2: "pr_index_enumerator n m1 = pr_index_enumerator n m2 \<Longrightarrow> m1 = m2"
proof -
  assume A: "pr_index_enumerator n m1 = pr_index_enumerator n m2"
  define f where "f x = pr_index_enumerator n x" for x
  have f_mono: "\<forall> x y. (x < y \<longrightarrow> f x < f y)"
  proof (rule allI, rule allI)
    fix x y show "x < y \<longrightarrow> f x < f y" by (unfold f_def, simp add: pr_index_enumerator_mono2)
  qed
  from f_mono have "\<forall> x y. (f x = f y \<longrightarrow> x = y)" by (rule f_mono_inj)
  with A f_def show ?thesis by auto
qed

theorem pr_index_enumerator_main: "nat_to_pr n = nat_to_pr (pr_index_enumerator n m)"
proof (induct m)
  show "nat_to_pr n = nat_to_pr (pr_index_enumerator n 0)" by simp
next
  fix na assume A: "nat_to_pr n = nat_to_pr (pr_index_enumerator n na)"
  show "nat_to_pr n = nat_to_pr (pr_index_enumerator n (Suc na))"
  proof -
    let ?a = "pr_index_enumerator n na"
    have S1: "pr_index_enumerator n (Suc na) = comp_by_index index_of_id ?a" by simp
    have "nat_to_pr (comp_by_index index_of_id ?a) = (\<lambda> x. (nat_to_pr index_of_id) (nat_to_pr ?a x))" by (rule comp_by_index_main)
    with index_of_id_main have "nat_to_pr (comp_by_index index_of_id ?a) = nat_to_pr ?a" by simp
    with A S1 show ?thesis by simp
  qed
qed

end


(*  Title:      HOL/Cardinals/Wellorder_Extension.thy
    Author:     Christian Sternagel, JAIST
*)

section \<open>Extending Well-founded Relations to Wellorders\<close>

theory Wellorder_Extension
imports Main Order_Union
begin

subsection \<open>Extending Well-founded Relations to Wellorders\<close>

text \<open>A \emph{downset} (also lower set, decreasing set, initial segment, or
downward closed set) is closed w.r.t.\ smaller elements.\<close>
definition downset_on where
  "downset_on A r = (\<forall>x y. (x, y) \<in> r \<and> y \<in> A \<longrightarrow> x \<in> A)"

(*
text {*Connection to order filters of the @{theory Cardinals} theory.*}
lemma (in wo_rel) ofilter_downset_on_conv:
  "ofilter A \<longleftrightarrow> downset_on A r \<and> A \<subseteq> Field r"
  by (auto simp: downset_on_def ofilter_def under_def)
*)

lemma downset_onI:
  "(\<And>x y. (x, y) \<in> r \<Longrightarrow> y \<in> A \<Longrightarrow> x \<in> A) \<Longrightarrow> downset_on A r"
  by (auto simp: downset_on_def)

lemma downset_onD:
  "downset_on A r \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> y \<in> A \<Longrightarrow> x \<in> A"
  unfolding downset_on_def by blast

text \<open>Extensions of relations w.r.t.\ a given set.\<close>
definition extension_on where
  "extension_on A r s = (\<forall>x\<in>A. \<forall>y\<in>A. (x, y) \<in> s \<longrightarrow> (x, y) \<in> r)"

lemma extension_onI:
  "(\<And>x y. \<lbrakk>x \<in> A; y \<in> A; (x, y) \<in> s\<rbrakk> \<Longrightarrow> (x, y) \<in> r) \<Longrightarrow> extension_on A r s"
  by (auto simp: extension_on_def)

lemma extension_onD:
  "extension_on A r s \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> (x, y) \<in> s \<Longrightarrow> (x, y) \<in> r"
  by (auto simp: extension_on_def)

lemma downset_on_Union:
  assumes "\<And>r. r \<in> R \<Longrightarrow> downset_on (Field r) p"
  shows "downset_on (Field (\<Union>R)) p"
  using assms by (auto intro: downset_onI dest: downset_onD)

lemma chain_subset_extension_on_Union:
  assumes "chain\<^sub>\<subseteq> R" and "\<And>r. r \<in> R \<Longrightarrow> extension_on (Field r) r p"
  shows "extension_on (Field (\<Union>R)) (\<Union>R) p"
  using assms
  by (simp add: chain_subset_def extension_on_def)
     (metis (no_types) mono_Field subsetD)

lemma downset_on_empty [simp]: "downset_on {} p"
  by (auto simp: downset_on_def)

lemma extension_on_empty [simp]: "extension_on {} p q"
  by (auto simp: extension_on_def)

text \<open>Every well-founded relation can be extended to a wellorder.\<close>
theorem well_order_extension:
  assumes "wf p"
  shows "\<exists>w. p \<subseteq> w \<and> Well_order w"
proof -
  let ?K = "{r. Well_order r \<and> downset_on (Field r) p \<and> extension_on (Field r) r p}"
  define I where "I = init_seg_of \<inter> ?K \<times> ?K"
  have I_init: "I \<subseteq> init_seg_of" by (simp add: I_def)
  then have subch: "\<And>R. R \<in> Chains I \<Longrightarrow> chain\<^sub>\<subseteq> R"
    by (auto simp: init_seg_of_def chain_subset_def Chains_def)
  have Chains_wo: "\<And>R r. R \<in> Chains I \<Longrightarrow> r \<in> R \<Longrightarrow>
      Well_order r \<and> downset_on (Field r) p \<and> extension_on (Field r) r p"
    by (simp add: Chains_def I_def) blast
  have FI: "Field I = ?K" by (auto simp: I_def init_seg_of_def Field_def)
  then have 0: "Partial_order I"
    by (auto simp: partial_order_on_def preorder_on_def antisym_def antisym_init_seg_of refl_on_def
      trans_def I_def elim: trans_init_seg_of)
  have "\<Union>R \<in> ?K \<and> (\<forall>r\<in>R. (r,\<Union>R) \<in> I)" if "R \<in> Chains I" for R
  proof -
    from that have Ris: "R \<in> Chains init_seg_of" using mono_Chains [OF I_init] by blast
    have subch: "chain\<^sub>\<subseteq> R" using \<open>R \<in> Chains I\<close> I_init
      by (auto simp: init_seg_of_def chain_subset_def Chains_def)
    have "\<forall>r\<in>R. Refl r" and "\<forall>r\<in>R. trans r" and "\<forall>r\<in>R. antisym r" and
      "\<forall>r\<in>R. Total r" and "\<forall>r\<in>R. wf (r - Id)" and
      "\<And>r. r \<in> R \<Longrightarrow> downset_on (Field r) p" and
      "\<And>r. r \<in> R \<Longrightarrow> extension_on (Field r) r p"
      using Chains_wo [OF \<open>R \<in> Chains I\<close>] by (simp_all add: order_on_defs)
    have "Refl (\<Union>R)" using \<open>\<forall>r\<in>R. Refl r\<close>  unfolding refl_on_def by fastforce
    moreover have "trans (\<Union>R)"
      by (rule chain_subset_trans_Union [OF subch \<open>\<forall>r\<in>R. trans r\<close>])
    moreover have "antisym (\<Union>R)"
      by (rule chain_subset_antisym_Union [OF subch \<open>\<forall>r\<in>R. antisym r\<close>])
    moreover have "Total (\<Union>R)"
      by (rule chain_subset_Total_Union [OF subch \<open>\<forall>r\<in>R. Total r\<close>])
    moreover have "wf ((\<Union>R) - Id)"
    proof -
      have "(\<Union>R) - Id = \<Union>{r - Id | r. r \<in> R}" by blast
      with \<open>\<forall>r\<in>R. wf (r - Id)\<close> wf_Union_wf_init_segs [OF Chains_inits_DiffI [OF Ris]]
      show ?thesis by fastforce
    qed
    ultimately have "Well_order (\<Union>R)" by (simp add: order_on_defs)
    moreover have "\<forall>r\<in>R. r initial_segment_of \<Union>R" using Ris
      by (simp add: Chains_init_seg_of_Union)
    moreover have "downset_on (Field (\<Union>R)) p"
      by (rule downset_on_Union [OF \<open>\<And>r. r \<in> R \<Longrightarrow> downset_on (Field r) p\<close>])
    moreover have "extension_on (Field (\<Union>R)) (\<Union>R) p"
      by (rule chain_subset_extension_on_Union [OF subch \<open>\<And>r. r \<in> R \<Longrightarrow> extension_on (Field r) r p\<close>])
    ultimately show ?thesis
      using mono_Chains [OF I_init] and \<open>R \<in> Chains I\<close>
      by (simp (no_asm) add: I_def del: Field_Union) (metis Chains_wo)
  qed
  then have 1: "\<exists>u\<in>Field I. \<forall>r\<in>R. (r, u) \<in> I" if "R\<in>Chains I" for R
    using that by (subst FI) blast
  txt \<open>Zorn's Lemma yields a maximal wellorder m.\<close>
  from Zorns_po_lemma [OF 0 1] obtain m :: "('a \<times> 'a) set"
    where "Well_order m" and "downset_on (Field m) p" and "extension_on (Field m) m p" and
    max: "\<forall>r. Well_order r \<and> downset_on (Field r) p \<and> extension_on (Field r) r p \<and>
      (m, r) \<in> I \<longrightarrow> r = m"
    by (auto simp: FI)
  have "Field p \<subseteq> Field m"
  proof (rule ccontr)
    let ?Q = "Field p - Field m"
    assume "\<not> (Field p \<subseteq> Field m)"
    with assms [unfolded wf_eq_minimal, THEN spec, of ?Q]
      obtain x where "x \<in> Field p" and "x \<notin> Field m" and
      min: "\<forall>y. (y, x) \<in> p \<longrightarrow> y \<notin> ?Q" by blast
    txt \<open>Add \<^term>\<open>x\<close> as topmost element to \<^term>\<open>m\<close>.\<close>
    let ?s = "{(y, x) | y. y \<in> Field m}"
    let ?m = "insert (x, x) m \<union> ?s"
    have Fm: "Field ?m = insert x (Field m)" by (auto simp: Field_def)
    have "Refl m" and "trans m" and "antisym m" and "Total m" and "wf (m - Id)"
      using \<open>Well_order m\<close> by (simp_all add: order_on_defs)
    txt \<open>We show that the extension is a wellorder.\<close>
    have "Refl ?m" using \<open>Refl m\<close> Fm by (auto simp: refl_on_def)
    moreover have "trans ?m" using \<open>trans m\<close> \<open>x \<notin> Field m\<close>
      unfolding trans_def Field_def Domain_unfold Domain_converse [symmetric] by blast
    moreover have "antisym ?m" using \<open>antisym m\<close> \<open>x \<notin> Field m\<close>
      unfolding antisym_def Field_def Domain_unfold Domain_converse [symmetric] by blast
    moreover have "Total ?m" using \<open>Total m\<close> Fm by (auto simp: Relation.total_on_def)
    moreover have "wf (?m - Id)"
    proof -
      have "wf ?s" using \<open>x \<notin> Field m\<close>
        by (simp add: wf_eq_minimal Field_def Domain_unfold Domain_converse [symmetric]) metis
      thus ?thesis using \<open>wf (m - Id)\<close> \<open>x \<notin> Field m\<close>
        wf_subset [OF \<open>wf ?s\<close> Diff_subset]
        by (fastforce intro!: wf_Un simp add: Un_Diff Field_def)
    qed
    ultimately have "Well_order ?m" by (simp add: order_on_defs)
    moreover have "extension_on (Field ?m) ?m p"
      using \<open>extension_on (Field m) m p\<close> \<open>downset_on (Field m) p\<close>
      by (subst Fm) (auto simp: extension_on_def dest: downset_onD)
    moreover have "downset_on (Field ?m) p"
      apply (subst Fm)
      using \<open>downset_on (Field m) p\<close> and min
      unfolding downset_on_def Field_def by blast
    moreover have "(m, ?m) \<in> I"
      using \<open>Well_order m\<close> and \<open>Well_order ?m\<close> and
      \<open>downset_on (Field m) p\<close> and \<open>downset_on (Field ?m) p\<close> and
      \<open>extension_on (Field m) m p\<close> and \<open>extension_on (Field ?m) ?m p\<close> and
      \<open>Refl m\<close> and \<open>x \<notin> Field m\<close>
      by (auto simp: I_def init_seg_of_def refl_on_def)
    ultimately
    \<comment> \<open>This contradicts maximality of m:\<close>
    show False using max and \<open>x \<notin> Field m\<close> unfolding Field_def by blast
  qed
  have "p \<subseteq> m"
    using \<open>Field p \<subseteq> Field m\<close> and \<open>extension_on (Field m) m p\<close>
    unfolding Field_def extension_on_def by auto fast
  with \<open>Well_order m\<close> show ?thesis by blast
qed

text \<open>Every well-founded relation can be extended to a total wellorder.\<close>
corollary total_well_order_extension:
  assumes "wf p"
  shows "\<exists>w. p \<subseteq> w \<and> Well_order w \<and> Field w = UNIV"
proof -
  from well_order_extension [OF assms] obtain w
    where "p \<subseteq> w" and wo: "Well_order w" by blast
  let ?A = "UNIV - Field w"
  from well_order_on [of ?A] obtain w' where wo': "well_order_on ?A w'" ..
  have [simp]: "Field w' = ?A" using well_order_on_Well_order [OF wo'] by simp
  have *: "Field w \<inter> Field w' = {}" by simp
  let ?w = "w \<union>o w'"
  have "p \<subseteq> ?w" using \<open>p \<subseteq> w\<close> by (auto simp: Osum_def)
  moreover have "Well_order ?w" using Osum_Well_order [OF * wo] and wo' by simp
  moreover have "Field ?w = UNIV" by (simp add: Field_Osum)
  ultimately show ?thesis by blast
qed

corollary well_order_on_extension:
  assumes "wf p" and "Field p \<subseteq> A"
  shows "\<exists>w. p \<subseteq> w \<and> well_order_on A w"
proof -
  from total_well_order_extension [OF \<open>wf p\<close>] obtain r
    where "p \<subseteq> r" and wo: "Well_order r" and univ: "Field r = UNIV" by blast
  let ?r = "{(x, y). x \<in> A \<and> y \<in> A \<and> (x, y) \<in> r}"
  from \<open>p \<subseteq> r\<close> have "p \<subseteq> ?r" using \<open>Field p \<subseteq> A\<close> by (auto simp: Field_def)
  have "Refl r" "trans r" "antisym r" "Total r" "wf (r - Id)"
    using \<open>Well_order r\<close> by (simp_all add: order_on_defs)
  have "refl_on A ?r" using \<open>Refl r\<close> by (auto simp: refl_on_def univ)
  moreover have "trans ?r" using \<open>trans r\<close>
    unfolding trans_def by blast
  moreover have "antisym ?r" using \<open>antisym r\<close>
    unfolding antisym_def by blast
  moreover have "total_on A ?r" using \<open>Total r\<close> by (simp add: total_on_def univ)
  moreover have "wf (?r - Id)" by (rule wf_subset [OF \<open>wf(r - Id)\<close>]) blast
  ultimately have "well_order_on A ?r" by (simp add: order_on_defs)
  with \<open>p \<subseteq> ?r\<close> show ?thesis by blast
qed

end


theory Collatz_Conjecture
  imports "ITree_VCG.ITree_VCG"
begin

zstore state =
  n :: nat
  hist :: "nat list"

procedure collatz "N :: nat" over state =
  "n := N ;
   hist := [n] ;
   while n \<noteq> 1 inv True do
     if even n then n := n div 2 else n := 3*n + 1 fi ;
     hist := hist @ [n]
   od"

execute "collatz 2"
execute "collatz 3"
execute "collatz 4"
execute "collatz 5"
execute "collatz 6"
execute "collatz 7"
execute "collatz 27"

lemma "\<^bold>{True\<^bold>} collatz N \<^bold>{n = 1\<^bold>}"
  unfolding collatz_def
  by hoare

end


subsection \<open> Instances for Partial Monoids \<close>

theory Partial_Monoids_Instances
  imports Partial_Monoids "Z_Toolkit.Z_Toolkit"
begin

subsection \<open> Partial Functions \<close>

instantiation pfun :: (type, type) pas
begin
  definition compat_pfun :: "('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun \<Rightarrow> bool" where
  "f ## g = (pdom(f) \<inter> pdom(g) = {})"
instance proof
  fix x y z :: "('a, 'b) pfun"
  assume "x ## y"
  thus "y ## x"
    by (auto simp add: compat_pfun_def)
  assume a: "x ## y" "x + y ## z"
  thus "x ## y + z"
    by (auto simp add: compat_pfun_def)
  from a show "y ## z"
    by (auto simp add: compat_pfun_def)
  from a show "x + y + z = x + (y + z)"
    by (simp add: add.assoc)
next
  fix x y :: "('a, 'b) pfun"
  assume "x ## y"
  thus "x + y = y + x"
    by (meson compat_pfun_def pfun_plus_commute)
qed
end

instance pfun :: (type, type) pam
proof
  fix x :: "('a, 'b) pfun"
  show "{}\<^sub>p ## x"
    by (simp add: compat_pfun_def)
  show "{}\<^sub>p + x = x"
    by (simp)
  show "x + {}\<^sub>p = x"
    by (simp)
qed

instance pfun :: (type, type) pam_cancel_pos
proof
  fix x y z :: "('a, 'b) pfun"
  assume "z ## x" "z ## y" "z + x = z + y"
  thus "x = y"
    by (auto simp add: compat_pfun_def, metis Int_commute pfun_minus_plus pfun_plus_commute)
next
  fix x y :: "('a, 'b) pfun"
  show "x + y = {}\<^sub>p \<Longrightarrow> x = {}\<^sub>p"
    using pfun_plus_pos by blast
qed

lemma pfun_compat_minus:
  fixes x y :: "('a, 'b) pfun"
  assumes "y \<subseteq>\<^sub>p x"
  shows "y ## x - y"
  using assms by (simp add: compat_pfun_def)

instance pfun :: (type, type) sep_alg
proof
  show 1: "\<And> x y :: ('a, 'b) pfun. (x \<subseteq>\<^sub>p y) = (x \<preceq>\<^sub>G y)"
    by (simp add: green_preorder_def compat_pfun_def)
       (metis compat_pfun_def pfun_compat_minus pfun_le_plus pfun_plus_commute pfun_plus_minus)
  show "\<And>x y :: ('a, 'b) pfun. (x \<subset>\<^sub>p y) = (x \<prec>\<^sub>G y)"
    by (simp add: "1" green_strict_def less_le_not_le)
  show "\<And>x y :: ('a, 'b) pfun. y \<subseteq>\<^sub>p x \<Longrightarrow> x - y = x -\<^sub>G y"
    apply (rule sym)
    apply (auto simp add: green_subtract_def 1[THEN sym])
     apply (rule the_equality)
      apply (auto simp add: pfun_compat_minus)
    using pfun_compat_minus pfun_plus_minus plus_pcomm apply fastforce
    apply (metis Int_commute compat_pfun_def pfun_minus_plus plus_pcomm)
    done
qed

instance pfun :: (type, type) sep_alg_cancel_pos ..

subsection \<open> Finite Functions \<close>

instantiation ffun :: (type, type) pas
begin
  definition compat_ffun :: "('a, 'b) ffun \<Rightarrow> ('a, 'b) ffun \<Rightarrow> bool" where
  "f ## g = (fdom(f) \<inter> fdom(g) = {})"

instance proof
  fix x y z :: "('a, 'b) ffun"
  assume "x ## y"
  thus "y ## x"
    by (simp add: compat_ffun_def inf_commute)
  assume a:"x ## y" "x + y ## z"
  thus "x ## y + z"
    by (metis (mono_tags, lifting) Partial_Monoids_Instances.compat_ffun_def compat_pfun_def compat_property fdom.rep_eq fdom_plus pdom_plus)
  from a show "y ## z"
    by (metis Partial_Monoids_Instances.compat_ffun_def compat_pfun_def compat_property fdom.rep_eq plus_ffun.rep_eq)
  from a show "x + y + z = x + (y + z)"
    by (simp add: add.assoc)
next
  fix x y :: "('a, 'b) ffun"
  assume "x ## y"
  thus "x + y = y + x"
    by (meson compat_ffun_def ffun_plus_commute)
qed
end

instance ffun :: (type, type) pam
proof
  fix x :: "('a, 'b) ffun"
  show "{}\<^sub>f ## x"
    by (simp add: compat_ffun_def)
  show "{}\<^sub>f + x = x"
    by (simp)
  show "x + {}\<^sub>f = x"
    by (simp)
qed

instance ffun :: (type, type) pam_cancel_pos
proof
  fix x y z :: "('a, 'b) ffun"
  assume "z ## x" "z ## y" "z + x = z + y"
  thus "x = y"
    by (metis compat_comm compat_ffun_def ffun_minus_plus plus_pcomm)
next
  fix x y :: "('a, 'b) ffun"
  show "x + y = {}\<^sub>f \<Longrightarrow> x = {}\<^sub>f"
    using ffun_plus_pos by auto
qed

lemma ffun_compat_minus:
  fixes x y :: "('a, 'b) ffun"
  assumes "y \<subseteq>\<^sub>f x"
  shows "y ## x - y"
  by (metis assms compat_ffun_def compat_pfun_def fdom.rep_eq less_eq_ffun.rep_eq minus_ffun.rep_eq pfun_compat_minus)

instance ffun :: (type, type) sep_alg
proof
  show 1: "\<And> x y :: ('a, 'b) ffun. (x \<subseteq>\<^sub>f y) = (x \<preceq>\<^sub>G y)"
    using compat_ffun_def ffun_compat_minus ffun_le_plus ffun_plus_minus green_preorder_def plus_pcomm by fastforce
  show "\<And>x y :: ('a, 'b) ffun. (x \<subset>\<^sub>f y) = (x \<prec>\<^sub>G y)"
    by (simp add: "1" green_strict_def less_le_not_le)
  show "\<And>x y :: ('a, 'b) ffun. y \<subseteq>\<^sub>f x \<Longrightarrow> x - y = x -\<^sub>G y"
    apply (rule sym)
    apply (auto simp add: green_subtract_def 1[THEN sym])
     apply (rule the_equality)
      apply (auto simp add: ffun_compat_minus)
    using ffun_compat_minus ffun_plus_minus plus_pcomm apply fastforce
    apply (metis compat_comm compat_ffun_def ffun_minus_plus plus_pcomm)
    done
qed

instance ffun :: (type, type) sep_alg_cancel_pos ..

end


theory libs_nat_functions
  imports Main
begin

(*----looking up functions-------------------------------------------------------*)
fun lookup_1 :: "nat \<Rightarrow> (nat * nat list) list \<Rightarrow> nat list" where
"lookup_1 k [] = []" |
"lookup_1 k (x#xs) = (if fst x = k then (snd x) else lookup_1 k xs)"

fun lookup_2 :: "nat \<Rightarrow> (nat * nat list) list list \<Rightarrow> nat list" where
"lookup_2 k [] = []" |
"lookup_2 k (x#xs) = (lookup_1 k x) @ (lookup_2 k xs)"

fun lookup_3 :: "nat \<Rightarrow> (nat * nat list) list list list \<Rightarrow> nat list" where
"lookup_3 k [] = []" |
"lookup_3 k (x#xs) = (lookup_2 k x) @ (lookup_3 k xs)"

(*----making betaSet functions-------------------------------------------------------*)
(*----make pair: (Type, Instance)------------------------*)
fun mk_pair :: "nat \<Rightarrow> nat list \<Rightarrow> (nat * nat) list" where
"mk_pair k [] = []" |
"mk_pair k (x#xs) = [(k, x)] @ mk_pair k xs"

fun mk_pair_1 :: "(nat * nat list) \<Rightarrow> (nat * nat) list" where
"mk_pair_1 k = mk_pair (fst k) (snd k)"

fun mk_pair_2 :: "(nat * nat list) list \<Rightarrow> (nat * nat) list list" where
"mk_pair_2 [] = []" |
"mk_pair_2 (x#xs) = [mk_pair_1 x] @ mk_pair_2 xs"

fun mk_pair_3 :: "(nat * nat list) list list \<Rightarrow> (nat * nat) list list list" where
"mk_pair_3 [] = []" |
"mk_pair_3 (x#xs) = [product_lists (mk_pair_2 x)] @ mk_pair_3 xs"

fun mk_pair_4 :: "(nat * nat list) list list list \<Rightarrow> (nat * nat) list list list" where
"mk_pair_4 [] = []" |
"mk_pair_4 (x#xs) = product_lists (mk_pair_3 x) @ mk_pair_4 xs"

fun mk_pair_3_no_product :: "(nat * nat list) list list \<Rightarrow> (nat * nat) list list list" where
"mk_pair_3_no_product [] = []" |
"mk_pair_3_no_product (x#xs) = [(mk_pair_2 x)] @ mk_pair_3_no_product xs"

fun mk_pair_4_no_product :: "(nat * nat list) list list list \<Rightarrow> (nat * nat) list list list" where
"mk_pair_4_no_product [] = []" |
"mk_pair_4_no_product (x#xs) = (mk_pair_3_no_product x) @ mk_pair_4_no_product xs"

fun mk_Trigger_list :: "(nat * nat) list list list \<Rightarrow> (nat * nat) list list list" where
"mk_Trigger_list [] = []" |
"mk_Trigger_list (x#xs) = [(product_lists  x)] @ mk_Trigger_list xs"
(*----
get all pairs (Type, Instance) of a  trigger list or a synchron list
----*)
fun all_pairs :: "(nat * nat list) list list list \<Rightarrow> (nat * nat) list" where
"all_pairs x = concat (concat (mk_pair_4_no_product x))"

(*----
the remaining pair (Type, Instance) of a  trigger list or a synchron list from the current connector
----*)
fun remaining_pairs :: "(nat \<times> nat) list \<Rightarrow> (nat \<times> nat) list \<Rightarrow> (nat \<times> nat) set" where
"remaining_pairs x y = set (x) - set (y)"

(*----------------------------
merge_list: After producting 2 lists, we need to convert list of pairs to list of lists -----------------------------*)
fun merge_list :: "('a list \<times> 'a list) list \<Rightarrow> 'a list list list" where
"merge_list []= []" |
"merge_list (x#xs) = [[(fst x)]@[(snd x)]] @ (merge_list xs)"

fun merge_list_1 :: "('a list list \<times> 'a list) list \<Rightarrow> 'a list list list" where
"merge_list_1 []= []" |
"merge_list_1 (x#xs) = [(fst x)@[(snd x)]] @ (merge_list_1 xs)"

(*----------------------------
make_betaSet_3: make all the combination between elements in the exported_list of all the trigger ()
-----------------------------*)
fun make_betaSet_3 :: "(nat * nat list) list list list \<Rightarrow> (nat * nat list) list list list" where
"make_betaSet_3 [] = []" |
"make_betaSet_3 (x#[]) =  [x]" |
"make_betaSet_3 (x#y#[]) = merge_list (List.product y x)" |
"make_betaSet_3 (x#y#xs#[]) = merge_list_1 (List.product (merge_list (List.product xs y)) (x))"|
"make_betaSet_3 (x#y#xs#ys) = merge_list_1 (List.product (make_betaSet_3 (y#xs#ys)) (x))"

fun mk_jvb :: "'a list \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'b) list" where
"mk_jvb [] y = []"|
"mk_jvb (x#xs) y = [(Pair x) y] @ mk_jvb xs y"

(*------------------------------------------------------------------------------------------*)
(*test List of all the trigger C = {C_1, C_2, ..., C_n}*)
definition test_triggers_1 :: "(nat * nat list) list list list" where
"test_triggers_1 = [[[(11,[1,2])], [(12,[1,2])]],
[[(2,[1])]],
[[(31,[1])], [(321,[1]),(322,[1,2])]],
[[(4,[1])]]
]"
definition test_triggers :: "(nat * nat list) list list list" where
"test_triggers = [
[[(11,[1,2]), (12,[1])], [(2,[1,2,3])]]
]"

definition test_triggers_null :: "(nat * nat list) list list list" where
"test_triggers_null = [[[]]]"

definition test_synchron_1 :: "(nat * nat list) list list list" where
"test_synchron_1 = [ [[(4, [1,2])]],
[[(51,[1]),(52,[1,2])]]
]"

definition test_synchron :: "(nat * nat list) list list list" where
"test_synchron = [
[[(4, [1,2])]],
[[(51,[1,2]),(52,[1,2, 3])]]
]"

definition Connector :: "((nat \<times> nat) list list \<times> (nat \<times> nat) list list list) list" where
"Connector = mk_jvb (mk_pair_4_no_product test_synchron) (mk_pair_4 (make_betaSet_3 test_triggers))"

(*------------------------------- test -------------------------------*)

(*test List of all the trigger C = {C_1, C_2, ..., C_n}*)
definition test_triggers_11 :: "(nat * nat list) list list list" where
"test_triggers_11 = [[[(11,[1,2])], [(12,[1,2])]],
[[(2,[1])]],
[[(31,[1])], [(321,[1]),(322,[1,2])]],
[[(4,[1])]]
]"

definition test_triggers_2 :: "(nat * nat list) list list list" where
"test_triggers_2 = [[[(11,[1,2])], [(12,[1,2])]],
[[(2,[1])]],
[[(31,[1])], [(321,[1]),(322,[1,2])]],
[[(4,[1])]],
[[(51,[1])], [(52,[6])]]
]"

value "Connector"

lemma for_synchron: "(\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<Longrightarrow>
(\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t). (P ((fst t), l) \<longleftrightarrow> (P ((fst t), l) \<and> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1)))))"
  by blast

lemma for_trigger: "(\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1))))
\<Longrightarrow>
(\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k). (Q ((fst k), h) \<longleftrightarrow> (Q ((fst k), h) \<and> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1)))))"
  by blast

value "(\<forall>connector\<in>set Connector.\<forall>trig_list\<in>set(snd connector).\<forall>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm)) \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q ((fst t_elm), h)) ))"

value "(\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h)) \<longrightarrow> (\<forall>h \<in> set (lookup_3 (fst k) test_triggers) - {h}. \<not>Q ((fst k), h)))"

(*----quick check-------------------------------------------------------*)
definition s_list :: "nat list" where
"s_list = [1::nat,2,3,4,5,6,7,8,9]"

definition t_list :: "nat list" where
"t_list = [1::nat,2,3,4,5,6,7,8,9,10]"

value "\<exists>x \<in> set s_list. ((P x \<longrightarrow> (\<exists>y \<in> set t_list. Q y \<and> (\<forall>x1 \<in> set s_list - {x}. \<not>P x1) \<and> (\<forall>y1 \<in> set t_list - {y}. \<not>Q y1))))"

value "(\<forall>x \<in> set s_list. (P x \<longrightarrow> (\<exists>y \<in> set t_list. Q y)))
\<and> (\<forall>x \<in> set s_list. (P x \<longrightarrow> (\<forall>x1 \<in> set s_list - {x}. \<not>P x1)))
\<and> (\<forall>y \<in> set t_list. (Q y \<longrightarrow> (\<forall>y1 \<in> set t_list - {y}. \<not>Q y1)))"

value "(\<forall>x \<in> set s_list. (P x \<longrightarrow> (\<forall>x1 \<in> set s_list - {x}. \<not>P x1)))"
value "(\<exists>x \<in> set s_list. (\<forall>x1 \<in> set s_list - {x}. \<not>P x1))"

(*
lemma ins: "
(\<exists>x \<in> set s_list. ((P x \<longrightarrow> (\<exists>y \<in> set t_list. Q y \<and> (\<forall>x1 \<in> set s_list - {x}. \<not>P x1) \<and> (\<forall>y1 \<in> set t_list - {y}. \<not>Q y1))))) \<Longrightarrow> (
(\<forall>x \<in> set s_list. (P x \<longrightarrow> (\<exists>y \<in> set t_list. Q y)))
\<and> (\<forall>x \<in> set s_list. (P x \<longrightarrow> (\<forall>x1 \<in> set s_list - {x}. \<not>P x1)))
\<and> (\<forall>y \<in> set t_list. (Q y \<longrightarrow> (\<forall>y1 \<in> set t_list - {y}. \<not>Q y1)))
)
"
  nitpick [card = 3]
  done*)
lemma test_0: "((\<forall>x \<in> set s_list. (P x \<longrightarrow> (\<forall>x1 \<in> set s_list - {x}. \<not>P x1)))) \<Longrightarrow> (
(\<exists>x \<in> set s_list. (\<forall>x1 \<in> set s_list - {x}. \<not>P x1))
)"
  by (metis DiffE list.set_sel(1) neq_Nil_conv s_list_def)

(*
lemma test_11:
  fixes s_list::"nat list"
  assumes "card (set s_list) > 1"
  shows "((\<forall>x \<in> set s_list. (P x \<longrightarrow> (\<forall>x1 \<in> set s_list - {x}. \<not>P x1)))) \<Longrightarrow> (
  (\<exists>x \<in> set s_list. (\<forall>x1 \<in> set s_list - {x}. \<not>P x1))
  )"
  (*sledgehammer*)
  nitpick [card=10]*)

lemma test_1:
  fixes test_synchron::"(nat * nat list) list list list"
  fixes test_triggers::"(nat * nat list) list list list"
  fixes Connector::"((nat \<times> nat) list list \<times> (nat \<times> nat) list list list) list"
  assumes "Connector = mk_jvb (mk_pair_4_no_product test_synchron) (mk_pair_4 (make_betaSet_3 test_triggers))"
  shows "((\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. \<exists>trig_list\<in>set(snd connector).(P ((fst sync),(snd sync)) \<longrightarrow>
      (( \<exists>trig\<in>set trig_list.\<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
       ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1),(snd s_elm_1))
      )
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1)))))
\<Longrightarrow> (
(\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. (P ((fst sync), (snd sync)) \<longrightarrow>
      ((\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
      \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q ((fst t_elm), h)) ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1), (snd s_elm_1))
      \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P ((fst s_elm_1), l)))
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1))))
)"
  nitpick [timeout = 120, card = 3]

end


theory Ifte
imports Nchoice
begin

definition ifprog :: " 'a proc  \<Rightarrow> bool \<Rightarrow> 'a proc \<Rightarrow> 'a proc"  ("(_ \<triangleleft> _  \<triangleright>\<^sub>\<p>/ _)" [52,0,53] 52)
  where "x  \<triangleleft> P  \<triangleright>\<^sub>\<p> y \<equiv> (THE z::'a proc. (P = True \<longrightarrow> z = x) \<and> (P = False \<longrightarrow> z = y))"
(***I hope I can use abbreviation to define this If-then-else!
typedef ('t, '\<alpha>) uexpr = "UNIV :: ('\<alpha> \<Rightarrow> 't) set" ..
......
abbreviation cond ::
  "('a,'\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr \<Rightarrow> ('a,'\<alpha>) uexpr \<Rightarrow> ('a,'\<alpha>) uexpr"
  ("(3_ \<triangleleft> _ \<triangleright>/ _)" [52,0,53] 52)
  where "P \<triangleleft> b \<triangleright> Q \<equiv> trop uIf b P Q"
***)
theorem ifprog_idemp : "x \<triangleleft> a \<triangleright>\<^sub>\<p> x = x"
  by (simp add: ifprog_def)

theorem ifprog_compl : "y \<triangleleft> (\<not> a) \<triangleright>\<^sub>\<p> x = x \<triangleleft> a \<triangleright>\<^sub>\<p> y "
  by (metis (no_types) If_def ifprog_def)

theorem ifprog_true : "x \<triangleleft> True \<triangleright>\<^sub>\<p> y = x"
  by (simp add: ifprog_def)

theorem ifprog_false : "x \<triangleleft> False \<triangleright>\<^sub>\<p> y = y"
   by (simp add: ifprog_def)

definition ifbool :: "bool  \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool"  ("(_ \<triangleleft> _ \<triangleright>\<^sub>\<b>/ _)" [52,0,53] 52)
  where "x \<triangleleft> P \<triangleright>\<^sub>\<b> y \<equiv> (THE z:: bool. (P = True \<longrightarrow> z = x) \<and> (P = False \<longrightarrow> z = y))"

theorem ifbool_idemp : "x \<triangleleft> (a \<triangleleft> b \<triangleright>\<^sub>\<b> a) \<triangleright>\<^sub>\<p> y = x \<triangleleft> a \<triangleright>\<^sub>\<p> y"
  by (simp add: ifbool_def)

theorem ifbool_true : "x \<triangleleft> (a \<triangleleft> True \<triangleright>\<^sub>\<b> c) \<triangleright>\<^sub>\<p> y = x \<triangleleft> a \<triangleright>\<^sub>\<p> y"
  by (simp add: ifbool_def)

theorem ifbool_false : "x \<triangleleft> (a \<triangleleft> False \<triangleright>\<^sub>\<b> c) \<triangleright>\<^sub>\<p> y = x \<triangleleft> c \<triangleright>\<^sub>\<p> y"
  by (simp add: ifbool_def)

definition iflist :: "'a list \<Rightarrow> bool \<Rightarrow> 'a list\<Rightarrow> 'a list"   ("(3_ \<triangleleft> _ \<triangleright>\<^sub>l/ _)" [52,0,53] 52)
  where "x \<triangleleft> P \<triangleright>\<^sub>l y \<equiv> (THE z:: 'a list. (P = True \<longrightarrow> z = x) \<and> (P = False \<longrightarrow> z = y))"

theorem iflist_idemp: "v:=(g \<triangleleft> a \<triangleright>\<^sub>l g) = v:=g"
  by (simp add: iflist_def)

theorem iflist_true: "v:=(g \<triangleleft> True \<triangleright>\<^sub>l h) = v:=g"
  by (simp add: iflist_def)

theorem iflist_false: "v:=(g \<triangleleft> False \<triangleright>\<^sub>l h) = v:=h"
  by (simp add: iflist_def)

theorem iflist_proc: "((v:=g) \<triangleleft> True \<triangleright>\<^sub>\<p> (v:= h)) = v:=(g \<triangleleft> True \<triangleright>\<^sub>l h)"
  by (simp add: iflist_true ifprog_true)

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   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_prop_18
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun rev :: "'a list => 'a list" where
  "rev (nil2) = nil2"
| "rev (cons2 z xs) = x (rev xs) (cons2 z (nil2))"

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

end


theory TickTock_Recursion
  imports TickTock_Core TickTock_IntChoice
begin

fun iterateTT :: "('a ttobs list set \<Rightarrow> 'a ttobs list set) \<Rightarrow> nat \<Rightarrow> 'a ttobs list set" where
  "iterateTT F 0       = {[]}" |
  "iterateTT F (Suc n) = F (iterateTT F n)"

lemma iterateTT_wf:
  assumes "\<And> X. \<forall>t\<in>X. ttWF t \<Longrightarrow> \<forall>t\<in>F X. ttWF t"
  shows "\<forall>t\<in>(iterateTT F n). ttWF t"
  by (induct n, simp_all add: assms)

lemma iterateTT_TT0:
  assumes "\<And> X. TT0 X \<Longrightarrow>TT0 (F X)"
  shows "TT0 (iterateTT F n)"
  by (induct n, simp_all add: assms, unfold TT0_def, simp)

lemma iterateTT_TT1:
  assumes "\<And> X. TT1 X \<Longrightarrow>TT1 (F X)"
  shows "TT1 (iterateTT F n)"
  by (induct n, simp_all add: assms, unfold TT1_def, auto, case_tac \<rho>, auto)

lemma iterateTT_TT2:
  assumes "\<And> X. TT2 X \<Longrightarrow>TT2 (F X)"
  shows "TT2 (iterateTT F n)"
  by (induct n, simp_all add: assms, unfold TT2_def, auto)

lemma iterateTT_TT2w:
  assumes "\<And> X. TT2w X \<Longrightarrow>TT2w (F X)"
  shows "TT2w (iterateTT F n)"
  by (induct n, simp_all add: assms, unfold TT2w_def, auto)

lemma iterateTT_ttWFx:
  assumes "\<And> X. ttWFx X \<Longrightarrow>ttWFx (F X)"
  shows "ttWFx (iterateTT F n)"
  by (induct n, simp_all add: assms, unfold ttWFx_def, auto)

lemma iterateTT_TT3w:
  assumes "\<And> X. TT3w X \<Longrightarrow>TT3w (F X)"
  shows "TT3w (iterateTT F n)"
  by (induct n, simp_all add: assms, unfold TT3w_def, auto)

lemma iterateTT_TT3ww:
  assumes "\<And> X. TT3ww X \<Longrightarrow>TT3ww (F X)"
  shows "TT3ww (iterateTT F n)"
  by (induct n, simp_all add: assms, unfold TT3ww_def, auto)

lemma iterateTT_TT3:
  assumes "\<And> X. TT3 X \<Longrightarrow>TT3 (F X)"
  shows "TT3 (iterateTT F n)"
  by (induct n, simp_all add: assms, unfold TT3_def, auto)

lemma iterateTT_TT:
  assumes "\<And> X. TT X \<Longrightarrow>TT (F X)"
  shows "TT (iterateTT F n)"
  apply (induct n, simp_all add: assms, unfold TT_def, auto simp add: TT_defs)
  using TT1_def tt_prefix_subset.elims(2) by auto

lemma iterateTT_subset:
  assumes TT0_F: "\<And> X. TT0 X \<Longrightarrow> TT0 (F X)"
  assumes TT1_F: "\<And> X. TT1 X \<Longrightarrow> TT1 (F X)"
  assumes monotonic_F: "\<And> X Y. X \<sqsubseteq>\<^sub>C Y \<Longrightarrow> F X \<sqsubseteq>\<^sub>C F Y"
  shows "iterateTT F n \<subseteq> iterateTT F (n+1)"
proof (induct n, auto)
  show "[] \<in> F {[]}"
    by (metis TT0_F TT0_TT1_empty TT0_def TT1_F empty_subsetI insert_subset iterateTT.simps(1) iterateTT_TT1)
next
  fix n x
  assume "iterateTT F n \<subseteq> F (iterateTT F n)"
  then have "F (iterateTT F n) \<subseteq> F (F (iterateTT F n))"
    by (meson RefinesTT_def monotonic_F)
  then show "x \<in> F (iterateTT F n) \<Longrightarrow> x \<in> F (F (iterateTT F n))"
    by blast
qed

lemma iterateTT_subset2:
  assumes TT0_F: "\<And> X. TT0 X \<Longrightarrow> TT0 (F X)"
  assumes TT1_F: "\<And> X. TT1 X \<Longrightarrow> TT1 (F X)"
  assumes monotonic_F: "\<And> X Y. X \<sqsubseteq>\<^sub>C Y \<Longrightarrow> F X \<sqsubseteq>\<^sub>C F Y"
  shows "n > m \<Longrightarrow> iterateTT F m \<subseteq> iterateTT F n"
  by (induct n, auto, smt TT0_F TT1_F add.commute iterateTT.simps(2) iterateTT_subset less_Suc_eq monotonic_F plus_1_eq_Suc set_mp)

lemma iterateTT_subset3:
  assumes TT0_F: "\<And> X. TT0 X \<Longrightarrow> TT0 (F X)"
  assumes TT1_F: "\<And> X. TT1 X \<Longrightarrow> TT1 (F X)"
  assumes monotonic_F: "\<And> X Y. X \<sqsubseteq>\<^sub>C Y \<Longrightarrow> F X \<sqsubseteq>\<^sub>C F Y"
  shows "iterateTT F m \<subseteq> iterateTT F n \<or> iterateTT F n \<subseteq> iterateTT F m"
  by (metis TT0_F TT1_F eq_iff iterateTT_subset2 monotonic_F not_less)

lemma iterateTT_mono:
  assumes mono_F: "\<And>X Y. X \<sqsubseteq>\<^sub>C Y \<Longrightarrow> F X \<sqsubseteq>\<^sub>C F Y"
  shows "(\<And>P. F P \<sqsubseteq>\<^sub>C G P) \<Longrightarrow> iterateTT F n \<sqsubseteq>\<^sub>C iterateTT G n"
  using mono_F unfolding RefinesTT_def by (induct n, auto, blast)

lemma TT0_Union: "X \<noteq> {} \<Longrightarrow> \<forall> x\<in>X. TT0 x \<Longrightarrow> TT0 (\<Union>X)"
  by (simp add: TT0_def)

lemma TT1_Union: "\<forall> x\<in>X. TT1 x \<Longrightarrow> TT1 (\<Union>X)"
  by (meson TT1_def Union_iff)

lemma TT2_Union: "X \<noteq> {} \<Longrightarrow> \<forall> x\<in>X. TT2 x \<Longrightarrow> TT2 (\<Union>X)"
  unfolding TT2_def apply (simp, safe, simp, erule_tac x=Xaa in ballE, erule_tac x=Xaa in ballE, auto)
  by (erule_tac x=\<rho> in allE, erule_tac x=\<sigma> in allE, erule_tac x=Xa in allE, erule_tac x=Y in allE, auto)

lemma TT2w_Union: "X \<noteq> {} \<Longrightarrow> \<forall> x\<in>X. TT2w x \<Longrightarrow> TT2w (\<Union>X)"
  unfolding TT2w_def apply (simp, safe, simp, erule_tac x=Xaa in ballE, erule_tac x=Xaa in ballE, auto)
  by (erule_tac x=\<rho> in allE, erule_tac x=Xa in allE, erule_tac x=Y in allE, auto)

lemma ttWFx_Union: "\<forall> x\<in>X. ttWFx x \<Longrightarrow> ttWFx (\<Union>X)"
  unfolding ttWFx_def by auto

lemma TT3w_Union: "\<forall> x\<in>X. TT3w x \<Longrightarrow> TT3w (\<Union>X)"
  unfolding TT3w_def by auto

lemma TT3ww_Union: "\<forall> x\<in>X. TT3ww x \<Longrightarrow> TT3ww (\<Union>X)"
  unfolding TT3ww_def by auto

definition RecursionTT :: "('a ttobs list set \<Rightarrow> 'a ttobs list set) \<Rightarrow> 'a ttobs list set" ("\<mu>\<^sub>C(_)") where
  "RecursionTT F = \<Union> {P. \<exists> n. P = iterateTT F n}"

lemma RecursionTT_wf:
  assumes "\<And> X. \<forall>t\<in>X. ttWF t \<Longrightarrow> \<forall>t\<in>F X. ttWF t"
  shows "\<forall>t\<in>(RecursionTT F). ttWF t"
  unfolding RecursionTT_def
  by (smt Union_iff assms iterateTT_wf mem_Collect_eq)

lemma RecursionTT_TT0:
  assumes "\<And> X. TT0 X \<Longrightarrow> TT0 (F X)"
  shows "TT0 (RecursionTT F)"
  unfolding RecursionTT_def by (smt Collect_empty_eq TT0_Union assms iterateTT_TT0 mem_Collect_eq)

lemma RecursionTT_TT1:
  assumes "\<And> X. TT1 X \<Longrightarrow> TT1 (F X)"
  shows "TT1 (RecursionTT F)"
  unfolding RecursionTT_def by (smt TT1_Union assms iterateTT_TT1 mem_Collect_eq)

lemma RecursionTT_TT2:
  assumes "\<And> X. TT2 X \<Longrightarrow> TT2 (F X)"
  shows "TT2 (RecursionTT F)"
  unfolding RecursionTT_def by (smt Collect_empty_eq TT2_Union assms iterateTT_TT2 mem_Collect_eq)

lemma RecursionTT_TT2w:
  assumes "\<And> X. TT2w X \<Longrightarrow> TT2w (F X)"
  shows "TT2w (RecursionTT F)"
  unfolding RecursionTT_def by (smt TT2w_Union assms empty_iff iterateTT_TT2w mem_Collect_eq)

lemma RecursionTT_ttWFx:
  assumes "\<And> X. ttWFx X \<Longrightarrow> ttWFx (F X)"
  shows "ttWFx (RecursionTT F)"
  unfolding RecursionTT_def by (smt ttWFx_Union assms iterateTT_ttWFx mem_Collect_eq)

lemma RecursionTT_TT3w:
  assumes "\<And> X. TT3w X \<Longrightarrow> TT3w (F X)"
  shows "TT3w (RecursionTT F)"
  unfolding RecursionTT_def by (smt TT3w_Union assms iterateTT_TT3w mem_Collect_eq)

lemma RecursionTT_TT3ww:
  assumes "\<And> X. TT3ww X \<Longrightarrow> TT3ww (F X)"
  shows "TT3ww (RecursionTT F)"
  unfolding RecursionTT_def by (smt TT3ww_Union assms iterateTT_TT3ww mem_Collect_eq)

lemma RecursionTT_TT:
  assumes "\<And> X. TT X \<Longrightarrow> TT (F X)"
  shows "TT (RecursionTT F)"
  unfolding RecursionTT_def TT_def apply auto
  using TT_def assms iterateTT_TT apply auto
  apply (metis (mono_tags, lifting) CollectI Sup_bot_conv(1) TT0_def empty_not_insert iterateTT.simps(1))
  apply (smt TT1_Union TT_TT1 assms iterateTT_TT mem_Collect_eq)
  apply (smt TT2w_Union TT_TT2w assms empty_iff iterateTT_TT mem_Collect_eq)
  apply (smt ttWFx_Union TT_ttWFx assms iterateTT_TT mem_Collect_eq)
  done

lemma RecursionTT_strengthen:
  assumes monotonic_F: "\<And> X Y. X \<sqsubseteq>\<^sub>C Y \<Longrightarrow> F X \<sqsubseteq>\<^sub>C F Y"
  assumes TT0_F: "\<And> X. TT0 X \<Longrightarrow> TT0 (F X)"
  assumes TT1_F: "\<And> X. TT1 X \<Longrightarrow> TT1 (F X)"
  shows "F (\<mu>\<^sub>C F) \<sqsubseteq>\<^sub>C \<mu>\<^sub>C F"
  unfolding RefinesTT_def RecursionTT_def
proof auto
  fix x n
  show "x \<in> iterateTT F n \<Longrightarrow> x \<in> F (\<Union>{P. \<exists>n. P = iterateTT F n})"
  proof (induct n, auto)
    show "[] \<in> F (\<Union>{P. \<exists>n. P = iterateTT F n})"
      by (metis (full_types) RecursionTT_TT0 RecursionTT_TT1 RecursionTT_def TT0_F TT0_TT1_empty TT1_F)
  next
    fix n
    have "iterateTT F n \<subseteq> \<Union>{P. \<exists>n. P = iterateTT F n}"
      by auto
    then have "F (iterateTT F n) \<subseteq> F (\<Union>{P. \<exists>n. P = iterateTT F n})"
      by (meson RefinesTT_def monotonic_F)
    then show "x \<in> F (iterateTT F n) \<Longrightarrow> x \<in> F (\<Union>{P. \<exists>n. P = iterateTT F n})"
      by auto
  qed
qed

lemma RecursionTT_sfp:
  assumes monotonic_F: "\<And> X Y. X \<sqsubseteq>\<^sub>C Y \<Longrightarrow> F X \<sqsubseteq>\<^sub>C F Y"
  assumes Y_TT0: "TT0 Y" and Y_TT1: "TT1 Y"
  shows "Y \<sqsubseteq>\<^sub>C F(Y) \<Longrightarrow> Y \<sqsubseteq>\<^sub>C (\<mu>\<^sub>C F)"
  unfolding RefinesTT_def RecursionTT_def
proof (auto)
  fix x n
  assume assm: "F Y \<subseteq> Y"
  have "iterateTT F n \<subseteq> Y"
  proof (induct n, auto)
    show "[] \<in> Y"
      by (simp add: TT0_TT1_empty Y_TT0 Y_TT1)
  next
    fix x n
    assume "iterateTT F n \<subseteq> Y"
    then have "F (iterateTT F n) \<subseteq> F Y"
      by (meson RefinesTT_def monotonic_F)
    then have "F (iterateTT F n) \<subseteq> Y"
      using assm by blast
    then show "x \<in> F (iterateTT F n) \<Longrightarrow> x \<in> Y"
      by auto
  qed
  then show "F Y \<subseteq> Y \<Longrightarrow> x \<in> iterateTT F n \<Longrightarrow> x \<in> Y"
    by auto
qed

lemma RecursionTT_unfold:
  assumes TT0_F: "\<And> X. TT0 X \<Longrightarrow> TT0 (F X)"
  assumes TT1_F: "\<And> X. TT1 X \<Longrightarrow> TT1 (F X)"
  assumes dist_F: "\<And>S. S \<noteq> {} \<Longrightarrow> F (\<Union>S) = \<Union>{R. \<exists>Q. Q \<in> S \<and> R = F Q}"
  shows "(\<mu>\<^sub>C F) = F (\<mu>\<^sub>C F)"
proof -
  have "{P. \<exists>n. P = iterateTT F n} \<noteq> {}"
    by blast
  then have "\<Union>{P. \<exists>n. P = F (iterateTT F n)} = F (\<Union>{P. \<exists>n. P = iterateTT F n})"
    using dist_F[where S="{P. \<exists>n. P = iterateTT F n}"] by auto
  also have "\<Union>{P. \<exists>n. P = F (iterateTT F n)} = \<Union>{P. \<exists>n. P = (iterateTT F n)}"
  proof auto
    fix x n
    show "x \<in> F (iterateTT F n) \<Longrightarrow> \<exists>xa. (\<exists>n. xa = iterateTT F n) \<and> x \<in> xa"
      by (rule_tac x="iterateTT F (n+1)" in exI, auto, rule_tac x="n+1" in exI, auto)
  next
    fix x n
    show "x \<in> iterateTT F n \<Longrightarrow> \<exists>xa. (\<exists>n. xa = F (iterateTT F n)) \<and> x \<in> xa"
      apply (induct n, auto, rule_tac x="iterateTT F 1" in exI, auto, rule_tac x="0" in exI, auto)
      by (metis TT0_F TT0_TT1_empty TT0_def TT1_F insert_not_empty iterateTT.simps(1) iterateTT_TT1)
  qed
  then show ?thesis
    unfolding RefinesTT_def RecursionTT_def using calculation by auto
qed

lemma RecursionTT_mono:
  assumes mono_F: "\<And>X Y. X \<sqsubseteq>\<^sub>C Y \<Longrightarrow> F X \<sqsubseteq>\<^sub>C F Y"
  shows "(\<And> P. F P \<sqsubseteq>\<^sub>C G P) \<Longrightarrow> (\<mu>\<^sub>C F) \<sqsubseteq>\<^sub>C (\<mu>\<^sub>C G)"
  using iterateTT_mono unfolding RecursionTT_def RefinesTT_def apply auto
  by (rule_tac x="iterateTT F n" in exI, auto, metis RefinesTT_def iterateTT_mono mono_F subsetCE)

end


(*  Title:      HOL/HOLCF/IOA/meta_theory/LiveIOA.thy
    Author:     Olaf Müller
*)

section {* Live I/O automata -- specified by temproal formulas *}

theory LiveIOA
imports TLS
begin

default_sort type

type_synonym
  ('a, 's) live_ioa = "('a,'s)ioa * ('a,'s)ioa_temp"

definition
  validLIOA :: "('a,'s)live_ioa => ('a,'s)ioa_temp  => bool" where
  "validLIOA AL P = validIOA (fst AL) ((snd AL) .--> P)"

definition
  WF :: "('a,'s)ioa => 'a set => ('a,'s)ioa_temp" where
  "WF A acts = (<> [] <%(s,a,t) . Enabled A acts s> .--> [] <> <xt2 (plift (%a. a : acts))>)"
definition
  SF :: "('a,'s)ioa => 'a set => ('a,'s)ioa_temp" where
  "SF A acts = ([] <> <%(s,a,t) . Enabled A acts s> .--> [] <> <xt2 (plift (%a. a : acts))>)"

definition
  liveexecutions :: "('a,'s)live_ioa => ('a,'s)execution set" where
  "liveexecutions AP = {exec. exec : executions (fst AP) & (exec |== (snd AP))}"
definition
  livetraces :: "('a,'s)live_ioa => 'a trace set" where
  "livetraces AP = {mk_trace (fst AP)$(snd ex) | ex. ex:liveexecutions AP}"
definition
  live_implements :: "('a,'s1)live_ioa => ('a,'s2)live_ioa => bool" where
  "live_implements CL AM = ((inp (fst CL) = inp (fst AM)) &
                            (out (fst CL) = out (fst AM)) &
                            livetraces CL <= livetraces AM)"
definition
  is_live_ref_map :: "('s1 => 's2) => ('a,'s1)live_ioa => ('a,'s2)live_ioa => bool" where
  "is_live_ref_map f CL AM =
           (is_ref_map f (fst CL ) (fst AM) &
            (! exec : executions (fst CL). (exec |== (snd CL)) -->
                                           ((corresp_ex (fst AM) f exec) |== (snd AM))))"

lemma live_implements_trans:
"!!LC. [| live_implements (A,LA) (B,LB); live_implements (B,LB) (C,LC) |]
      ==> live_implements (A,LA) (C,LC)"
apply (unfold live_implements_def)
apply auto
done

subsection "Correctness of live refmap"

lemma live_implements: "[| inp(C)=inp(A); out(C)=out(A);
                   is_live_ref_map f (C,M) (A,L) |]
                ==> live_implements (C,M) (A,L)"
apply (simp add: is_live_ref_map_def live_implements_def livetraces_def liveexecutions_def)
apply auto
apply (rule_tac x = "corresp_ex A f ex" in exI)
apply auto
  (* Traces coincide, Lemma 1 *)
  apply (tactic {* pair_tac @{context} "ex" 1 *})
  apply (erule lemma_1 [THEN spec, THEN mp])
  apply (simp (no_asm) add: externals_def)
  apply (auto)[1]
  apply (simp add: executions_def reachable.reachable_0)

  (* corresp_ex is execution, Lemma 2 *)
  apply (tactic {* pair_tac @{context} "ex" 1 *})
  apply (simp add: executions_def)
  (* start state *)
  apply (rule conjI)
  apply (simp add: is_ref_map_def corresp_ex_def)
  (* is-execution-fragment *)
  apply (erule lemma_2 [THEN spec, THEN mp])
  apply (simp add: reachable.reachable_0)

done

end