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

header {* Primitive recursive functions *}

theory PRecFun imports CPair
begin

text {*
  This theory contains definition of the primitive recursive functions.
*}

subsection {* Basic definitions *}

primrec
  PrimRecOp :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> nat)"
where
  "PrimRecOp g h 0 x  = g x"
| "PrimRecOp g h (Suc y) x = h y (PrimRecOp g h y x) x"

primrec
  PrimRecOp_last :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> nat)"
where
  "PrimRecOp_last g h x 0  = g x"
| "PrimRecOp_last g h x (Suc y)= h x (PrimRecOp_last g h x y) y"

primrec
  PrimRecOp1 :: "nat \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat)"
where
  "PrimRecOp1 a h 0 = a"
| "PrimRecOp1 a h (Suc y) = h y (PrimRecOp1 a h y)"

inductive_set
  PrimRec1 :: "(nat \<Rightarrow> nat) set" and
  PrimRec2 :: "(nat \<Rightarrow> nat \<Rightarrow> nat) set" and
  PrimRec3 :: "(nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat) set"
where
  zero: "(\<lambda> x. 0) \<in> PrimRec1"
  | suc:   "Suc \<in> PrimRec1"
  | id1_1: "(\<lambda> x. x) \<in> PrimRec1"
  | id2_1: "(\<lambda> x y. x) \<in> PrimRec2"
  | id2_2: "(\<lambda> x y. y) \<in> PrimRec2"
  | id3_1: "(\<lambda> x y z. x) \<in> PrimRec3"
  | id3_2: "(\<lambda> x y z. y) \<in> PrimRec3"
  | id3_3: "(\<lambda> x y z. z) \<in> PrimRec3"
  | comp1_1: "\<lbrakk> f \<in> PrimRec1; g \<in> PrimRec1\<rbrakk> \<Longrightarrow> (\<lambda> x. f (g x)) \<in> PrimRec1"
  | comp1_2: "\<lbrakk> f \<in> PrimRec1; g \<in> PrimRec2\<rbrakk> \<Longrightarrow> (\<lambda> x y. f (g x y)) \<in> PrimRec2"
  | comp1_3: "\<lbrakk> f \<in> PrimRec1; g \<in> PrimRec3\<rbrakk> \<Longrightarrow> (\<lambda> x y z. f (g x y z)) \<in> PrimRec3"
  | comp2_1: "\<lbrakk> f \<in> PrimRec2; g \<in> PrimRec1; h \<in> PrimRec1\<rbrakk> \<Longrightarrow> (\<lambda> x. f (g x) (h x)) \<in> PrimRec1"
  | comp3_1: "\<lbrakk> f \<in> PrimRec3; g \<in> PrimRec1; h \<in> PrimRec1; k \<in> PrimRec1\<rbrakk> \<Longrightarrow> (\<lambda> x. f (g x) (h x) (k x)) \<in> PrimRec1"
  | comp2_2: "\<lbrakk> f \<in> PrimRec2; g \<in> PrimRec2; h \<in> PrimRec2\<rbrakk> \<Longrightarrow> (\<lambda> x y. f (g x y) (h x y)) \<in> PrimRec2"
  | comp2_3: "\<lbrakk> f \<in> PrimRec2; g \<in> PrimRec3; h \<in> PrimRec3\<rbrakk> \<Longrightarrow> (\<lambda> x y z. f (g x y z) (h x y z)) \<in> PrimRec3"
  | comp3_2: "\<lbrakk> f \<in> PrimRec3; g \<in> PrimRec2; h \<in> PrimRec2; k \<in> PrimRec2\<rbrakk> \<Longrightarrow> (\<lambda> x y. f (g x y) (h x y) (k x y)) \<in> PrimRec2"
  | comp3_3: "\<lbrakk> f \<in> PrimRec3; g \<in> PrimRec3; h \<in> PrimRec3; k \<in> PrimRec3\<rbrakk> \<Longrightarrow> (\<lambda> x y z. f (g x y z) (h x y z) (k x y z)) \<in> PrimRec3"
  | prim_rec: "\<lbrakk> g \<in> PrimRec1; h \<in> PrimRec3\<rbrakk> \<Longrightarrow> PrimRecOp g h \<in> PrimRec2"

lemmas pr_zero = PrimRec1_PrimRec2_PrimRec3.zero
lemmas pr_suc = PrimRec1_PrimRec2_PrimRec3.suc
lemmas pr_id1_1 = PrimRec1_PrimRec2_PrimRec3.id1_1
lemmas pr_id2_1 = PrimRec1_PrimRec2_PrimRec3.id2_1
lemmas pr_id2_2 = PrimRec1_PrimRec2_PrimRec3.id2_2
lemmas pr_id3_1 = PrimRec1_PrimRec2_PrimRec3.id3_1
lemmas pr_id3_2 = PrimRec1_PrimRec2_PrimRec3.id3_2
lemmas pr_id3_3 = PrimRec1_PrimRec2_PrimRec3.id3_3
lemmas pr_comp1_1 = PrimRec1_PrimRec2_PrimRec3.comp1_1
lemmas pr_comp1_2 = PrimRec1_PrimRec2_PrimRec3.comp1_2
lemmas pr_comp1_3 = PrimRec1_PrimRec2_PrimRec3.comp1_3
lemmas pr_comp2_1 = PrimRec1_PrimRec2_PrimRec3.comp2_1
lemmas pr_comp2_2 = PrimRec1_PrimRec2_PrimRec3.comp2_2
lemmas pr_comp2_3 = PrimRec1_PrimRec2_PrimRec3.comp2_3
lemmas pr_comp3_1 = PrimRec1_PrimRec2_PrimRec3.comp3_1
lemmas pr_comp3_2 = PrimRec1_PrimRec2_PrimRec3.comp3_2
lemmas pr_comp3_3 = PrimRec1_PrimRec2_PrimRec3.comp3_3
lemmas pr_rec = PrimRec1_PrimRec2_PrimRec3.prim_rec

ML_file "Utils.ML"

named_theorems prec

method_setup prec0 = {*
  Attrib.thms >> (fn ths => fn ctxt => Method.METHOD (fn facts =>
    HEADGOAL (prec0_tac ctxt (facts @ Named_Theorems.get ctxt @{named_theorems prec}))))
*} "apply primitive recursive functions"

lemmas [prec] = pr_zero pr_suc pr_id1_1 pr_id2_1 pr_id2_2 pr_id3_1 pr_id3_2 pr_id3_3

lemma pr_swap: "f \<in> PrimRec2 \<Longrightarrow> (\<lambda> x y. f y x) \<in> PrimRec2" by prec0

theorem pr_rec_scheme: "\<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_at_0: "\<forall> x. f 0 x = g x"
  assume f_at_Suc: "\<forall> x y. f (Suc y) x = h y (f y x) x"
  from f_at_0 f_at_Suc have "\<And> x y. f y x  = PrimRecOp g h y x" by (induct_tac y, simp_all)
  then have "f = PrimRecOp g h" by (simp add: ext)
  with g_is_pr h_is_pr show ?thesis by (simp add: pr_rec)
qed

lemma op_plus_is_pr [prec]: "(\<lambda> x y. x + y) \<in> PrimRec2"
proof (rule pr_swap)
 show "(\<lambda> x y. y+x) \<in> PrimRec2"
  proof -
    have S1: "PrimRecOp (\<lambda> x. x) (\<lambda> x y z. Suc y) \<in> PrimRec2"
    proof (rule pr_rec)
      show "(\<lambda> x. x) \<in> PrimRec1" by (rule pr_id1_1)
    next
      show "(\<lambda> x y z. Suc y) \<in> PrimRec3" by prec0
    qed
    have "(\<lambda> x y. y+x) = PrimRecOp (\<lambda> x. x) (\<lambda> x y z. Suc y)" (is "_ = ?f")
    proof -
      have "\<And> x y. (?f y x = y + x)" by (induct_tac y, auto)
      thus ?thesis by (simp add: ext)
    qed
    with S1 show ?thesis by simp
  qed
qed

lemma op_mult_is_pr [prec]: "(\<lambda> x y. x*y) \<in> PrimRec2"
proof (rule pr_swap)
 show "(\<lambda> x y. y*x) \<in> PrimRec2"
  proof -
    have S1: "PrimRecOp (\<lambda> x. 0) (\<lambda> x y z. y+z) \<in> PrimRec2"
    proof (rule pr_rec)
      show "(\<lambda> x. 0) \<in> PrimRec1" by (rule pr_zero)
    next
      show "(\<lambda> x y z. y+z) \<in> PrimRec3" by prec0
    qed
    have "(\<lambda> x y. y*x) = PrimRecOp (\<lambda> x. 0) (\<lambda> x y z. y+z)" (is "_ = ?f")
    proof -
      have "\<And> x y. (?f y x = y * x)" by (induct_tac y, auto)
      thus ?thesis by (simp add: ext)
    qed
    with S1 show ?thesis by simp
  qed
qed

lemma const_is_pr: "(\<lambda> x. (n::nat)) \<in> PrimRec1"
proof (induct n)
  show "(\<lambda> x. 0) \<in> PrimRec1" by (rule pr_zero)
next
  fix n assume "(\<lambda> x. n) \<in> PrimRec1"
  then show "(\<lambda> x. Suc n) \<in> PrimRec1" by prec0
qed

lemma const_is_pr_2: "(\<lambda> x y. (n::nat)) \<in> PrimRec2"
proof (rule pr_comp1_2 [where ?f="%x.(n::nat)" and ?g="%x y. x"])
  show "(\<lambda> x. n) \<in> PrimRec1" by (rule const_is_pr)
next
  show "(\<lambda> x y. x) \<in> PrimRec2" by (rule pr_id2_1)
qed

lemma const_is_pr_3: "(\<lambda> x y z. (n::nat)) \<in> PrimRec3"
proof (rule pr_comp1_3 [where ?f="%x.(n::nat)" and ?g="%x y z. x"])
  show "(\<lambda> x. n) \<in> PrimRec1" by (rule const_is_pr)
next
  show "(\<lambda> x y z. x) \<in> PrimRec3" by (rule pr_id3_1)
qed

theorem pr_rec_last: "\<lbrakk>g \<in> PrimRec1; h \<in> PrimRec3\<rbrakk> \<Longrightarrow> PrimRecOp_last g h \<in> PrimRec2"
proof -
  assume A1: "g \<in> PrimRec1"
  assume A2: "h \<in> PrimRec3"
  let ?h1 = "\<lambda> x y z. h z y x"
  from A2 pr_id3_3 pr_id3_2 pr_id3_1 have h1_is_pr: "?h1 \<in> PrimRec3" by (rule pr_comp3_3)
  let ?f1 = "PrimRecOp g ?h1"
  from A1 h1_is_pr have f1_is_pr: "?f1 \<in> PrimRec2" by (rule pr_rec)
  let ?f = "\<lambda> x y. ?f1 y x"
  from f1_is_pr have f_is_pr: "?f \<in> PrimRec2" by (rule pr_swap)
  have "\<And> x y. ?f x y = PrimRecOp_last g h x y" by (induct_tac y, simp_all)
  then have "?f = PrimRecOp_last g h" by (simp add: ext)
  with f_is_pr show ?thesis by simp
qed

theorem pr_rec1: "h \<in> PrimRec2 \<Longrightarrow> PrimRecOp1 (a::nat) h \<in> PrimRec1"
proof -
  assume A1: "h \<in> PrimRec2"
  let ?g = "(\<lambda> x. a)"
  have g_is_pr: "?g \<in> PrimRec1" by (rule const_is_pr)
  let ?h1 = "(\<lambda> x y z. h x y)"
  from A1 have h1_is_pr: "?h1 \<in> PrimRec3" by prec0
  let ?f1 = "PrimRecOp ?g ?h1"
  from g_is_pr h1_is_pr have f1_is_pr: "?f1 \<in> PrimRec2" by (rule pr_rec)
  let ?f = "(\<lambda> x. ?f1 x 0)"
  from f1_is_pr pr_id1_1 pr_zero have f_is_pr: "?f \<in> PrimRec1" by (rule pr_comp2_1)
  have "\<And> y. ?f y = PrimRecOp1 a h y" by (induct_tac y, auto)
  then have "?f = PrimRecOp1 a h" by (simp add: ext)
  with f_is_pr show ?thesis by (auto)
qed

theorem pr_rec1_scheme: "\<lbrakk> h \<in> PrimRec2; f 0 = a; \<forall> y. f (Suc y) = h y (f y) \<rbrakk> \<Longrightarrow> f \<in> PrimRec1"
proof -
  assume h_is_pr: "h \<in> PrimRec2"
  assume f_at_0: "f 0 = a"
  assume f_at_Suc: "\<forall> y. f (Suc y) = h y (f y)"
  from f_at_0 f_at_Suc have "\<And> y. f y  = PrimRecOp1 a h y" by (induct_tac y, simp_all)
  then have "f = PrimRecOp1 a h" by (simp add: ext)
  with h_is_pr show ?thesis by (simp add: pr_rec1)
qed

lemma pred_is_pr: "(\<lambda> x. x - (1::nat)) \<in> PrimRec1"
proof -
  have S1: "PrimRecOp1 0 (\<lambda> x y. x) \<in> PrimRec1"
  proof (rule pr_rec1)
    show "(\<lambda> x y. x) \<in> PrimRec2" by (rule pr_id2_1)
  qed
  have "(\<lambda> x. x-(1::nat)) = PrimRecOp1 0 (\<lambda> x y. x)" (is "_ = ?f")
  proof -
    have "\<And> x. (?f x = x-(1::nat))" by (induct_tac x, auto)
    thus ?thesis by (simp add: ext)
  qed
  with S1 show ?thesis by simp
qed

lemma op_sub_is_pr [prec]: "(\<lambda> x y. x-y) \<in> PrimRec2"
proof (rule pr_swap)
 show "(\<lambda> x y. y - x) \<in> PrimRec2"
  proof -
    have S1: "PrimRecOp (\<lambda> x. x) (\<lambda> x y z.  y-(1::nat)) \<in> PrimRec2"
    proof (rule pr_rec)
      show "(\<lambda> x. x) \<in> PrimRec1" by (rule pr_id1_1)
    next
      from pred_is_pr pr_id3_2 show "(\<lambda> x y z. y-(1::nat)) \<in> PrimRec3" by (rule pr_comp1_3)
    qed
    have "(\<lambda> x y. y - x) = PrimRecOp (\<lambda> x. x) (\<lambda> x y z.  y-(1::nat))" (is "_ = ?f")
    proof -
      have "\<And> x y. (?f y x = x - y)" by (induct_tac y, auto)
      thus ?thesis by (simp add: ext)
    qed
    with S1 show ?thesis by simp
  qed
qed

lemmas [prec] =
  const_is_pr [of 0] const_is_pr_2 [of 0] const_is_pr_3 [of 0]
  const_is_pr [of 1] const_is_pr_2 [of 1] const_is_pr_3 [of 1]
  const_is_pr [of 2] const_is_pr_2 [of 2] const_is_pr_3 [of 2]

definition
  sgn1 :: "nat \<Rightarrow> nat" where
  "sgn1 x = (case x of 0 \<Rightarrow> 0 | Suc y \<Rightarrow> 1)"

definition
  sgn2 :: "nat \<Rightarrow> nat" where
  "sgn2 x \<equiv> (case x of 0 \<Rightarrow> 1 | Suc y \<Rightarrow> 0)"

definition
  abs_of_diff :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "abs_of_diff = (\<lambda> x y. (x - y) + (y - x))"

lemma sgn1_nz_impl_arg_pos: "sgn1 x \<noteq> 0 \<Longrightarrow> x > 0" by (cases x) auto
lemma sgn1_zero_impl_arg_zero: "sgn1 x = 0 \<Longrightarrow> x = 0" by (cases x) auto
lemma sgn2_nz_impl_arg_zero: "sgn2 x \<noteq> 0 \<Longrightarrow> x = 0" by (cases x) auto
lemma sgn2_zero_impl_arg_pos: "sgn2 x = 0 \<Longrightarrow> x > 0" by (cases x) auto

