(* Authors:  Florian Haftmann and René Neumann, TU Muenchen *)

section \<open>Abstract priority queues\<close>

theory PQ
imports Main
begin

subsection \<open>Generic Lemmas\<close>

lemma tl_set:
  "distinct q \<Longrightarrow> set (tl q) = set q - {hd q}"
  by (cases q) simp_all

subsection \<open>Type of abstract priority queues\<close>

typedef (overloaded) ('a, 'b::linorder) pq =
  "{xs :: ('a \<times> 'b) list. distinct (map fst xs) \<and> sorted (map snd xs)}"
  morphisms alist_of Abs_pq
proof -
  have "[] \<in> ?pq" by simp
  then show ?thesis by blast
qed

lemma alist_of_Abs_pq:
  assumes "distinct (map fst xs)"
    and "sorted (map snd xs)"
  shows "alist_of (Abs_pq xs) = xs"
  by (rule Abs_pq_inverse) (simp add: assms)

lemma [code abstype]:
  "Abs_pq (alist_of q) = q"
  by (fact alist_of_inverse)

lemma distinct_fst_alist_of [simp]:
  "distinct (map fst (alist_of q))"
  using alist_of [of q] by simp

lemma distinct_alist_of [simp]:
  "distinct (alist_of q)"
  using distinct_fst_alist_of [of q] by (simp add: distinct_map)

lemma sorted_snd_alist_of [simp]:
  "sorted (map snd (alist_of q))"
  using alist_of [of q] by simp

lemma alist_of_eqI:
  "alist_of p = alist_of q \<Longrightarrow> p = q"
proof -
  assume "alist_of p = alist_of q"
  then have "Abs_pq (alist_of p) = Abs_pq (alist_of q)" by simp
  thus "p = q" by (simp add: alist_of_inverse)
qed

definition "values" :: "('a, 'b::linorder) pq \<Rightarrow> 'a list" ("|(_)|") where
  "values q = map fst (alist_of q)"

definition priorities :: "('a, 'b::linorder) pq \<Rightarrow> 'b list" ("\<parallel>(_)\<parallel>") where
  "priorities q = map snd (alist_of q)"

lemma values_set:
  "set |q| = fst ` set (alist_of q)"
  by (simp add: values_def)

lemma priorities_set:
  "set \<parallel>q\<parallel> = snd ` set (alist_of q)"
  by (simp add: priorities_def)

definition is_empty :: "('a, 'b::linorder) pq \<Rightarrow> bool" where
  "is_empty q \<longleftrightarrow> alist_of q = []"

definition priority :: "('a, 'b::linorder) pq \<Rightarrow> 'a \<Rightarrow> 'b option" where
  "priority q = map_of (alist_of q)"

definition min :: "('a, 'b::linorder) pq \<Rightarrow> 'a" where
  "min q = fst (hd (alist_of q))"

definition empty :: "('a, 'b::linorder) pq" where
  "empty = Abs_pq []"

lemma is_empty_alist_of [dest]:
  "is_empty q \<Longrightarrow> alist_of q = []"
  by (simp add: is_empty_def)

lemma not_is_empty_alist_of [dest]:
  "\<not> is_empty q \<Longrightarrow> alist_of q \<noteq> []"
  by (simp add: is_empty_def)

lemma alist_of_empty [simp, code abstract]:
  "alist_of empty = []"
  by (simp add: empty_def Abs_pq_inverse)

lemma values_empty [simp]:
  "|empty| = []"
  by (simp add: values_def)

lemma priorities_empty [simp]:
  "\<parallel>empty\<parallel> = []"
  by (simp add: priorities_def)

lemma values_empty_nothing [simp]:
  "\<forall>k. k \<notin> set |empty|"
  by (simp add: values_def)

lemma is_empty_empty:
  "is_empty q \<longleftrightarrow> q = empty"
proof (rule iffI)
  assume "is_empty q"
  then have "alist_of q = []" by (simp add: is_empty_alist_of)
  then have "Abs_pq (alist_of q) = Abs_pq []" by simp
  then show "q = empty" by (simp add: empty_def alist_of_inverse)
qed (simp add: is_empty_def)

lemma is_empty_empty_simp [simp]:
  "is_empty empty"
by (simp add: is_empty_empty)

lemma map_snd_alist_of:
  "map (the \<circ> priority q) (values q) = map snd (alist_of q)"
  by (auto simp add: values_def priority_def)

lemma image_snd_alist_of:
  "the ` priority q ` set (values q) = snd ` set (alist_of q)"
proof -
  from map_snd_alist_of [of q]
    have "set (map (the \<circ> priority q) (values q)) = set (map snd (alist_of q))"
      by (simp only:)
  then show ?thesis by (simp add: image_comp)
qed

lemma Min_snd_alist_of:
  assumes "\<not> is_empty q"
  shows "Min (snd ` set (alist_of q)) = snd (hd (alist_of q))"
proof -
  from assms obtain ps p where q: "map snd (alist_of q) = p # ps"
    by (cases "map snd (alist_of q)") auto
  then have "hd (map snd (alist_of q)) = p" by simp
  with assms have p: "snd (hd (alist_of q)) = p" by (auto simp add: hd_map)
  have "sorted (map snd (alist_of q))" by simp
  with q have "sorted (p # ps)" by simp
  then have "\<forall>p'\<in>set ps. p' \<ge> p" by (simp)
  then have "Min (set (p # ps)) = p" by (auto intro: Min_eqI)
  with p q have "Min (set (map snd (alist_of q))) = snd (hd (alist_of q))"
    by simp
  then show ?thesis by simp
qed

lemma priority_fst:
  assumes "xp \<in> set (alist_of q)"
  shows "priority q (fst xp) = Some (snd xp)"
  using assms by (simp add: priority_def)

lemma priority_Min:
  assumes "\<not> is_empty q"
  shows "priority q (min q) = Some (Min (the ` priority q ` set (values q)))"
  using assms
    by (auto simp add: min_def image_snd_alist_of Min_snd_alist_of priority_fst)

lemma priority_Min_priorities:
  assumes "\<not> is_empty q"
  shows "priority q (min q) = Some (Min (set \<parallel>q\<parallel>))"
  using assms
    by (simp add: priority_Min image_snd_alist_of priorities_def)

definition push :: "'a \<Rightarrow> 'b::linorder \<Rightarrow> ('a, 'b) pq \<Rightarrow> ('a, 'b) pq" where
  "push k p q = Abs_pq (if k \<notin> set (values q)
           then insort_key snd (k, p) (alist_of q)
           else alist_of q)"

lemma Min_snd_hd:
  "q \<noteq> [] \<Longrightarrow> sorted (map snd q) \<Longrightarrow> Min (snd ` set q) = snd (hd q)"
proof (induct q)
  case (Cons x xs) then show ?case by (cases xs) (auto simp add: ord_class.min_def)
qed simp

lemma hd_construct:
  assumes "\<not> is_empty q"
  shows "hd (alist_of q) = (min q, the (priority q (min q)))"
proof -
  from assms have "the (priority q (min q)) = snd (hd (alist_of q))"
    using Min_snd_hd [of "alist_of q"]
      by (auto simp add: priority_Min_priorities priorities_def)
  then show ?thesis by (simp add: min_def)
qed

lemma not_in_first_image:
  "x \<notin> fst ` s \<Longrightarrow> (x, p) \<notin> s"
  by (auto simp add: image_def)

lemma alist_of_push [simp, code abstract]:
  "alist_of (push k p q) =
    (if k \<notin> set (values q) then insort_key snd (k, p) (alist_of q) else alist_of q)"
  using distinct_fst_alist_of [of q]
    by (auto simp add: distinct_map set_insort_key distinct_insort not_in_first_image
      push_def values_def sorted_insort_key intro: alist_of_Abs_pq)

lemma push_values [simp]:
  "set |push k p q| = set |q| \<union> {k}"
  by (auto simp add: values_def set_insort_key)

lemma push_priorities [simp]:
  "k \<notin> set |q| \<Longrightarrow> set \<parallel>push k p q\<parallel> = set \<parallel>q\<parallel> \<union> {p}"
  "k \<in> set |q| \<Longrightarrow> set \<parallel>push k p q\<parallel> = set \<parallel>q\<parallel>"
  by (auto simp add: priorities_def set_insort_key)

lemma not_is_empty_push [simp]:
  "\<not> is_empty (push k p q)"
  by (auto simp add: values_def is_empty_def)

lemma push_commute:
  assumes "a \<noteq> b" and "v \<noteq> w"
  shows "push w b (push v a q) = push v a (push w b q)"
  using assms by (auto intro!: alist_of_eqI insort_key_left_comm)

definition remove_min :: "('a, 'b::linorder) pq \<Rightarrow> ('a, 'b::linorder) pq" where
  "remove_min q = (if is_empty q then empty else Abs_pq (tl (alist_of q)))"

lemma alift_of_remove_min_if [code abstract]:
  "alist_of (remove_min q) = (if is_empty q then [] else tl (alist_of q))"
  by (auto simp add: remove_min_def map_tl sorted_tl distinct_tl alist_of_Abs_pq)

lemma remove_min_empty [simp]:
  "is_empty q \<Longrightarrow> remove_min q = empty"
  by (simp add: remove_min_def)

lemma alist_of_remove_min [simp]:
  "\<not> is_empty q \<Longrightarrow> alist_of (remove_min q) = tl (alist_of q)"
  by (simp add: alift_of_remove_min_if)

lemma values_remove_min [simp]:
  "\<not> is_empty q \<Longrightarrow> values (remove_min q) = tl (values q)"
  by (simp add: values_def map_tl)

lemma set_alist_of_remove_min:
  "\<not> is_empty q \<Longrightarrow> set (alist_of (remove_min q)) =
    set (alist_of q) - {(min q, the (priority q (min q)))}"
  by (simp add: tl_set hd_construct)

definition pop :: "('a, 'b::linorder) pq \<Rightarrow> ('a \<times> ('a, 'b) pq) option" where
  "pop q = (if is_empty q then None else Some (min q, remove_min q))"

lemma pop_simps [simp]:
  "is_empty q \<Longrightarrow> pop q = None"
  "\<not> is_empty q \<Longrightarrow> pop q = Some (min q, remove_min q)"
  by (simp_all add: pop_def)

hide_const (open) Abs_pq alist_of "values" priority empty is_empty push min pop

no_notation
  "PQ.values" ("|(_)|")
  and "PQ.priorities" ("\<parallel>(_)\<parallel>")

end


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

header {* Primitive recursive functions of one variable *}

theory PRecFun2
imports PRecFun
begin

subsection {* Alternative definition of primitive recursive functions of one variable *}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

subsection {* The scheme datatype *}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

subsection {* Indexes of primitive recursive functions of one variables *}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

subsection {* s-1-1 theorem for primitive recursive functions of one variable *}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end


theory LetRec2
imports "../Nominal2"
begin

atom_decl name

nominal_datatype trm =
  Var "name"
| App "trm" "trm"
| Lam x::"name" t::"trm"  binds x in t
| Let as::"assn" t::"trm"   binds "bn as" in t
| Let_rec as::"assn" t::"trm"   binds "bn as" in as t
and assn =
  ANil
| ACons "name" "trm" "assn"
binder
  bn
where
  "bn (ANil) = []"
| "bn (ACons x t as) = (atom x) # (bn as)"

thm trm_assn.eq_iff
thm trm_assn.supp

ML {*
@{term Trueprop} ;
@{const_name HOL.eq}
*}

thm trm_assn.fv_defs
thm trm_assn.eq_iff
thm trm_assn.bn_defs
thm trm_assn.perm_simps
thm trm_assn.induct
thm trm_assn.distinct

section {* Tests *}

(* why is this not in HOL simpset? *)
(*
lemma set_sub: "{a, b} - {b} = {a} - {b}"
by auto

lemma lets_bla:
  "x \<noteq> z \<Longrightarrow> y \<noteq> z \<Longrightarrow> x \<noteq> y \<Longrightarrow>(Lt (Lcons x (Vr y) Lnil) (Vr x)) \<noteq> (Lt (Lcons x (Vr z) Lnil) (Vr x))"
  apply (auto simp add: trm_lts.eq_iff alphas set_sub supp_at_base)
  done

lemma lets_ok:
  "(Lt (Lcons x (Vr x) Lnil) (Vr x)) = (Lt (Lcons y (Vr y) Lnil) (Vr y))"
  apply (simp add: trm_lts.eq_iff)
  apply (rule_tac x="(x \<leftrightarrow> y)" in exI)
  apply (simp_all add: alphas fresh_star_def eqvts supp_at_base)
  done

lemma lets_ok3:
  "x \<noteq> y \<Longrightarrow>
   (Lt (Lcons x (Ap (Vr y) (Vr x)) (Lcons y (Vr y) Lnil)) (Ap (Vr x) (Vr y))) \<noteq>
   (Lt (Lcons y (Ap (Vr x) (Vr y)) (Lcons x (Vr x) Lnil)) (Ap (Vr x) (Vr y)))"
  apply (simp add: alphas trm_lts.eq_iff)
  done

lemma lets_not_ok1:
  "x \<noteq> y \<Longrightarrow>
   (Lt (Lcons x (Vr x) (Lcons y (Vr y) Lnil)) (Ap (Vr x) (Vr y))) \<noteq>
   (Lt (Lcons y (Vr x) (Lcons x (Vr y) Lnil)) (Ap (Vr x) (Vr y)))"
  apply (simp add: alphas trm_lts.eq_iff)
  done

lemma lets_nok:
  "x \<noteq> y \<Longrightarrow> x \<noteq> z \<Longrightarrow> z \<noteq> y \<Longrightarrow>
   (Lt (Lcons x (Ap (Vr z) (Vr z)) (Lcons y (Vr z) Lnil)) (Ap (Vr x) (Vr y))) \<noteq>
   (Lt (Lcons y (Vr z) (Lcons x (Ap (Vr z) (Vr z)) Lnil)) (Ap (Vr x) (Vr y)))"
  apply (simp add: alphas trm_lts.eq_iff fresh_star_def)
  done

lemma lets_ok4:
  "(Lt (Lcons x (Ap (Vr y) (Vr x)) (Lcons y (Vr y) Lnil)) (Ap (Vr x) (Vr y))) =
   (Lt (Lcons y (Ap (Vr x) (Vr y)) (Lcons x (Vr x) Lnil)) (Ap (Vr y) (Vr x)))"
  apply (simp add: alphas trm_lts.eq_iff supp_at_base)
  apply (rule_tac x="(x \<leftrightarrow> y)" in exI)
  apply (simp add: atom_eqvt fresh_star_def)
  done
*)
end


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

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

datatype Nat = Z | S "Nat"

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

fun lt :: "Nat => Nat => bool" where
  "lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun insert :: "Nat => Nat list => Nat list" where
  "insert y (nil2) = cons2 y (nil2)"