lemma sgn1_nz_eq_arg_pos: "(sgn1 x \<noteq> 0) = (x > 0)" by (cases x) auto
lemma sgn1_zero_eq_arg_zero: "(sgn1 x = 0) = (x = 0)" by (cases x) auto
lemma sgn2_nz_eq_arg_pos: "(sgn2 x \<noteq> 0) = (x = 0)" by (cases x) auto
lemma sgn2_zero_eq_arg_zero: "(sgn2 x = 0) = (x > 0)" by (cases x) auto

lemma sgn1_pos_eq_one: "sgn1 x > 0 \<Longrightarrow> sgn1 x = 1" by (cases x) auto
lemma sgn2_pos_eq_one: "sgn2 x > 0 \<Longrightarrow> sgn2 x = 1" by (cases x) auto

lemma sgn2_eq_1_sub_arg: "sgn2 = (\<lambda> x. 1 - x)"
proof (rule ext)
  fix x show "sgn2 x = 1 - x" by (cases x) auto
qed

lemma sgn1_eq_1_sub_sgn2: "sgn1  = (\<lambda> x. 1 - (sgn2 x))"
proof
  fix x show "sgn1 x = 1 - sgn2 x"
  proof -
    have "1- sgn2 x = 1 - (1 - x)" by (simp add: sgn2_eq_1_sub_arg)
    then show ?thesis by (simp add: sgn1_def, cases x, auto)
  qed
qed

lemma sgn2_is_pr [prec]: "sgn2 \<in> PrimRec1"
proof -
  have "(\<lambda> x. 1 - x) \<in> PrimRec1" by prec0
  thus ?thesis by (simp add: sgn2_eq_1_sub_arg)
qed

lemma sgn1_is_pr [prec]: "sgn1 \<in> PrimRec1"
proof -
  from sgn2_is_pr have "(\<lambda> x. 1 - (sgn2 x)) \<in> PrimRec1" by prec0
  thus ?thesis by (simp add: sgn1_eq_1_sub_sgn2)
qed

lemma abs_of_diff_is_pr [prec]: "abs_of_diff \<in> PrimRec2" unfolding abs_of_diff_def by prec0

lemma abs_of_diff_eq: "(abs_of_diff x y = 0) = (x = y)" by (simp add: abs_of_diff_def, arith)

lemma sf_is_pr [prec]: "sf \<in> PrimRec1"
proof -
  have S1: "PrimRecOp1 0 (\<lambda> x y. y + x + 1) \<in> PrimRec1"
  proof (rule pr_rec1)
    show "(\<lambda> x y. y + x + 1) \<in> PrimRec2" by prec0
  qed
  have "(\<lambda> x. sf x) = PrimRecOp1 0 (\<lambda> x y. y + x + 1)" (is "_ = ?f")
  proof -
    have "\<And> x. (?f x = sf x)"
    proof (induct_tac x)
      show "?f 0 = sf 0" by (simp add: sf_at_0)
    next
      fix x assume "?f x = sf x"
      with sf_at_Suc show "?f (Suc x) = sf (Suc x)"  by auto
    qed
    thus ?thesis by (simp add: ext)
  qed
  with S1 show ?thesis by simp
qed

lemma c_pair_is_pr [prec]: "c_pair \<in> PrimRec2"
proof -
  have "c_pair = (\<lambda> x y. sf (x+y) + x)" by (simp add: c_pair_def ext)
  moreover from sf_is_pr have "(\<lambda> x y. sf (x+y) + x) \<in> PrimRec2" by prec0
  ultimately show ?thesis by (simp)
qed

lemma if_is_pr: "\<lbrakk> p \<in> PrimRec1; q1 \<in> PrimRec1; q2 \<in> PrimRec1\<rbrakk> \<Longrightarrow> (\<lambda> x. if (p x = 0) then (q1 x) else (q2 x)) \<in> PrimRec1"
proof -
  have if_as_pr: "(\<lambda> x. if (p x = 0) then (q1 x) else (q2 x)) = (\<lambda> x. (sgn2 (p x)) * (q1 x) + (sgn1 (p x)) * (q2 x))"
  proof (rule ext)
    fix x show "(if (p x = 0) then (q1 x) else (q2 x)) = (sgn2 (p x)) * (q1 x) + (sgn1 (p x)) * (q2 x)" (is "?left = ?right")
    proof cases
      assume A1: "p x = 0"
      then have S1: "?left = q1 x" by simp
      from A1 have S2: "?right = q1 x" by simp
      from S1 S2 show ?thesis by simp
    next
      assume A2: "p x \<noteq> 0"
      then have S3: "p x > 0" by simp
      then show ?thesis by simp
    qed
  qed
  assume "p \<in> PrimRec1" and "q1 \<in> PrimRec1" and "q2 \<in> PrimRec1"
  then have "(\<lambda> x. (sgn2 (p x)) * (q1 x) + (sgn1 (p x)) * (q2 x)) \<in> PrimRec1" by prec0
  with if_as_pr show ?thesis by simp
qed

lemma if_eq_is_pr [prec]: "\<lbrakk> p1 \<in> PrimRec1; p2 \<in> PrimRec1; q1 \<in> PrimRec1; q2 \<in> PrimRec1\<rbrakk> \<Longrightarrow> (\<lambda> x. if (p1 x = p2 x) then (q1 x) else (q2 x)) \<in> PrimRec1"
proof -
  have S1: "(\<lambda> x. if (p1 x = p2 x) then (q1 x) else (q2 x)) = (\<lambda> x. if (abs_of_diff (p1 x) (p2 x) = 0) then (q1 x) else (q2 x))" (is "?L = ?R") by (simp add: abs_of_diff_eq)
  assume A1: "p1 \<in> PrimRec1" and A2: "p2 \<in> PrimRec1"
  with abs_of_diff_is_pr have S2: "(\<lambda> x. abs_of_diff (p1 x) (p2 x)) \<in> PrimRec1" by prec0
  assume "q1 \<in> PrimRec1" and "q2 \<in> PrimRec1"
  with S2 have "?R \<in> PrimRec1" by (rule if_is_pr)
  with S1 show ?thesis by simp
qed

lemma if_is_pr2 [prec]: "\<lbrakk> p \<in> PrimRec2; q1 \<in> PrimRec2; q2 \<in> PrimRec2\<rbrakk> \<Longrightarrow> (\<lambda> x y. if (p x y = 0) then (q1 x y) else (q2 x y)) \<in> PrimRec2"
proof -
  have if_as_pr: "(\<lambda> x y. if (p x y = 0) then (q1 x y) else (q2 x y)) = (\<lambda> x y. (sgn2 (p x y)) * (q1 x y) + (sgn1 (p x y)) * (q2 x y))"
  proof (rule ext, rule ext)
    fix x fix y show "(if (p x y = 0) then (q1 x y) else (q2 x y)) = (sgn2 (p x y)) * (q1 x y) + (sgn1 (p x y)) * (q2 x y)" (is "?left = ?right")
    proof cases
      assume A1: "p x y = 0"
      then have S1: "?left = q1 x y" by simp
      from A1 have S2: "?right = q1 x y" by simp
      from S1 S2 show ?thesis by simp
    next
      assume A2: "p x y \<noteq> 0"
      then have S3: "p x y > 0" by simp
      then show ?thesis by simp
    qed
  qed
  assume "p \<in> PrimRec2" and "q1 \<in> PrimRec2" and "q2 \<in> PrimRec2"
  then have "(\<lambda> x y. (sgn2 (p x y)) * (q1 x y) + (sgn1 (p x y)) * (q2 x y)) \<in> PrimRec2" by prec0
  with if_as_pr show ?thesis by simp
qed

lemma if_eq_is_pr2: "\<lbrakk> p1 \<in> PrimRec2; p2 \<in> PrimRec2; q1 \<in> PrimRec2; q2 \<in> PrimRec2\<rbrakk> \<Longrightarrow> (\<lambda> x y. if (p1 x y = p2 x y) then (q1 x y) else (q2 x y)) \<in> PrimRec2"
proof -
  have S1: "(\<lambda> x y. if (p1 x y = p2 x y) then (q1 x y) else (q2 x y)) = (\<lambda> x y. if (abs_of_diff (p1 x y) (p2 x y) = 0) then (q1 x y) else (q2 x y))" (is "?L = ?R") by (simp add: abs_of_diff_eq)
  assume A1: "p1 \<in> PrimRec2" and A2: "p2 \<in> PrimRec2"
  with abs_of_diff_is_pr have S2: "(\<lambda> x y. abs_of_diff (p1 x y) (p2 x y)) \<in> PrimRec2" by prec0
  assume "q1 \<in> PrimRec2" and "q2 \<in> PrimRec2"
  with S2 have "?R \<in> PrimRec2" by (rule if_is_pr2)
  with S1 show ?thesis by simp
qed

lemma if_is_pr3 [prec]: "\<lbrakk> p \<in> PrimRec3; q1 \<in> PrimRec3; q2 \<in> PrimRec3\<rbrakk> \<Longrightarrow> (\<lambda> x y z. if (p x y z = 0) then (q1 x y z) else (q2 x y z)) \<in> PrimRec3"
proof -
  have if_as_pr: "(\<lambda> x y z. if (p x y z = 0) then (q1 x y z) else (q2 x y z)) = (\<lambda> x y z. (sgn2 (p x y z)) * (q1 x y z) + (sgn1 (p x y z)) * (q2 x y z))"
  proof (rule ext, rule ext, rule ext)
    fix x fix y fix z show "(if (p x y z = 0) then (q1 x y z) else (q2 x y z)) = (sgn2 (p x y z)) * (q1 x y z) + (sgn1 (p x y z)) * (q2 x y z)" (is "?left = ?right")
    proof cases
      assume A1: "p x y z = 0"
      then have S1: "?left = q1 x y z" by simp
      from A1 have S2: "?right = q1 x y z" by simp
      from S1 S2 show ?thesis by simp
    next
      assume A2: "p x y z \<noteq> 0"
      then have S3: "p x y z > 0" by simp
      then show ?thesis by simp
    qed
  qed
  assume "p \<in> PrimRec3" and "q1 \<in> PrimRec3" and "q2 \<in> PrimRec3"
  then have "(\<lambda> x y z. (sgn2 (p x y z)) * (q1 x y z) + (sgn1 (p x y z)) * (q2 x y z)) \<in> PrimRec3"
    by prec0
  with if_as_pr show ?thesis by simp
qed

lemma if_eq_is_pr3: "\<lbrakk> p1 \<in> PrimRec3; p2 \<in> PrimRec3; q1 \<in> PrimRec3; q2 \<in> PrimRec3\<rbrakk> \<Longrightarrow> (\<lambda> x y z. if (p1 x y z = p2 x y z) then (q1 x y z) else (q2 x y z)) \<in> PrimRec3"
proof -
  have S1: "(\<lambda> x y z. if (p1 x y z = p2 x y z) then (q1 x y z) else (q2 x y z)) = (\<lambda> x y z. if (abs_of_diff (p1 x y z) (p2 x y z) = 0) then (q1 x y z) else (q2 x y z))" (is "?L = ?R") by (simp add: abs_of_diff_eq)
  assume A1: "p1 \<in> PrimRec3" and A2: "p2 \<in> PrimRec3"
  with abs_of_diff_is_pr have S2: "(\<lambda> x y z. abs_of_diff (p1 x y z) (p2 x y z)) \<in> PrimRec3"
    by prec0
  assume "q1 \<in> PrimRec3" and "q2 \<in> PrimRec3"
  with S2 have "?R \<in> PrimRec3" by (rule if_is_pr3)
  with S1 show ?thesis by simp
qed

ML {*
fun get_if_by_index 1 = @{thm if_eq_is_pr}
  | get_if_by_index 2 = @{thm if_eq_is_pr2}
  | get_if_by_index 3 = @{thm if_eq_is_pr3}
  | get_if_by_index _ = raise BadArgument

fun if_comp_tac ctxt = SUBGOAL (fn (t, i) =>
  let
    val t = extract_trueprop_arg (Logic.strip_imp_concl t)
    val (t1, t2) = extract_set_args t
    val n2 =
      let
        val Const(s, _) = t2
      in
        get_num_by_set s
      end
    val (name, _, n1) = extract_free_arg t1
  in
    if name = @{const_name If} then
      resolve_tac [get_if_by_index n2] i
    else
      let
        val comp = get_comp_by_indexes (n1, n2)
      in
        res_inst_tac ctxt [(("f", 0), Variable.revert_fixed ctxt name)] comp i
      end
  end
  handle BadArgument => no_tac)

fun prec_tac ctxt facts i =
  Method.insert_tac facts i THEN
  REPEAT (resolve_tac [@{thm const_is_pr}, @{thm const_is_pr_2}, @{thm const_is_pr_3}] i ORELSE
    assume_tac i ORELSE if_comp_tac ctxt i)
*}

method_setup prec = {*
  Attrib.thms >> (fn ths => fn ctxt => Method.METHOD (fn facts =>
    HEADGOAL (prec_tac ctxt (facts @ Named_Theorems.get ctxt @{named_theorems prec}))))
*} "apply primitive recursive functions"

subsection {* Bounded least operator *}

definition
  b_least :: "(nat \<Rightarrow> nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat)" where
  "b_least f x \<equiv> (Least (%y. y = x \<or> (y < x \<and> (f x y) \<noteq> 0)))"

definition
  b_least2 :: "(nat \<Rightarrow> nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat \<Rightarrow> nat)" where
  "b_least2 f x y \<equiv> (Least (%z. z = y \<or> (z < y \<and> (f x z) \<noteq> 0)))"

lemma b_least_aux1: "b_least f x = x \<or> (b_least f x < x \<and> (f x (b_least f x)) \<noteq> 0)"
proof -
  let ?P = "%y. y = x \<or> (y < x \<and> (f x y) \<noteq> 0)"
  have "?P x" by simp
  then have "?P (Least ?P)" by (rule LeastI)
  thus ?thesis by (simp add: b_least_def)
qed

lemma b_least_le_arg: "b_least f x \<le> x"
proof -
  have "b_least f x = x \<or> (b_least f x < x \<and> (f x (b_least f x)) \<noteq> 0)" by (rule b_least_aux1)
  from this show ?thesis by (arith)
qed

lemma less_b_least_impl_zero: "y < b_least f x \<Longrightarrow> f x y = 0"
proof -
  assume A1: "y < b_least f x" (is "_ < ?b")
  have "b_least f x \<le> x" by (rule b_least_le_arg)
  with A1 have S1: "y < x" by simp
  with A1 have " y < (Least (%y. y = x \<or> (y < x \<and> (f x y) \<noteq> 0)))" by (simp add: b_least_def)
  then have "\<not> (y = x \<or> (y < x \<and> (f x y) \<noteq> 0))" by (rule not_less_Least)
  with S1 show ?thesis by simp
qed

lemma nz_impl_b_least_le: "(f x y) \<noteq> 0 \<Longrightarrow> (b_least f x) \<le> y"
proof (rule ccontr)
  assume A1: "f x y \<noteq> 0"
  assume "\<not> b_least f x \<le> y"
  then have "y < b_least f x" by simp
  with A1 show False by (simp add: less_b_least_impl_zero)
qed

lemma b_least_less_impl_nz: "b_least f x < x \<Longrightarrow> f x (b_least f x) \<noteq> 0"
proof -
  assume A1: "b_least f x < x"
  have "b_least f x = x \<or> (b_least f x < x \<and> (f x (b_least f x)) \<noteq> 0)" by (rule b_least_aux1)
  from A1 this show ?thesis by simp
qed

lemma b_least_less_impl_eq: "b_least f x < x \<Longrightarrow> (b_least f x) = (Least (%y. (f x y) \<noteq> 0))"
proof -
  assume A1: "b_least f x < x" (is "?b < _")
  let ?B = "(Least (%y. (f x y) \<noteq> 0))"
  from A1 have S1: "f x ?b \<noteq> 0" by (rule b_least_less_impl_nz)
  from S1 have S2: "?B  \<le> ?b" by (rule Least_le)
  from S1 have S3: "f x ?B \<noteq> 0" by (rule LeastI)
  from S3 have S4: "?b \<le> ?B" by (rule nz_impl_b_least_le)
  from S2 S4 show ?thesis by simp
qed

lemma less_b_least_impl_zero2: "\<lbrakk>y < x; b_least f x = x\<rbrakk> \<Longrightarrow> f x y = 0" by (simp add: less_b_least_impl_zero)

lemma nz_impl_b_least_less: "\<lbrakk>y<x; (f x y) \<noteq> 0\<rbrakk> \<Longrightarrow> (b_least f x) < x"
proof -
  assume A1: "y < x"
  assume "f x y \<noteq> 0"
  then have "b_least f x \<le> y" by (rule nz_impl_b_least_le)
  with A1 show ?thesis by simp
qed

lemma b_least_aux2: "\<lbrakk>y<x; (f x y) \<noteq> 0\<rbrakk> \<Longrightarrow> (b_least f x) = (Least (%y. (f x y) \<noteq> 0))"
proof -
  assume A1: "y < x" and A2: "f x y \<noteq> 0"
  from A1 A2 have S1: "b_least f x < x" by (rule nz_impl_b_least_less)
  thus ?thesis by (rule b_least_less_impl_eq)
qed

lemma b_least2_aux1: "b_least2 f x y = y \<or> (b_least2 f x y < y \<and> (f x (b_least2 f x y)) \<noteq> 0)"
proof -
  let ?P = "%z. z = y \<or> (z < y \<and> (f x z) \<noteq> 0)"
  have "?P y" by simp
  then have "?P (Least ?P)" by (rule LeastI)
  thus ?thesis by (simp add: b_least2_def)
qed

lemma b_least2_le_arg: "b_least2 f x y \<le> y"
proof -
  let ?B = "b_least2 f x y"
  have "?B = y \<or> (?B < y \<and> (f x ?B) \<noteq> 0)" by (rule b_least2_aux1)
  from this show ?thesis by (arith)
qed

lemma less_b_least2_impl_zero: "z < b_least2 f x y \<Longrightarrow> f x z = 0"
proof -
  assume A1: "z < b_least2 f x y" (is "_ < ?b")
  have "b_least2 f x y \<le> y" by (rule b_least2_le_arg)
  with A1 have S1: "z < y" by simp
  with A1 have " z < (Least (%z. z = y \<or> (z < y \<and> (f x z) \<noteq> 0)))" by (simp add: b_least2_def)
  then have "\<not> (z = y \<or> (z < y \<and> (f x z) \<noteq> 0))" by (rule not_less_Least)
  with S1 show ?thesis by simp
qed

lemma nz_impl_b_least2_le: "(f x z) \<noteq> 0 \<Longrightarrow> (b_least2 f x y) \<le> z"
proof -
  assume A1: "f x z \<noteq> 0"
  have S1: "z < b_least2 f x y \<Longrightarrow> f x z = 0" by (rule less_b_least2_impl_zero)
  from A1 S1 show ?thesis by arith
qed

lemma b_least2_less_impl_nz: "b_least2 f x y < y \<Longrightarrow> f x (b_least2 f x y) \<noteq> 0"
proof -
  assume A1: "b_least2 f x y < y"
  have "b_least2 f x y = y \<or> (b_least2 f x y < y \<and> (f x (b_least2 f x y)) \<noteq> 0)" by (rule b_least2_aux1)
  with A1 show ?thesis by simp
qed

lemma b_least2_less_impl_eq: "b_least2 f x y < y \<Longrightarrow> (b_least2 f x y) = (Least (%z. (f x z) \<noteq> 0))"
proof -
  assume A1: "b_least2 f x y < y" (is "?b < _")
  let ?B = "(Least (%z. (f x z) \<noteq> 0))"
  from A1 have S1: "f x ?b \<noteq> 0" by (rule b_least2_less_impl_nz)
  from S1 have S2: "?B  \<le> ?b" by (rule Least_le)
  from S1 have S3: "f x ?B \<noteq> 0" by (rule LeastI)
  from S3 have S4: "?b \<le> ?B" by (rule nz_impl_b_least2_le)
  from S2 S4 show ?thesis by simp
qed

lemma less_b_least2_impl_zero2: "\<lbrakk>z<y; b_least2 f x y = y\<rbrakk> \<Longrightarrow> f x z = 0"
proof -
  assume  "z < y" and "b_least2 f x y = y"
  hence "z < b_least2 f x y" by simp
  thus ?thesis by (rule less_b_least2_impl_zero)
qed

lemma nz_b_least2_impl_less: "\<lbrakk>z<y; (f x z) \<noteq> 0\<rbrakk> \<Longrightarrow> (b_least2 f x y) < y"
proof (rule ccontr)
  assume A1: "z < y"
  assume A2: "f x z \<noteq> 0"
  assume "\<not> (b_least2 f x y) < y" then have A3: "y \<le> (b_least2 f x y)" by simp
  have "b_least2 f x y \<le> y" by (rule b_least2_le_arg)
  with A3 have "b_least2 f x y = y" by simp
  with A1 have "f x z = 0" by (rule less_b_least2_impl_zero2)
  with A2 show False by simp
qed

lemma b_least2_less_impl_eq2: "\<lbrakk>z < y; (f x z) \<noteq> 0\<rbrakk> \<Longrightarrow> (b_least2 f x y) = (Least (%z. (f x z) \<noteq> 0))"
proof -
  assume A1: "z < y" and A2: "f x z \<noteq> 0"
  from A1 A2 have S1: "b_least2 f x y < y" by (rule nz_b_least2_impl_less)
  thus ?thesis by (rule b_least2_less_impl_eq)
qed

lemma b_least2_aux2: "b_least2 f x y < y \<Longrightarrow> b_least2 f x (Suc y) = b_least2 f x y"
proof -
  let ?B = "b_least2 f x y"
  assume A1: "?B < y"
  from A1 have S1: "f x ?B \<noteq> 0" by (rule b_least2_less_impl_nz)
  from S1 have S2: "b_least2 f x (Suc y) \<le> ?B" by (simp add: nz_impl_b_least2_le)
  from A1 S2 have S3: "b_least2 f x (Suc y) < Suc y" by (simp)
  from S3 have S4: "f x (b_least2 f x (Suc y)) \<noteq> 0" by (rule b_least2_less_impl_nz)
  from S4 have S5: "?B \<le> b_least2 f x (Suc y)" by (rule nz_impl_b_least2_le)
  from S2 S5 show ?thesis by simp
qed

lemma b_least2_aux3: "\<lbrakk> b_least2 f x y = y; f x y \<noteq> 0\<rbrakk> \<Longrightarrow> b_least2 f x (Suc y) = y"
proof -
  assume A1: "b_least2 f x y =y"
  assume A2: "f x y \<noteq> 0"
  from A2 have S1: "b_least2 f x (Suc y) \<le> y" by (rule nz_impl_b_least2_le)
  have S2: "b_least2 f x (Suc y) < y \<Longrightarrow> False"
  proof -
    assume A2_1: "b_least2 f x (Suc y) < y" (is "?z < _")
    from A2_1 have S2_1: "?z < Suc y" by simp
    from S2_1 have S2_2: "f x ?z \<noteq> 0" by (rule b_least2_less_impl_nz)
    from A2_1 S2_2 have S2_3: "b_least2 f x y < y" by (rule nz_b_least2_impl_less)
    from S2_3 A1 show ?thesis by simp
  qed
  from S2 have S3: "\<not> (b_least2 f x (Suc y) < y)" by auto
  from S1 S3 show ?thesis by simp
qed

lemma b_least2_mono: "y1 \<le> y2 \<Longrightarrow> b_least2 f x y1 \<le> b_least2 f x y2"
proof (rule ccontr)
  assume A1: "y1 \<le> y2"
  let ?b1 = "b_least2 f x y1" and ?b2 = "b_least2 f x y2"
  assume "\<not> ?b1 \<le> ?b2" then have A2: "?b2 < ?b1" by simp
  have S1: "?b1 \<le> y1" by (rule b_least2_le_arg)
  have S2: "?b2 \<le> y2" by (rule b_least2_le_arg)
  from A1 A2 S1 S2 have S3: "?b2 < y2" by simp
  then have S4: "f x ?b2 \<noteq> 0" by (rule b_least2_less_impl_nz)
  from A2 have S5: "f x ?b2 = 0" by (rule less_b_least2_impl_zero)
  from S4 S5 show False by simp
qed

lemma b_least2_aux4: "\<lbrakk> b_least2 f x y = y; f x y = 0\<rbrakk> \<Longrightarrow> b_least2 f x (Suc y) = Suc y"
proof -
  assume A1: "b_least2 f x y = y"
  assume A2: "f x y = 0"
  have S1: "b_least2 f x (Suc y) \<le> Suc y" by (rule b_least2_le_arg)
  have S2: "y \<le> b_least2 f x (Suc y)"
  proof -
    have "y \<le> Suc y" by simp
    then have "b_least2 f x y \<le> b_least2 f x (Suc y)" by (rule b_least2_mono)
    with A1 show ?thesis by simp
  qed
  from S1 S2  have "b_least2 f x (Suc y) =y \<or> b_least2 f x (Suc y) = Suc y" by arith
  moreover
  {
    assume A3: "b_least2 f x (Suc y) = y"
    have "f x y \<noteq> 0"
    proof -
      have "y < Suc y" by simp
      with A3 have "b_least2 f x (Suc y) < Suc y" by simp
      from this have "f x (b_least2 f x (Suc y)) \<noteq> 0" by (simp add: b_least2_less_impl_nz)
      with A3 show "f x y \<noteq> 0" by simp
    qed
    with A2 have ?thesis by simp
  }
  moreover
  {
    assume "b_least2 f x (Suc y) = Suc y"
    then have ?thesis by simp
  }
  ultimately show ?thesis by blast
qed

lemma b_least2_at_zero: "b_least2 f x 0 = 0"
proof -
  have S1: "b_least2 f x 0 \<le> 0" by (rule b_least2_le_arg)
  from S1 show ?thesis by auto
qed

theorem pr_b_least2: "f \<in> PrimRec2 \<Longrightarrow> b_least2 f \<in> PrimRec2"
proof -
  def loc_Op1 == "(\<lambda> (f::nat \<Rightarrow> nat \<Rightarrow> nat) x y z. (sgn1 (z - y)) * y + (sgn2 (z - y))*((sgn1 (f x z))*z + (sgn2 (f x z))*(Suc z)))"
  def loc_Op2 == "(\<lambda> f. PrimRecOp_last (\<lambda> x. 0) (loc_Op1 f))"
  have loc_op2_lm_1: "\<And> f x y. loc_Op2 f x y < y \<Longrightarrow> loc_Op2 f x (Suc y) = loc_Op2 f x y"
  proof -
    fix f x y
    let ?b = "loc_Op2 f x y"
    have S1: "loc_Op2 f x (Suc y) = (loc_Op1 f) x ?b y" by (simp add: loc_Op2_def)
    assume "?b < y"
    then have "y - ?b > 0" by simp
    then have "loc_Op1 f x ?b y = ?b" by (simp add: loc_Op1_def)
    with S1 show "loc_Op2 f x y < y \<Longrightarrow> loc_Op2 f x (Suc y) = loc_Op2 f x y" by simp
  qed
  have loc_op2_lm_2: "\<And> f x y. \<lbrakk>\<not>(loc_Op2 f x y < y); f x y \<noteq> 0\<rbrakk> \<Longrightarrow> loc_Op2 f x (Suc y) = y"
  proof -
    fix f x y
    let ?b = "loc_Op2 f x y" and ?h = "loc_Op1 f"
    have S1: "loc_Op2 f x (Suc y) = ?h x ?b y" by (simp add: loc_Op2_def)
    assume "\<not>(?b < y)"
    then have S2: "y - ?b = 0" by simp
    assume "f x y \<noteq> 0"
    with S2 have "?h x ?b y = y" by (simp add: loc_Op1_def)
    with S1 show "loc_Op2 f x (Suc y) = y" by simp
  qed
  have loc_op2_lm_3: "\<And> f x y. \<lbrakk>\<not>(loc_Op2 f x y < y); f x y = 0\<rbrakk> \<Longrightarrow> loc_Op2 f x (Suc y) = Suc y"
  proof -
    fix f x y
    let ?b = "loc_Op2 f x y" and ?h = "loc_Op1 f"
    have S1: "loc_Op2 f x (Suc y) = ?h x ?b y" by (simp add: loc_Op2_def)
    assume "\<not>(?b < y)"
    then have S2: "y - ?b = 0" by simp
    assume "f x y = 0"
    with S2 have "?h x ?b y = Suc y" by (simp add: loc_Op1_def)
    with S1 show "loc_Op2 f x (Suc y) = Suc y" by simp
  qed
  have Op2_eq_b_least2_at_point: "\<And> f x y. loc_Op2 f x y = b_least2 f x y"
  proof - fix f x show "\<And> y. loc_Op2 f x y = b_least2 f x y"
  proof (induct_tac y)
    show "loc_Op2 f x 0 = b_least2 f x 0" by (simp add: loc_Op2_def b_least2_at_zero)
  next
    fix y
    assume A1: "loc_Op2 f x y = b_least2 f x y"
    then show "loc_Op2 f x (Suc y) = b_least2 f x (Suc y)"
    proof cases
      assume A2: "loc_Op2 f x y < y"
      then have S1: "loc_Op2 f x (Suc y) = loc_Op2 f x y" by (rule loc_op2_lm_1)
      from A1 A2 have "b_least2 f x y < y" by simp
      then have S2: "b_least2 f x (Suc y) = b_least2 f x y" by (rule b_least2_aux2)
      from A1 S1 S2 show ?thesis by simp
    next
      assume A3: "\<not> loc_Op2 f x y < y"
      have A3': "b_least2 f x y = y"
      proof -
        have "b_least2 f x y \<le> y" by (rule b_least2_le_arg)
        from A1 A3 this show ?thesis by simp
      qed
      then show ?thesis
      proof cases
        assume A4: "f x y \<noteq> 0"
        with A3 have S3: "loc_Op2 f x (Suc y) = y" by (rule loc_op2_lm_2)
        from A3' A4 have S4: "b_least2 f x (Suc y) = y" by (rule b_least2_aux3)
        from S3 S4 show ?thesis by simp
      next
        assume "\<not> f x y \<noteq>  0"
        then have A5: "f x y = 0" by simp
        with A3 have S5: "loc_Op2 f x (Suc y) = Suc y" by (rule loc_op2_lm_3)
        from A3' A5 have S6: "b_least2 f x (Suc y) = Suc y" by (rule b_least2_aux4)
        from S5 S6 show ?thesis by simp
      qed
    qed
  qed
  qed
  have Op2_eq_b_least2: "loc_Op2 = b_least2" by (simp add: Op2_eq_b_least2_at_point ext)
  assume A1: "f \<in> PrimRec2"
  have pr_loc_Op2: "loc_Op2 f \<in> PrimRec2"
  proof -
    from A1 have S1: "loc_Op1 f \<in> PrimRec3" by (simp add: loc_Op1_def, prec)
    from pr_zero S1 have S2: "PrimRecOp_last (\<lambda> x. 0) (loc_Op1 f) \<in> PrimRec2" by (rule pr_rec_last)
    from this show ?thesis by (simp add: loc_Op2_def)
  qed
  from Op2_eq_b_least2 this show "b_least2 f \<in> PrimRec2" by simp
qed

lemma b_least_def1: "b_least f = (\<lambda> x. b_least2 f x x)" by (simp add: b_least2_def b_least_def ext)

theorem pr_b_least: "f \<in> PrimRec2 \<Longrightarrow> b_least f \<in> PrimRec1"
proof -
  assume "f \<in> PrimRec2"
  then have "b_least2 f \<in> PrimRec2" by (rule pr_b_least2)
  from this pr_id1_1 pr_id1_1 have "(\<lambda> x. b_least2 f x x) \<in> PrimRec1" by (rule pr_comp2_1)
  then show ?thesis by (simp add: b_least_def1)
qed

subsection {* Examples *}