| "insert y (cons2 z2 xs) =
     (if le y z2 then cons2 y (cons2 z2 xs) else
        cons2 z2 (insert y xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 z xs) = insert z (isort xs)"

fun gt :: "Nat => Nat => bool" where
  "gt y z = lt z y"

fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter q (nil2) = nil2"
| "filter q (cons2 z xs) =
     (if q z then cons2 z (filter q xs) else filter q xs)"

(*fun did not finish the proof*)
function qsort :: "Nat list => Nat list" where
  "qsort (nil2) = nil2"
| "qsort (cons2 z xs) =
     x (qsort (filter (% (z2 :: Nat) => le z2 z) xs))
       (x (cons2 z (nil2))
          (qsort (filter (% (x2 :: Nat) => gt x2 z) xs)))"
  by pat_completeness auto

theorem property0 :
  "((qsort xs) = (isort xs))"
  oops

end


(* Title: Stream_Fusion_Examples
  Author: Andreas Lochbihler, ETH Zurich *)

section \<open>Examples and test cases for stream fusion\<close>

theory Stream_Fusion_Examples imports Stream_Fusion_LList begin

lemma fixes rhs z
  defines "rhs \<equiv> nth_cons (flatten (\<lambda>s'. s') (upto_prod 17) (upto_prod z)) (2, None) 8"
  shows "nth (List.maps (\<lambda>x. upto x 17) (upto 2 z)) 8 = rhs"
using [[simproc add: stream_fusion, stream_fusion_trace]]
apply(simp del: id_apply) \<comment> \<open>fuses\<close>
by(unfold rhs_def) rule

lemma fixes rhs z
  defines "rhs \<equiv> nth_cons (flatten (\<lambda>s. (s, 1)) (fix_gen (\<lambda>x. upto_prod (id x))) (upto_prod z)) (2, None) 8"
  shows "nth (List.maps (\<lambda>x. upto 1 (id x)) (upto 2 z)) 8 = rhs"
using [[simproc add: stream_fusion, stream_fusion_trace]]
apply(simp del: id_apply) \<comment> \<open>fuses\<close>
by(unfold rhs_def) rule

lemma fixes rhs n
  defines "rhs \<equiv> List.maps (\<lambda>x. [Suc 0..<sum_list_cons (replicate_prod x) x]) [2..<n]"
  shows "(concat (map (\<lambda>x. [1..<sum_list (replicate x x)]) [2..<n])) = rhs"
using [[simproc add: stream_fusion, stream_fusion_trace]]
apply(simp add: concat_map_maps) \<comment> \<open>fuses partially\<close>
by(unfold rhs_def) rule

subsection \<open>Micro-benchmarks from Farmer et al. \cite{FarmerHoenerGill2014PEPM}\<close>

definition test_enum :: "nat \<Rightarrow> nat" \<comment> \<open>@{const id} required to avoid eta contraction\<close>
where "test_enum n = foldl (+) 0 (List.maps (\<lambda>x. upt 1 (id x)) (upt 1 n))"

definition test_nested :: "nat \<Rightarrow> nat"
where "test_nested n = foldl (+) 0 (List.maps (\<lambda>x. List.maps (\<lambda>y. upt y x) (upt 1 x)) (upt 1 n))"

definition test_merge :: "integer \<Rightarrow> nat"
where "test_merge n = foldl (+) 0 (List.maps (\<lambda>x. if 2 dvd x then upt 1 x else upt 2 x) (upt 1 (nat_of_integer n)))"

text \<open>
  This rule performs the merge operation from \cite[\S 5.2]{FarmerHoenerGill2014PEPM} for \<open>if\<close>.
  In general, we would also need it for all case operators.
\<close>
lemma unstream_if [stream_fusion]:
  "unstream (if b then g else g') (if b then s else s') =
   (if b then unstream g s else unstream g' s')"
by simp

lemma if_same [code_unfold]: "(if b then x else x) = x"
by simp

code_thms test_enum
code_thms test_nested
code_thms test_merge

subsection \<open>Test stream fusion in the code generator\<close>

definition fuse_test :: integer
where "fuse_test =
  integer_of_int (lhd (lfilter (\<lambda>x. x < 1) (lappend (lmap (\<lambda>x. x + 1) (llist_of (map (\<lambda>x. if x = 0 then undefined else x) [-3..5]))) (repeat 3))))"

ML_val \<open>val ~2 = @{code fuse_test}\<close> \<comment> \<open>If this test fails with exception Fail, then the stream fusion simproc failed. This test exploits
  that stream fusion introduces laziness.\<close>

end


(* The encoding of LF in Curry-style simply typed lambda calculus *)
theory LF_to_STLC
imports "../Examples/LF" "../Examples/Lambda"
begin

(* Simple types: *)
datatype 'tct stype = Tp 'tct | Omega | Arr "'tct stype" "'tct stype"

nonfree_primrec
  otau :: "('ct,'tct) obj \<Rightarrow> unit"
and
  ftau :: "('ct,'tct) tfam \<Rightarrow> 'tct stype"
and
  ktau :: "('ct,'tct) kind \<Rightarrow> 'tct stype"
where
  "otau (LF.Ct c) = ()"
| "otau (LF.Var x) = ()"
| "otau (LF.Lam A x M) = ()"
| "otau (LF.App M N) = ()"
| "otau (LF.subst M N x) = ()"
(*  *)
| "ftau (LF.Tct a) = Tp a"
| "ftau (LF.Tprod A x B) = Arr (ftau A) (ftau B)"
| "ftau (LF.Tapp A M) = ftau A"
| "ftau (LF.tsubst A N x) = ftau A"
(*  *)
| "ktau Type = Omega"
| "ktau (LF.Kprod A x K) = Arr (ftau A) (ktau K)"
| "ktau (LF.ksubst K N x) = ktau K"
(*  *)
| "LF.fresh x (M :: ('ct,'tct) obj)  ==> True"
| "LF.tfresh x (A :: ('ct,'tct) tfam) ==> True"
| "LF.kfresh x (K :: ('ct, 'tct) kind) ==> True"
by auto

datatype ('ct,'tct) const = Pi "'tct stype" | LFconst 'ct | LFtconst 'tct

lemma [simp]:
assumes "x' \<noteq> x" and "fresh x' Y" and
y: "y = pickFresh [X] []" and z: "z = pickFresh [subst X Y x] []"
shows "subst (Lam y (Lam x' X)) Y x = Lam z (Lam x' (subst X Y x))"
by sorry2
(* Proof: Since above "Lam y" and "Lam z" are dummy abstractions, they can be replaced by some
totally fresh u.  Now,  "subst (Lam u (Lam x' X)) Y x = Lam u (Lam x' (subst X Y x))"
follows by appliying subst_lam twice.  *)

(* The "modulus" operator: Since the package does not support full recursion,
  I need to go through an auxiliary operator returning pairs (just like I did for the finite-set cardinal).
  The only culprit is "ftau A" from the "LF.Tprod A x B" case. *)
nonfree_primrec
  omod' :: "('ct,'tct) obj \<Rightarrow> ('ct,'tct) obj \<times> (var, ('ct,'tct) const) trm"
and
  fmod' :: "('ct,'tct) tfam \<Rightarrow> ('ct,'tct) tfam \<times> (var, ('ct,'tct) const) trm"
and
  kmod' :: "('ct,'tct) kind \<Rightarrow> unit"
where
  "omod' (LF.Ct c) = (LF.Ct c, Ct (LFconst c))"
| "omod' (LF.Var x) = (LF.Var x, Var x)"
| "omod' (LF.Lam A x M) =
   (
    case (fmod' A, omod' M) of ((A,X), (M,Y)) \<Rightarrow>
     (LF.Lam A x M, App (Lam (pickFresh [Y] []) (Lam x (Y))) X)
   )"
| "omod' (LF.App M N) =
   (case (omod' M, omod' N) of ((M,X), (N,Y)) \<Rightarrow>
     (LF.App M N, App X Y)
   )"
| "omod' (LF.subst M N x) =
   (case (omod' M, omod' N) of ((M,X), (N,Y)) \<Rightarrow>
     (LF.subst M N x, subst X Y x)
   )"
(*  *)
| "fmod' (LF.Tct a) = (LF.Tct a, Ct (LFtconst a))"
| "fmod' (LF.Tprod A x B) =
   (
    case (fmod' A, fmod' B) of ((A,X), (B,Y)) \<Rightarrow>
     (LF.Tprod A x B, App (App (Ct (Pi (ftau A))) X) (Lam x Y))
   )"
| "fmod' (LF.Tapp A M) =
   (
    case (fmod' A, omod' M) of ((A,X), (M,Y)) \<Rightarrow>
     (LF.Tapp A M, App X Y)
   )"
| "fmod' (LF.tsubst A N x) =
  (
   case (fmod' A, omod' N) of ((A,X), (N,Y)) \<Rightarrow>
    (LF.tsubst A N x, subst X Y x)
  )"
(*  *)
| "kmod' Type = ()"
| "kmod' (LF.Kprod A x K) = ()"
| "kmod' (LF.ksubst K N x) = ()"
(*  *)
| "LF.fresh x M ==> LF.fresh x (fst (omod' M)) \<and> fresh x (snd (omod' M))"
| "LF.tfresh x A ==> LF.tfresh x (fst (fmod' A)) \<and> fresh x (snd (fmod' A))"
| "LF.kfresh x (K :: ('ct,'tct) kind) ==> True"
by auto

lemma fst_omod'[simp]: "fst (omod' M) = M"
apply(induction rule: obj_induct[of "\<lambda> A. fst (fmod' A) = A" "\<lambda> M. fst (omod' M) = M"])
by (auto split: prod.splits)