theorem c_sum_as_b_least: "c_sum = (\<lambda> u. b_least2 (\<lambda> u z. (sgn1 (sf(z+1) - u))) u (Suc u))"
proof (rule ext)
  fix u show "c_sum u = b_least2 (\<lambda> u z. (sgn1 (sf(z+1) - u))) u (Suc u)"
  proof -
    have lm_1: "(\<lambda> x y. (sgn1 (sf(y+1) - x) \<noteq> 0)) = (\<lambda> x y. (x < sf(y+1)))"
    proof (rule ext, rule ext)
      fix x y show "(sgn1 (sf(y+1) - x) \<noteq> 0) = (x < sf(y+1))"
      proof -
        have "(sgn1 (sf(y+1) - x) \<noteq> 0) = (sf(y+1) - x > 0)" by (rule sgn1_nz_eq_arg_pos)
        thus "(sgn1 (sf(y+1) - x) \<noteq> 0) = (x < sf(y+1))" by auto
      qed
    qed (* lm_1 *)
    let ?f = "\<lambda> u z. (sgn1 (sf(z+1) - u))"
    have S1: "?f u u \<noteq> 0"
    proof -
      have S1_1: "u+1 \<le> sf(u+1)" by (rule arg_le_sf)
      have S1_2: "u < u+1" by simp
      from S1_1 S1_2 have S1_3: "u < sf(u+1)" by simp
      from S1_3 have S1_4: "sf(u+1) - u > 0" by simp
      from S1_4 have S1_5: "sgn1 (sf(u+1)-u) = 1" by simp
      from S1_5 show ?thesis by simp
    qed
    have S3: "u < Suc u" by simp
    from S3 S1 have S4: "b_least2 ?f u (Suc u) = (Least (%z. (?f u z) \<noteq> 0))" by (rule b_least2_less_impl_eq2)
    let ?P = "\<lambda> u z. ?f u z \<noteq> 0"
    let ?Q = "\<lambda> u z. u < sf(z+1)"
    from lm_1 have S6: "?P = ?Q" by simp
    from S6 have S7: "(%z. ?P u z) = (%z. ?Q u z)" by (rule fun_cong)
    from S7 have S8: "(Least (%z. ?P u z)) = (Least (%z. ?Q u z))" by auto
    from S4 S8 have S9: "b_least2 ?f u (Suc u) = (Least (%z. u < sf(z+1)))" by (rule trans)
    thus ?thesis by (simp add: c_sum_def)
  qed
qed

theorem c_sum_is_pr: "c_sum \<in> PrimRec1"
proof -
  let ?f = "\<lambda> u z. (sgn1 (sf(z+1) - u))"
  have S1: "(\<lambda> u z. sgn1 ((sf(z+1) - u))) \<in> PrimRec2" by prec
  def D1: g == "b_least2 ?f"
  from D1 S1 have "g \<in> PrimRec2" by (simp add: pr_b_least2)
  then have S2: "(\<lambda> u. g u (Suc u)) \<in> PrimRec1" by prec
  from D1 have "c_sum = (\<lambda> u. g u (Suc u))" by (simp add: c_sum_as_b_least ext)
  with S2 show ?thesis by simp
qed

theorem c_fst_is_pr [prec]: "c_fst \<in> PrimRec1"
proof -
  have S1: "(\<lambda> u. c_fst u) = (\<lambda> u. (u - sf (c_sum u)))" by (simp add: c_fst_def ext)
  from c_sum_is_pr have "(\<lambda> u. (u - sf (c_sum u))) \<in> PrimRec1" by prec
  with S1 show ?thesis by simp
qed

theorem c_snd_is_pr [prec]: "c_snd \<in> PrimRec1"
proof -
  have S1: "c_snd = (\<lambda> u. (c_sum u) - (c_fst u))" by (simp add: c_snd_def ext)
  from c_sum_is_pr c_fst_is_pr have S2: "(\<lambda> u. (c_sum u) - (c_fst u)) \<in> PrimRec1" by prec
  from S1 this show ?thesis by simp
qed

theorem pr_1_to_2: "f \<in> PrimRec1 \<Longrightarrow> (\<lambda> x y. f (c_pair x y)) \<in> PrimRec2" by prec

theorem pr_2_to_1: "f \<in> PrimRec2 \<Longrightarrow> (\<lambda> z. f (c_fst z) (c_snd z)) \<in> PrimRec1" by prec

definition "pr_conv_1_to_2 = (\<lambda> f x y. f (c_pair x y))"
definition "pr_conv_1_to_3 = (\<lambda> f x y z. f (c_pair (c_pair x y) z))"
definition "pr_conv_2_to_1 = (\<lambda> f x. f (c_fst x) (c_snd x))"
definition "pr_conv_3_to_1 = (\<lambda> f x. f (c_fst (c_fst x)) (c_snd (c_fst x)) (c_snd x))"
definition "pr_conv_3_to_2 = (\<lambda> f. pr_conv_1_to_2 (pr_conv_3_to_1 f))"
definition "pr_conv_2_to_3 = (\<lambda> f. pr_conv_1_to_3 (pr_conv_2_to_1 f))"

lemma [simp]: "pr_conv_1_to_2 (pr_conv_2_to_1 f) = f" by(simp add: pr_conv_1_to_2_def pr_conv_2_to_1_def)
lemma [simp]: "pr_conv_2_to_1 (pr_conv_1_to_2 f) = f" by(simp add: pr_conv_1_to_2_def pr_conv_2_to_1_def)
lemma [simp]: "pr_conv_1_to_3 (pr_conv_3_to_1 f) = f" by(simp add: pr_conv_1_to_3_def pr_conv_3_to_1_def)
lemma [simp]: "pr_conv_3_to_1 (pr_conv_1_to_3 f) = f" by(simp add: pr_conv_1_to_3_def pr_conv_3_to_1_def)
lemma [simp]: "pr_conv_3_to_2 (pr_conv_2_to_3 f) = f" by(simp add: pr_conv_3_to_2_def pr_conv_2_to_3_def)
lemma [simp]: "pr_conv_2_to_3 (pr_conv_3_to_2 f) = f" by(simp add: pr_conv_3_to_2_def pr_conv_2_to_3_def)

lemma pr_conv_1_to_2_lm: "f \<in> PrimRec1 \<Longrightarrow> pr_conv_1_to_2 f \<in> PrimRec2" by (simp add: pr_conv_1_to_2_def, prec)
lemma pr_conv_1_to_3_lm: "f \<in> PrimRec1 \<Longrightarrow> pr_conv_1_to_3 f \<in> PrimRec3" by (simp add: pr_conv_1_to_3_def, prec)
lemma pr_conv_2_to_1_lm: "f \<in> PrimRec2 \<Longrightarrow> pr_conv_2_to_1 f \<in> PrimRec1" by (simp add: pr_conv_2_to_1_def, prec)
lemma pr_conv_3_to_1_lm: "f \<in> PrimRec3 \<Longrightarrow> pr_conv_3_to_1 f \<in> PrimRec1" by (simp add: pr_conv_3_to_1_def, prec)
lemma pr_conv_3_to_2_lm: "f \<in> PrimRec3 \<Longrightarrow> pr_conv_3_to_2 f \<in> PrimRec2"
proof -
  assume "f \<in> PrimRec3"
  then have "pr_conv_3_to_1 f \<in> PrimRec1" by (rule pr_conv_3_to_1_lm)
  thus ?thesis by (simp add: pr_conv_3_to_2_def pr_conv_1_to_2_lm)
qed
lemma pr_conv_2_to_3_lm: "f \<in> PrimRec2 \<Longrightarrow> pr_conv_2_to_3 f \<in> PrimRec3"
proof -
  assume "f \<in> PrimRec2"
  then have "pr_conv_2_to_1 f \<in> PrimRec1" by (rule pr_conv_2_to_1_lm)
  thus ?thesis by (simp add: pr_conv_2_to_3_def pr_conv_1_to_3_lm)
qed

theorem b_least2_scheme: "\<lbrakk> f \<in> PrimRec2; g \<in> PrimRec1; \<forall> x. h x < g x; \<forall> x. f x (h x) \<noteq> 0; \<forall> z x. z < h x \<longrightarrow> f x z = 0 \<rbrakk> \<Longrightarrow>
                            h \<in> PrimRec1"
proof -
  assume f_is_pr: "f \<in> PrimRec2"
  assume g_is_pr: "g \<in> PrimRec1"
  assume h_lt_g: "\<forall> x. h x < g x"
  assume f_at_h_nz: "\<forall> x. f x (h x) \<noteq> 0"
  assume h_is_min: "\<forall> z x. z < h x \<longrightarrow> f x z = 0"
  have h_def: "h = (\<lambda> x. b_least2 f x (g x))"
    proof
      fix x show "h x = b_least2 f x (g x)"
      proof -
        from f_at_h_nz have S1: "b_least2 f x (g x) \<le> h x" by (simp add: nz_impl_b_least2_le)
        from h_lt_g have "h x < g x" by auto
        with S1 have "b_least2 f x (g x) < g x" by simp
        then have S2: "f x (b_least2 f x (g x)) \<noteq> 0" by (rule b_least2_less_impl_nz)
        have S3: "h x \<le> b_least2 f x (g x)"
        proof (rule ccontr)
          assume "\<not> h x \<le> b_least2 f x (g x)" then have "b_least2 f x (g x) < h x" by auto
          with h_is_min have "f x (b_least2 f x (g x)) = 0" by simp
          with S2 show False by auto
        qed
        from S1 S3 show ?thesis by auto
      qed
    qed
  def f1_def: f1 \<equiv> "b_least2 f"
  from f_is_pr f1_def have f1_is_pr: "f1 \<in> PrimRec2" by (simp add: pr_b_least2)
  with g_is_pr have "(\<lambda> x. f1 x (g x)) \<in> PrimRec1" by prec
  with h_def f1_def show "h \<in> PrimRec1" by auto
qed

theorem b_least2_scheme2: "\<lbrakk> f \<in> PrimRec3; g \<in> PrimRec2; \<forall> x y. h x y < g x y; \<forall> x y. f x y (h x y) \<noteq> 0;
                             \<forall> z x y. z < h x y \<longrightarrow> f x y z = 0 \<rbrakk> \<Longrightarrow>
                             h \<in> PrimRec2"
proof -
  assume f_is_pr: "f \<in> PrimRec3"
  assume g_is_pr: "g \<in> PrimRec2"
  assume h_lt_g: "\<forall> x y. h x y < g x y"
  assume f_at_h_nz: "\<forall> x y. f x y (h x y) \<noteq> 0"
  assume h_is_min: "\<forall> z x y. z < h x y \<longrightarrow> f x y z = 0"
  def f1_def: f1 \<equiv> "pr_conv_3_to_2 f"
  def g1_def: g1 \<equiv> "pr_conv_2_to_1 g"
  def h1_def: h1 \<equiv> "pr_conv_2_to_1 h"
  from f_is_pr f1_def have f1_is_pr: "f1 \<in> PrimRec2" by (simp add: pr_conv_3_to_2_lm)
  from g_is_pr g1_def have g1_is_pr: "g1 \<in> PrimRec1" by (simp add: pr_conv_2_to_1_lm)
  from h_lt_g h1_def g1_def have h1_lt_g1: "\<forall> x. h1 x < g1 x" by (simp add: pr_conv_2_to_1_def)
  from f_at_h_nz f1_def h1_def have f1_at_h1_nz: "\<forall> x. f1 x (h1 x) \<noteq> 0" by (simp add: pr_conv_2_to_1_def pr_conv_3_to_2_def pr_conv_3_to_1_def pr_conv_1_to_2_def)
  from h_is_min f1_def h1_def have h1_is_min: "\<forall> z x. z < h1 x \<longrightarrow> f1 x z = 0" by (simp add: pr_conv_2_to_1_def pr_conv_3_to_2_def pr_conv_3_to_1_def pr_conv_1_to_2_def)
  from f1_is_pr g1_is_pr h1_lt_g1 f1_at_h1_nz h1_is_min have h1_is_pr: "h1 \<in> PrimRec1" by (rule b_least2_scheme)
  from h1_def have "h = pr_conv_1_to_2 h1" by simp
  with h1_is_pr show "h \<in> PrimRec2" by (simp add: pr_conv_1_to_2_lm)
qed

theorem div_is_pr: "(\<lambda> a b. a div b) \<in> PrimRec2"
proof -
  def f_def: f \<equiv> "\<lambda> a b z. (sgn1 b) * (sgn1 (b*(z+1)-a)) + (sgn2 b)*(sgn2 z)"
  have f_is_pr: "f \<in> PrimRec3" unfolding f_def by prec
  def h_def: h \<equiv> "\<lambda> (a::nat) (b::nat). a div b"
  def g_def: g \<equiv> "\<lambda> (a::nat) (b::nat). a + 1"
  have g_is_pr: "g \<in> PrimRec2" unfolding g_def by prec
  have h_lt_g: "\<forall> a b. h a b < g a b"
  proof (rule allI, rule allI)
    fix a b
    from h_def have "h a b \<le> a" by simp
    also from g_def have "a < g a b" by simp
    ultimately show "h a b < g a b" by simp
  qed
  have f_at_h_nz: "\<forall> a b. f a b (h a b) \<noteq> 0"
  proof (rule allI, rule allI)
    fix a b show "f a b (h a b) \<noteq> 0"
    proof cases
      assume A: "b = 0"
      with h_def have "h a b = 0" by simp
      with f_def A show ?thesis by simp
    next
      assume A: "b \<noteq> 0"
      then have S1: "b > 0" by auto
      from A f_def have S2: "f a b (h a b) = sgn1 (b * (h a b + 1) - a)" by simp
      then have "?thesis = (sgn1(b * (h a b + 1) - a) \<noteq> 0)" by auto
      also have "\<dots> = (b * (h a b + 1) - a > 0)" by (rule sgn1_nz_eq_arg_pos)
      also have "\<dots> = (a < b * (h a b + 1))" by auto
      also have "\<dots> = (a < b * (h a b) + b)" by auto
      also from h_def have "\<dots> = (a < b * (a div b) + b)" by simp
      finally have S3: "?thesis = (a < b * (a div b) + b)" by auto
      have S4: "a < b * (a div b) + b"
      proof -
        from S1 have S4_1: "a mod b < b" by (rule mod_less_divisor)
        also have S4_2: "b * (a div b) + a mod b = a" by (rule mod_div_equality2)
        from S4_1 have S4_3: "b * (a div b) + a mod b < b * (a div b) + b" by arith
        from S4_2 S4_3 show ?thesis by auto
      qed
      from S3 S4 show ?thesis by auto
    qed
  qed
  have h_is_min: "\<forall> z a b. z < h a b \<longrightarrow> f a b z = 0"
  proof (rule allI, rule allI, rule allI, rule impI)
    fix a b z assume A: "z < h a b" show "f a b z = 0"
    proof -
      from A h_def have S1: "z < a div b" by simp
      then have S2: "a div b > 0" by simp
      have S3: "b \<noteq> 0"
      proof (rule ccontr)
        assume "\<not> b \<noteq> 0" then have "b = 0" by auto
        then have "a div b = 0" by auto
        with S2 show False by auto
      qed
      from S3 have b_pos: "0 < b" by auto
      from S1 have S4: "z+1 \<le> a div b" by auto
      from b_pos have "(b * (z+1) \<le> b * (a div b)) = (z+1 \<le> a div b)" by (rule nat_mult_le_cancel1)
      with S4 have S5: "b*(z+1) \<le> b*(a div b)" by simp
      moreover have "b*(a div b) \<le> a"
      proof -
        have "b*(a div b) + (a mod b) = a" by (rule mod_div_equality2)
        moreover have "0 \<le> a mod b" by auto
        ultimately show ?thesis by arith
      qed
      ultimately have S6: "b*(z+1) \<le> a" by auto
      then have "b*(z+1) - a = 0" by auto
      with S3 f_def show ?thesis by simp
    qed
  qed
  from f_is_pr g_is_pr h_lt_g f_at_h_nz h_is_min have h_is_pr: "h \<in> PrimRec2" by (rule b_least2_scheme2)
  with h_def show ?thesis by simp
qed

theorem mod_is_pr: "(\<lambda> a b. a mod b) \<in> PrimRec2"
proof -
  have "(\<lambda> (a::nat) (b::nat). a mod b) = (\<lambda> a b. a - (a div b) * b)"
  proof (rule ext, rule ext)
    fix a b show "(a::nat) mod b = a - (a div b) * b" by (rule mod_div_equality')
  qed
  also from div_is_pr have "(\<lambda> a b. a - (a div b) * b) \<in> PrimRec2" by prec
  ultimately show ?thesis by auto
qed

theorem pr_rec_last_scheme: "\<lbrakk> g \<in> PrimRec1; h \<in> PrimRec3; \<forall> x. f x 0 = g x; \<forall> x y. f x (Suc y) = h x (f x y) y \<rbrakk> \<Longrightarrow> f \<in> PrimRec2"
proof -
  assume g_is_pr: "g \<in> PrimRec1"
  assume h_is_pr: "h \<in> PrimRec3"
  assume f_at_0: "\<forall> x. f x 0 = g x"
  assume f_at_Suc: "\<forall> x y. f x (Suc y) = h x (f x y) y"
  from f_at_0 f_at_Suc have "\<And> x y. f x y = PrimRecOp_last g h x y" by (induct_tac y, simp_all)
  then have "f = PrimRecOp_last g h" by (simp add: ext)
  with g_is_pr h_is_pr show ?thesis by (simp add: pr_rec_last)
qed

theorem power_is_pr: "(\<lambda> (x::nat) (n::nat). x ^ n) \<in> PrimRec2"
proof -
  def g_def: g \<equiv> "\<lambda> (x::nat). (1::nat)"
  def h_def: h \<equiv> "\<lambda> (a::nat) (b::nat) (c::nat). a * b"
  have g_is_pr: "g \<in> PrimRec1" unfolding g_def by prec
  have h_is_pr: "h \<in> PrimRec3" unfolding h_def by prec
  let ?f = "\<lambda> (x::nat) (n::nat). x ^ n"
  have f_at_0: "\<forall> x. ?f x 0 = g x"
  proof
    fix x show "x ^ 0 = g x" by (simp add: g_def)
  qed
  have f_at_Suc: "\<forall> x y. ?f x (Suc y) = h x (?f x y) y"
  proof (rule allI, rule allI)
    fix x y show "?f x (Suc y) = h x (?f x y) y" by (simp add: h_def)
  qed
  from g_is_pr h_is_pr f_at_0 f_at_Suc show ?thesis by (rule pr_rec_last_scheme)
qed

end


subsection\<open>Simplified Variant with Simple Entailment in Logic T (Fig.~9 in \<^cite>\<open>"C85"\<close>)\<close>

theory SimpleVariantSEinT imports
  HOML
  MFilter
  BaseDefs
begin
text\<open>Axiom's of new variant based on ultrafilters.\<close>
axiomatization where
  A1': "\<lfloor>\<^bold>\<not>(\<P>(\<lambda>x.(x\<^bold>\<noteq>x)))\<rfloor>" and
  A2'': "\<lfloor>\<^bold>\<forall>X Y.(((\<P> X) \<^bold>\<and> (X\<^bold>\<sqsubseteq>Y)) \<^bold>\<rightarrow> (\<P> Y))\<rfloor>" and
  T2:   "\<lfloor>\<P> \<G>\<rfloor>"

text\<open>Modal Logic T.\<close>
axiomatization where T: "\<lfloor>\<^bold>\<forall>\<phi>.((\<^bold>\<box>\<phi>) \<^bold>\<rightarrow> \<phi>)\<rfloor>"
lemma T': "\<lfloor>\<^bold>\<forall>\<phi>.(\<phi> \<^bold>\<rightarrow> (\<^bold>\<diamond>\<phi>))\<rfloor>" by (metis T)

text\<open>Necessary existence of a Godlike entity.\<close>
theorem T6: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>"  \<comment>\<open>Proof found by sledgehammer\<close>
proof -
  have T1: "\<lfloor>\<^bold>\<forall>X.((\<P> X)\<^bold>\<rightarrow>(\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E X)))\<rfloor>" by (metis A1' A2'' T')
  have T3: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" by (metis T1 T2)
  have T5: "\<lfloor>(\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" by (metis A1' A2'' T2)
  thus ?thesis using T3 by simp qed

text\<open>T6 again, with an alternative, simpler proof.\<close>
theorem T6again: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>"
proof -
  have L1: "\<lfloor>(\<^bold>\<exists>X.((\<P> X)\<^bold>\<and>\<^bold>\<not>(\<^bold>\<exists>\<^sup>EX)))\<^bold>\<rightarrow>(\<P>(\<lambda>x.(x\<^bold>\<noteq>x)))\<rfloor>"
    by (smt A2'')
  have L2: "\<lfloor>\<^bold>\<not>(\<^bold>\<exists>X.((\<P> X) \<^bold>\<and> \<^bold>\<not>(\<^bold>\<exists>\<^sup>E X)))\<rfloor>" by (metis L1 A1')
  have T1': "\<lfloor>\<^bold>\<forall>X.((\<P> X) \<^bold>\<rightarrow> (\<^bold>\<exists>\<^sup>E X))\<rfloor>" by (metis L2)
  have T3': "\<lfloor>\<^bold>\<exists>\<^sup>E \<G>\<rfloor>" by (metis T1' T2)
  have L3: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>E \<G>)\<rfloor>" by (metis T3' T') \<comment>\<open>not needed\<close>
  thus ?thesis using T3' by simp qed
end


theory Tut03
  imports "HOL-IMP.ASM"
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl: "star r x x" |
app: "star r x y \<Longrightarrow> r y z \<Longrightarrow> star r x z"

lemma star_prepend: "\<lbrakk>star r y z; r x y\<rbrakk> \<Longrightarrow> star r x z"
  by(induction rule:star.induct, auto intro: star.refl star.app)

lemma star_append: "\<lbrakk> star r x y; r y z \<rbrakk> \<Longrightarrow> star r x z"
  by(auto intro: app)

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r  where
refl': "star' r x x" |
prep: "r x y \<Longrightarrow> star' r y z \<Longrightarrow> star' r x z"

lemma star'_append: "\<lbrakk> star' r x y; r y z \<rbrakk> \<Longrightarrow> star' r x z"
  by(induction rule: star'.induct, auto intro: star'.intros)

lemma "star r x y = star' r x y"
proof
  assume "star r x y"
  thus "star' r x y"
    by(induction rule: star.induct, auto intro: star'.intros star'_append)
next
  assume "star' r x y"
  thus  "star r x y"
    by(induction rule: star'.induct, auto intro: star.intros star_prepend)
qed

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option"  where
  "exec1 (LOADI n) _ stk  =  Some (n # stk)" |
  "exec1 (LOAD x) s stk  =  Some (s(x) # stk)" |
  "exec1  ADD _ (stk)  = (case stk of
    (i#j#stk) \<Rightarrow> Some ((i + j) # stk) |
    _ \<Rightarrow> None)"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option"  where
  "exec [] _ stk = Some (stk)" |
  "exec (i#is) s stk = (case exec1 i s stk of
    Some stk \<Rightarrow> exec is s stk |
    _ \<Rightarrow> None)"

lemma exec_append: "exec (xs@ys) s stk = (case exec xs s stk of
  Some stk \<Rightarrow> exec ys s stk |
  None \<Rightarrow> None)"
  by(induction xs arbitrary: stk, auto split: option.splits)

theorem exec_comp: "exec (comp a) s stk = Some (aval a s # stk)"
  by(induction a arbitrary: stk, auto simp: exec_append)

lemma
  assumes total: "\<forall> x y. T x y \<or> T y x"
      and anti: "\<forall> x y. A x y \<and> A y x \<longrightarrow> x = y"
      and subset: "\<forall> x y. T x y \<longrightarrow> A x y"
  shows "A x y \<longrightarrow> T x y"
proof
  fix x y
  assume "A x y"
  from total have "T x y \<or> T y x" by simp
  then show "T x y"
  proof (cases)
    assume "T x y"
    then show "T x y" .
  next
    assume "\<not>T x y"
    with \<open>T x y \<or> T y x\<close> have "T y x" by simp
    with subset have "A y x" by simp
    with \<open>A x y\<close> anti have "x = y" by simp
    with \<open>T y x\<close> show "T x y" by simp
  qed
qed

end


section \<open> Ground Mereology \<close>

(*<*)
theory M
  imports PM
begin
(*>*)

text \<open> The theory of \emph{ground mereology} adds to premereology the antisymmetry of parthood, and
defines proper parthood as nonidentical parthood.\footnote{For this axiomatization of ground mereology see,
for example, \<^cite>\<open>"varzi_parts_1996"\<close> p. 261 and \<^cite>\<open>"casati_parts_1999"\<close> p. 36. For discussion of the
antisymmetry of parthood see, for example, \<^cite>\<open>"cotnoir_antisymmetry_2010"\<close>. For the definition of
proper parthood as nonidentical parthood, see for example, \<^cite>\<open>"leonard_calculus_1940"\<close> p. 47.}
In other words, ground mereology assumes that parthood is a partial order.\<close>

locale M = PM +
  assumes part_antisymmetry: "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y"
  assumes nip_eq: "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y"
begin

subsection \<open> Proper Parthood \<close>

lemma proper_implies_part: "PP x y \<Longrightarrow> P x y"
proof -
  assume "PP x y"
  with nip_eq have "P x y \<and> x \<noteq> y"..
  thus "P x y"..
qed

lemma proper_implies_distinct: "PP x y \<Longrightarrow> x \<noteq> y"
proof -
  assume "PP x y"
  with nip_eq have "P x y \<and> x \<noteq> y"..
  thus "x \<noteq> y"..
qed

lemma proper_implies_not_part: "PP x y \<Longrightarrow> \<not> P y x"
proof -
  assume "PP x y"
  hence "P x y" by (rule proper_implies_part)
  show "\<not> P y x"
  proof
    from \<open>PP x y\<close> have "x \<noteq> y" by (rule proper_implies_distinct)
    moreover assume "P y x"
    with \<open>P x y\<close> have "x = y" by (rule part_antisymmetry)
    ultimately show "False"..
  qed
qed

lemma proper_part_asymmetry: "PP x y \<Longrightarrow> \<not> PP y x"
proof -
  assume "PP x y"
  hence "P x y" by (rule proper_implies_part)
  from \<open>PP x y\<close> have "x \<noteq> y" by (rule proper_implies_distinct)
  show "\<not> PP y x"
  proof
    assume "PP y x"
    hence "P y x" by (rule proper_implies_part)
    with \<open>P x y\<close> have "x = y" by (rule part_antisymmetry)
    with \<open>x \<noteq> y\<close> show "False"..
  qed
qed

lemma proper_implies_overlap: "PP x y \<Longrightarrow> O x y"
proof -
  assume "PP x y"
  hence "P x y" by (rule proper_implies_part)
  thus "O x y" by (rule part_implies_overlap)
qed

end

text \<open> The rest of this section compares four alternative axiomatizations of ground mereology, and
verifies their equivalence. \<close>

text \<open> The first alternative axiomatization defines proper parthood as nonmutual instead of nonidentical parthood.\footnote{
See, for example, \<^cite>\<open>"varzi_parts_1996"\<close> p. 261 and \<^cite>\<open>"casati_parts_1999"\<close> p. 36. For the distinction
between nonmutual and nonidentical parthood, see \<^cite>\<open>"parsons_many_2014"\<close> pp. 6-8.}
In the presence of antisymmetry, the two definitions of proper parthood are equivalent.\footnote{
See \<^cite>\<open>"cotnoir_antisymmetry_2010"\<close> p. 398, \<^cite>\<open>"donnelly_using_2011"\<close> p. 233,
\<^cite>\<open>"cotnoir_non-wellfounded_2012"\<close> p. 191, \<^cite>\<open>"obojska_remarks_2013"\<close> p. 344,
\<^cite>\<open>"cotnoir_does_2016"\<close> p. 128 and \<^cite>\<open>"cotnoir_is_2018"\<close>.} \<close>

locale M1 = PM +
  assumes nmp_eq: "PP x y \<longleftrightarrow> P x y \<and> \<not> P y x"
  assumes part_antisymmetry: "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y"

sublocale M \<subseteq> M1
proof
  fix x y
  show nmp_eq: "PP x y \<longleftrightarrow> P x y \<and> \<not> P y x"
  proof
    assume "PP x y"
    with nip_eq have nip: "P x y \<and> x \<noteq> y"..
    hence "x \<noteq> y"..
    from nip have "P x y"..
    moreover have "\<not> P y x"
    proof
      assume "P y x"
      with \<open>P x y\<close> have "x = y" by (rule part_antisymmetry)
      with \<open>x \<noteq> y\<close> show "False"..
    qed
    ultimately show "P x y \<and> \<not> P y x"..
  next
    assume nmp: "P x y \<and> \<not> P y x"
    hence "\<not> P y x"..
    from nmp have "P x y"..
    moreover have "x \<noteq> y"
    proof
      assume "x = y"
      hence "\<not> P y y" using \<open>\<not> P y x\<close> by (rule subst)
      thus "False" using part_reflexivity..
    qed
    ultimately have "P x y \<and> x \<noteq> y"..
    with nip_eq show "PP x y"..
  qed
  show  "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y" using part_antisymmetry.
qed

sublocale M1 \<subseteq> M
proof
  fix x y
  show nip_eq: "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y"
  proof
    assume "PP x y"
    with nmp_eq have nmp: "P x y \<and> \<not> P y x"..
    hence "\<not> P y x"..
    from nmp have "P x y"..
    moreover have "x \<noteq> y"
    proof
      assume "x = y"
      hence "\<not> P y y" using \<open>\<not> P y x\<close> by (rule subst)
      thus "False" using part_reflexivity..
    qed
    ultimately show "P x y \<and> x \<noteq> y"..
  next
    assume nip: "P x y \<and> x \<noteq> y"
    hence "x \<noteq> y"..
    from nip have "P x y"..
    moreover have "\<not> P y x"
    proof
      assume "P y x"
      with \<open>P x y\<close> have "x = y" by (rule part_antisymmetry)
      with \<open>x \<noteq> y\<close> show "False"..
    qed
    ultimately have "P x y \<and> \<not> P y x"..
    with nmp_eq show "PP x y"..
  qed
  show  "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y" using part_antisymmetry.
qed

text \<open> Conversely, assuming the two definitions of proper parthood are equivalent entails the antisymmetry
of parthood, leading to the second alternative axiomatization, which assumes both equivalencies.\footnote{
For this point see especially \<^cite>\<open>"parsons_many_2014"\<close> pp. 9-10.} \<close>

locale M2 = PM +
  assumes nip_eq: "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y"
  assumes nmp_eq: "PP x y \<longleftrightarrow> P x y \<and> \<not> P y x"

sublocale M \<subseteq> M2
proof
  fix x y
  show "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y" using nip_eq.
  show "PP x y \<longleftrightarrow> P x y \<and> \<not> P y x" using nmp_eq.
qed

sublocale M2 \<subseteq> M
proof
  fix x y
  show "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y" using nip_eq.
  show "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y"
  proof -
    assume "P x y"
    assume "P y x"
    show "x = y"
    proof (rule ccontr)
      assume "x \<noteq> y"
      with \<open>P x y\<close> have "P x y \<and> x \<noteq> y"..
      with nip_eq have "PP x y"..
      with nmp_eq have "P x y \<and> \<not> P y x"..
      hence "\<not> P y x"..
      thus "False" using \<open>P y x\<close>..
    qed
  qed
qed

text \<open> In the context of the other axioms, antisymmetry is equivalent to the extensionality of parthood,
which gives the third alternative axiomatization.\footnote{For this point see \<^cite>\<open>"cotnoir_antisymmetry_2010"\<close> p. 401
and \<^cite>\<open>"cotnoir_non-wellfounded_2012"\<close> p. 191-2.} \<close>

locale M3 = PM +
  assumes nip_eq: "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y"
  assumes part_extensionality: "x = y \<longleftrightarrow> (\<forall> z. P z x \<longleftrightarrow> P z y)"