lemma omod'_Pair: "omod' M = (M',X) \<Longrightarrow> M = M'"
using fst_omod' by (metis fst_conv)

lemma fst_fmod'[simp]: "fst (fmod' A) = A"
apply(induction rule: tfam_induct[of "\<lambda> A. fst (fmod' A) = A" "\<lambda> M. fst (omod' M) = M"]) apply auto
by (auto split: prod.splits dest: omod'_Pair)

lemma fmod'_Pair: "fmod' A = (A',X) \<Longrightarrow> A = A'"
using fst_fmod' by (metis fst_conv)

definition "omod \<equiv> snd o omod'"
definition "fmod \<equiv> snd o fmod'"

lemma mod_simps[simp]:
"omod (LF.Ct c) = Ct (LFconst c)"
"omod (LF.Var x) = Var x"
"omod (LF.Lam A x M) = App (Lam (pickFresh [omod M] [])
                           (Lam x (omod M))) (fmod A)"
"omod (LF.App M N) = App (omod M) (omod N)"
(*  *)
"fmod (LF.Tct a) = Ct (LFtconst a)"
"fmod (LF.Tprod A x B) = App (App (Ct (Pi (ftau A))) (fmod A)) (Lam x (fmod B))"
"fmod (LF.Tapp A M) = App (fmod A) (omod M)"
unfolding omod_def fmod_def by (auto split: prod.split dest: fmod'_Pair)

lemma mod_subst[simp]:
"omod (LF.subst M N x) = subst (omod M) (omod N) x"
"fmod (LF.tsubst A N x) = subst (fmod A) (omod N) x"
unfolding omod_def fmod_def by (auto split: prod.splits)

lemma mod_fresh[simp]:
"LF.fresh x M \<Longrightarrow> fresh x (omod M)"
"LF.tfresh x A \<Longrightarrow> fresh x (fmod A)"
unfolding omod_def fmod_def by (auto split: prod.splits)

end


theory Primed_Typed_Predicate_Language
  imports Typed_Predicate_Language
begin

text \<open>
Extend the predicate language with a concept of original and primed variables
\<close>

datatype 'var Primed =
  Orig "'var" ("_\<^sup>o" [1000] 1000)
| Prime "'var" ("_`" [1000] 1000)

type_synonym ('var,'val) rexp = "('var Primed,'val) exp"
type_synonym ('var,'val) rpred = "('var Primed,'val) pred"

abbreviation transition (infixr "\<mapsto>" 50)
  where "transition m\<^sub>1 m\<^sub>2 \<equiv> case_Primed m\<^sub>1 m\<^sub>2"

definition reflexive :: "('var,'val) rpred \<Rightarrow> bool"
  where "reflexive R \<equiv> \<forall>m \<Gamma>. test (m \<mapsto> m) (\<Gamma> \<mapsto> \<Gamma>) R"

definition transitive :: "('var,'val) rpred \<Rightarrow> bool"
  where "transitive R \<equiv> \<forall>m \<Gamma> m' \<Gamma>' m'' \<Gamma>''.
    test (m \<mapsto> m') (\<Gamma> \<mapsto> \<Gamma>') R \<longrightarrow> test (m' \<mapsto> m'') (\<Gamma>' \<mapsto> \<Gamma>'') R \<longrightarrow> test (m \<mapsto> m'') (\<Gamma> \<mapsto> \<Gamma>'') R"

definition preserved :: "('var,'val) pred \<Rightarrow> ('var,'val) rpred"
  where "preserved P \<equiv> map\<^sub>p Orig P \<longrightarrow>\<^sub>p  map\<^sub>p Prime P"

definition \<Gamma>_env_wf :: "('Var,'Val) rpred \<Rightarrow> bool"
  where "\<Gamma>_env_wf P \<equiv> \<forall>m m' \<Gamma> \<Gamma>' \<Gamma>n \<Gamma>n'. test (m \<mapsto> m') (\<Gamma> \<mapsto> \<Gamma>') P \<and> \<Gamma> \<sqsupseteq> \<Gamma>n \<and> \<Gamma>n' \<sqsupseteq> \<Gamma>' \<longrightarrow> test (m \<mapsto> m') (\<Gamma>n \<mapsto> \<Gamma>n') P"

(* Functions to lift predicates over one memory to two *)
definition orig\<^sub>e :: "('var, 'val) exp \<Rightarrow> ('var Primed, 'val) exp"
  where "orig\<^sub>e P \<equiv> map\<^sub>e Orig P"

definition orig :: "('var, 'val) pred \<Rightarrow> ('var , 'val) rpred"
  where "orig P \<equiv> map\<^sub>p Orig P"

definition prime :: "('var, 'val) pred \<Rightarrow> ('var , 'val) rpred"
  where "prime P \<equiv> map\<^sub>p Prime P"

(* Functions to drop predicates over two memories to one *)
definition unprime\<^sub>r :: "('var, 'val) rpred \<Rightarrow> ('var, 'val) pred"
  where "unprime\<^sub>r P \<equiv> map\<^sub>p (case_Primed id id) P"

lemma test_unprime [simp]:
  "test m \<Gamma> (unprime\<^sub>r G) = (test (m \<mapsto> m) (\<Gamma> \<mapsto> \<Gamma>) G)"
proof -
  have "test (m \<mapsto> m) (\<Gamma> \<mapsto> \<Gamma>) G = test  m \<Gamma> (unprime\<^sub>r G)"
    by (auto intro!: map\<^sub>p_vars_det simp: unprime\<^sub>r_def split: Primed.splits)
  thus ?thesis by auto
qed

lemma [simp]:
  "eval (m \<mapsto> m') (orig\<^sub>e e) = eval m e"
proof -
  have "eval m e = eval (m \<mapsto> m') (orig\<^sub>e e)"
    by (auto intro!: map\<^sub>e_vars_det simp: orig\<^sub>e_def)
  thus ?thesis by auto
qed

lemma [simp]:
  "test (m \<mapsto> m') (\<Gamma> \<mapsto> \<Gamma>') (orig e) = test m \<Gamma> e"
proof -
  have "test m \<Gamma> e = test (m \<mapsto> m') (\<Gamma> \<mapsto> \<Gamma>') (orig e)"
    by (auto intro!: map\<^sub>p_vars_det simp: orig_def)
  thus ?thesis by auto
qed

end


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

  theorem x0 :
    "(subset x y) ==> ((intersect x y) = x)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory negation_properties
  imports "../conditions/conditions_relativized"
begin

section \<open>Properties of negation(-like) operators\<close>

(*Introduces convenient notation for type for properties of operators (to avoid clutter)*)
type_synonym 'w \<Omega> = "('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool"
type_synonym 'w \<Delta> = "('w \<sigma> \<Rightarrow> 'w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> ('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool"

named_theorems neg (*to group together definitions for properties of negations*)

subsection \<open>Principles of excluded middle, contradiction and explosion\<close>

(**TND: tertium non datur, aka. law of excluded middle (resp. strong, weak, minimal).*)
abbreviation pTND  ("TND\<^sup>_  _") where "TND\<^sup>a  \<eta> \<equiv>       \<^bold>\<top>  \<approx> a \<^bold>\<or> (\<eta> a)"
abbreviation pTNDw ("TNDw\<^sup>_ _") where "TNDw\<^sup>a \<eta> \<equiv> \<forall>b. (\<eta> b) \<preceq> a \<^bold>\<or> (\<eta> a)"
abbreviation pTNDm ("TNDm\<^sup>_ _") where "TNDm\<^sup>a \<eta> \<equiv>     (\<eta> \<^bold>\<bottom>) \<preceq> a \<^bold>\<or> (\<eta> a)"
definition TND ::"'w \<Omega>" where "TND  \<eta> \<equiv> \<forall>\<phi>. TND\<^sup>\<phi>  \<eta>"
definition TNDw::"'w \<Omega>" where "TNDw \<eta> \<equiv> \<forall>\<phi>. TNDw\<^sup>\<phi> \<eta>"
definition TNDm::"'w \<Omega>" where "TNDm \<eta> \<equiv> \<forall>\<phi>. TNDm\<^sup>\<phi> \<eta>"
declare TND_def[neg] TNDw_def[neg] TNDm_def[neg]

(**Explore some (non)entailment relations:*)
lemma "TND  \<eta> \<Longrightarrow> TNDw \<eta>" unfolding neg conn order by simp
lemma "TNDw \<eta> \<Longrightarrow> TND  \<eta>" nitpick oops
lemma "TNDw \<eta> \<Longrightarrow> TNDm \<eta>" unfolding neg by simp
lemma "TNDm \<eta> \<Longrightarrow> TNDw \<eta>" nitpick oops

(**ECQ: ex contradictione (sequitur) quodlibet (resp: strong, weak, minimal).*)
abbreviation pECQ  ("ECQ\<^sup>_ _")  where "ECQ\<^sup>a  \<eta> \<equiv>     a \<^bold>\<and> (\<eta> a) \<approx> \<^bold>\<bottom>"
abbreviation pECQw ("ECQw\<^sup>_ _") where "ECQw\<^sup>a \<eta> \<equiv> \<forall>b. a \<^bold>\<and> (\<eta> a) \<preceq> (\<eta> b)"
abbreviation pECQm ("ECQm\<^sup>_ _") where "ECQm\<^sup>a \<eta> \<equiv>     a \<^bold>\<and> (\<eta> a) \<preceq> (\<eta> \<^bold>\<top>)"
definition ECQ ::"'w \<Omega>" where  "ECQ \<eta> \<equiv> \<forall>a. ECQ\<^sup>a  \<eta>"
definition ECQw::"'w \<Omega>" where "ECQw \<eta> \<equiv> \<forall>a. ECQw\<^sup>a \<eta>"
definition ECQm::"'w \<Omega>" where "ECQm \<eta> \<equiv> \<forall>a. ECQm\<^sup>a \<eta>"
declare ECQ_def[neg] ECQw_def[neg] ECQm_def[neg]

(**Explore some (non)entailment relations:*)
lemma "ECQ  \<eta> \<Longrightarrow> ECQw \<eta>" unfolding neg conn order by blast
lemma "ECQw \<eta> \<Longrightarrow> ECQ  \<eta>" nitpick oops
lemma "ECQw \<eta> \<Longrightarrow> ECQm \<eta>" unfolding neg by simp
lemma "ECQm \<eta> \<Longrightarrow> ECQw \<eta>" nitpick oops

(**LNC: law of non-contradiction.*)
abbreviation pLNC  ("LNC\<^sup>_ _")  where "LNC\<^sup>a \<eta> \<equiv> \<eta>(a \<^bold>\<and> \<eta> a) \<approx> \<^bold>\<top>"
definition LNC::"'w \<Omega>" where "LNC \<eta> \<equiv> \<forall>a. LNC\<^sup>a \<eta>"
declare LNC_def[neg]

(**ECQ and LNC are in general independent.*)
lemma "ECQ \<eta> \<Longrightarrow> LNC \<eta>" nitpick oops
lemma "LNC \<eta> \<Longrightarrow> ECQm \<eta>" nitpick oops

subsection \<open>Contraposition rules\<close>

(**CoP: contraposition (global/rule variants).
Variant 0 is antitonicity (ANTI). Variants 1-3 are stronger.*)
abbreviation pCoP1 ("CoP1\<^sup>_\<^sup>_ _") where "CoP1\<^sup>a\<^sup>b \<eta> \<equiv> a \<preceq> (\<eta> b) \<longrightarrow> b \<preceq> (\<eta> a)"
abbreviation pCoP2 ("CoP2\<^sup>_\<^sup>_ _") where "CoP2\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<preceq> b \<longrightarrow> (\<eta> b) \<preceq> a"
abbreviation pCoP3 ("CoP3\<^sup>_\<^sup>_ _") where "CoP3\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<preceq> (\<eta> b) \<longrightarrow> b \<preceq> a"

abbreviation CoP0 ::"'w \<Omega>" where "CoP0  \<eta> \<equiv> ANTI \<eta>"
definition   CoP1 ::"'w \<Omega>" where "CoP1  \<eta> \<equiv> \<forall>a b. CoP1\<^sup>a\<^sup>b \<eta>"
definition   CoP1'::"'w \<Omega>" where "CoP1' \<eta> \<equiv> \<forall>a b. a \<preceq> (\<eta> b) \<longleftrightarrow> b \<preceq> (\<eta> a)"
definition   CoP2 ::"'w \<Omega>" where "CoP2  \<eta> \<equiv> \<forall>a b. CoP2\<^sup>a\<^sup>b \<eta>"
definition   CoP2'::"'w \<Omega>" where "CoP2' \<eta> \<equiv> \<forall>a b. (\<eta> a) \<preceq> b \<longleftrightarrow> (\<eta> b) \<preceq> a"
definition   CoP3 ::"'w \<Omega>" where "CoP3  \<eta> \<equiv> \<forall>a b. CoP3\<^sup>a\<^sup>b \<eta>"

lemma CoP1_defs_rel: "CoP1 \<eta> = CoP1' \<eta>" unfolding neg CoP1_def CoP1'_def by blast
lemma CoP2_defs_rel: "CoP2 \<eta> = CoP2' \<eta>" unfolding neg CoP2_def CoP2'_def by blast

declare CoP1_def[neg] CoP2_def[neg] CoP3_def[neg]

(**Explore some (non)entailment relations:*)
lemma "CoP1 \<eta> \<Longrightarrow> CoP0 \<eta>" by (metis (mono_tags) ANTI_def CoP1_def subset_char1)
lemma "CoP0 \<eta> \<Longrightarrow> CoP1 \<eta>" nitpick oops
lemma "CoP2 \<eta> \<Longrightarrow> CoP0 \<eta>" by (metis ANTI_def CoP2_def subset_char1)
lemma "CoP0 \<eta> \<Longrightarrow> CoP2 \<eta>" nitpick oops
lemma "CoP3 \<eta> \<Longrightarrow> CoP0 \<eta>" unfolding neg (*nitpick*) oops (**no countermodel found so far. TODO: verify*)
lemma "CoP0 \<eta> \<Longrightarrow> CoP3 \<eta>" nitpick oops

(**All three strong variants are pairwise independent. However, CoP3 follows from CoP1 plus CoP2.*)
lemma CoP123: "CoP1 \<eta> \<Longrightarrow> CoP2 \<eta> \<Longrightarrow> CoP3 \<eta>" unfolding neg order by smt
(**Taking all CoP together still leaves room for a boldly paraconsistent resp. paracomplete logic.*)
lemma "CoP1 \<eta> \<Longrightarrow> CoP2 \<eta> \<Longrightarrow> ECQm \<eta>" nitpick oops
lemma "CoP1 \<eta> \<Longrightarrow> CoP2 \<eta> \<Longrightarrow> TNDm \<eta>" nitpick oops

subsection \<open>Modus tollens rules\<close>

(**MT: modus (tollendo) tollens (global/rule variants).*)
abbreviation pMT0 ("MT0\<^sup>_\<^sup>_ _") where "MT0\<^sup>a\<^sup>b \<eta> \<equiv> a \<preceq> b \<and> (\<eta> b) \<approx> \<^bold>\<top> \<longrightarrow> (\<eta> a) \<approx> \<^bold>\<top>"
abbreviation pMT1 ("MT1\<^sup>_\<^sup>_ _") where "MT1\<^sup>a\<^sup>b \<eta> \<equiv> a \<preceq> (\<eta> b) \<and> b \<approx> \<^bold>\<top> \<longrightarrow> (\<eta> a) \<approx> \<^bold>\<top>"
abbreviation pMT2 ("MT2\<^sup>_\<^sup>_ _") where "MT2\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<preceq> b \<and> (\<eta> b) \<approx> \<^bold>\<top> \<longrightarrow> a \<approx> \<^bold>\<top>"
abbreviation pMT3 ("MT3\<^sup>_\<^sup>_ _") where "MT3\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<preceq> (\<eta> b) \<and> b \<approx> \<^bold>\<top> \<longrightarrow> a \<approx> \<^bold>\<top>"
definition MT0::"'w \<Omega>" where "MT0 \<eta> \<equiv> \<forall>a b. MT0\<^sup>a\<^sup>b \<eta>"
definition MT1::"'w \<Omega>" where "MT1 \<eta> \<equiv> \<forall>a b. MT1\<^sup>a\<^sup>b \<eta>"
definition MT2::"'w \<Omega>" where "MT2 \<eta> \<equiv> \<forall>a b. MT2\<^sup>a\<^sup>b \<eta>"
definition MT3::"'w \<Omega>" where "MT3 \<eta> \<equiv> \<forall>a b. MT3\<^sup>a\<^sup>b \<eta>"

declare MT0_def[neg] MT1_def[neg] MT2_def[neg] MT3_def[neg]

(**Again, all MT variants are pairwise independent. We explore some (non)entailment relations:*)
lemma "CoP0 \<eta> \<Longrightarrow> MT0 \<eta>" unfolding neg order cond conn by blast
lemma "CoP1 \<eta> \<Longrightarrow> MT1 \<eta>" unfolding neg order conn by blast
lemma "CoP2 \<eta> \<Longrightarrow> MT2 \<eta>" unfolding neg order conn by blast
lemma "CoP3 \<eta> \<Longrightarrow> MT3 \<eta>" unfolding neg order conn by blast
lemma "MT0 \<eta> \<Longrightarrow> MT1 \<eta> \<Longrightarrow> MT2 \<eta> \<Longrightarrow> MT3 \<eta> \<Longrightarrow> CoP0 \<eta>" nitpick oops
lemma "MT0 \<eta> \<Longrightarrow> MT1 \<eta> \<Longrightarrow> MT2 \<eta> \<Longrightarrow> MT3 \<eta> \<Longrightarrow> ECQm \<eta>" nitpick oops
lemma "MT0 \<eta> \<Longrightarrow> MT1 \<eta> \<Longrightarrow> MT2 \<eta> \<Longrightarrow> MT3 \<eta> \<Longrightarrow> TNDm \<eta>" nitpick oops
lemma MT123: "MT1 \<eta> \<Longrightarrow> MT2 \<eta> \<Longrightarrow> MT3 \<eta>"  unfolding neg order conn by metis

subsection \<open>Double negation introduction and elimination\<close>

(**DNI/DNE: double negation introduction/elimination (as axioms).*)
abbreviation pDNI ("DNI\<^sup>_ _") where "DNI\<^sup>a \<eta> \<equiv> a \<preceq> \<eta> (\<eta> a)"
abbreviation pDNE ("DNE\<^sup>_ _") where "DNE\<^sup>a \<eta> \<equiv> \<eta> (\<eta> a) \<preceq> a"
definition DNI::"'w \<Omega>" where "DNI \<eta> \<equiv> \<forall>a. DNI\<^sup>a \<eta>"
definition DNE::"'w \<Omega>" where "DNE \<eta> \<equiv> \<forall>a. DNE\<^sup>a \<eta>"
declare DNI_def[neg] DNE_def[neg]

(**CoP1 (resp. CoP2) can alternatively be defined as CoPw plus DNI (resp. DNE).*)
lemma "DNI \<eta> \<Longrightarrow> CoP1 \<eta>" nitpick oops
lemma CoP1_def2: "CoP1 \<eta> = (CoP0 \<eta> \<and> DNI \<eta>)" unfolding neg cond using subset_char2 by blast
lemma "DNE \<eta> \<Longrightarrow>  CoP2 \<eta>" nitpick oops
lemma CoP2_def2: "CoP2 \<eta> = (CoP0 \<eta> \<and> DNE \<eta>)" unfolding neg cond using subset_char1 by blast

(**Explore some non-entailment relations:*)
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> CoP0 \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> TNDm \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> ECQm \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> MT0 \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> MT1 \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> MT2 \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> MT3 \<eta>" nitpick oops

(**DNI/DNE: double negation introduction/elimination (as rules).*)
abbreviation prDNI ("rDNI\<^sup>_ _") where "rDNI\<^sup>a \<eta> \<equiv> a \<approx> \<^bold>\<top> \<longrightarrow> \<eta> (\<eta> a) \<approx> \<^bold>\<top>"
abbreviation prDNE ("rDNE\<^sup>_ _") where "rDNE\<^sup>a \<eta> \<equiv> \<eta> (\<eta> a) \<approx> \<^bold>\<top> \<longrightarrow> a \<approx> \<^bold>\<top>"
definition rDNI::"'w \<Omega>" where "rDNI \<eta> \<equiv> \<forall>a. rDNI\<^sup>a \<eta>"
definition rDNE::"'w \<Omega>" where "rDNE \<eta> \<equiv> \<forall>a. rDNE\<^sup>a \<eta>"
declare rDNI_def[neg] rDNE_def[neg]

(**The rule variants are strictly weaker than the axiom variants,*)
lemma "DNI \<eta> \<Longrightarrow> rDNI \<eta>" unfolding neg order conn by simp
lemma "rDNI \<eta> \<Longrightarrow> DNI \<eta>" nitpick oops
lemma "DNE \<eta> \<Longrightarrow> rDNE \<eta>" unfolding neg order conn by blast
lemma "rDNE \<eta> \<Longrightarrow> DNE \<eta>" nitpick oops
(**and follow already from modus tollens.*)
lemma MT1_rDNI: "MT1 \<eta> \<Longrightarrow> rDNI \<eta>" unfolding neg order by blast
lemma MT2_rDNE: "MT2 \<eta> \<Longrightarrow> rDNE \<eta>" unfolding neg order by blast

subsection \<open>(anti)normality and its dual\<close>

(**nNORM (resp. nDNRM) is entailed by CoP1 (resp. CoP2). *)
lemma CoP1_NORM: "CoP1 \<eta> \<Longrightarrow> nNORM \<eta>" unfolding neg cond conn order by simp
lemma CoP2_DNRM: "CoP2 \<eta> \<Longrightarrow> nDNRM \<eta>" unfolding neg cond conn by (smt (verit) setequ_char subset_def)
lemma "DNI \<eta> \<Longrightarrow> nNORM \<eta>" nitpick oops
lemma "DNE \<eta> \<Longrightarrow> nDNRM \<eta>" nitpick oops
(**nNORM and nDNRM together entail the rule variant of DNI (rDNI).*)
lemma nDNRM_rDNI: "nNORM \<eta> \<Longrightarrow> nDNRM \<eta> \<Longrightarrow> rDNI \<eta>" unfolding neg cond by (simp add: setequ_ext)
lemma "nNORM \<eta> \<Longrightarrow> nDNRM \<eta> \<Longrightarrow> rDNE \<eta>" nitpick oops

subsection \<open>De Morgan laws\<close>

(**De Morgan laws correspond to anti-additivity and anti-multiplicativity)*)

(**DM3 (resp. DM4) are entailed by CoP0/ANTI together with DNE (resp. DNI).*)
lemma CoP0_DNE_nMULTb: "CoP0 \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> nMULT\<^sup>b \<eta>" unfolding neg cond by (metis ANTI_def ANTI_nADDIb L12 nADDI_b_def subset_char1)
lemma CoP0_DNI_nADDIa: "CoP0 \<eta> \<Longrightarrow> DNI \<eta> \<Longrightarrow> nADDI\<^sup>a \<eta>" unfolding neg cond by (metis ANTI_def ANTI_nMULTa L11 nMULT_a_def subset_char2)

(**From this follows that DM3 (resp. DM4) is entailed by CoP2 (resp. CoP1).*)
lemma CoP2_nMULTb: "CoP2 \<eta> \<Longrightarrow> nMULT\<^sup>b \<eta>" by (simp add: CoP0_DNE_nMULTb CoP2_def2)
lemma CoP1_nADDIa: "CoP1 \<eta> \<Longrightarrow> nADDI\<^sup>a \<eta>" by (simp add: CoP0_DNI_nADDIa CoP1_def2)

(**Explore some non-entailment relations:*)
lemma "CoP0 \<eta> \<Longrightarrow> nADDI\<^sup>a \<eta> \<Longrightarrow> nMULT\<^sup>b \<eta> \<Longrightarrow> nNORM \<eta> \<Longrightarrow> nDNRM \<eta> \<Longrightarrow> DNI \<eta>" nitpick oops
lemma "CoP0 \<eta> \<Longrightarrow> nADDI\<^sup>a \<eta> \<Longrightarrow> nMULT\<^sup>b \<eta> \<Longrightarrow> nNORM \<eta> \<Longrightarrow> nDNRM \<eta> \<Longrightarrow> DNE \<eta>" nitpick oops
lemma "CoP0 \<eta> \<Longrightarrow> nADDI\<^sup>a \<eta> \<Longrightarrow> nMULT\<^sup>b \<eta> \<Longrightarrow> DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> ECQm \<eta>" nitpick oops
lemma "CoP0 \<eta> \<Longrightarrow> nADDI\<^sup>a \<eta> \<Longrightarrow> nMULT\<^sup>b \<eta> \<Longrightarrow> DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> TNDm \<eta>" nitpick oops

subsection \<open>Contextual (strong) contraposition rule\<close>

(**XCoP: contextual contraposition (global/rule variant).*)
abbreviation pXCoP ("XCoP\<^sup>_\<^sup>_ _") where "XCoP\<^sup>a\<^sup>b \<eta> \<equiv> \<forall>c. c \<^bold>\<and> a \<preceq> b \<longrightarrow> c \<^bold>\<and> (\<eta> b) \<preceq> (\<eta> a)"
definition XCoP::"'w \<Omega>" where "XCoP \<eta> \<equiv> \<forall>a b. XCoP\<^sup>a\<^sup>b \<eta>"
declare XCoP_def[neg]

(**XCoP can alternatively be defined as ECQw plus TNDw.*)
lemma XCoP_def2: "XCoP \<eta> = (ECQw \<eta> \<and> TNDw \<eta>)" proof -
  have LtoR1: "XCoP \<eta> \<Longrightarrow> ECQw \<eta>" unfolding neg conn order by blast
  have LtoR2: "XCoP \<eta> \<Longrightarrow> TNDw \<eta>" sorry (*this holds. TODO reconstruct (use atomicity)*)
  have RtoL: "ECQw \<eta> \<and> TNDw \<eta> \<Longrightarrow> XCoP \<eta>" unfolding neg by (smt (verit, del_insts) join_def meet_def subset_def)
  from LtoR1 LtoR2 RtoL show ?thesis by blast
qed

(**Explore some (non)entailment relations:*)
lemma "XCoP \<eta> \<Longrightarrow> ECQ \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> TND \<eta>" nitpick oops
lemma XCoP_CoPw: "XCoP \<eta> \<Longrightarrow> CoP0 \<eta>" unfolding neg cond by (metis (full_types) meet_def subset_def)
lemma "XCoP \<eta> \<Longrightarrow> CoP1 \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> CoP2 \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> CoP3 \<eta>" nitpick oops
lemma "CoP1 \<eta> \<and> CoP2 \<eta> \<Longrightarrow> XCoP \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> nNORM \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> nDNRM \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> rDNI \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> rDNE \<eta>" nitpick oops
lemma XCoP_nMULTb: "XCoP \<eta> \<Longrightarrow> nMULT\<^sup>b \<eta>" sorry (*this holds. TODO reconstruct (use atomicity)*)
lemma XCoP_nADDIa: "XCoP \<eta> \<Longrightarrow> nADDI\<^sup>a \<eta>" sorry (*this holds. TODO reconstruct (use atomicity)*)

subsection \<open>Local contraposition axioms\<close>
(**Observe that the definitions below take implication as an additional parameter: @{text "\<iota>"}.*)

(**lCoP: contraposition (local/axiom variants).*)
abbreviation plCoP0 ("lCoP0\<^sup>_\<^sup>_ _ _") where "lCoP0\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> a b) \<preceq> (\<iota> (\<eta> b) (\<eta> a))"
abbreviation plCoP1 ("lCoP1\<^sup>_\<^sup>_ _ _") where "lCoP1\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> a (\<eta> b)) \<preceq> (\<iota> b (\<eta> a))"
abbreviation plCoP2 ("lCoP2\<^sup>_\<^sup>_ _ _") where "lCoP2\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> (\<eta> a) b) \<preceq> (\<iota> (\<eta> b) a)"
abbreviation plCoP3 ("lCoP3\<^sup>_\<^sup>_ _ _") where "lCoP3\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> (\<eta> a) (\<eta> b)) \<preceq> (\<iota> b a)"
definition lCoP0::"'w \<Delta>"  where "lCoP0  \<iota> \<eta> \<equiv> \<forall>a b. lCoP0\<^sup>a\<^sup>b \<iota> \<eta>"
definition lCoP1::"'w \<Delta>"  where "lCoP1  \<iota> \<eta> \<equiv> \<forall>a b. lCoP1\<^sup>a\<^sup>b \<iota> \<eta>"
definition lCoP1'::"'w \<Delta>" where "lCoP1' \<iota> \<eta> \<equiv> \<forall>a b. (\<iota> a (\<eta> b)) \<approx> (\<iota> b (\<eta> a))"
definition lCoP2::"'w \<Delta>"  where "lCoP2  \<iota> \<eta> \<equiv> \<forall>a b. lCoP2\<^sup>a\<^sup>b \<iota> \<eta>"
definition lCoP2'::"'w \<Delta>" where "lCoP2' \<iota> \<eta> \<equiv> \<forall>a b. (\<iota> (\<eta> a) b) \<approx> (\<iota> (\<eta> b) a)"
definition lCoP3::"'w \<Delta>"  where "lCoP3  \<iota> \<eta> \<equiv> \<forall>a b. lCoP3\<^sup>a\<^sup>b \<iota> \<eta>"

lemma lCoP1_defs_rel: "lCoP1 \<iota> \<eta> = lCoP1' \<iota> \<eta>" by (metis (mono_tags) lCoP1'_def lCoP1_def setequ_char)
lemma lCoP2_defs_rel: "lCoP2 \<iota> \<eta> = lCoP2' \<iota> \<eta>" using lCoP2'_def lCoP2_def setequ_char by blast

declare lCoP0_def[neg] lCoP1_def[neg] lCoP2_def[neg] lCoP3_def[neg]

(**All local contraposition variants are in general independent from each other.
However if we take classical implication we can verify some relationships.*)

lemma lCoP1_def2: "lCoP1(\<^bold>\<rightarrow>) \<eta> = (lCoP0(\<^bold>\<rightarrow>) \<eta> \<and> DNI \<eta>)" unfolding neg conn order by metis
lemma lCoP2_def2: "lCoP2(\<^bold>\<rightarrow>) \<eta> = (lCoP0(\<^bold>\<rightarrow>) \<eta> \<and> DNE \<eta>)" unfolding neg conn order by blast
lemma "lCoP1(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoP0(\<^bold>\<rightarrow>) \<eta>" unfolding neg conn order by blast
lemma "lCoP0(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoP1(\<^bold>\<rightarrow>) \<eta>" nitpick oops
lemma "lCoP2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoP0(\<^bold>\<rightarrow>) \<eta>" unfolding neg conn order by blast
lemma "lCoP0(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoP2(\<^bold>\<rightarrow>) \<eta>" nitpick oops
lemma "lCoP3(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoP0(\<^bold>\<rightarrow>) \<eta>" unfolding neg conn order by blast
lemma "lCoP0(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoP3(\<^bold>\<rightarrow>) \<eta>" nitpick oops
lemma lCoP123: "lCoP1(\<^bold>\<rightarrow>) \<eta> \<and> lCoP2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoP3(\<^bold>\<rightarrow>) \<eta>" unfolding neg conn order by metis

(**Local variants imply global ones as expected.*)
lemma "lCoP0(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> CoP0 \<eta>" unfolding neg cond conn order by blast
lemma "lCoP1(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> CoP1 \<eta>" unfolding neg conn order by blast
lemma "lCoP2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> CoP2 \<eta>" unfolding neg conn order by blast
lemma "lCoP3(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> CoP3 \<eta>" unfolding neg conn order by blast

(**Explore some (non)entailment relations.*)
lemma lCoPw_XCoP: "lCoP0(\<^bold>\<rightarrow>) \<eta> = XCoP \<eta>" unfolding XCoP_def2 neg conn order by metis
lemma lCoP1_TND: "lCoP1(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> TND \<eta>" unfolding neg conn by (smt (verit, best) setequ_char subset_def)
lemma "TND \<eta> \<Longrightarrow> lCoP1(\<^bold>\<rightarrow>) \<eta>" nitpick oops
lemma lCoP2_ECQ: "lCoP2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> ECQ \<eta>" unfolding neg conn by (smt (verit) setequ_def subset_def)
lemma "ECQ \<eta> \<Longrightarrow> lCoP2(\<^bold>\<rightarrow>) \<eta>" nitpick oops

subsection \<open>Local modus tollens axioms\<close>

(**lMT: Modus tollens (local/axiom variants).*)
abbreviation plMT0 ("lMT0\<^sup>_\<^sup>_ _ _") where "lMT0\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> a b) \<^bold>\<and> (\<eta> b) \<preceq> (\<eta> a)"
abbreviation plMT1 ("lMT1\<^sup>_\<^sup>_ _ _") where "lMT1\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> a (\<eta> b)) \<^bold>\<and> b \<preceq> (\<eta> a)"
abbreviation plMT2 ("lMT2\<^sup>_\<^sup>_ _ _") where "lMT2\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> (\<eta> a) b) \<^bold>\<and> (\<eta> b) \<preceq> a"
abbreviation plMT3 ("lMT3\<^sup>_\<^sup>_ _ _") where "lMT3\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> (\<eta> a) (\<eta> b)) \<^bold>\<and> b \<preceq> a"
definition lMT0::"'w \<Delta>" where "lMT0 \<iota> \<eta> \<equiv> \<forall>a b. lMT0\<^sup>a\<^sup>b \<iota> \<eta>"
definition lMT1::"'w \<Delta>" where "lMT1 \<iota> \<eta> \<equiv> \<forall>a b. lMT1\<^sup>a\<^sup>b \<iota> \<eta>"
definition lMT2::"'w \<Delta>" where "lMT2 \<iota> \<eta> \<equiv> \<forall>a b. lMT2\<^sup>a\<^sup>b \<iota> \<eta>"
definition lMT3::"'w \<Delta>" where "lMT3 \<iota> \<eta> \<equiv> \<forall>a b. lMT3\<^sup>a\<^sup>b \<iota> \<eta>"

declare lMT0_def[neg] lMT1_def[neg] lMT2_def[neg] lMT3_def[neg]

(**All local MT variants are in general independent from each other and also from local CoP instances.
However if we take classical implication we can verify that local MT and CoP are indeed equivalent.*)
lemma "lMT0(\<^bold>\<rightarrow>) \<eta> = lCoP0(\<^bold>\<rightarrow>) \<eta>" unfolding neg conn order by blast
lemma "lMT1(\<^bold>\<rightarrow>) \<eta> = lCoP1(\<^bold>\<rightarrow>) \<eta>" unfolding neg conn order by blast
lemma "lMT2(\<^bold>\<rightarrow>) \<eta> = lCoP2(\<^bold>\<rightarrow>) \<eta>" unfolding neg conn order by blast
lemma "lMT3(\<^bold>\<rightarrow>) \<eta> = lCoP3(\<^bold>\<rightarrow>) \<eta>" unfolding neg conn order by blast

subsection \<open>Disjunctive syllogism\<close>

(**DS: disjunctive syllogism.*)
abbreviation pDS1 ("DS1\<^sup>_\<^sup>_ _ _") where "DS1\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (a \<^bold>\<or> b) \<preceq> (\<iota> (\<eta> a) b)"
abbreviation pDS2 ("DS2\<^sup>_\<^sup>_ _ _") where "DS2\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> (\<eta> a) b) \<preceq> (a \<^bold>\<or> b)"
abbreviation pDS3 ("DS3\<^sup>_\<^sup>_ _ _") where "DS3\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> ((\<eta> a) \<^bold>\<or> b) \<preceq> (\<iota> a b)"
abbreviation pDS4 ("DS4\<^sup>_\<^sup>_ _ _") where "DS4\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> a b) \<preceq> ((\<eta> a) \<^bold>\<or> b)"
definition DS1::"'w \<Delta>" where "DS1 \<iota> \<eta> \<equiv> \<forall>a b. DS1\<^sup>a\<^sup>b \<iota> \<eta>"
definition DS2::"'w \<Delta>" where "DS2 \<iota> \<eta> \<equiv> \<forall>a b. DS2\<^sup>a\<^sup>b \<iota> \<eta>"
definition DS3::"'w \<Delta>" where "DS3 \<iota> \<eta> \<equiv> \<forall>a b. DS3\<^sup>a\<^sup>b \<iota> \<eta>"
definition DS4::"'w \<Delta>" where "DS4 \<iota> \<eta> \<equiv> \<forall>a b. DS4\<^sup>a\<^sup>b \<iota> \<eta>"

declare DS1_def[neg] DS2_def[neg] DS3_def[neg] DS4_def[neg]

(**All DS variants are in general independent from each other. However if we take classical implication
we can verify that the pairs DS1-DS3 and DS2-DS4 are indeed equivalent. *)
lemma "DS1(\<^bold>\<rightarrow>) \<eta> = DS3(\<^bold>\<rightarrow>) \<eta>" unfolding neg conn order by blast
lemma "DS2(\<^bold>\<rightarrow>) \<eta> = DS4(\<^bold>\<rightarrow>) \<eta>" unfolding neg conn order by blast

(**Explore some (non)entailment relations.*)
lemma DS1_nDNor: "DS1(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> nDNRM \<eta>" unfolding neg cond conn order by metis
lemma DS2_nNor:  "DS2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> nNORM \<eta>" unfolding neg cond conn order by metis
lemma lCoP2_DS1: "lCoP2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> DS1(\<^bold>\<rightarrow>) \<eta>" unfolding neg conn order by blast
lemma lCoP1_DS2: "lCoP1(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> DS2(\<^bold>\<rightarrow>) \<eta>" unfolding neg conn order by blast
lemma "CoP2 \<eta> \<Longrightarrow> DS1(\<^bold>\<rightarrow>) \<eta>" nitpick oops
lemma "CoP1 \<eta> \<Longrightarrow> DS2(\<^bold>\<rightarrow>) \<eta>" nitpick oops

end