sublocale M \<subseteq> M3
proof
  fix x y
  show "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y" using nip_eq.
  show part_extensionality: "x = y \<longleftrightarrow> (\<forall> z. P z x \<longleftrightarrow> P z y)"
  proof
    assume "x = y"
    moreover have "\<forall> z. P z x \<longleftrightarrow> P z x" by simp
    ultimately show "\<forall> z. P z x \<longleftrightarrow> P z y" by (rule subst)
  next
    assume z: "\<forall> z. P z x \<longleftrightarrow> P z y"
    show "x = y"
    proof (rule part_antisymmetry)
      from z have "P y x \<longleftrightarrow> P y y"..
      moreover have "P y y" by (rule part_reflexivity)
      ultimately show "P y x"..
    next
      from z have "P x x \<longleftrightarrow> P x y"..
      moreover have "P x x" by (rule part_reflexivity)
      ultimately show "P x y"..
    qed
  qed
qed

sublocale M3 \<subseteq> M
proof
  fix x y
  show "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y" using nip_eq.
  show part_antisymmetry: "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y"
  proof -
    assume "P x y"
    assume "P y x"
    have "\<forall> z. P z x \<longleftrightarrow> P z y"
    proof
      fix z
      show "P z x \<longleftrightarrow> P z y"
      proof
        assume "P z x"
        thus "P z y" using \<open>P x y\<close> by (rule part_transitivity)
      next
        assume "P z y"
        thus "P z x" using \<open>P y x\<close> by (rule part_transitivity)
      qed
    qed
    with part_extensionality show "x = y"..
  qed
qed

text \<open>The fourth axiomatization adopts proper parthood as primitive.\footnote{See, for example,
\<^cite>\<open>"simons_parts:_1987"\<close>, p. 26 and \<^cite>\<open>"casati_parts_1999"\<close> p. 37.} Improper parthood is
defined as proper parthood or identity.\<close>

locale M4 =
  assumes part_eq: "P x y \<longleftrightarrow> PP x y \<or> x = y"
  assumes  overlap_eq: "O x y \<longleftrightarrow> (\<exists> z. P z x \<and> P z y)"
  assumes proper_part_asymmetry: "PP x y \<Longrightarrow> \<not> PP y x"
  assumes proper_part_transitivity: "PP x y \<Longrightarrow> PP y z \<Longrightarrow> PP x z"
begin

lemma proper_part_irreflexivity: "\<not> PP x x"
proof
  assume "PP x x"
  hence "\<not> PP x x" by (rule proper_part_asymmetry)
  thus "False" using \<open>PP x x\<close>..
qed

end

sublocale M \<subseteq> M4
proof
  fix x y z
  show part_eq: "P x y \<longleftrightarrow> (PP x y \<or> x = y)"
  proof
    assume "P x y"
    show "PP x y \<or> x = y"
    proof cases
      assume "x = y"
      thus "PP x y \<or> x = y"..
    next
      assume "x \<noteq> y"
      with \<open>P x y\<close> have "P x y \<and> x \<noteq> y"..
      with nip_eq have "PP x y"..
      thus "PP x y \<or> x = y"..
    qed
  next
    assume "PP x y \<or> x = y"
    thus "P x y"
    proof
      assume "PP x y"
      thus "P x y" by (rule proper_implies_part)
    next
      assume "x = y"
      thus "P x y" by (rule identity_implies_part)
    qed
  qed
  show "O x y \<longleftrightarrow> (\<exists> z. P z x \<and> P z y)" using overlap_eq.
  show "PP x y \<Longrightarrow> \<not> PP y x" using proper_part_asymmetry.
  show proper_part_transitivity: "PP x y \<Longrightarrow> PP y z \<Longrightarrow> PP x z"
  proof -
    assume "PP x y"
    assume "PP y z"
    have "P x z \<and> x \<noteq> z"
    proof
      from \<open>PP x y\<close> have "P x y" by (rule proper_implies_part)
      moreover from \<open>PP y z\<close> have "P y z" by (rule proper_implies_part)
      ultimately show "P x z" by (rule part_transitivity)
    next
      show "x \<noteq> z"
      proof
        assume "x = z"
        hence "PP y x" using \<open>PP y z\<close> by (rule ssubst)
        hence "\<not> PP x y" by (rule proper_part_asymmetry)
        thus "False" using \<open>PP x y\<close>..
      qed
    qed
    with nip_eq show "PP x z"..
  qed
qed

sublocale M4 \<subseteq> M
proof
  fix x y z
  show proper_part_eq: "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y"
  proof
    assume "PP x y"
    hence "PP x y \<or> x = y"..
    with part_eq have "P x y"..
    moreover have "x \<noteq> y"
    proof
      assume "x = y"
      hence "PP y y" using \<open>PP x y\<close> by (rule subst)
      with proper_part_irreflexivity show "False"..
    qed
    ultimately show "P x y \<and> x \<noteq> y"..
  next
    assume rhs: "P x y \<and> x \<noteq> y"
    hence "x \<noteq> y"..
    from rhs have "P x y"..
    with part_eq have "PP x y \<or> x = y"..
    thus "PP x y"
    proof
      assume "PP x y"
      thus "PP x y".
    next
      assume "x = y"
      with \<open>x \<noteq> y\<close> show "PP x y"..
    qed
  qed
  show "P x x"
  proof -
    have "x = x" by (rule refl)
    hence "PP x x \<or> x = x"..
    with part_eq show "P x x"..
  qed
  show "O x y \<longleftrightarrow> (\<exists> z. P z x \<and> P z y)" using overlap_eq.
  show "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y"
  proof -
    assume "P x y"
    assume "P y x"
    from part_eq have "PP x y \<or> x = y" using \<open>P x y\<close>..
    thus "x = y"
    proof
      assume "PP x y"
      hence "\<not> PP y x" by (rule proper_part_asymmetry)
      from part_eq have "PP y x \<or> y = x" using \<open>P y x\<close>..
      thus "x = y"
      proof
        assume "PP y x"
        with \<open>\<not> PP y x\<close> show "x = y"..
      next
        assume "y = x"
        thus "x = y"..
      qed
    qed
  qed
  show "P x y \<Longrightarrow> P y z \<Longrightarrow> P x z"
  proof -
    assume "P x y"
    assume "P y z"
    with part_eq have "PP y z \<or> y = z"..
    hence "PP x z \<or> x = z"
    proof
      assume "PP y z"
      from part_eq have "PP x y \<or> x = y" using \<open>P x y\<close>..
      hence "PP x z"
      proof
        assume "PP x y"
        thus "PP x z" using \<open>PP y z\<close> by (rule proper_part_transitivity)
      next
        assume "x = y"
        thus "PP x z" using \<open>PP y z\<close> by (rule ssubst)
      qed
      thus "PP x z \<or> x = z"..
    next
      assume "y = z"
      moreover from part_eq have "PP x y \<or> x = y" using \<open>P x y\<close>..
      ultimately show "PP x z \<or> x = z" by (rule subst)
    qed
    with part_eq show "P x z"..
  qed
qed

(*<*) end (*>*)


(* Title:      Kleene Algebra with Tests
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

header {* Two sorted Kleene Algebra with Tests *}

theory KAT2
  imports "../../Kleene_Algebra/Kleene_Algebra"
begin

text {*
  As an alternative to the one-sorted implementation of tests, we provide a two-sorted, more
  conventional one. In this setting, Isabelle's Boolean algebra theory can be used.
  This alternative can be developed further along the lines of the one-sorted implementation.
*}

syntax "_kat" :: "'a \<Rightarrow> 'a" ("`_`")

named_theorems kat_hom "KAT test homomorphism rules"

ML {*
val kat_test_vars = ["p","q","r","s","t","p'","q'","r'","s'","t'","p''","q''","r''","s''","t''"]

fun map_ast_variables ast =
  case ast of
    (Ast.Variable v) =>
      if exists (fn tv => tv = v) kat_test_vars
      then Ast.Appl [Ast.Variable "test", Ast.Variable v]
      else Ast.Variable v
  | (Ast.Constant c) => Ast.Constant c
  | (Ast.Appl []) => Ast.Appl []
  | (Ast.Appl (f :: xs)) => Ast.Appl (f :: map map_ast_variables xs)

fun kat_hom_tac ctxt n =
  let
    val rev_rules =
      map (fn thm => thm RS @{thm sym}) (Named_Theorems.get ctxt @{named_theorems kat_hom})
  in
    asm_full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps rev_rules) n
  end
*}

method_setup kat_hom = {*
Scan.succeed (fn ctxt => SIMPLE_METHOD (CHANGED (kat_hom_tac ctxt 1)))
*}

parse_ast_translation {*
let
  fun kat_tr ctxt [t] = map_ast_variables t
in [(@{syntax_const "_kat"}, kat_tr)] end
*}

named_theorems vcg "verification condition generator rules"
ML {*
fun vcg_tac ctxt n =
  let
    fun vcg' [] = no_tac
      | vcg' (r :: rs) = rtac r n ORELSE vcg' rs;
  in REPEAT (CHANGED
       (kat_hom_tac ctxt n
        THEN REPEAT (vcg' (rev (Named_Theorems.get ctxt @{named_theorems vcg})))
        THEN kat_hom_tac ctxt n
        THEN TRY (rtac @{thm order_refl} n ORELSE asm_full_simp_tac (put_simpset HOL_basic_ss ctxt) n)))
  end
*}

method_setup vcg = {*
Scan.succeed (fn ctxt => SIMPLE_METHOD (CHANGED (vcg_tac ctxt 1)))
*}

locale dioid_tests =
  fixes test :: "'a::boolean_algebra \<Rightarrow> 'b::dioid_one_zerol"
  and not :: "'b::dioid_one_zerol \<Rightarrow> 'b::dioid_one_zerol" ("-")
  assumes test_sup [simp,kat_hom]: "test (sup p q) = `p + q`"
  and test_inf [simp,kat_hom]: "test (inf p q) = `p \<cdot> q`"
  and test_top [simp,kat_hom]: "test top = 1"
  and test_bot [simp,kat_hom]: "test bot = 0"
  and test_not [simp,kat_hom]: "test (- p) = `-p`"
  and test_iso_eq [kat_hom]: "p \<le> q \<longleftrightarrow> `p \<le> q`"
begin

notation test ("\<iota>")

lemma test_eq [kat_hom]: "p = q \<longleftrightarrow> `p = q`"
  by (metis eq_iff test_iso_eq)

lemma test_iso: "p \<le> q \<Longrightarrow> `p \<le> q`"
  by (simp add: test_iso_eq)

(* Import lemmas and modify them to fit KAT syntax *)

lemma test_meet_comm: "`p \<cdot> q = q \<cdot> p`"
  by kat_hom (fact inf_commute)

lemmas test_one_top[simp] = test_iso[OF top_greatest, simplified]

lemma [simp]: "`p + (-p) = 1`"
  by kat_hom (metis sup_compl_top)

lemma [simp]: "`(-p) \<cdot> p = 0`"
  by (metis inf.commute inf_compl_bot test_bot test_inf test_not)

lemma [simp]: "`p \<cdot> (-p) = 0`"
  by (metis inf_compl_bot test_bot test_inf test_not)

end

locale kat =
  fixes test :: "'a::boolean_algebra \<Rightarrow> 'b::kleene_algebra"
  and not :: "'b::kleene_algebra \<Rightarrow> 'b::kleene_algebra" ("!")
  assumes is_dioid_tests: "dioid_tests test not"

sublocale kat \<subseteq> dioid_tests using is_dioid_tests .

context kat
begin

notation test ("\<iota>")

lemma test_eq [kat_hom]: "p = q \<longleftrightarrow> `p = q`"
  by (metis eq_iff test_iso_eq)

lemma test_iso: "p \<le> q \<Longrightarrow> `p \<le> q`"
  by (simp add: test_iso_eq)

(* Import lemmas and modify them to fit KAT syntax *)

lemma test_meet_comm: "`p \<cdot> q = q \<cdot> p`"
  by kat_hom (fact inf_commute)

lemmas test_one_top[simp] = test_iso[OF top_greatest, simplified]

lemma test_star [simp]: "`p\<^sup>\<star> = 1`"
  by (metis star_subid test_iso test_top top_greatest)

lemmas [kat_hom] = test_star[symmetric]

lemma [simp]: "`!p + p = 1`"
  by kat_hom (metis compl_sup_top)

lemma [simp]: "`p + !p = 1`"
  by kat_hom (metis sup_compl_top)

lemma [simp]: "`!p \<cdot> p = 0`"
  by (metis inf.commute inf_compl_bot test_bot test_inf test_not)

lemma [simp]: "`p \<cdot> !p = 0`"
  by (metis inf_compl_bot test_bot test_inf test_not)

definition hoare_triple :: "'b \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>") where
  "\<lbrace>p\<rbrace> c \<lbrace>q\<rbrace> \<equiv> p\<cdot>c \<le> c\<cdot>q"

declare hoare_triple_def[iff]

lemma hoare_triple_def_var: "`p\<cdot>c \<le> c\<cdot>q \<longleftrightarrow> p\<cdot>c\<cdot>!q = 0`"
  apply (intro iffI antisym)
  apply (rule order_trans[of _ "`c \<cdot> q \<cdot> !q`"])
  apply (rule mult_isor[rule_format])
  apply (simp add: mult.assoc)+
  apply (simp add: mult.assoc[symmetric])
  apply (rule order_trans[of _ "`p\<cdot>c\<cdot>(!q + q)`"])
  apply simp
  apply (simp only: distrib_left add_zerol)
  apply (rule order_trans[of _ "`1 \<cdot> c \<cdot> q`"])
  apply (simp only: mult.assoc)
  apply (rule mult_isor[rule_format])
  by simp_all

lemmas [intro!] = star_sim2[rule_format]

lemma hoare_weakening: "p \<le> p' \<Longrightarrow> q' \<le> q \<Longrightarrow> `\<lbrace>p'\<rbrace> c \<lbrace>q'\<rbrace>` \<Longrightarrow> `\<lbrace>p\<rbrace> c \<lbrace>q\<rbrace>`"
  by auto (metis mult_isol mult_isor order_trans test_iso)

lemma hoare_star: "`\<lbrace>p\<rbrace> c \<lbrace>p\<rbrace>` \<Longrightarrow> `\<lbrace>p\<rbrace> c\<^sup>\<star> \<lbrace>p\<rbrace>`"
  by auto

lemmas [vcg] = hoare_weakening[OF order_refl _ hoare_star]

lemma hoare_test [vcg]: "`p \<cdot> t \<le> q` \<Longrightarrow> `\<lbrace>p\<rbrace> t \<lbrace>q\<rbrace>`"
  by auto (metis inf_le2 le_inf_iff test_inf test_iso_eq)

lemma [simp]: "`!p \<cdot> !p = !p`"
  by (metis inf.idem test_inf test_not)

lemma hoare_plus [vcg]: "`\<lbrace>p\<rbrace> x \<lbrace>q\<rbrace>` \<Longrightarrow> `\<lbrace>p\<rbrace> y \<lbrace>q\<rbrace>` \<Longrightarrow> `\<lbrace>p\<rbrace> x + y \<lbrace>q\<rbrace>`"
  by (auto simp add: distrib_left distrib_right add_iso_var)

definition While :: "'b \<Rightarrow> 'b \<Rightarrow> 'b" ("While _ Do _ End" [50,50] 51) where
  "While t Do c End = (t\<cdot>c)\<^sup>\<star>\<cdot>!t"

lemma hoare_while: "`\<lbrace>p \<cdot> t\<rbrace> c \<lbrace>p\<rbrace>` \<Longrightarrow> `\<lbrace>p\<rbrace> While t Do c End \<lbrace>!t \<cdot> p\<rbrace>`"
  unfolding While_def by vcg (metis inf_commute order_refl)

lemma [vcg]: "`\<lbrace>p \<cdot> t\<rbrace> c \<lbrace>p\<rbrace>` \<Longrightarrow> `!t \<cdot> p \<le> q` \<Longrightarrow> `\<lbrace>p\<rbrace> While t Do c End \<lbrace>q\<rbrace>`"
  by (metis hoare_weakening hoare_while order_refl test_inf test_iso_eq test_not)

definition If :: "'b \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b" ("If _ Then _ Else _" [50,50,50] 51) where
  "If p Then c1 Else c2 \<equiv> p\<cdot>c1 + !p\<cdot>c2"

lemma hoare_if [vcg]: "`\<lbrace>p \<cdot> t\<rbrace> c1 \<lbrace>q\<rbrace>` \<Longrightarrow> `\<lbrace>p \<cdot> !t\<rbrace> c2 \<lbrace>q\<rbrace>` \<Longrightarrow> `\<lbrace>p\<rbrace> If t Then c1 Else c2 \<lbrace>q\<rbrace>`"
  unfolding If_def by vcg assumption

end

end


text\<open> 8 October 2021: Exercise for Homework Assignment 06 in CS 511 \<close>
text\<open> Your task to remove the invocation of the pre-defined method blast,
      by an equivalent sequence of 'apply' steps \<close>
text\<open> This is a continuation of the Isabelle exercise you did for
      Homework Assignment 05, and inspired by the exercise on page 32
      in Lecture Slides 11 "Quantified Propositional Logic" \<close>

theory HW06
  imports Main
begin
(* The following is a theorem of QPL. Note that "=" means the same as "\<longleftrightarrow>" *)
theorem "(\<exists>y. (y = Phi) \<and> (y \<or> Psi1) \<and> (y \<or> Psi2)) \<longleftrightarrow> (Phi \<or> Psi1) \<and> (Phi \<or> Psi2)"
  apply (rule simp_thms)
  done

end


(*  Title:      ZF/UNITY/GenPrefix.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2001  University of Cambridge

<xs,ys>:gen_prefix(r)
  if ys = xs' @ zs where length(xs) = length(xs')
  and corresponding elements of xs, xs' are pairwise related by r

Based on Lex/Prefix
*)

section\<open>Charpentier's Generalized Prefix Relation\<close>

theory GenPrefix
imports ZF
begin

definition (*really belongs in ZF/Trancl*)
  part_order :: "[i, i] => o"  where
  "part_order(A, r) == refl(A,r) & trans[A](r) & antisym(r)"

consts
  gen_prefix :: "[i, i] => i"

inductive
  (* Parameter A is the domain of zs's elements *)

  domains "gen_prefix(A, r)" \<subseteq> "list(A)*list(A)"

  intros
    Nil:     "<[],[]>:gen_prefix(A, r)"

    prepend: "[| <xs,ys>:gen_prefix(A, r);  <x,y>:r; x \<in> A; y \<in> A |]
              ==> <Cons(x,xs), Cons(y,ys)>: gen_prefix(A, r)"

    append:  "[| <xs,ys>:gen_prefix(A, r); zs:list(A) |]
              ==> <xs, ys@zs>:gen_prefix(A, r)"
    type_intros app_type list.Nil list.Cons

definition
  prefix :: "i=>i"  where
  "prefix(A) == gen_prefix(A, id(A))"

definition
  strict_prefix :: "i=>i"  where
  "strict_prefix(A) == prefix(A) - id(list(A))"

(* less or equal and greater or equal over prefixes *)

abbreviation
  pfixLe :: "[i, i] => o"  (infixl \<open>pfixLe\<close> 50)  where
  "xs pfixLe ys == <xs, ys>:gen_prefix(nat, Le)"

abbreviation
  pfixGe :: "[i, i] => o"  (infixl \<open>pfixGe\<close> 50)  where
  "xs pfixGe ys == <xs, ys>:gen_prefix(nat, Ge)"

lemma reflD:
 "[| refl(A, r); x \<in> A |] ==> <x,x>:r"
apply (unfold refl_def, auto)
done

(*** preliminary lemmas ***)

lemma Nil_gen_prefix: "xs \<in> list(A) ==> <[], xs> \<in> gen_prefix(A, r)"
by (drule gen_prefix.append [OF gen_prefix.Nil], simp)
declare Nil_gen_prefix [simp]

lemma gen_prefix_length_le: "<xs,ys> \<in> gen_prefix(A, r) ==> length(xs) \<le> length(ys)"
apply (erule gen_prefix.induct)
apply (subgoal_tac [3] "ys \<in> list (A) ")
apply (auto dest: gen_prefix.dom_subset [THEN subsetD]
            intro: le_trans simp add: length_app)
done

lemma Cons_gen_prefix_aux:
  "[| <xs', ys'> \<in> gen_prefix(A, r) |]
   ==> (\<forall>x xs. x \<in> A \<longrightarrow> xs'= Cons(x,xs) \<longrightarrow>
       (\<exists>y ys. y \<in> A & ys' = Cons(y,ys) &
       <x,y>:r & <xs, ys> \<in> gen_prefix(A, r)))"
apply (erule gen_prefix.induct)
prefer 3 apply (force intro: gen_prefix.append, auto)
done

lemma Cons_gen_prefixE:
  "[| <Cons(x,xs), zs> \<in> gen_prefix(A, r);
    !!y ys. [|zs = Cons(y, ys); y \<in> A; x \<in> A; <x,y>:r;
      <xs,ys> \<in> gen_prefix(A, r) |] ==> P |] ==> P"
apply (frule gen_prefix.dom_subset [THEN subsetD], auto)
apply (blast dest: Cons_gen_prefix_aux)
done
declare Cons_gen_prefixE [elim!]

lemma Cons_gen_prefix_Cons:
"(<Cons(x,xs),Cons(y,ys)> \<in> gen_prefix(A, r))
  \<longleftrightarrow> (x \<in> A & y \<in> A & <x,y>:r & <xs,ys> \<in> gen_prefix(A, r))"
apply (auto intro: gen_prefix.prepend)
done
declare Cons_gen_prefix_Cons [iff]

(** Monotonicity of gen_prefix **)

lemma gen_prefix_mono2: "r<=s ==> gen_prefix(A, r) \<subseteq> gen_prefix(A, s)"
apply clarify
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (erule rev_mp)
apply (erule gen_prefix.induct)
apply (auto intro: gen_prefix.append)
done

lemma gen_prefix_mono1: "A<=B ==>gen_prefix(A, r) \<subseteq> gen_prefix(B, r)"
apply clarify
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (erule rev_mp)
apply (erule_tac P = "y \<in> list (A) " in rev_mp)
apply (erule_tac P = "xa \<in> list (A) " in rev_mp)
apply (erule gen_prefix.induct)
apply (simp (no_asm_simp))
apply clarify
apply (erule ConsE)+
apply (auto dest: gen_prefix.dom_subset [THEN subsetD]
            intro: gen_prefix.append list_mono [THEN subsetD])
done

lemma gen_prefix_mono: "[| A \<subseteq> B; r \<subseteq> s |] ==> gen_prefix(A, r) \<subseteq> gen_prefix(B, s)"
apply (rule subset_trans)
apply (rule gen_prefix_mono1)
apply (rule_tac [2] gen_prefix_mono2, auto)
done

(*** gen_prefix order ***)

(* reflexivity *)
lemma refl_gen_prefix: "refl(A, r) ==> refl(list(A), gen_prefix(A, r))"
apply (unfold refl_def, auto)
apply (induct_tac "x", auto)
done
declare refl_gen_prefix [THEN reflD, simp]

(* Transitivity *)
(* A lemma for proving gen_prefix_trans_comp *)

lemma append_gen_prefix [rule_format (no_asm)]: "xs \<in> list(A) ==>
   \<forall>zs. <xs @ ys, zs> \<in> gen_prefix(A, r) \<longrightarrow> <xs, zs>: gen_prefix(A, r)"
apply (erule list.induct)
apply (auto dest: gen_prefix.dom_subset [THEN subsetD])
done

(* Lemma proving transitivity and more*)

lemma gen_prefix_trans_comp [rule_format (no_asm)]:
     "<x, y>: gen_prefix(A, r) ==>
   (\<forall>z \<in> list(A). <y,z> \<in> gen_prefix(A, s)\<longrightarrow><x, z> \<in> gen_prefix(A, s O r))"
apply (erule gen_prefix.induct)
apply (auto elim: ConsE simp add: Nil_gen_prefix)
apply (subgoal_tac "ys \<in> list (A) ")
prefer 2 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
apply (drule_tac xs = ys and r = s in append_gen_prefix, auto)
done

lemma trans_comp_subset: "trans(r) ==> r O r \<subseteq> r"
by (auto dest: transD)

lemma trans_gen_prefix: "trans(r) ==> trans(gen_prefix(A,r))"
apply (simp (no_asm) add: trans_def)
apply clarify
apply (rule trans_comp_subset [THEN gen_prefix_mono2, THEN subsetD], assumption)
apply (rule gen_prefix_trans_comp)
apply (auto dest: gen_prefix.dom_subset [THEN subsetD])
done

lemma trans_on_gen_prefix:
 "trans(r) ==> trans[list(A)](gen_prefix(A, r))"
apply (drule_tac A = A in trans_gen_prefix)
apply (unfold trans_def trans_on_def, blast)
done

lemma prefix_gen_prefix_trans:
    "[| <x,y> \<in> prefix(A); <y, z> \<in> gen_prefix(A, r); r<=A*A |]
      ==>  <x, z> \<in> gen_prefix(A, r)"
apply (unfold prefix_def)
apply (rule_tac P = "%r. <x,z> \<in> gen_prefix (A, r) " in right_comp_id [THEN subst])
apply (blast dest: gen_prefix_trans_comp gen_prefix.dom_subset [THEN subsetD])+
done

lemma gen_prefix_prefix_trans:
"[| <x,y> \<in> gen_prefix(A,r); <y, z> \<in> prefix(A); r<=A*A |]
  ==>  <x, z> \<in> gen_prefix(A, r)"
apply (unfold prefix_def)
apply (rule_tac P = "%r. <x,z> \<in> gen_prefix (A, r) " in left_comp_id [THEN subst])
apply (blast dest: gen_prefix_trans_comp gen_prefix.dom_subset [THEN subsetD])+
done

(** Antisymmetry **)

lemma nat_le_lemma [rule_format]: "n \<in> nat ==> \<forall>b \<in> nat. n #+ b \<le> n \<longrightarrow> b = 0"
by (induct_tac "n", auto)

lemma antisym_gen_prefix: "antisym(r) ==> antisym(gen_prefix(A, r))"
apply (simp (no_asm) add: antisym_def)
apply (rule impI [THEN allI, THEN allI])
apply (erule gen_prefix.induct, blast)
apply (simp add: antisym_def, blast)
txt\<open>append case is hardest\<close>
apply clarify
apply (subgoal_tac "length (zs) = 0")
apply (subgoal_tac "ys \<in> list (A) ")
prefer 2 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
apply (drule_tac psi = "<ys @ zs, xs> \<in> gen_prefix (A,r) " in asm_rl)
apply simp
apply (subgoal_tac "length (ys @ zs) = length (ys) #+ length (zs) &ys \<in> list (A) &xs \<in> list (A) ")
prefer 2 apply (blast intro: length_app dest: gen_prefix.dom_subset [THEN subsetD])
apply (drule gen_prefix_length_le)+
apply clarify
apply simp
apply (drule_tac j = "length (xs) " in le_trans)
apply blast
apply (auto intro: nat_le_lemma)
done

(*** recursion equations ***)

lemma gen_prefix_Nil: "xs \<in> list(A) ==> <xs, []> \<in> gen_prefix(A,r) \<longleftrightarrow> (xs = [])"
by (induct_tac "xs", auto)
declare gen_prefix_Nil [simp]

lemma same_gen_prefix_gen_prefix:
 "[| refl(A, r);  xs \<in> list(A) |] ==>
    <xs@ys, xs@zs>: gen_prefix(A, r) \<longleftrightarrow> <ys,zs> \<in> gen_prefix(A, r)"
apply (unfold refl_def)
apply (induct_tac "xs")
apply (simp_all (no_asm_simp))
done
declare same_gen_prefix_gen_prefix [simp]

lemma gen_prefix_Cons: "[| xs \<in> list(A); ys \<in> list(A); y \<in> A |] ==>
    <xs, Cons(y,ys)> \<in> gen_prefix(A,r)  \<longleftrightarrow>
      (xs=[] | (\<exists>z zs. xs=Cons(z,zs) & z \<in> A & <z,y>:r & <zs,ys> \<in> gen_prefix(A,r)))"
apply (induct_tac "xs", auto)
done

lemma gen_prefix_take_append: "[| refl(A,r);  <xs,ys> \<in> gen_prefix(A, r); zs \<in> list(A) |]
      ==>  <xs@zs, take(length(xs), ys) @ zs> \<in> gen_prefix(A, r)"
apply (erule gen_prefix.induct)
apply (simp (no_asm_simp))
apply (frule_tac [!] gen_prefix.dom_subset [THEN subsetD], auto)
apply (frule gen_prefix_length_le)
apply (subgoal_tac "take (length (xs), ys) \<in> list (A) ")
apply (simp_all (no_asm_simp) add: diff_is_0_iff [THEN iffD2] take_type)
done

lemma gen_prefix_append_both: "[| refl(A, r);  <xs,ys> \<in> gen_prefix(A,r);
         length(xs) = length(ys); zs \<in> list(A) |]
      ==>  <xs@zs, ys @ zs> \<in> gen_prefix(A, r)"
apply (drule_tac zs = zs in gen_prefix_take_append, assumption+)
apply (subgoal_tac "take (length (xs), ys) =ys")
apply (auto intro!: take_all dest: gen_prefix.dom_subset [THEN subsetD])
done

(*NOT suitable for rewriting since [y] has the form y#ys*)
lemma append_cons_conv: "xs \<in> list(A) ==> xs @ Cons(y, ys) = (xs @ [y]) @ ys"
by (auto simp add: app_assoc)

lemma append_one_gen_prefix_lemma [rule_format]:
     "[| <xs,ys> \<in> gen_prefix(A, r);  refl(A, r) |]
      ==> length(xs) < length(ys) \<longrightarrow>
          <xs @ [nth(length(xs), ys)], ys> \<in> gen_prefix(A, r)"
apply (erule gen_prefix.induct, blast)
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (simp_all add: length_type)
(* Append case is hardest *)
apply (frule gen_prefix_length_le [THEN le_iff [THEN iffD1]])
apply (frule gen_prefix.dom_subset [THEN subsetD], clarify)
apply (subgoal_tac "length (xs) :nat&length (ys) :nat &length (zs) :nat")
prefer 2 apply (blast intro: length_type, clarify)
apply (simp_all add: nth_append length_type length_app)
apply (rule conjI)
apply (blast intro: gen_prefix.append)
apply (erule_tac V = "length (xs) < length (ys) \<longrightarrow>u" for u in thin_rl)
apply (erule_tac a = zs in list.cases, auto)
apply (rule_tac P1 = "%x. <u(x), v>:w" for u v w in nat_diff_split [THEN iffD2])
apply auto
apply (simplesubst append_cons_conv)
apply (rule_tac [2] gen_prefix.append)
apply (auto elim: ConsE simp add: gen_prefix_append_both)
done

lemma append_one_gen_prefix: "[| <xs,ys>: gen_prefix(A, r);  length(xs) < length(ys);  refl(A, r) |]
      ==> <xs @ [nth(length(xs), ys)], ys> \<in> gen_prefix(A, r)"
apply (blast intro: append_one_gen_prefix_lemma)
done

(** Proving the equivalence with Charpentier's definition **)

lemma gen_prefix_imp_nth_lemma [rule_format]: "xs \<in> list(A) ==>
  \<forall>ys \<in> list(A). \<forall>i \<in> nat. i < length(xs)
          \<longrightarrow> <xs, ys>: gen_prefix(A, r) \<longrightarrow> <nth(i, xs), nth(i, ys)>:r"
apply (induct_tac "xs", simp, clarify)
apply simp
apply (erule natE, auto)
done

lemma gen_prefix_imp_nth: "[| <xs,ys> \<in> gen_prefix(A,r); i < length(xs)|]
      ==> <nth(i, xs), nth(i, ys)>:r"
apply (cut_tac A = A in gen_prefix.dom_subset)
apply (rule gen_prefix_imp_nth_lemma)
apply (auto simp add: lt_nat_in_nat)
done

lemma nth_imp_gen_prefix [rule_format]: "xs \<in> list(A) ==>
  \<forall>ys \<in> list(A). length(xs) \<le> length(ys)
      \<longrightarrow> (\<forall>i. i < length(xs) \<longrightarrow> <nth(i, xs), nth(i,ys)>:r)
      \<longrightarrow> <xs, ys> \<in> gen_prefix(A, r)"
apply (induct_tac "xs")
apply (simp_all (no_asm_simp))
apply clarify
apply (erule_tac a = ys in list.cases, simp)
apply (force intro!: nat_0_le simp add: lt_nat_in_nat)
done

lemma gen_prefix_iff_nth: "(<xs,ys> \<in> gen_prefix(A,r)) \<longleftrightarrow>
      (xs \<in> list(A) & ys \<in> list(A) & length(xs) \<le> length(ys) &
      (\<forall>i. i < length(xs) \<longrightarrow> <nth(i,xs), nth(i, ys)>: r))"
apply (rule iffI)
apply (frule gen_prefix.dom_subset [THEN subsetD])
apply (frule gen_prefix_length_le, auto)
apply (rule_tac [2] nth_imp_gen_prefix)
apply (drule gen_prefix_imp_nth)
apply (auto simp add: lt_nat_in_nat)
done

(** prefix is a partial order: **)

lemma refl_prefix: "refl(list(A), prefix(A))"
apply (unfold prefix_def)
apply (rule refl_gen_prefix)
apply (auto simp add: refl_def)
done
declare refl_prefix [THEN reflD, simp]

lemma trans_prefix: "trans(prefix(A))"
apply (unfold prefix_def)
apply (rule trans_gen_prefix)
apply (auto simp add: trans_def)
done

lemmas prefix_trans = trans_prefix [THEN transD]

lemma trans_on_prefix: "trans[list(A)](prefix(A))"
apply (unfold prefix_def)
apply (rule trans_on_gen_prefix)
apply (auto simp add: trans_def)
done

lemmas prefix_trans_on = trans_on_prefix [THEN trans_onD]

(* Monotonicity of "set" operator WRT prefix *)

lemma set_of_list_prefix_mono:
"<xs,ys> \<in> prefix(A) ==> set_of_list(xs) \<subseteq> set_of_list(ys)"

apply (unfold prefix_def)
apply (erule gen_prefix.induct)
apply (subgoal_tac [3] "xs \<in> list (A) &ys \<in> list (A) ")
prefer 4 apply (blast dest: gen_prefix.dom_subset [THEN subsetD])
apply (auto simp add: set_of_list_append)
done

(** recursion equations **)

lemma Nil_prefix: "xs \<in> list(A) ==> <[],xs> \<in> prefix(A)"

apply (unfold prefix_def)
apply (simp (no_asm_simp) add: Nil_gen_prefix)
done
declare Nil_prefix [simp]

lemma prefix_Nil: "<xs, []> \<in> prefix(A) \<longleftrightarrow> (xs = [])"

apply (unfold prefix_def, auto)
apply (frule gen_prefix.dom_subset [THEN subsetD])
apply (drule_tac psi = "<xs, []> \<in> gen_prefix (A, id (A))" in asm_rl)
apply (simp add: gen_prefix_Nil)
done
declare prefix_Nil [iff]

lemma Cons_prefix_Cons:
"<Cons(x,xs), Cons(y,ys)> \<in> prefix(A) \<longleftrightarrow> (x=y & <xs,ys> \<in> prefix(A) & y \<in> A)"
apply (unfold prefix_def, auto)
done
declare Cons_prefix_Cons [iff]

lemma same_prefix_prefix:
"xs \<in> list(A)==> <xs@ys,xs@zs> \<in> prefix(A) \<longleftrightarrow> (<ys,zs> \<in> prefix(A))"
apply (unfold prefix_def)
apply (subgoal_tac "refl (A,id (A))")
apply (simp (no_asm_simp))
apply (auto simp add: refl_def)
done
declare same_prefix_prefix [simp]

lemma same_prefix_prefix_Nil: "xs \<in> list(A) ==> <xs@ys,xs> \<in> prefix(A) \<longleftrightarrow> (<ys,[]> \<in> prefix(A))"
apply (rule_tac P = "%x. <u, x>:v \<longleftrightarrow> w(x)" for u v w in app_right_Nil [THEN subst])
apply (rule_tac [2] same_prefix_prefix, auto)
done
declare same_prefix_prefix_Nil [simp]

lemma prefix_appendI:
"[| <xs,ys> \<in> prefix(A); zs \<in> list(A) |] ==> <xs,ys@zs> \<in> prefix(A)"
apply (unfold prefix_def)
apply (erule gen_prefix.append, assumption)
done
declare prefix_appendI [simp]

lemma prefix_Cons:
"[| xs \<in> list(A); ys \<in> list(A); y \<in> A |] ==>
  <xs,Cons(y,ys)> \<in> prefix(A) \<longleftrightarrow>
  (xs=[] | (\<exists>zs. xs=Cons(y,zs) & <zs,ys> \<in> prefix(A)))"
apply (unfold prefix_def)
apply (auto simp add: gen_prefix_Cons)
done

lemma append_one_prefix:
  "[| <xs,ys> \<in> prefix(A); length(xs) < length(ys) |]
  ==> <xs @ [nth(length(xs),ys)], ys> \<in> prefix(A)"
apply (unfold prefix_def)
apply (subgoal_tac "refl (A, id (A))")
apply (simp (no_asm_simp) add: append_one_gen_prefix)
apply (auto simp add: refl_def)
done

lemma prefix_length_le:
"<xs,ys> \<in> prefix(A) ==> length(xs) \<le> length(ys)"
apply (unfold prefix_def)
apply (blast dest: gen_prefix_length_le)
done

lemma prefix_type: "prefix(A)<=list(A)*list(A)"
apply (unfold prefix_def)
apply (blast intro!: gen_prefix.dom_subset)
done

lemma strict_prefix_type:
"strict_prefix(A) \<subseteq> list(A)*list(A)"
apply (unfold strict_prefix_def)
apply (blast intro!: prefix_type [THEN subsetD])
done

lemma strict_prefix_length_lt_aux:
     "<xs,ys> \<in> prefix(A) ==> xs\<noteq>ys \<longrightarrow> length(xs) < length(ys)"
apply (unfold prefix_def)
apply (erule gen_prefix.induct, clarify)
apply (subgoal_tac [!] "ys \<in> list(A) & xs \<in> list(A)")
apply (auto dest: gen_prefix.dom_subset [THEN subsetD]
            simp add: length_type)
apply (subgoal_tac "length (zs) =0")
apply (drule_tac [2] not_lt_imp_le)
apply (rule_tac [5] j = "length (ys) " in lt_trans2)
apply auto
done

lemma strict_prefix_length_lt:
     "<xs,ys>:strict_prefix(A) ==> length(xs) < length(ys)"
apply (unfold strict_prefix_def)
apply (rule strict_prefix_length_lt_aux [THEN mp])
apply (auto dest: prefix_type [THEN subsetD])
done

(*Equivalence to the definition used in Lex/Prefix.thy*)
lemma prefix_iff:
    "<xs,zs> \<in> prefix(A) \<longleftrightarrow> (\<exists>ys \<in> list(A). zs = xs@ys) & xs \<in> list(A)"
apply (unfold prefix_def)
apply (auto simp add: gen_prefix_iff_nth lt_nat_in_nat nth_append nth_type app_type length_app)
apply (subgoal_tac "drop (length (xs), zs) \<in> list (A) ")
apply (rule_tac x = "drop (length (xs), zs) " in bexI)
apply safe
 prefer 2 apply (simp add: length_type drop_type)
apply (rule nth_equalityI)
apply (simp_all (no_asm_simp) add: nth_append app_type drop_type length_app length_drop)
apply (rule nat_diff_split [THEN iffD2], simp_all, clarify)
apply (drule_tac i = "length (zs) " in leI)
apply (force simp add: le_subset_iff, safe)
apply (subgoal_tac "length (xs) #+ (i #- length (xs)) = i")
apply (subst nth_drop)
apply (simp_all (no_asm_simp) add: leI split: nat_diff_split)
done

lemma prefix_snoc:
"[|xs \<in> list(A); ys \<in> list(A); y \<in> A |] ==>
   <xs, ys@[y]> \<in> prefix(A) \<longleftrightarrow> (xs = ys@[y] | <xs,ys> \<in> prefix(A))"
apply (simp (no_asm) add: prefix_iff)
apply (rule iffI, clarify)
apply (erule_tac xs = ysa in rev_list_elim, simp)
apply (simp add: app_type app_assoc [symmetric])
apply (auto simp add: app_assoc app_type)
done
declare prefix_snoc [simp]

lemma prefix_append_iff [rule_format]: "zs \<in> list(A) ==> \<forall>xs \<in> list(A). \<forall>ys \<in> list(A).
   (<xs, ys@zs> \<in> prefix(A)) \<longleftrightarrow>
  (<xs,ys> \<in> prefix(A) | (\<exists>us. xs = ys@us & <us,zs> \<in> prefix(A)))"
apply (erule list_append_induct, force, clarify)
apply (rule iffI)
apply (simp add: add: app_assoc [symmetric])
apply (erule disjE)
apply (rule disjI2)
apply (rule_tac x = "y @ [x]" in exI)
apply (simp add: add: app_assoc [symmetric], force+)
done

(*Although the prefix ordering is not linear, the prefixes of a list
  are linearly ordered.*)
lemma common_prefix_linear_lemma [rule_format]: "[| zs \<in> list(A); xs \<in> list(A); ys \<in> list(A) |]
   ==> <xs, zs> \<in> prefix(A) \<longrightarrow> <ys,zs> \<in> prefix(A)
  \<longrightarrow><xs,ys> \<in> prefix(A) | <ys,xs> \<in> prefix(A)"
apply (erule list_append_induct, auto)
done

lemma common_prefix_linear: "[|<xs, zs> \<in> prefix(A); <ys,zs> \<in> prefix(A) |]
      ==> <xs,ys> \<in> prefix(A) | <ys,xs> \<in> prefix(A)"
apply (cut_tac prefix_type)
apply (blast del: disjCI intro: common_prefix_linear_lemma)
done

(*** pfixLe, pfixGe \<in> properties inherited from the translations ***)

(** pfixLe **)

lemma refl_Le: "refl(nat,Le)"

apply (unfold refl_def, auto)
done
declare refl_Le [simp]

lemma antisym_Le: "antisym(Le)"
apply (unfold antisym_def)
apply (auto intro: le_anti_sym)
done
declare antisym_Le [simp]

lemma trans_on_Le: "trans[nat](Le)"
apply (unfold trans_on_def, auto)
apply (blast intro: le_trans)
done
declare trans_on_Le [simp]

lemma trans_Le: "trans(Le)"
apply (unfold trans_def, auto)
apply (blast intro: le_trans)
done
declare trans_Le [simp]

lemma part_order_Le: "part_order(nat,Le)"
by (unfold part_order_def, auto)
declare part_order_Le [simp]

lemma pfixLe_refl: "x \<in> list(nat) ==> x pfixLe x"
by (blast intro: refl_gen_prefix [THEN reflD] refl_Le)
declare pfixLe_refl [simp]

lemma pfixLe_trans: "[| x pfixLe y; y pfixLe z |] ==> x pfixLe z"
by (blast intro: trans_gen_prefix [THEN transD] trans_Le)

lemma pfixLe_antisym: "[| x pfixLe y; y pfixLe x |] ==> x = y"
by (blast intro: antisym_gen_prefix [THEN antisymE] antisym_Le)

lemma prefix_imp_pfixLe:
"<xs,ys>:prefix(nat)==> xs pfixLe ys"

apply (unfold prefix_def)
apply (rule gen_prefix_mono [THEN subsetD], auto)
done

lemma refl_Ge: "refl(nat, Ge)"
by (unfold refl_def Ge_def, auto)
declare refl_Ge [iff]

lemma antisym_Ge: "antisym(Ge)"
apply (unfold antisym_def Ge_def)
apply (auto intro: le_anti_sym)
done
declare antisym_Ge [iff]

lemma trans_Ge: "trans(Ge)"
apply (unfold trans_def Ge_def)
apply (auto intro: le_trans)
done
declare trans_Ge [iff]

lemma pfixGe_refl: "x \<in> list(nat) ==> x pfixGe x"
by (blast intro: refl_gen_prefix [THEN reflD])
declare pfixGe_refl [simp]

lemma pfixGe_trans: "[| x pfixGe y; y pfixGe z |] ==> x pfixGe z"
by (blast intro: trans_gen_prefix [THEN transD])

lemma pfixGe_antisym: "[| x pfixGe y; y pfixGe x |] ==> x = y"
by (blast intro: antisym_gen_prefix [THEN antisymE])

lemma prefix_imp_pfixGe:
  "<xs,ys>:prefix(nat) ==> xs pfixGe ys"
apply (unfold prefix_def Ge_def)
apply (rule gen_prefix_mono [THEN subsetD], auto)
done
(* Added by Sidi \<in> prefix and take *)

lemma prefix_imp_take:
"<xs, ys> \<in> prefix(A) ==> xs = take(length(xs), ys)"

apply (unfold prefix_def)
apply (erule gen_prefix.induct)
apply (subgoal_tac [3] "length (xs) :nat")
apply (auto dest: gen_prefix.dom_subset [THEN subsetD] simp add: length_type)
apply (frule gen_prefix.dom_subset [THEN subsetD])
apply (frule gen_prefix_length_le)
apply (auto simp add: take_append)
apply (subgoal_tac "length (xs) #- length (ys) =0")
apply (simp_all (no_asm_simp) add: diff_is_0_iff)
done

lemma prefix_length_equal: "[|<xs,ys> \<in> prefix(A); length(xs)=length(ys)|] ==> xs = ys"
apply (cut_tac A = A in prefix_type)
apply (drule subsetD, auto)
apply (drule prefix_imp_take)
apply (erule trans, simp)
done

lemma prefix_length_le_equal: "[|<xs,ys> \<in> prefix(A); length(ys) \<le> length(xs)|] ==> xs = ys"
by (blast intro: prefix_length_equal le_anti_sym prefix_length_le)

lemma take_prefix [rule_format]: "xs \<in> list(A) ==> \<forall>n \<in> nat. <take(n, xs), xs> \<in> prefix(A)"
apply (unfold prefix_def)
apply (erule list.induct, simp, clarify)
apply (erule natE, auto)
done

lemma prefix_take_iff: "<xs,ys> \<in> prefix(A) \<longleftrightarrow> (xs=take(length(xs), ys) & xs \<in> list(A) & ys \<in> list(A))"
apply (rule iffI)
apply (frule prefix_type [THEN subsetD])
apply (blast intro: prefix_imp_take, clarify)
apply (erule ssubst)
apply (blast intro: take_prefix length_type)
done

lemma prefix_imp_nth: "[| <xs,ys> \<in> prefix(A); i < length(xs)|] ==> nth(i,xs) = nth(i,ys)"
by (auto dest!: gen_prefix_imp_nth simp add: prefix_def)

lemma nth_imp_prefix:
     "[|xs \<in> list(A); ys \<in> list(A); length(xs) \<le> length(ys);
        !!i. i < length(xs) ==> nth(i, xs) = nth(i,ys)|]
      ==> <xs,ys> \<in> prefix(A)"
apply (auto simp add: prefix_def nth_imp_gen_prefix)
apply (auto intro!: nth_imp_gen_prefix simp add: prefix_def)
apply (blast intro: nth_type lt_trans2)
done

lemma length_le_prefix_imp_prefix: "[|length(xs) \<le> length(ys);
        <xs,zs> \<in> prefix(A); <ys,zs> \<in> prefix(A)|] ==> <xs,ys> \<in> prefix(A)"
apply (cut_tac A = A in prefix_type)
apply (rule nth_imp_prefix, blast, blast)
 apply assumption
apply (rule_tac b = "nth (i,zs)" in trans)
 apply (blast intro: prefix_imp_nth)
apply (blast intro: sym prefix_imp_nth prefix_length_le lt_trans2)
done

end