(*  Title:      HOL/Quotient_Examples/Quotient_Message.thy
    Author:     Christian Urban

Message datatype, based on an older version by Larry Paulson.
*)

theory Quotient_Message
imports MainRLT "HOL-Library.Quotient_Syntax"
begin

subsection\<open>Defining the Free Algebra\<close>

datatype
  freemsg = NONCE  nat
        | MPAIR  freemsg freemsg
        | CRYPT  nat freemsg
        | DECRYPT  nat freemsg

inductive
  msgrel::"freemsg \<Rightarrow> freemsg \<Rightarrow> bool" (infixl "\<sim>" 50)
where
  CD:    "CRYPT K (DECRYPT K X) \<sim> X"
| DC:    "DECRYPT K (CRYPT K X) \<sim> X"
| NONCE: "NONCE N \<sim> NONCE N"
| MPAIR: "\<lbrakk>X \<sim> X'; Y \<sim> Y'\<rbrakk> \<Longrightarrow> MPAIR X Y \<sim> MPAIR X' Y'"
| CRYPT: "X \<sim> X' \<Longrightarrow> CRYPT K X \<sim> CRYPT K X'"
| DECRYPT: "X \<sim> X' \<Longrightarrow> DECRYPT K X \<sim> DECRYPT K X'"
| SYM:   "X \<sim> Y \<Longrightarrow> Y \<sim> X"
| TRANS: "\<lbrakk>X \<sim> Y; Y \<sim> Z\<rbrakk> \<Longrightarrow> X \<sim> Z"

lemmas msgrel.intros[intro]

text\<open>Proving that it is an equivalence relation\<close>

lemma msgrel_refl: "X \<sim> X"
by (induct X) (auto intro: msgrel.intros)

theorem equiv_msgrel: "equivp msgrel"
proof (rule equivpI)
  show "reflp msgrel" by (rule reflpI) (simp add: msgrel_refl)
  show "symp msgrel" by (rule sympI) (blast intro: msgrel.SYM)
  show "transp msgrel" by (rule transpI) (blast intro: msgrel.TRANS)
qed

subsection\<open>Some Functions on the Free Algebra\<close>

subsubsection\<open>The Set of Nonces\<close>

primrec
  freenonces :: "freemsg \<Rightarrow> nat set"
where
  "freenonces (NONCE N) = {N}"
| "freenonces (MPAIR X Y) = freenonces X \<union> freenonces Y"
| "freenonces (CRYPT K X) = freenonces X"
| "freenonces (DECRYPT K X) = freenonces X"

theorem msgrel_imp_eq_freenonces:
  assumes a: "U \<sim> V"
  shows "freenonces U = freenonces V"
  using a by (induct) (auto)

subsubsection\<open>The Left Projection\<close>

text\<open>A function to return the left part of the top pair in a message.  It will
be lifted to the initial algebra, to serve as an example of that process.\<close>
primrec
  freeleft :: "freemsg \<Rightarrow> freemsg"
where
  "freeleft (NONCE N) = NONCE N"
| "freeleft (MPAIR X Y) = X"
| "freeleft (CRYPT K X) = freeleft X"
| "freeleft (DECRYPT K X) = freeleft X"

text\<open>This theorem lets us prove that the left function respects the
equivalence relation.  It also helps us prove that MPair
  (the abstract constructor) is injective\<close>
lemma msgrel_imp_eqv_freeleft_aux:
  shows "freeleft U \<sim> freeleft U"
  by (fact msgrel_refl)

theorem msgrel_imp_eqv_freeleft:
  assumes a: "U \<sim> V"
  shows "freeleft U \<sim> freeleft V"
  using a
  by (induct) (auto intro: msgrel_imp_eqv_freeleft_aux)

subsubsection\<open>The Right Projection\<close>

text\<open>A function to return the right part of the top pair in a message.\<close>
primrec
  freeright :: "freemsg \<Rightarrow> freemsg"
where
  "freeright (NONCE N) = NONCE N"
| "freeright (MPAIR X Y) = Y"
| "freeright (CRYPT K X) = freeright X"
| "freeright (DECRYPT K X) = freeright X"

text\<open>This theorem lets us prove that the right function respects the
equivalence relation.  It also helps us prove that MPair
  (the abstract constructor) is injective\<close>
lemma msgrel_imp_eqv_freeright_aux:
  shows "freeright U \<sim> freeright U"
  by (fact msgrel_refl)

theorem msgrel_imp_eqv_freeright:
  assumes a: "U \<sim> V"
  shows "freeright U \<sim> freeright V"
  using a
  by (induct) (auto intro: msgrel_imp_eqv_freeright_aux)

subsubsection\<open>The Discriminator for Constructors\<close>

text\<open>A function to distinguish nonces, mpairs and encryptions\<close>
primrec
  freediscrim :: "freemsg \<Rightarrow> int"
where
   "freediscrim (NONCE N) = 0"
 | "freediscrim (MPAIR X Y) = 1"
 | "freediscrim (CRYPT K X) = freediscrim X + 2"
 | "freediscrim (DECRYPT K X) = freediscrim X - 2"

text\<open>This theorem helps us prove \<^term>\<open>Nonce N \<noteq> MPair X Y\<close>\<close>
theorem msgrel_imp_eq_freediscrim:
  assumes a: "U \<sim> V"
  shows "freediscrim U = freediscrim V"
  using a by (induct) (auto)

subsection\<open>The Initial Algebra: A Quotiented Message Type\<close>

quotient_type msg = freemsg / msgrel
  by (rule equiv_msgrel)

text\<open>The abstract message constructors\<close>

quotient_definition
  "Nonce :: nat \<Rightarrow> msg"
is
  "NONCE"
done

quotient_definition
  "MPair :: msg \<Rightarrow> msg \<Rightarrow> msg"
is
  "MPAIR"
by (rule MPAIR)

quotient_definition
  "Crypt :: nat \<Rightarrow> msg \<Rightarrow> msg"
is
  "CRYPT"
by (rule CRYPT)

quotient_definition
  "Decrypt :: nat \<Rightarrow> msg \<Rightarrow> msg"
is
  "DECRYPT"
by (rule DECRYPT)

text\<open>Establishing these two equations is the point of the whole exercise\<close>
theorem CD_eq [simp]:
  shows "Crypt K (Decrypt K X) = X"
  by (lifting CD)

theorem DC_eq [simp]:
  shows "Decrypt K (Crypt K X) = X"
  by (lifting DC)

subsection\<open>The Abstract Function to Return the Set of Nonces\<close>

quotient_definition
   "nonces:: msg \<Rightarrow> nat set"
is
  "freenonces"
by (rule msgrel_imp_eq_freenonces)

text\<open>Now prove the four equations for \<^term>\<open>nonces\<close>\<close>

lemma nonces_Nonce [simp]:
  shows "nonces (Nonce N) = {N}"
  by (lifting freenonces.simps(1))

lemma nonces_MPair [simp]:
  shows "nonces (MPair X Y) = nonces X \<union> nonces Y"
  by (lifting freenonces.simps(2))

lemma nonces_Crypt [simp]:
  shows "nonces (Crypt K X) = nonces X"
  by (lifting freenonces.simps(3))

lemma nonces_Decrypt [simp]:
  shows "nonces (Decrypt K X) = nonces X"
  by (lifting freenonces.simps(4))

subsection\<open>The Abstract Function to Return the Left Part\<close>

quotient_definition
  "left:: msg \<Rightarrow> msg"
is
  "freeleft"
by (rule msgrel_imp_eqv_freeleft)

lemma left_Nonce [simp]:
  shows "left (Nonce N) = Nonce N"
  by (lifting freeleft.simps(1))

lemma left_MPair [simp]:
  shows "left (MPair X Y) = X"
  by (lifting freeleft.simps(2))

lemma left_Crypt [simp]:
  shows "left (Crypt K X) = left X"
  by (lifting freeleft.simps(3))

lemma left_Decrypt [simp]:
  shows "left (Decrypt K X) = left X"
  by (lifting freeleft.simps(4))

subsection\<open>The Abstract Function to Return the Right Part\<close>

quotient_definition
  "right:: msg \<Rightarrow> msg"
is
  "freeright"
by (rule msgrel_imp_eqv_freeright)

text\<open>Now prove the four equations for \<^term>\<open>right\<close>\<close>

lemma right_Nonce [simp]:
  shows "right (Nonce N) = Nonce N"
  by (lifting freeright.simps(1))

lemma right_MPair [simp]:
  shows "right (MPair X Y) = Y"
  by (lifting freeright.simps(2))

lemma right_Crypt [simp]:
  shows "right (Crypt K X) = right X"
  by (lifting freeright.simps(3))

lemma right_Decrypt [simp]:
  shows "right (Decrypt K X) = right X"
  by (lifting freeright.simps(4))

subsection\<open>Injectivity Properties of Some Constructors\<close>

text\<open>Can also be proved using the function \<^term>\<open>nonces\<close>\<close>
lemma Nonce_Nonce_eq [iff]:
  shows "(Nonce m = Nonce n) = (m = n)"
proof
  assume "Nonce m = Nonce n"
  then show "m = n"
    by (descending) (drule msgrel_imp_eq_freenonces, simp)
next
  assume "m = n"
  then show "Nonce m = Nonce n" by simp
qed

lemma MPair_imp_eq_left:
  assumes eq: "MPair X Y = MPair X' Y'"
  shows "X = X'"
  using eq
  by (descending) (drule msgrel_imp_eqv_freeleft, simp)

lemma MPair_imp_eq_right:
  shows "MPair X Y = MPair X' Y' \<Longrightarrow> Y = Y'"
  by (descending) (drule msgrel_imp_eqv_freeright, simp)

theorem MPair_MPair_eq [iff]:
  shows "(MPair X Y = MPair X' Y') = (X=X' & Y=Y')"
  by (blast dest: MPair_imp_eq_left MPair_imp_eq_right)

theorem Nonce_neq_MPair [iff]:
  shows "Nonce N \<noteq> MPair X Y"
  by (descending) (auto dest: msgrel_imp_eq_freediscrim)

text\<open>Example suggested by a referee\<close>

theorem Crypt_Nonce_neq_Nonce:
  shows "Crypt K (Nonce M) \<noteq> Nonce N"
  by (descending) (auto dest: msgrel_imp_eq_freediscrim)

text\<open>...and many similar results\<close>

theorem Crypt2_Nonce_neq_Nonce:
  shows "Crypt K (Crypt K' (Nonce M)) \<noteq> Nonce N"
  by (descending) (auto dest: msgrel_imp_eq_freediscrim)

theorem Crypt_Crypt_eq [iff]:
  shows "(Crypt K X = Crypt K X') = (X=X')"
proof
  assume "Crypt K X = Crypt K X'"
  hence "Decrypt K (Crypt K X) = Decrypt K (Crypt K X')" by simp
  thus "X = X'" by simp
next
  assume "X = X'"
  thus "Crypt K X = Crypt K X'" by simp
qed

theorem Decrypt_Decrypt_eq [iff]:
  shows "(Decrypt K X = Decrypt K X') = (X=X')"
proof
  assume "Decrypt K X = Decrypt K X'"
  hence "Crypt K (Decrypt K X) = Crypt K (Decrypt K X')" by simp
  thus "X = X'" by simp
next
  assume "X = X'"
  thus "Decrypt K X = Decrypt K X'" by simp
qed

lemma msg_induct [case_names Nonce MPair Crypt Decrypt, cases type: msg]:
  assumes N: "\<And>N. P (Nonce N)"
      and M: "\<And>X Y. \<lbrakk>P X; P Y\<rbrakk> \<Longrightarrow> P (MPair X Y)"
      and C: "\<And>K X. P X \<Longrightarrow> P (Crypt K X)"
      and D: "\<And>K X. P X \<Longrightarrow> P (Decrypt K X)"
  shows "P msg"
  using N M C D
  by (descending) (auto intro: freemsg.induct)

subsection\<open>The Abstract Discriminator\<close>

text\<open>However, as \<open>Crypt_Nonce_neq_Nonce\<close> above illustrates, we don't
need this function in order to prove discrimination theorems.\<close>

quotient_definition
  "discrim:: msg \<Rightarrow> int"
is
  "freediscrim"
by (rule msgrel_imp_eq_freediscrim)

text\<open>Now prove the four equations for \<^term>\<open>discrim\<close>\<close>

lemma discrim_Nonce [simp]:
  shows "discrim (Nonce N) = 0"
  by (lifting freediscrim.simps(1))

lemma discrim_MPair [simp]:
  shows "discrim (MPair X Y) = 1"
  by (lifting freediscrim.simps(2))

lemma discrim_Crypt [simp]:
  shows "discrim (Crypt K X) = discrim X + 2"
  by (lifting freediscrim.simps(3))

lemma discrim_Decrypt [simp]:
  shows "discrim (Decrypt K X) = discrim X - 2"
  by (lifting freediscrim.simps(4))

end


theory sort_MSortBU2Permutes'
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun risers :: "int list => (int list) list" where
"risers (Nil2) = Nil2"
| "risers (Cons2 y (Nil2)) = Cons2 (Cons2 y (Nil2)) (Nil2)"
| "risers (Cons2 y (Cons2 y2 xs)) =
     (if y <= y2 then
        case risers (Cons2 y2 xs) of
          | Nil2 => risers (Cons2 y2 xs)
          | Cons2 ys yss => Cons2 (Cons2 y ys) yss
        end
        else
        Cons2 (Cons2 y (Nil2)) (risers (Cons2 y2 xs)))"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun null :: "'t list => bool" where
"null (Nil2) = True"
| "null (Cons2 y z) = False"

fun lmerge :: "int list => int list => int list" where
"lmerge (Nil2) y = y"
| "lmerge (Cons2 z x2) (Nil2) = Cons2 z x2"
| "lmerge (Cons2 z x2) (Cons2 x3 x4) =
     (if z <= x3 then Cons2 z (lmerge x2 (Cons2 x3 x4)) else
        Cons2 x3 (lmerge (Cons2 z x2) x4))"

fun pairwise :: "(int list) list => (int list) list" where
"pairwise (Nil2) = Nil2"
| "pairwise (Cons2 xs (Nil2)) = Cons2 xs (Nil2)"
| "pairwise (Cons2 xs (Cons2 ys xss)) =
     Cons2 (lmerge xs ys) (pairwise xss)"

fun mergingbu2 :: "(int list) list => int list" where
"mergingbu2 (Nil2) = Nil2"
| "mergingbu2 (Cons2 xs (Nil2)) = xs"
| "mergingbu2 (Cons2 xs (Cons2 z x2)) =
     mergingbu2 (pairwise (Cons2 xs (Cons2 z x2)))"

fun elem :: "int => int list => bool" where
"elem x (Nil2) = False"
| "elem x (Cons2 z ys) = or2 (x = z) (elem x ys)"

fun dot :: "('b => 'c) => ('a => 'b) => 'a => 'c" where
"dot x y z = x (y z)"

fun msortbu2 :: "int list => int list" where
"msortbu2 x =
   dot
     (% (y :: (int list) list) => mergingbu2 y)
     (% (z :: int list) => risers z) x"

fun delete :: "int => int list => int list" where
"delete x (Nil2) = Nil2"
| "delete x (Cons2 z ys) =
     (if x = z then ys else Cons2 z (delete x ys))"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun isPermutation :: "int list => int list => bool" where
"isPermutation (Nil2) y = null y"
| "isPermutation (Cons2 z xs) y =
     and2 (elem z y) (isPermutation xs (delete z y))"

(*hipster risers
          or2
          null
          lmerge
          pairwise
          mergingbu2
          elem
          dot
          msortbu2
          delete
          and2
          isPermutation *)

theorem x0 :
  "!! (x :: int list) . isPermutation (msortbu2 x) x"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


subsubsection \<open>Register Equations\<close>

theory Register_Equations imports "../Register_Machine/MultipleStepRegister"
                                  Equation_Setup "../Diophantine/Register_Machine_Sums"
                                  "../Diophantine/Binary_And" "HOL-Library.Rewrite"

begin

context rm_eq_fixes
begin

  text \<open>Equation 4.22\<close>
  definition register_0 :: "bool" where
    "register_0 \<equiv> r 0 = a + b*r 0 + b*\<Sum>R+ p 0 s - b*\<Sum>R- p 0 (\<lambda>k. s k && z 0)"

  text \<open>Equation 4.23\<close>
  definition register_l :: "bool" where
    "register_l \<equiv> \<forall>l>0. l < n \<longrightarrow> r l = b*r l + b*\<Sum>R+ p l s - b*\<Sum>R- p l (\<lambda>k. s k && z l)"

  text \<open>Extra equation not in Matiyasevich's book\<close>
  definition register_bound :: "bool" where
    "register_bound \<equiv> \<forall>l < n. r l < b ^ q"

  definition register_equations :: "bool" where
    "register_equations \<equiv> register_0 \<and> register_l \<and> register_bound"

end

context register_machine
begin

definition sum_rsub_of_bit_and  :: "polynomial \<Rightarrow> nat \<Rightarrow> polynomial list \<Rightarrow> polynomial
                              \<Rightarrow> relation"
  ("[_ = \<Sum>R- _ '(_ && _')]") where
  "[x = \<Sum>R- d (s && zl)] \<equiv> let x' = push_param x (length p);
                               s' = push_param_list s (length p);
                               zl' = push_param zl (length p)
                            in [\<exists>length p] [\<forall><length p] (\<lambda>i. [Param i = s'!i && zl'])
                                                        [\<and>] x' [=] [\<Sum>R-] p d Param"

lemma sum_rsub_of_bit_and_dioph[dioph]:
  fixes s :: "polynomial list" and d :: nat and x zl :: polynomial
  shows "is_dioph_rel [x = \<Sum>R- d (s && zl)]"
  unfolding sum_rsub_of_bit_and_def by (auto simp add: dioph)

lemma sum_rsub_of_bit_and_eval:
  fixes z s :: "polynomial list" and d :: nat and x :: polynomial
  assumes "length s = Suc m" "length p > 0"
  shows "eval [x = \<Sum>R- d (s && zl)] a
         \<longleftrightarrow> peval x a = \<Sum>R- p d (\<lambda>k. peval (s!k) a && peval zl a)" (is "?P \<longleftrightarrow> ?Q")
proof -
  have invariance: "\<forall>k<length p. y1 k = y2 k \<Longrightarrow> \<Sum>R- p d y1 = \<Sum>R- p d y2" for y1 y2
    unfolding sum_rsub.simps apply (intro sum.cong, simp)
    using \<open>length p > 0\<close> by auto (metis Suc_pred le_imp_less_Suc length_greater_0_conv)

  have len_ps: "length s = length p"
    using m_def \<open>length s = Suc m\<close> \<open>length p > 0\<close> by auto

  have aux1: "peval ([\<Sum>R-] p l f) a = \<Sum>R- p l (\<lambda>x. peval (f x) a) " for l f
    using defs \<open>length p > 0\<close> by auto

  show ?thesis
  proof (rule)
    assume ?P
    thus ?Q
      unfolding sum_rsub_of_bit_and_def
      using aux1 apply simp
      apply (auto simp add: aux1 push_push defs)
      using push_push_map_i apply (simp add: push_param_list_def len_ps)
      unfolding list_eval_def apply (simp add: assms len_ps invariance)
      using assms(2) invariance len_ps sum_rsub_polynomial_eval by force
  next
    assume ?Q
    thus ?P
      unfolding sum_rsub_of_bit_and_def apply (auto simp add: aux1 defs push_push)
      apply (rule exI[of _ "map (\<lambda>k. peval (s ! k) a && peval zl a) [0..<length p]"], simp)
      using push_push push_push_map_i apply (simp add: push_param_list_def len_ps)
      using invariance len_ps push_list_eval \<open>length p > 0\<close> defs by simp
  qed
qed

lemma register_0_dioph[dioph]:
  fixes A b :: polynomial
  fixes r z s :: "polynomial list"
  assumes "length r = n" "length z = n" "length s = Suc m"
  defines "DR \<equiv> LARY (\<lambda>ll. rm_eq_fixes.register_0 p (ll!0!0) (ll!0!1)
                            (nth (ll!1)) (nth (ll!2)) (nth (ll!3))) [[A, b], r, z, s]"
  shows "is_dioph_rel DR"
proof -
  let ?N = "1"
  define A' b' r' z' s' where pushed_def: "A' = push_param A ?N" "b' = push_param b ?N"
                               "r' = map (\<lambda>x. push_param x ?N) r" "z' = map (\<lambda>x. push_param x ?N) z"
                               "s' = map (\<lambda>x. push_param x ?N) s"

  define DS where "DS \<equiv> [\<exists>] ([Param 0 = \<Sum>R- 0 (s' && (z'!0))] [\<and>]
                              r'!0 [=] A' [+] b' [*] r'!0 [+] b' [*] ([\<Sum>R+] p 0 (nth s'))
                                                          [-] b' [*] (Param 0))"

  have "length p > 0" using p_nonempty by auto
  have "n > 0" using n_gt_0 by auto

  have "length p = length s"
    using \<open>length s = Suc m\<close> m_def \<open>length p > 0\<close> by auto
  have "length s' = length s"
    unfolding pushed_def by auto
  have "length z > 0"
    using \<open>length z = n\<close> \<open>n > 0\<close> by simp
  have "length r > 0"
    using \<open>length r = n\<close> \<open>n > 0\<close> by simp

  have "eval DS a = eval DR a" for a
  proof -
    (* the key to this proof is to write these intermediate steps with list_eval on the RHS
        because that is needed in the final proof; otherwise showing the equivalence again
        re-requires unfolding the sum definitions *)
    have sum_radd_push: "\<Sum>R+ p 0 (\<lambda>x. peval (s' ! x) (push a k)) = \<Sum>R+ p 0 (list_eval s a)" for k
      unfolding sum_radd.simps pushed_def apply (intro sum.cong, simp)
      using push_push_map1 \<open>length p = length s\<close> \<open>length s = Suc m\<close> by simp

    have sum_rsub_push: "\<Sum>R- p 0 (\<lambda>x. peval (s' ! x) (push a k) && peval (z' ! 0) (push a k))
                           = \<Sum>R- p 0 (\<lambda>x. list_eval s a x && peval (z ! 0) a)" for k
      unfolding sum_rsub.simps pushed_def apply (intro sum.cong, simp)
      using push_push_map1 \<open>length p = length s\<close> \<open>length s = Suc m\<close> \<open>length z > 0\<close>
      by (simp add: list_eval_def)

    have 1: "peval ([\<Sum>R-] p l f) a = \<Sum>R- p l (\<lambda>x. peval (f x) a) " for f l
      using defs \<open>length p > 0\<close> by auto

    show ?thesis
      unfolding DS_def rm_eq_fixes.register_0_def
      register_machine_axioms rm_eq_fixes_def apply (simp add: defs)
      using \<open>length p > 0\<close> apply (simp add: sum_rsub_of_bit_and_eval \<open>length s' = length s\<close>
                                            \<open>length s = Suc m\<close>)
      apply (simp add: sum_radd_push sum_rsub_push)
      unfolding pushed_def using push_push1 push_push_map1 \<open>length r > 0\<close> apply simp
      unfolding DR_def assms defs \<open>length p > 0\<close>
      using rm_eq_fixes_def rm_eq_fixes.register_0_def register_machine_axioms apply (simp)
      using \<open>length z > 0\<close> push_def list_eval_def 1 apply (simp add: 1 defs \<open>length p > 0\<close>)
      using One_nat_def sum_radd_push unfolding pushed_def(5) list_eval_def by presburger
  qed

  moreover have "is_dioph_rel DS"
    unfolding DS_def by (simp add: dioph)

  ultimately show ?thesis
    by (auto simp: is_dioph_rel_def)
qed

lemma register_l_dioph[dioph]:
  fixes b :: polynomial
  fixes r z s :: "polynomial list"
  assumes "length r = n" "length z = n" "length s = Suc m"
  defines "DR \<equiv> LARY (\<lambda>ll. rm_eq_fixes.register_l p n (ll!0!0)
                            (nth (ll!1)) (nth (ll!2)) (nth (ll!3))) [[b], r, z, s]"
  shows "is_dioph_rel DR"
proof -
  define indices where "indices \<equiv> [Suc 0..<n]" (* for now *)

  let ?N = "length indices + 1"
  define b' r' z' s' where pushed_def: "b' = push_param b ?N"
                                       "r' = map (\<lambda>x. push_param x ?N) r"
                                       "z' = map (\<lambda>x. push_param x ?N) z"
                                       "s' = map (\<lambda>x. push_param x ?N) s"

  define param_l_is_sum_rsub_of_bitand where
    "param_l_is_sum_rsub_of_bitand \<equiv> \<lambda>l. [Param l = \<Sum>R- l (s' && (z'!l))]"
  define params_are_sum_rsub_of_bitand where
    "params_are_sum_rsub_of_bitand \<equiv> [\<forall> in indices] param_l_is_sum_rsub_of_bitand"
  define single_register where
    "single_register \<equiv> \<lambda>l. r'!l [=] b' [*] r'!l [+] b' [*] ([\<Sum>R+] p l (nth s')) [-] b' [*] (Param l)"

  define DS where "DS \<equiv> [\<exists>n] params_are_sum_rsub_of_bitand [\<and>] [\<forall> in indices] single_register"

  have "length p > 0" using p_nonempty by auto
  have "n > 0" using n_gt_0 by auto
  have "length p = length s"
    using \<open>length s = Suc m\<close> m_def \<open>length p > 0\<close> by auto
  have "length s' = length s"
    unfolding pushed_def by auto
  have "length z > 0"
    using \<open>length z = n\<close> \<open>n > 0\<close> by simp
  have "length r > 0"
    using \<open>length r = n\<close> \<open>n > 0\<close> by simp
  have "length indices + 1 = n"
    unfolding indices_def \<open>n>0\<close>
    using Suc_pred' \<open>n > 0\<close> length_upt by presburger
  have "length s' = Suc m"
    using \<open>length s' = length s\<close> \<open>length s = Suc m\<close> by auto

  have "eval DS a = eval DR a" for a
  proof -

    have eval_to_peval:
          "eval [polynomial.Param (indices ! k)
          = \<Sum>R- indices ! k (s' && z' ! (indices ! k))] y
      \<longleftrightarrow>(peval (polynomial.Param (indices ! k)) y
          = \<Sum>R- p (indices ! k) (\<lambda>ka. peval (s' ! ka) y && peval (z' ! (indices ! k)) y) )" for k y
      using sum_rsub_of_bit_and_eval \<open>length p > 0\<close> \<open>length s' = Suc m\<close> by auto

    have b'_unfold: "peval b' (push_list a ks) = peval b a" if "length ks = n" for ks
      unfolding pushed_def using indices_def push_push that \<open>length indices + 1 = n\<close> by auto

    have r'_unfold: "peval (r' ! (indices ! k)) (push_list a ks) = peval (r!(indices!k)) a"
      if "k < length indices" and "length ks = n" for k ks
      using indices_def push_push pushed_def that(1) that(2) \<open>length r = n\<close> by auto

    have Param_unfold: "peval (Param (indices ! k)) (push_list a ks) = ks!(indices!k)"
      if "k < length indices" and "length ks = n" for k ks
      using One_nat_def Suc_pred indices_def length_upt nat_add_left_cancel_less
          nth_upt peval.simps(2) plus_1_eq_Suc push_list_eval that(1) that(2) by (metis \<open>0 < n\<close>)

    have unfold_4: "push_list a ks (indices ! k) = ks!(indices!k)"
      if "k < length indices" and "length ks = n" for k ks
      using Param_unfold that(1) that(2) by force

    have unfold_sum_radd: "\<Sum>R+ p (indices ! k) (\<lambda>x. peval (s' ! x) (push_list a ks))
                         = \<Sum>R+ p (indices ! k) (list_eval s a)"
      if "length ks = n" for k ks
      apply (rule sum_radd_cong) unfolding pushed_def
      using push_push_map_i[of ks n _ s a] \<open>length indices + 1 = n\<close> that
      using \<open>length p = length s\<close>
      by (metis \<open>0 < length p\<close> add.left_neutral add_lessD1 le_neq_implies_less less_add_one
          less_diff_conv less_diff_conv2 nat_le_linear not_add_less1)

    have unfold_sum_rsub: "\<Sum>R- p (indices ! k) (\<lambda>ka. peval (s' ! ka) (push_list a ks)
                                        && peval (z' ! (indices ! k)) (push_list a ks))
                         = \<Sum>R- p (indices ! k) (\<lambda>ka. list_eval s a ka
                                        && peval (z ! (indices ! k)) a)"
      if "length ks = n" for k ks
      apply (rule sum_rsub_cong) unfolding pushed_def
      using push_push_map_i[of ks n _ s a] unfolding \<open>length indices + 1 = n\<close>
      using \<open>length p = length s\<close> assms apply simp
      using nth_map[of _ z "\<lambda>x. push_param x (Suc (length indices))"]
      using modifies_yields_valid_register \<open>length z = n\<close>
      by (smt assms le_imp_less_Suc nth_map push_push_simp that)

    have indices_unfold: "(\<forall>k < length indices. P (indices!k)) \<longleftrightarrow> (\<forall>l>0. l<n \<longrightarrow> P l)" for P
      unfolding indices_def apply auto
      using \<open>n>0\<close> by (metis Suc_diff_Suc diff_zero not_less_eq)

    have alternative_sum_rsub:
          "(\<Sum>R- p l (\<lambda>ka. list_eval s a ka && peval (z ! l) a))
         =(\<Sum>R- p l (\<lambda>k. map (\<lambda>P. peval P a) s ! k && map (\<lambda>P. peval P a) z ! l))" for l
      apply (rule sum_rsub_cong) unfolding list_eval_def apply simp
      using modifies_yields_valid_register
      One_nat_def assms(3) nth_map \<open>length z = n\<close> \<open>length s = Suc m\<close>
      by (metis \<open>length p = length s\<close> le_imp_less_Suc m_def)

    (* Start of chain of equalities *)
    have "(eval DS a) = (\<exists>ks. n = length ks \<and>
           (\<forall>k<length indices. eval [Param (indices ! k)
                               = \<Sum>R- (indices ! k) (s' && z' ! (indices ! k))] (push_list a ks)) \<and>
           (\<forall>k<length indices. eval (single_register (indices ! k)) (push_list a ks)))"
      unfolding DS_def params_are_sum_rsub_of_bitand_def param_l_is_sum_rsub_of_bitand_def
      by (simp add: defs)

    also have "... = (\<exists>ks. n = length ks \<and>
           (\<forall>k<length indices.
              peval (Param (indices ! k)) (push_list a ks)
              = \<Sum>R- p (indices ! k) (\<lambda>ka. peval (s' ! ka) (push_list a ks)
                                        && peval (z' ! (indices ! k)) (push_list a ks)) \<and>
              peval (r' ! (indices ! k)) (push_list a ks)
              = peval b' (push_list a ks) * peval (r' ! (indices ! k)) (push_list a ks)
              + peval b' (push_list a ks) * \<Sum>R+ p (indices ! k)
                                                   (\<lambda>x. peval (s' ! x) (push_list a ks))
              - peval b' (push_list a ks) * (push_list a ks (indices ! k))))"
      using eval_to_peval unfolding single_register_def
      using sum_radd_polynomial_eval \<open>length p > 0\<close> by (simp add: defs) (blast)

    also have "... = (\<exists>ks. n = length ks \<and>
           (\<forall>k<length indices.
              ks!(indices!k)
              = \<Sum>R- p (indices ! k) (\<lambda>ka. peval (s' ! ka) (push_list a ks)
                                        && peval (z' ! (indices ! k)) (push_list a ks)) \<and>
              peval (r!(indices!k)) a
              = peval b a * peval (r!(indices!k)) a
              + peval b a * \<Sum>R+ p (indices ! k) (\<lambda>x. peval (s' ! x) (push_list a ks))
              - peval b a * (ks!(indices!k))))"
      using b'_unfold r'_unfold Param_unfold unfold_4 by (smt (z3))

    also have "... = (\<exists>ks. n = length ks \<and>
           (\<forall>k<length indices.
              ks!(indices!k)
              = (\<Sum>R- p (indices ! k) (\<lambda>ka. peval (s' ! ka) (push_list a ks)
                                        && peval (z' ! (indices ! k)) (push_list a ks))) \<and>
              peval (r!(indices!k)) a
              = peval b a * peval (r!(indices!k)) a
              + peval b a * (\<Sum>R+ p (indices ! k) (list_eval s a))
              - peval b a * (ks!(indices!k))))"
      using unfold_sum_radd by (smt (z3))

    also have "... = (\<exists>ks. n = length ks \<and>
           (\<forall>k<length indices.
              ks!(indices!k)
                = \<Sum>R- p (indices ! k) (\<lambda>ka. list_eval s a ka && peval (z ! (indices ! k)) a)
            \<and> peval (r!(indices!k)) a
                = peval b a * peval (r!(indices!k)) a
                + peval b a * (\<Sum>R+ p (indices ! k) (list_eval s a))
                - peval b a * (ks!(indices!k))))"
      using unfold_sum_rsub by auto

    also have "... = (\<exists>ks. n = length ks \<and>
           (\<forall>k<length indices.
              ks!(indices!k)
                = \<Sum>R- p (indices ! k) (\<lambda>ka. list_eval s a ka && peval (z ! (indices ! k)) a)
            \<and> peval (r!(indices!k)) a
                = peval b a * peval (r!(indices!k)) a
                + peval b a * (\<Sum>R+ p (indices ! k) (list_eval s a))
                - peval b a *
                (\<Sum>R- p (indices ! k) (\<lambda>ka. list_eval s a ka && peval (z ! (indices ! k)) a))))"
      by smt

    also have "... = (\<forall>k<length indices.
              peval (r!(indices!k)) a
                = peval b a * peval (r!(indices!k)) a
                + peval b a * (\<Sum>R+ p (indices ! k) (list_eval s a))
                - peval b a *
                (\<Sum>R- p (indices ! k) (\<lambda>ka. list_eval s a ka && peval (z ! (indices ! k)) a)))"
      unfolding indices_def apply auto
      apply (rule exI[of _
             "map (\<lambda>k. \<Sum>R- p k (\<lambda>ka. list_eval s a ka && peval (z ! k) a)) [0..<n]"])
      by auto

    also have "... = (\<forall>l>0. l < n \<longrightarrow>
                  peval (r!l) a
                    = peval b a * peval (r!l) a
                    + peval b a * (\<Sum>R+ p l (list_eval s a))
                    - peval b a *
                    (\<Sum>R- p l (\<lambda>ka. list_eval s a ka && peval (z ! l) a)))"
      using indices_unfold[of "\<lambda>x. peval (r ! x) a =
        peval b a * peval (r ! x) a + peval b a * (\<Sum>R+ p x (list_eval s a)) -
        peval b a * (\<Sum>R- p x (\<lambda>ka. (list_eval s a ka) && peval (z ! x) a))"]
      by auto

    also have "... =  (\<forall>l>0. l < n \<longrightarrow>
           peval (r!l) a =
           peval b a * map (\<lambda>P. peval P a) r ! l
         + peval b a * (\<Sum>R+ p l ((!) (map (\<lambda>P. peval P a) s)))
         - peval b a * (\<Sum>R- p l (\<lambda>k. map (\<lambda>P. peval P a) s ! k && map (\<lambda>P. peval P a) z ! l)))"
      using nth_map[of _ r "(\<lambda>P. peval P a)"] unfolding \<open>length r = n\<close>
      using alternative_sum_rsub list_eval_def by auto

    also have "... = (eval DR a)"
      apply (simp add: DR_def defs) using rm_eq_fixes_def rm_eq_fixes.register_l_def
      local.register_machine_axioms
      using nth_map[of _ r "\<lambda>P. peval P a"] unfolding \<open>length r = n\<close> by auto

    finally show "eval DS a = eval DR a" by auto
  qed

  moreover have "is_dioph_rel DS"
  proof -
    have "list_all (is_dioph_rel \<circ> param_l_is_sum_rsub_of_bitand) indices"
      unfolding param_l_is_sum_rsub_of_bitand_def indices_def list_all_def by (auto simp:dioph)
    hence "is_dioph_rel params_are_sum_rsub_of_bitand"
      unfolding params_are_sum_rsub_of_bitand_def by (auto simp: dioph)

    have "list_all (is_dioph_rel \<circ> single_register) indices"
      unfolding single_register_def list_all_def indices_def by (auto simp: dioph)
    thus ?thesis
    unfolding DS_def using \<open>is_dioph_rel params_are_sum_rsub_of_bitand\<close> by (auto simp: dioph)
  qed

  ultimately show ?thesis
    by (auto simp: is_dioph_rel_def)
qed

lemma register_bound_dioph:
  fixes b q :: polynomial
  fixes r :: "polynomial list"
  assumes "length r = n"
  defines "DR \<equiv> LARY (\<lambda>ll. rm_eq_fixes.register_bound n (ll!0!0) (ll!0!1) (nth (ll!1)))
                     [[b, q], r]"
  shows "is_dioph_rel DR"
proof -

  define indices where "indices \<equiv> [0..<n]" (* for now *)
  hence "length indices = n" by auto

  let ?N = "length indices"
  define b' q' r' where pushed_def: "b' = push_param b ?N"
                                    "q' = push_param q ?N"
                                    "r' = map (\<lambda>x. push_param x ?N) r"

  define bound where
    "bound \<equiv> \<lambda>l. (r'!l [<] (Param l) [\<and>] [Param l = b' ^ q'])"

  define DS where "DS \<equiv> [\<exists>n] [\<forall> in indices] bound"

  have "eval DS a = eval DR a" for a
  proof -

    have r'_unfold: "peval (r' ! k) (push_list a ks) = peval (r ! k) a"
      if "length ks = n" and "k < length ks" for k ks
      unfolding pushed_def \<open>length indices = n\<close>
      using push_push_map_i[of ks n k r] that \<open>length r = n\<close> list_eval_def by auto

    have b'_unfold: "peval b' (push_list a ks) = peval b a"
     and q'_unfold: "peval q' (push_list a ks) = peval q a"
      if "length ks = n" and "k < length ks" for k ks
      unfolding pushed_def \<open>length indices = n\<close>
      using push_push_simp that \<open>length r = n\<close> list_eval_def by auto

    have "eval DS a = (\<exists>ks. n = length ks \<and>
          (\<forall>k<n. peval (r' ! k) (push_list a ks) < push_list a ks k \<and>
                 push_list a ks k = peval b' (push_list a ks) ^ peval q' (push_list a ks)))"
      unfolding DS_def indices_def bound_def by (simp add: defs)

    also have "... = (\<exists>ks. n = length ks \<and>
          (\<forall>k<n. peval (r ! k) a < peval b a ^ peval q a \<and>
                 push_list a ks k = peval b a ^ peval q a))"
      using r'_unfold b'_unfold q'_unfold by (metis (full_types))

    also have "... = (\<forall>k<n. peval (r ! k) a < peval b a ^ peval q a)"
      apply auto apply (rule exI[of _ "map (\<lambda>k. peval b a ^ peval q a) [0..<n]"])
      unfolding indices_def push_list_def by auto

    also have "... = (\<forall>l<n. map (\<lambda>P. peval P a) r ! l < peval b a ^ peval q a)"
      using nth_map[of _ r "\<lambda>P. peval P a"] \<open>length r = n\<close> by force

    finally show ?thesis unfolding DR_def
      using rm_eq_fixes.register_bound_def rm_eq_fixes_def register_machine_def
      p_nonempty n_gt_0 valid_program by (auto simp add: defs)

  qed

  moreover have "is_dioph_rel DS"
  proof -
    have "list_all (is_dioph_rel \<circ> bound) indices"
      unfolding bound_def indices_def list_all_def by (auto simp:dioph)
    thus ?thesis unfolding DS_def indices_def bound_def by (auto simp: dioph)
  qed

  ultimately show ?thesis
    by (auto simp: is_dioph_rel_def)
qed

definition register_equations_relation :: "polynomial \<Rightarrow> polynomial \<Rightarrow> polynomial
   \<Rightarrow> polynomial list \<Rightarrow> polynomial list \<Rightarrow> polynomial list \<Rightarrow> relation" ("[REG] _ _ _ _ _ _") where
  "[REG] a b q r z s \<equiv> LARY (\<lambda>ll. rm_eq_fixes.register_equations p n (ll!0!0) (ll!0!1) (ll!0!2)
                          (nth (ll!1)) (nth (ll!2)) (nth (ll!3))) [[a, b, q], r, z, s]"

lemma reg_dioph:
  fixes A b q r z s
  assumes "length r = n" "length z = n" "length s = Suc m"
  defines "DR \<equiv> [REG] A b q r z s"
  shows "is_dioph_rel DR"
proof -

  define DS where "DS \<equiv> (LARY (\<lambda>ll. rm_eq_fixes.register_0 p (ll!0!0) (ll!0!1)
                        (nth (ll!1)) (nth (ll!2)) (nth (ll!3))) [[A, b], r, z, s])
                    [\<and>] (LARY (\<lambda>ll. rm_eq_fixes.register_l p n (ll!0!0)
                        (nth (ll!1)) (nth (ll!2)) (nth (ll!3))) [[b], r, z, s])
                    [\<and>] (LARY (\<lambda>ll. rm_eq_fixes.register_bound n (ll!0!0) (ll!0!1) (nth (ll!1)))
                        [[b, q], r])"

  have "eval DS a = eval DR a" for a
    unfolding DS_def DR_def register_equations_relation_def rm_eq_fixes.register_equations_def
    apply (simp add: defs)
    by (simp add: register_machine_axioms rm_eq_fixes.intro rm_eq_fixes.register_equations_def)

  moreover have "is_dioph_rel DS"
    unfolding DS_def using assms register_0_dioph[of r z s] register_l_dioph[of r z s]
    register_bound_dioph by (auto simp: dioph)

  ultimately show ?thesis by (auto simp: is_dioph_rel_def)
qed

end

end


(*  Title:      HOL/Metis_Examples/Abstraction.thy
    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    Author:     Jasmin Blanchette, TU Muenchen

Example featuring Metis's support for lambda-abstractions.
*)

section \<open>Example Featuring Metis's Support for Lambda-Abstractions\<close>

theory Abstraction
imports "~~/src/HOL/Library/FuncSet"
begin

(* For Christoph Benzmüller *)
lemma "x < 1 \<and> ((op =) = (op =)) \<Longrightarrow> ((op =) = (op =)) \<and> x < (2::nat)"
by (metis nat_1_add_1 trans_less_add2)

lemma "(op = ) = (\<lambda>x y. y = x)"
by metis

consts
  monotone :: "['a => 'a, 'a set, ('a *'a)set] => bool"
  pset  :: "'a set => 'a set"
  order :: "'a set => ('a * 'a) set"

lemma "a \<in> {x. P x} \<Longrightarrow> P a"
proof -
  assume "a \<in> {x. P x}"
  thus "P a" by (metis mem_Collect_eq)
qed

lemma Collect_triv: "a \<in> {x. P x} \<Longrightarrow> P a"
by (metis mem_Collect_eq)

lemma "a \<in> {x. P x --> Q x} \<Longrightarrow> a \<in> {x. P x} \<Longrightarrow> a \<in> {x. Q x}"
by (metis Collect_imp_eq ComplD UnE)

lemma "(a, b) \<in> Sigma A B \<Longrightarrow> a \<in> A \<and> b \<in> B a"
proof -
  assume A1: "(a, b) \<in> Sigma A B"
  hence F1: "b \<in> B a" by (metis mem_Sigma_iff)
  have F2: "a \<in> A" by (metis A1 mem_Sigma_iff)
  have "b \<in> B a" by (metis F1)
  thus "a \<in> A \<and> b \<in> B a" by (metis F2)
qed

lemma Sigma_triv: "(a, b) \<in> Sigma A B \<Longrightarrow> a \<in> A & b \<in> B a"
by (metis SigmaD1 SigmaD2)

lemma "(a, b) \<in> (SIGMA x:A. {y. x = f y}) \<Longrightarrow> a \<in> A \<and> a = f b"
by (metis (full_types, lifting) CollectD SigmaD1 SigmaD2)

lemma "(a, b) \<in> (SIGMA x:A. {y. x = f y}) \<Longrightarrow> a \<in> A \<and> a = f b"
proof -
  assume A1: "(a, b) \<in> (SIGMA x:A. {y. x = f y})"
  hence F1: "a \<in> A" by (metis mem_Sigma_iff)
  have "b \<in> {R. a = f R}" by (metis A1 mem_Sigma_iff)
  hence "a = f b" by (metis (full_types) mem_Collect_eq)
  thus "a \<in> A \<and> a = f b" by (metis F1)
qed

lemma "(cl, f) \<in> CLF \<Longrightarrow> CLF = (SIGMA cl: CL.{f. f \<in> pset cl}) \<Longrightarrow> f \<in> pset cl"
by (metis Collect_mem_eq SigmaD2)

lemma "(cl, f) \<in> CLF \<Longrightarrow> CLF = (SIGMA cl: CL.{f. f \<in> pset cl}) \<Longrightarrow> f \<in> pset cl"
proof -
  assume A1: "(cl, f) \<in> CLF"
  assume A2: "CLF = (SIGMA cl:CL. {f. f \<in> pset cl})"
  have "\<forall>v u. (u, v) \<in> CLF \<longrightarrow> v \<in> {R. R \<in> pset u}" by (metis A2 mem_Sigma_iff)
  hence "\<forall>v u. (u, v) \<in> CLF \<longrightarrow> v \<in> pset u" by (metis mem_Collect_eq)
  thus "f \<in> pset cl" by (metis A1)
qed

lemma
  "(cl, f) \<in> (SIGMA cl: CL. {f. f \<in> pset cl \<rightarrow> pset cl}) \<Longrightarrow>
   f \<in> pset cl \<rightarrow> pset cl"
by (metis (no_types) Collect_mem_eq Sigma_triv)

lemma
  "(cl, f) \<in> (SIGMA cl: CL. {f. f \<in> pset cl \<rightarrow> pset cl}) \<Longrightarrow>
   f \<in> pset cl \<rightarrow> pset cl"
proof -
  assume A1: "(cl, f) \<in> (SIGMA cl:CL. {f. f \<in> pset cl \<rightarrow> pset cl})"
  have "f \<in> {R. R \<in> pset cl \<rightarrow> pset cl}" using A1 by simp
  thus "f \<in> pset cl \<rightarrow> pset cl" by (metis mem_Collect_eq)
qed

lemma
  "(cl, f) \<in> (SIGMA cl: CL. {f. f \<in> pset cl \<inter> cl}) \<Longrightarrow>
   f \<in> pset cl \<inter> cl"
by (metis (no_types) Collect_conj_eq Int_def Sigma_triv inf_idem)

lemma
  "(cl, f) \<in> (SIGMA cl: CL. {f. f \<in> pset cl \<inter> cl}) \<Longrightarrow>
   f \<in> pset cl \<inter> cl"
proof -
  assume A1: "(cl, f) \<in> (SIGMA cl:CL. {f. f \<in> pset cl \<inter> cl})"
  have "f \<in> {R. R \<in> pset cl \<inter> cl}" using A1 by simp
  hence "f \<in> Id_on cl `` pset cl" by (metis Int_commute Image_Id_on mem_Collect_eq)
  hence "f \<in> cl \<inter> pset cl" by (metis Image_Id_on)
  thus "f \<in> pset cl \<inter> cl" by (metis Int_commute)
qed

lemma
  "(cl, f) \<in> (SIGMA cl: CL. {f. f \<in> pset cl \<rightarrow> pset cl & monotone f (pset cl) (order cl)}) \<Longrightarrow>
   (f \<in> pset cl \<rightarrow> pset cl)  &  (monotone f (pset cl) (order cl))"
by auto

lemma
  "(cl, f) \<in> CLF \<Longrightarrow>
   CLF \<subseteq> (SIGMA cl: CL. {f. f \<in> pset cl \<inter> cl}) \<Longrightarrow>
   f \<in> pset cl \<inter> cl"
by (metis (lifting) CollectD Sigma_triv subsetD)

lemma
  "(cl, f) \<in> CLF \<Longrightarrow>
   CLF = (SIGMA cl: CL. {f. f \<in> pset cl \<inter> cl}) \<Longrightarrow>
   f \<in> pset cl \<inter> cl"
by (metis (lifting) CollectD Sigma_triv)

lemma
  "(cl, f) \<in> CLF \<Longrightarrow>
   CLF \<subseteq> (SIGMA cl': CL. {f. f \<in> pset cl' \<rightarrow> pset cl'}) \<Longrightarrow>
   f \<in> pset cl \<rightarrow> pset cl"
by (metis (lifting) CollectD Sigma_triv subsetD)

lemma
  "(cl, f) \<in> CLF \<Longrightarrow>
   CLF = (SIGMA cl: CL. {f. f \<in> pset cl \<rightarrow> pset cl}) \<Longrightarrow>
   f \<in> pset cl \<rightarrow> pset cl"
by (metis (lifting) CollectD Sigma_triv)

lemma
  "(cl, f) \<in> CLF \<Longrightarrow>
   CLF = (SIGMA cl: CL. {f. f \<in> pset cl \<rightarrow> pset cl & monotone f (pset cl) (order cl)}) \<Longrightarrow>
   (f \<in> pset cl \<rightarrow> pset cl) & (monotone f (pset cl) (order cl))"
by auto

lemma "map (\<lambda>x. (f x, g x)) xs = zip (map f xs) (map g xs)"
apply (induct xs)
 apply (metis list.map(1) zip_Nil)
by auto

lemma
  "map (\<lambda>w. (w \<rightarrow> w, w \<times> w)) xs =
   zip (map (\<lambda>w. w \<rightarrow> w) xs) (map (\<lambda>w. w \<times> w) xs)"
apply (induct xs)
 apply (metis list.map(1) zip_Nil)
by auto

lemma "(\<lambda>x. Suc (f x)) ` {x. even x} \<subseteq> A \<Longrightarrow> \<forall>x. even x --> Suc (f x) \<in> A"
by (metis mem_Collect_eq image_eqI subsetD)

lemma
  "(\<lambda>x. f (f x)) ` ((\<lambda>x. Suc(f x)) ` {x. even x}) \<subseteq> A \<Longrightarrow>
   (\<forall>x. even x --> f (f (Suc(f x))) \<in> A)"
by (metis mem_Collect_eq imageI set_rev_mp)

lemma "f \<in> (\<lambda>u v. b \<times> u \<times> v) ` A \<Longrightarrow> \<forall>u v. P (b \<times> u \<times> v) \<Longrightarrow> P(f y)"
by (metis (lifting) imageE)

lemma image_TimesA: "(\<lambda>(x, y). (f x, g y)) ` (A \<times> B) = (f ` A) \<times> (g ` B)"
by (metis map_prod_def map_prod_surj_on)

lemma image_TimesB:
    "(\<lambda>(x, y, z). (f x, g y, h z)) ` (A \<times> B \<times> C) = (f ` A) \<times> (g ` B) \<times> (h ` C)"
by force

lemma image_TimesC:
  "(\<lambda>(x, y). (x \<rightarrow> x, y \<times> y)) ` (A \<times> B) =
   ((\<lambda>x. x \<rightarrow> x) ` A) \<times> ((\<lambda>y. y \<times> y) ` B)"
by (metis image_TimesA)

end


(* Title: Examples/SML_Relativization/Foundations/Transfer_Ext.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Extension of the theory \<^text>\<open>Transfer\<close>\<close>
theory Transfer_Ext
  imports Main
begin

lemma bi_unique_intersect_r:
  assumes "bi_unique T"
    and "rel_set T a a'"
    and "rel_set T b b'"
    and "rel_set T (a \<inter> b) xr"
  shows "a' \<inter> b' = xr"
proof -
  {
    fix x assume "x \<in> a \<inter> b"
    then have "x \<in> a" and "x \<in> b" by simp+
    from assms(2) \<open>x \<in> a\<close> have "\<exists>y \<in> a'. T x y" by (rule rel_setD1)
    moreover from assms(3) \<open>x \<in> b\<close> have "\<exists>y \<in> b'. T x y" by (rule rel_setD1)
    ultimately have "\<exists>y \<in> a' \<inter> b'. T x y"
      using assms(1) by (auto dest: bi_uniqueDr)
  }
  note unique_r = this
  {
    fix x assume "x \<in> a' \<inter> b'"
    then have "x \<in> a'" and "x \<in> b'" by simp+
    from assms(2) \<open>x \<in> a'\<close> have "\<exists>y \<in> a. T y x" by (rule rel_setD2)
    moreover from assms(3) \<open>x \<in> b'\<close> have "\<exists>y \<in> b. T y x" by (rule rel_setD2)
    ultimately have "\<exists>y \<in> a \<inter> b. T y x"
      using assms(1) by (auto dest: bi_uniqueDl)
  }
  with unique_r have "rel_set T (a \<inter> b) (a' \<inter> b')" using rel_setI by blast
  with assms(1,4) show ?thesis by (auto dest: bi_uniqueDr bi_unique_rel_set)
qed

lemma bi_unique_intersect_l:
  assumes "bi_unique T"
    and "rel_set T a a'"
    and "rel_set T b b'"
    and "rel_set T xl (a' \<inter> b')"
  shows "a \<inter> b = xl"
proof -
  let ?T' = "\<lambda> y x. T x y"
  from assms(1) have "bi_unique ?T'" unfolding bi_unique_def by simp
  moreover from assms(2) have "rel_set ?T' a' a" unfolding rel_set_def by simp
  moreover from assms(3) have "rel_set ?T' b' b" unfolding rel_set_def by simp
  moreover from assms(4) have "rel_set ?T' (a' \<inter> b') xl"
    unfolding rel_set_def by simp
  ultimately show ?thesis by (rule bi_unique_intersect_r)
qed

lemma bi_unique_intersect:
  assumes "bi_unique T" and "rel_set T a a'" and "rel_set T b b'"
  shows "rel_set T (a \<inter> b) (a' \<inter> b')"
proof -
  {
    fix xl assume "xl \<in> a \<inter> b"
    then have "xl \<in> a" and "xl \<in> b" by simp+
    with assms(3) obtain xr where "T xl xr" unfolding rel_set_def by auto
    with assms(1,2) \<open>xl \<in> a\<close> have "xr \<in> a'"
      by (auto dest: bi_uniqueDr rel_setD1)
    moreover with assms(1,3) \<open>xl \<in> b\<close> \<open>T xl xr\<close> have "xr \<in> b'"
      by (auto dest: bi_uniqueDr rel_setD1)
    ultimately have "xr \<in> a' \<inter> b'" by simp
    with \<open>T xl xr\<close> have "\<exists>xr. xr \<in> a' \<inter> b' \<and> T xl xr" by auto
  }
  then have prem_lhs: "\<forall>xl \<in> a \<inter> b. \<exists>xr. xr \<in> a' \<inter> b' \<and> T xl xr" by simp
  {
    fix xr
    assume "xr \<in> a' \<inter> b'"
    then have "xr \<in> a'" and "xr \<in> b'" by simp+
    with assms(3) obtain xl where "T xl xr" unfolding rel_set_def by auto
    with assms(1,2) \<open>xr \<in> a'\<close> have "xl \<in> a"
      by (auto dest: bi_uniqueDl rel_setD2)
    moreover with assms(1,3) \<open>xr \<in> b'\<close> \<open>T xl xr\<close> have "xl \<in> b"
      by (auto dest: bi_uniqueDl rel_setD2)
    ultimately have "xl \<in> a \<inter> b" by simp
    with \<open>T xl xr\<close> have "\<exists>xl. xl \<in> a \<inter> b \<and> T xl xr" by auto
  }
  then have prem_rhs: "\<forall>xr \<in> a' \<inter> b'. \<exists>xl. xl \<in> a \<inter> b \<and> T xl xr" by simp
  from prem_lhs prem_rhs show ?thesis unfolding rel_set_def by auto
qed

lemma bi_unique_union_r:
  assumes "bi_unique T"
    and "rel_set T a a'"
    and "rel_set T b b'"
    and "rel_set T (a \<union> b) xr"
  shows "a' \<union> b' = xr"
proof -
  {
    fix x assume "x \<in> a \<union> b"
    then have "x \<in> a \<or> x \<in> b" by simp
    from assms(2) have "\<exists>y \<in> a'. T x y" if "x \<in> a"
      using that by (rule rel_setD1)
    moreover from assms(3) have "\<exists>y \<in> b'. T x y" if "x \<in> b"
      using that by (rule rel_setD1)
    ultimately have "\<exists>y \<in> a' \<union> b'. T x y" using \<open>x \<in> a \<or> x \<in> b\<close> by auto
  }
  note unique_r = this
  {
    fix x assume "x \<in> a' \<union> b'"
    then have "x \<in> a' \<or> x \<in> b'" by simp
    from assms(2) have "\<exists>y \<in> a. T y x" if "x \<in> a'"
      using that by (rule rel_setD2)
    moreover from assms(3) have "\<exists>y \<in> b. T y x" if "x \<in> b'"
      using that by (rule rel_setD2)
    ultimately have "\<exists>y \<in> a \<union> b. T y x" using \<open>x \<in> a' \<or> x \<in> b'\<close> by auto
  }
  with unique_r have "rel_set T (a \<union> b) (a' \<union> b')" by (auto intro: rel_setI)
  with assms(1,4) show ?thesis by (auto dest: bi_uniqueDr bi_unique_rel_set)
qed

lemma bi_unique_union_l:
  assumes "bi_unique T"
    and "rel_set T a a'"
    and "rel_set T b b'"
    and "rel_set T xl (a' \<union> b')"
  shows "a \<union> b = xl"
proof -
  let ?T' = "\<lambda>y x. T x y"
  from assms(1) have "bi_unique ?T'" unfolding bi_unique_def by simp
  moreover from assms(2) have "rel_set ?T' a' a" unfolding rel_set_def by simp
  moreover from assms(3) have "rel_set ?T' b' b" unfolding rel_set_def by simp
  moreover from assms(4) have "rel_set ?T' (a' \<union> b') xl"
    unfolding rel_set_def by simp
  ultimately show ?thesis by (rule bi_unique_union_r)
qed

lemma bi_unique_union:
  assumes "bi_unique T" and "rel_set T a a'" and "rel_set T b b'"
  shows "rel_set T (a \<union> b) (a' \<union> b')"
proof -
  {
    fix xl assume "xl \<in> a \<union> b"
    with assms(2,3) obtain xr where "T xl xr" unfolding rel_set_def by auto
    with assms \<open>xl \<in> a \<union> b\<close> have "xr \<in> a' \<union> b'"
      unfolding bi_unique_def using Un_iff by (metis Un_iff rel_setD1)
    with \<open>T xl xr\<close> have "\<exists>xr. xr \<in> a' \<union> b' \<and> T xl xr" by auto
  }
  then have prem_lhs: "\<forall>xl \<in> a \<union> b. \<exists>xr. xr \<in> a' \<union> b' \<and> T xl xr" by simp
  {
    fix xr assume "xr \<in> a' \<union> b'"
    with assms(2,3) obtain xl where "T xl xr" unfolding rel_set_def by auto
    with assms \<open>xr \<in> a' \<union> b'\<close> have "xl \<in> a \<union> b"
      unfolding bi_unique_def by (metis Un_iff rel_setD2)
    with \<open>T xl xr\<close> have "\<exists>xl. xl \<in> a \<union> b \<and> T xl xr" by auto
  }
  then have prem_rhs: "\<forall>xr \<in> a' \<union> b'. \<exists>xl. xl \<in> a \<union> b \<and> T xl xr" by simp
  from prem_lhs prem_rhs show ?thesis unfolding rel_set_def by auto
qed

lemma bi_unique_Union_r:
  fixes T :: "['a, 'b] \<Rightarrow> bool" and K
  defines K':  "K' \<equiv> {(x, y). rel_set T x y} `` K"
  assumes "bi_unique T"
    and "\<Union>K \<subseteq> Collect (Domainp T)"
    and "rel_set T (\<Union>K) xr"
  shows "\<Union>K' = xr"
proof -
  {
    fix x assume "x \<in> \<Union>K"
    then obtain k where "x \<in> k" and "k \<in> K" by clarsimp
    from assms have ex_k'_prem: "\<forall>k \<in> K. \<forall>x \<in> k. \<exists>x'. T x x'" by auto
    define k' where k': "k' = {x'. \<exists>x \<in> k. T x x'}"
    have "rel_set T k k'"
      unfolding rel_set_def Bex_def k'
      using \<open>k \<in> K\<close> by (blast dest: ex_k'_prem[rule_format])
    with \<open>k \<in> K\<close> have "k' \<in> K'" unfolding K' by auto
    from \<open>rel_set T k k'\<close> \<open>x \<in> k\<close> obtain y where "y \<in> k' \<and> T x y"
      by (auto dest: rel_setD1)
    then have "\<exists>y \<in> \<Union>K'. T x y" using \<open>k' \<in> K'\<close> by auto
  }
  note unique_r = this
  {
    fix x' assume "x' \<in> \<Union>K'"
    then obtain k' where "x' \<in> k'" and "k' \<in> K'" by clarsimp
    then have ex_k_prem: "\<forall>k' \<in> K'. \<forall>x \<in> k'. \<exists>x. T x x'"
      unfolding K' by (auto dest: rel_setD2)
    define k where k: "k = {x. \<exists>x' \<in> k'. T x x'}"
    have "rel_set T k k'"
      unfolding rel_set_def Bex_def k
      using \<open>k' \<in> K'\<close> K' by (blast dest: rel_setD2)
    from assms(2) have "bi_unique (rel_set T)" by (rule bi_unique_rel_set)
    with \<open>rel_set T k k'\<close> have "\<exists>!k. rel_set T k k'" by (auto dest: bi_uniqueDl)
    with \<open>rel_set T k k'\<close> K' \<open>k' \<in> K'\<close> have "k \<in> K" by auto
    from \<open>rel_set T k k'\<close> \<open>x' \<in> k'\<close> obtain y where "y \<in> k \<and> T y x'"
      by (auto dest: rel_setD2)
    then have "\<exists>y \<in> \<Union>K. T y x'" using \<open>k \<in> K\<close> by auto
  }
  with unique_r have "rel_set T (\<Union>K) (\<Union>K')" by (intro rel_setI)
  with assms(2,4) show ?thesis by (auto dest: bi_uniqueDr bi_unique_rel_set)
qed

lemma bi_unique_Union_l:
  fixes T :: "['a, 'b] \<Rightarrow> bool" and K'
  defines K: "K \<equiv> {(x, y). rel_set (\<lambda> y x. T x y) x y} `` K'"
  assumes "bi_unique T"
    and "\<Union>K' \<subseteq> Collect (Rangep T)"
    and "rel_set T xl (\<Union>K')"
  shows "\<Union>K = xl"
proof -
  let ?T' = "\<lambda> y x. T x y"
  from assms(2) have "bi_unique ?T'" unfolding bi_unique_def by simp
  moreover from assms(3) have "\<Union>K' \<subseteq> Collect (Domainp ?T')" by blast
  moreover from assms(4) have "rel_set ?T' (\<Union>K') xl"
    unfolding rel_set_def by simp
  ultimately have "\<Union>({(x, y). rel_set ?T' x y} `` K') = xl"
    by (rule bi_unique_Union_r)
  thus ?thesis using K by simp
qed

context
  includes lifting_syntax
begin

text\<open>
The lemma \<^text>\<open>Domainp_applyI\<close> was adopted from the lemma with the
identical name in the theory \<^text>\<open>Types_To_Sets/Group_on_With.thy\<close>.
\<close>
lemma Domainp_applyI:
  includes lifting_syntax
  shows "(A ===> B) f g \<Longrightarrow> A x y \<Longrightarrow> Domainp B (f x)"
  by (auto simp: rel_fun_def)

lemma Domainp_fun:
  assumes "left_unique A"
  shows
    "Domainp (rel_fun A B) =
      (\<lambda>f. f ` (Collect (Domainp A)) \<subseteq> (Collect (Domainp B)))"
proof-
  have
    "pred_fun (Domainp A) (Domainp B) =
      (\<lambda>f. f ` (Collect (Domainp A)) \<subseteq> (Collect (Domainp B)))"
    by (simp add: image_subset_iff)
  from Domainp_pred_fun_eq[OF \<open>left_unique A\<close>, of B, unfolded this]
  show ?thesis .
qed

lemma Bex_fun_transfer[transfer_rule]:
  assumes "bi_unique A" "right_total B"
  shows
    "(((A ===> B) ===> (=)) ===> (=))
      (Bex (Collect (\<lambda>f. f ` (Collect (Domainp A)) \<subseteq> (Collect (Domainp B)))))
      Ex"
proof-
  from assms(1) have "left_unique A" by (simp add: bi_unique_alt_def)
  note right_total_BA[transfer_rule] =
    right_total_fun[
      OF conjunct2[OF bi_unique_alt_def[THEN iffD1, OF assms(1)]] assms(2)
      ]
  show ?thesis
    unfolding Domainp_fun[OF \<open>left_unique A\<close>, symmetric]
    by transfer_prover
qed

end

text\<open>\newpage\<close>

end


(*  Title:      HOL/HOLCF/LowerPD.thy
    Author:     Brian Huffman
*)

section \<open>Lower powerdomain\<close>

theory LowerPD
imports Compact_Basis
begin

subsection \<open>Basis preorder\<close>

definition
  lower_le :: "'a pd_basis \<Rightarrow> 'a pd_basis \<Rightarrow> bool" (infix "\<le>\<flat>" 50) where
  "lower_le = (\<lambda>u v. \<forall>x\<in>Rep_pd_basis u. \<exists>y\<in>Rep_pd_basis v. x \<sqsubseteq> y)"

lemma lower_le_refl [simp]: "t \<le>\<flat> t"
unfolding lower_le_def by fast

lemma lower_le_trans: "\<lbrakk>t \<le>\<flat> u; u \<le>\<flat> v\<rbrakk> \<Longrightarrow> t \<le>\<flat> v"
unfolding lower_le_def
apply (rule ballI)
apply (drule (1) bspec, erule bexE)
apply (drule (1) bspec, erule bexE)
apply (erule rev_bexI)
apply (erule (1) below_trans)
done

interpretation lower_le: preorder lower_le
by (rule preorder.intro, rule lower_le_refl, rule lower_le_trans)

lemma lower_le_minimal [simp]: "PDUnit compact_bot \<le>\<flat> t"
unfolding lower_le_def Rep_PDUnit
by (simp, rule Rep_pd_basis_nonempty [folded ex_in_conv])

lemma PDUnit_lower_mono: "x \<sqsubseteq> y \<Longrightarrow> PDUnit x \<le>\<flat> PDUnit y"
unfolding lower_le_def Rep_PDUnit by fast

lemma PDPlus_lower_mono: "\<lbrakk>s \<le>\<flat> t; u \<le>\<flat> v\<rbrakk> \<Longrightarrow> PDPlus s u \<le>\<flat> PDPlus t v"
unfolding lower_le_def Rep_PDPlus by fast

lemma PDPlus_lower_le: "t \<le>\<flat> PDPlus t u"
unfolding lower_le_def Rep_PDPlus by fast

lemma lower_le_PDUnit_PDUnit_iff [simp]:
  "(PDUnit a \<le>\<flat> PDUnit b) = (a \<sqsubseteq> b)"
unfolding lower_le_def Rep_PDUnit by fast

lemma lower_le_PDUnit_PDPlus_iff:
  "(PDUnit a \<le>\<flat> PDPlus t u) = (PDUnit a \<le>\<flat> t \<or> PDUnit a \<le>\<flat> u)"
unfolding lower_le_def Rep_PDPlus Rep_PDUnit by fast

lemma lower_le_PDPlus_iff: "(PDPlus t u \<le>\<flat> v) = (t \<le>\<flat> v \<and> u \<le>\<flat> v)"
unfolding lower_le_def Rep_PDPlus by fast

lemma lower_le_induct [induct set: lower_le]:
  assumes le: "t \<le>\<flat> u"
  assumes 1: "\<And>a b. a \<sqsubseteq> b \<Longrightarrow> P (PDUnit a) (PDUnit b)"
  assumes 2: "\<And>t u a. P (PDUnit a) t \<Longrightarrow> P (PDUnit a) (PDPlus t u)"
  assumes 3: "\<And>t u v. \<lbrakk>P t v; P u v\<rbrakk> \<Longrightarrow> P (PDPlus t u) v"
  shows "P t u"
using le
apply (induct t arbitrary: u rule: pd_basis_induct)
apply (erule rev_mp)
apply (induct_tac u rule: pd_basis_induct)
apply (simp add: 1)
apply (simp add: lower_le_PDUnit_PDPlus_iff)
apply (simp add: 2)
apply (subst PDPlus_commute)
apply (simp add: 2)
apply (simp add: lower_le_PDPlus_iff 3)
done

subsection \<open>Type definition\<close>

typedef 'a lower_pd  ("('(_')\<flat>)") =
  "{S::'a pd_basis set. lower_le.ideal S}"
by (rule lower_le.ex_ideal)

instantiation lower_pd :: (bifinite) below
begin

definition
  "x \<sqsubseteq> y \<longleftrightarrow> Rep_lower_pd x \<subseteq> Rep_lower_pd y"

instance ..
end

instance lower_pd :: (bifinite) po
using type_definition_lower_pd below_lower_pd_def
by (rule lower_le.typedef_ideal_po)

instance lower_pd :: (bifinite) cpo
using type_definition_lower_pd below_lower_pd_def
by (rule lower_le.typedef_ideal_cpo)

definition
  lower_principal :: "'a pd_basis \<Rightarrow> 'a lower_pd" where
  "lower_principal t = Abs_lower_pd {u. u \<le>\<flat> t}"

interpretation lower_pd:
  ideal_completion lower_le lower_principal Rep_lower_pd
using type_definition_lower_pd below_lower_pd_def
using lower_principal_def pd_basis_countable
by (rule lower_le.typedef_ideal_completion)

text \<open>Lower powerdomain is pointed\<close>

lemma lower_pd_minimal: "lower_principal (PDUnit compact_bot) \<sqsubseteq> ys"
by (induct ys rule: lower_pd.principal_induct, simp, simp)

instance lower_pd :: (bifinite) pcpo
by intro_classes (fast intro: lower_pd_minimal)

lemma inst_lower_pd_pcpo: "\<bottom> = lower_principal (PDUnit compact_bot)"
by (rule lower_pd_minimal [THEN bottomI, symmetric])

subsection \<open>Monadic unit and plus\<close>

definition
  lower_unit :: "'a \<rightarrow> 'a lower_pd" where
  "lower_unit = compact_basis.extension (\<lambda>a. lower_principal (PDUnit a))"

definition
  lower_plus :: "'a lower_pd \<rightarrow> 'a lower_pd \<rightarrow> 'a lower_pd" where
  "lower_plus = lower_pd.extension (\<lambda>t. lower_pd.extension (\<lambda>u.
      lower_principal (PDPlus t u)))"

abbreviation
  lower_add :: "'a lower_pd \<Rightarrow> 'a lower_pd \<Rightarrow> 'a lower_pd"
    (infixl "\<union>\<flat>" 65) where
  "xs \<union>\<flat> ys == lower_plus\<cdot>xs\<cdot>ys"

syntax
  "_lower_pd" :: "args \<Rightarrow> logic" ("{_}\<flat>")

translations
  "{x,xs}\<flat>" == "{x}\<flat> \<union>\<flat> {xs}\<flat>"
  "{x}\<flat>" == "CONST lower_unit\<cdot>x"

lemma lower_unit_Rep_compact_basis [simp]:
  "{Rep_compact_basis a}\<flat> = lower_principal (PDUnit a)"
unfolding lower_unit_def
by (simp add: compact_basis.extension_principal PDUnit_lower_mono)

lemma lower_plus_principal [simp]:
  "lower_principal t \<union>\<flat> lower_principal u = lower_principal (PDPlus t u)"
unfolding lower_plus_def
by (simp add: lower_pd.extension_principal
    lower_pd.extension_mono PDPlus_lower_mono)

interpretation lower_add: semilattice lower_add proof
  fix xs ys zs :: "'a lower_pd"
  show "(xs \<union>\<flat> ys) \<union>\<flat> zs = xs \<union>\<flat> (ys \<union>\<flat> zs)"
    apply (induct xs rule: lower_pd.principal_induct, simp)
    apply (induct ys rule: lower_pd.principal_induct, simp)
    apply (induct zs rule: lower_pd.principal_induct, simp)
    apply (simp add: PDPlus_assoc)
    done
  show "xs \<union>\<flat> ys = ys \<union>\<flat> xs"
    apply (induct xs rule: lower_pd.principal_induct, simp)
    apply (induct ys rule: lower_pd.principal_induct, simp)
    apply (simp add: PDPlus_commute)
    done
  show "xs \<union>\<flat> xs = xs"
    apply (induct xs rule: lower_pd.principal_induct, simp)
    apply (simp add: PDPlus_absorb)
    done
qed

lemmas lower_plus_assoc = lower_add.assoc
lemmas lower_plus_commute = lower_add.commute
lemmas lower_plus_absorb = lower_add.idem
lemmas lower_plus_left_commute = lower_add.left_commute
lemmas lower_plus_left_absorb = lower_add.left_idem

text \<open>Useful for \<open>simp add: lower_plus_ac\<close>\<close>
lemmas lower_plus_ac =
  lower_plus_assoc lower_plus_commute lower_plus_left_commute

text \<open>Useful for \<open>simp only: lower_plus_aci\<close>\<close>
lemmas lower_plus_aci =
  lower_plus_ac lower_plus_absorb lower_plus_left_absorb

lemma lower_plus_below1: "xs \<sqsubseteq> xs \<union>\<flat> ys"
apply (induct xs rule: lower_pd.principal_induct, simp)
apply (induct ys rule: lower_pd.principal_induct, simp)
apply (simp add: PDPlus_lower_le)
done

lemma lower_plus_below2: "ys \<sqsubseteq> xs \<union>\<flat> ys"
by (subst lower_plus_commute, rule lower_plus_below1)

lemma lower_plus_least: "\<lbrakk>xs \<sqsubseteq> zs; ys \<sqsubseteq> zs\<rbrakk> \<Longrightarrow> xs \<union>\<flat> ys \<sqsubseteq> zs"
apply (subst lower_plus_absorb [of zs, symmetric])
apply (erule (1) monofun_cfun [OF monofun_cfun_arg])
done

lemma lower_plus_below_iff [simp]:
  "xs \<union>\<flat> ys \<sqsubseteq> zs \<longleftrightarrow> xs \<sqsubseteq> zs \<and> ys \<sqsubseteq> zs"
apply safe
apply (erule below_trans [OF lower_plus_below1])
apply (erule below_trans [OF lower_plus_below2])
apply (erule (1) lower_plus_least)
done

lemma lower_unit_below_plus_iff [simp]:
  "{x}\<flat> \<sqsubseteq> ys \<union>\<flat> zs \<longleftrightarrow> {x}\<flat> \<sqsubseteq> ys \<or> {x}\<flat> \<sqsubseteq> zs"
apply (induct x rule: compact_basis.principal_induct, simp)
apply (induct ys rule: lower_pd.principal_induct, simp)
apply (induct zs rule: lower_pd.principal_induct, simp)
apply (simp add: lower_le_PDUnit_PDPlus_iff)
done

lemma lower_unit_below_iff [simp]: "{x}\<flat> \<sqsubseteq> {y}\<flat> \<longleftrightarrow> x \<sqsubseteq> y"
apply (induct x rule: compact_basis.principal_induct, simp)
apply (induct y rule: compact_basis.principal_induct, simp)
apply simp
done

lemmas lower_pd_below_simps =
  lower_unit_below_iff
  lower_plus_below_iff
  lower_unit_below_plus_iff

lemma lower_unit_eq_iff [simp]: "{x}\<flat> = {y}\<flat> \<longleftrightarrow> x = y"
by (simp add: po_eq_conv)

lemma lower_unit_strict [simp]: "{\<bottom>}\<flat> = \<bottom>"
using lower_unit_Rep_compact_basis [of compact_bot]
by (simp add: inst_lower_pd_pcpo)

lemma lower_unit_bottom_iff [simp]: "{x}\<flat> = \<bottom> \<longleftrightarrow> x = \<bottom>"
unfolding lower_unit_strict [symmetric] by (rule lower_unit_eq_iff)

lemma lower_plus_bottom_iff [simp]:
  "xs \<union>\<flat> ys = \<bottom> \<longleftrightarrow> xs = \<bottom> \<and> ys = \<bottom>"
apply safe
apply (rule bottomI, erule subst, rule lower_plus_below1)
apply (rule bottomI, erule subst, rule lower_plus_below2)
apply (rule lower_plus_absorb)
done

lemma lower_plus_strict1 [simp]: "\<bottom> \<union>\<flat> ys = ys"
apply (rule below_antisym [OF _ lower_plus_below2])
apply (simp add: lower_plus_least)
done

lemma lower_plus_strict2 [simp]: "xs \<union>\<flat> \<bottom> = xs"
apply (rule below_antisym [OF _ lower_plus_below1])
apply (simp add: lower_plus_least)
done

lemma compact_lower_unit: "compact x \<Longrightarrow> compact {x}\<flat>"
by (auto dest!: compact_basis.compact_imp_principal)

lemma compact_lower_unit_iff [simp]: "compact {x}\<flat> \<longleftrightarrow> compact x"
apply (safe elim!: compact_lower_unit)
apply (simp only: compact_def lower_unit_below_iff [symmetric])
apply (erule adm_subst [OF cont_Rep_cfun2])
done

lemma compact_lower_plus [simp]:
  "\<lbrakk>compact xs; compact ys\<rbrakk> \<Longrightarrow> compact (xs \<union>\<flat> ys)"
by (auto dest!: lower_pd.compact_imp_principal)

subsection \<open>Induction rules\<close>

lemma lower_pd_induct1:
  assumes P: "adm P"
  assumes unit: "\<And>x. P {x}\<flat>"
  assumes insert:
    "\<And>x ys. \<lbrakk>P {x}\<flat>; P ys\<rbrakk> \<Longrightarrow> P ({x}\<flat> \<union>\<flat> ys)"
  shows "P (xs::'a lower_pd)"
apply (induct xs rule: lower_pd.principal_induct, rule P)
apply (induct_tac a rule: pd_basis_induct1)
apply (simp only: lower_unit_Rep_compact_basis [symmetric])
apply (rule unit)
apply (simp only: lower_unit_Rep_compact_basis [symmetric]
                  lower_plus_principal [symmetric])
apply (erule insert [OF unit])
done

lemma lower_pd_induct
  [case_names adm lower_unit lower_plus, induct type: lower_pd]:
  assumes P: "adm P"
  assumes unit: "\<And>x. P {x}\<flat>"
  assumes plus: "\<And>xs ys. \<lbrakk>P xs; P ys\<rbrakk> \<Longrightarrow> P (xs \<union>\<flat> ys)"
  shows "P (xs::'a lower_pd)"
apply (induct xs rule: lower_pd.principal_induct, rule P)
apply (induct_tac a rule: pd_basis_induct)
apply (simp only: lower_unit_Rep_compact_basis [symmetric] unit)
apply (simp only: lower_plus_principal [symmetric] plus)
done

subsection \<open>Monadic bind\<close>

definition
  lower_bind_basis ::
  "'a pd_basis \<Rightarrow> ('a \<rightarrow> 'b lower_pd) \<rightarrow> 'b lower_pd" where
  "lower_bind_basis = fold_pd
    (\<lambda>a. \<Lambda> f. f\<cdot>(Rep_compact_basis a))
    (\<lambda>x y. \<Lambda> f. x\<cdot>f \<union>\<flat> y\<cdot>f)"

lemma ACI_lower_bind:
  "semilattice (\<lambda>x y. \<Lambda> f. x\<cdot>f \<union>\<flat> y\<cdot>f)"
apply unfold_locales
apply (simp add: lower_plus_assoc)
apply (simp add: lower_plus_commute)
apply (simp add: eta_cfun)
done

lemma lower_bind_basis_simps [simp]:
  "lower_bind_basis (PDUnit a) =
    (\<Lambda> f. f\<cdot>(Rep_compact_basis a))"
  "lower_bind_basis (PDPlus t u) =
    (\<Lambda> f. lower_bind_basis t\<cdot>f \<union>\<flat> lower_bind_basis u\<cdot>f)"
unfolding lower_bind_basis_def
apply -
apply (rule fold_pd_PDUnit [OF ACI_lower_bind])
apply (rule fold_pd_PDPlus [OF ACI_lower_bind])
done

lemma lower_bind_basis_mono:
  "t \<le>\<flat> u \<Longrightarrow> lower_bind_basis t \<sqsubseteq> lower_bind_basis u"
unfolding cfun_below_iff
apply (erule lower_le_induct, safe)
apply (simp add: monofun_cfun)
apply (simp add: rev_below_trans [OF lower_plus_below1])
apply simp
done

definition
  lower_bind :: "'a lower_pd \<rightarrow> ('a \<rightarrow> 'b lower_pd) \<rightarrow> 'b lower_pd" where
  "lower_bind = lower_pd.extension lower_bind_basis"

syntax
  "_lower_bind" :: "[logic, logic, logic] \<Rightarrow> logic"
    ("(3\<Union>\<flat>_\<in>_./ _)" [0, 0, 10] 10)

translations
  "\<Union>\<flat>x\<in>xs. e" == "CONST lower_bind\<cdot>xs\<cdot>(\<Lambda> x. e)"

lemma lower_bind_principal [simp]:
  "lower_bind\<cdot>(lower_principal t) = lower_bind_basis t"
unfolding lower_bind_def
apply (rule lower_pd.extension_principal)
apply (erule lower_bind_basis_mono)
done

lemma lower_bind_unit [simp]:
  "lower_bind\<cdot>{x}\<flat>\<cdot>f = f\<cdot>x"
by (induct x rule: compact_basis.principal_induct, simp, simp)

lemma lower_bind_plus [simp]:
  "lower_bind\<cdot>(xs \<union>\<flat> ys)\<cdot>f = lower_bind\<cdot>xs\<cdot>f \<union>\<flat> lower_bind\<cdot>ys\<cdot>f"
by (induct xs rule: lower_pd.principal_induct, simp,
    induct ys rule: lower_pd.principal_induct, simp, simp)

lemma lower_bind_strict [simp]: "lower_bind\<cdot>\<bottom>\<cdot>f = f\<cdot>\<bottom>"
unfolding lower_unit_strict [symmetric] by (rule lower_bind_unit)

lemma lower_bind_bind:
  "lower_bind\<cdot>(lower_bind\<cdot>xs\<cdot>f)\<cdot>g = lower_bind\<cdot>xs\<cdot>(\<Lambda> x. lower_bind\<cdot>(f\<cdot>x)\<cdot>g)"
by (induct xs, simp_all)

subsection \<open>Map\<close>

definition
  lower_map :: "('a \<rightarrow> 'b) \<rightarrow> 'a lower_pd \<rightarrow> 'b lower_pd" where
  "lower_map = (\<Lambda> f xs. lower_bind\<cdot>xs\<cdot>(\<Lambda> x. {f\<cdot>x}\<flat>))"

lemma lower_map_unit [simp]:
  "lower_map\<cdot>f\<cdot>{x}\<flat> = {f\<cdot>x}\<flat>"
unfolding lower_map_def by simp

lemma lower_map_plus [simp]:
  "lower_map\<cdot>f\<cdot>(xs \<union>\<flat> ys) = lower_map\<cdot>f\<cdot>xs \<union>\<flat> lower_map\<cdot>f\<cdot>ys"
unfolding lower_map_def by simp

lemma lower_map_bottom [simp]: "lower_map\<cdot>f\<cdot>\<bottom> = {f\<cdot>\<bottom>}\<flat>"
unfolding lower_map_def by simp

lemma lower_map_ident: "lower_map\<cdot>(\<Lambda> x. x)\<cdot>xs = xs"
by (induct xs rule: lower_pd_induct, simp_all)

lemma lower_map_ID: "lower_map\<cdot>ID = ID"
by (simp add: cfun_eq_iff ID_def lower_map_ident)

lemma lower_map_map:
  "lower_map\<cdot>f\<cdot>(lower_map\<cdot>g\<cdot>xs) = lower_map\<cdot>(\<Lambda> x. f\<cdot>(g\<cdot>x))\<cdot>xs"
by (induct xs rule: lower_pd_induct, simp_all)

lemma lower_bind_map:
  "lower_bind\<cdot>(lower_map\<cdot>f\<cdot>xs)\<cdot>g = lower_bind\<cdot>xs\<cdot>(\<Lambda> x. g\<cdot>(f\<cdot>x))"
by (simp add: lower_map_def lower_bind_bind)

lemma lower_map_bind:
  "lower_map\<cdot>f\<cdot>(lower_bind\<cdot>xs\<cdot>g) = lower_bind\<cdot>xs\<cdot>(\<Lambda> x. lower_map\<cdot>f\<cdot>(g\<cdot>x))"
by (simp add: lower_map_def lower_bind_bind)

lemma ep_pair_lower_map: "ep_pair e p \<Longrightarrow> ep_pair (lower_map\<cdot>e) (lower_map\<cdot>p)"
apply standard
apply (induct_tac x rule: lower_pd_induct, simp_all add: ep_pair.e_inverse)
apply (induct_tac y rule: lower_pd_induct)
apply (simp_all add: ep_pair.e_p_below monofun_cfun del: lower_plus_below_iff)
done

lemma deflation_lower_map: "deflation d \<Longrightarrow> deflation (lower_map\<cdot>d)"
apply standard
apply (induct_tac x rule: lower_pd_induct, simp_all add: deflation.idem)
apply (induct_tac x rule: lower_pd_induct)
apply (simp_all add: deflation.below monofun_cfun del: lower_plus_below_iff)
done

(* FIXME: long proof! *)
lemma finite_deflation_lower_map:
  assumes "finite_deflation d" shows "finite_deflation (lower_map\<cdot>d)"
proof (rule finite_deflation_intro)
  interpret d: finite_deflation d by fact
  from d.deflation_axioms show "deflation (lower_map\<cdot>d)"
    by (rule deflation_lower_map)
  have "finite (range (\<lambda>x. d\<cdot>x))" by (rule d.finite_range)
  hence "finite (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))"
    by (rule finite_vimageI, simp add: inj_on_def Rep_compact_basis_inject)
  hence "finite (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x)))" by simp
  hence "finite (Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))"
    by (rule finite_vimageI, simp add: inj_on_def Rep_pd_basis_inject)
  hence *: "finite (lower_principal ` Rep_pd_basis -` (Pow (Rep_compact_basis -` range (\<lambda>x. d\<cdot>x))))" by simp
  hence "finite (range (\<lambda>xs. lower_map\<cdot>d\<cdot>xs))"
    apply (rule rev_finite_subset)
    apply clarsimp
    apply (induct_tac xs rule: lower_pd.principal_induct)
    apply (simp add: adm_mem_finite *)
    apply (rename_tac t, induct_tac t rule: pd_basis_induct)
    apply (simp only: lower_unit_Rep_compact_basis [symmetric] lower_map_unit)
    apply simp
    apply (subgoal_tac "\<exists>b. d\<cdot>(Rep_compact_basis a) = Rep_compact_basis b")
    apply clarsimp
    apply (rule imageI)
    apply (rule vimageI2)
    apply (simp add: Rep_PDUnit)
    apply (rule range_eqI)
    apply (erule sym)
    apply (rule exI)
    apply (rule Abs_compact_basis_inverse [symmetric])
    apply (simp add: d.compact)
    apply (simp only: lower_plus_principal [symmetric] lower_map_plus)
    apply clarsimp
    apply (rule imageI)
    apply (rule vimageI2)
    apply (simp add: Rep_PDPlus)
    done
  thus "finite {xs. lower_map\<cdot>d\<cdot>xs = xs}"
    by (rule finite_range_imp_finite_fixes)
qed

subsection \<open>Lower powerdomain is bifinite\<close>

lemma approx_chain_lower_map:
  assumes "approx_chain a"
  shows "approx_chain (\<lambda>i. lower_map\<cdot>(a i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP lower_map_ID finite_deflation_lower_map)

instance lower_pd :: (bifinite) bifinite
proof
  show "\<exists>(a::nat \<Rightarrow> 'a lower_pd \<rightarrow> 'a lower_pd). approx_chain a"
    using bifinite [where 'a='a]
    by (fast intro!: approx_chain_lower_map)
qed

subsection \<open>Join\<close>

definition
  lower_join :: "'a lower_pd lower_pd \<rightarrow> 'a lower_pd" where
  "lower_join = (\<Lambda> xss. lower_bind\<cdot>xss\<cdot>(\<Lambda> xs. xs))"

lemma lower_join_unit [simp]:
  "lower_join\<cdot>{xs}\<flat> = xs"
unfolding lower_join_def by simp

lemma lower_join_plus [simp]:
  "lower_join\<cdot>(xss \<union>\<flat> yss) = lower_join\<cdot>xss \<union>\<flat> lower_join\<cdot>yss"
unfolding lower_join_def by simp

lemma lower_join_bottom [simp]: "lower_join\<cdot>\<bottom> = \<bottom>"
unfolding lower_join_def by simp

lemma lower_join_map_unit:
  "lower_join\<cdot>(lower_map\<cdot>lower_unit\<cdot>xs) = xs"
by (induct xs rule: lower_pd_induct, simp_all)

lemma lower_join_map_join:
  "lower_join\<cdot>(lower_map\<cdot>lower_join\<cdot>xsss) = lower_join\<cdot>(lower_join\<cdot>xsss)"
by (induct xsss rule: lower_pd_induct, simp_all)

lemma lower_join_map_map:
  "lower_join\<cdot>(lower_map\<cdot>(lower_map\<cdot>f)\<cdot>xss) =
   lower_map\<cdot>f\<cdot>(lower_join\<cdot>xss)"
by (induct xss rule: lower_pd_induct, simp_all)

end


theory Practical1
imports Main
begin

(***************************First-order logic*************************************)

(*1 mark*)
lemma "A\<or>A \<longrightarrow> A"
  apply (rule impI)
  by (erule disjE)

(*1 mark*)
lemma "(P\<longrightarrow>R)\<longrightarrow>(\<not>P\<or>R)"
  apply (rule impI)
  apply (rule classical)
  apply (erule impE)
   apply (rule classical)
   apply (erule notE)
  apply (rule disjI1)
   apply assumption
  by (rule disjI2)

(*1 mark*)
lemma "(P\<and>Q\<longrightarrow>R)\<longrightarrow>P\<longrightarrow>Q\<longrightarrow>R"
  apply (rule impI)+
  apply (rule classical)
  apply (erule impE)
  by (rule conjI)

(*3 marks*)
lemma "\<not>\<not>P \<or> \<not>P"
  apply (rule classical)
  apply (rule disjI1)
  apply (rule notI)
  apply (erule notE)
  by (rule disjI2)

(*4 marks*)
lemma "(P\<or>R)\<longleftrightarrow>(\<not>(\<not>P\<and> \<not>R))"
  apply (rule iffI)
   apply (rule classical)
   apply (rule notI)
   apply (erule notE)
   apply (erule conjE)
   apply (rule classical)
   apply (rule notI)
   apply (erule notE)
   apply (erule conjE)
   apply (erule disjE)
    apply assumption
   apply (erule notE)
   apply assumption
  apply (rule classical)
  apply (erule notE)
  apply (rule conjI)
   apply (rule classical)
   apply (rule notI)
   apply (erule notE)
   apply (rule disjI1)
   apply assumption
  apply (rule classical)
  apply (rule notI)
  apply (erule notE)
  by (rule disjI2)

(*1 mark*)
lemma "(\<forall> x . F x) \<and> (\<forall> x . G x ) \<longrightarrow> (\<forall> x . F x \<and> G x )"
  apply (rule impI)
  apply (erule conjE)
  apply (rule allI)
  apply (erule_tac x="x" in allE)+
  apply (rule conjI)
  by assumption

(*1 mark*)
lemma "(\<forall> x y. R x y) \<longrightarrow> (\<forall> x . R x x )"
  apply (rule impI)
  apply (rule allI)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  by assumption

(*3 marks*)
lemma "(\<forall>x. P x)\<or>(\<exists>x.\<not>P x)"

  apply (rule classical)
  apply (rule disjI1)
  apply (rule allI)
  apply (rule classical)
  apply (erule notE)
  apply (rule disjI2)
  by (rule_tac x="x" in exI)

(*3 marks*)
lemma "(\<forall>x. \<not> (P x \<longrightarrow> Q x)) \<longrightarrow> \<not>(\<exists>x. \<not>P x \<and> Q x)"
  apply (rule impI)
  apply (rule notI)
  apply (rule classical)
  apply (erule notE)
  apply (erule exE)
  apply (erule conjE)
  apply (erule notE)
  apply (erule allE)
  apply (rule classical)
  apply (erule notE)
  by (rule impI)

(*3 marks*)
lemma "\<exists>Bob. (drunk Bob \<longrightarrow> (\<forall>y. drunk y))"
  apply (rule classical)
  apply (rule_tac x="Bob" in exI)
  apply (rule impI)
  apply (rule allI)
  apply (rule ccontr)
  apply (erule notE)
  apply (rule exI)
  apply (rule impI)
  apply (rule allI)
  by (erule notE)

(*4 marks*)
lemma "\<not> (\<exists> b . M b \<and> (\<forall> x . M x \<and> \<not>S x x \<longleftrightarrow> S B x ))"
  apply (rule classical)
  apply (rule notI)
  apply (erule notE)
  apply (erule exE)
  apply (erule conjE)
  apply (rule notI)
  apply (erule exE)
  apply (erule conjE)
  apply (erule allE)
  apply (erule iffE)+
  apply (erule impE)+
    apply (erule allE)
    apply (erule iffE)
  oops

locale incidence =
  fixes incidence_points_on_sections :: "'point \<Rightarrow> 'section \<Rightarrow> bool" (infix " \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t " 80)
  fixes region_to_section :: "'region \<Rightarrow> 'section"
  assumes section_nonempty: "\<exists>point. point \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t section"
(*Write here your axiom stating that every section has
                                            a point incident to it*) (*2 marks*)
  and section_uniqueness:"(\<And>p. (p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t s1 \<longleftrightarrow> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t s2)) \<Longrightarrow> s1 = s2"
(*Write here your axiom stating that two sections are the same
                                      if the same points are incident to each*) (*2 marks*)
begin

definition isPartOf ::"'section \<Rightarrow> 'section \<Rightarrow> bool" (infix "isPartOf" 80) where
"a isPartOf b \<equiv> (\<forall>p.(p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t a \<longrightarrow> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t b))"
(*write your formalisation of definition D1 here*) (*1 mark*)

definition inclusion ::"'region \<Rightarrow> 'section \<Rightarrow> bool"(infix "isIncludedIn" 80) where
"R isIncludedIn s \<equiv> (region_to_section R) isPartOf s"
(*write your formalisation of definition D2 here*) (*1 mark*)

definition overlaps ::"'region \<Rightarrow> 'section \<Rightarrow> bool"(infix "overlaps" 80) where
"R overlaps s \<equiv> \<exists>p. p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t (region_to_section R) \<and> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t s"
(*write your formalisation of definition D3 here*) (*1 mark*)

lemma region_overlaps_itself: "R overlaps (region_to_section R)"
proof-
  from section_nonempty
  have " \<exists>p. p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t (region_to_section R)" by blast
  hence "\<exists>p. p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t (region_to_section R) \<and> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t (region_to_section R)" by blast
  thus "R overlaps (region_to_section R)" using overlaps_def by blast
qed

(*Write your structured proof here*) (*2 marks*)

(*Formalise and prove that isPartOf is reflexive, transitive and antisymmetric*) (*3 marks*)
 lemma isPartOf_reflexive: "R isPartOf R"
   by (simp add: isPartOf_def)
(*  proof-
   from section_uniqueness
   have "\<forall>p. p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t R \<longrightarrow> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t R" by blast
   thus "R isPartOf R" using isPartOf_def by blast
 qed *)
(*Formalise and prove that isPartOf is reflexive here*)

lemma isPartOf_transitive:"(a isPartOf b) \<and> (b isPartOf c) \<Longrightarrow> a isPartOf c"
  by (simp add: isPartOf_def)
(* proof-
  from 1
  have "(\<forall>p1. p1 \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t a \<longrightarrow> p1 \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t b) \<and> (\<forall>p2. p2 \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t b \<longrightarrow> p2 \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t c)" using isPartOf_def by blast
  hence "\<forall>p. (p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t a \<longrightarrow> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t b) \<and> (p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t b \<longrightarrow> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t c)" by blast
  hence "\<forall>p. (\<not>(p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t a) \<or> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t b) \<and> (\<not>(p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t b) \<or> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t c)" by blast
  hence "\<forall>p. (\<not>(p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t a) \<or> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t c) \<and> (\<not>(p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t b) \<or> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t b)" by blast
  hence "\<forall>p. (\<not>(p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t a) \<or> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t c)" by blast
  hence "\<forall>p. p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t a \<longrightarrow> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t c" by blast
  thus "a isPartOf c" using isPartOf_def by blast
qed *)
(*Formalise and prove that isPartOf is transitive here*)

lemma isPartOf_antisymmetric:
  assumes 1:"a isPartOf b \<and> b isPartOf a" shows " a = b"
  using assms isPartOf_def section_uniqueness by blast
(* proof-
  from 1
  have "\<And>p. (p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t a \<longrightarrow> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t b) \<and> (p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t b \<longrightarrow> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t a)" using isPartOf_def by blast
  hence "\<And>p. (\<not>(p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t a) \<or> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t b) \<and> (\<not>(p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t b) \<or> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t a)" by blast
  hence "\<And>p. (p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t a) \<longleftrightarrow> (p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t b)" by blast
  thus "a = b" using section_uniqueness by blast
qed *)
(*Formalise and prove that isPartOf is antisymmetric here*)

end

locale section_bundles =  incidence incidence_points_on_sections region_to_section
  for  incidence_points_on_sections :: "'point \<Rightarrow> 'section \<Rightarrow> bool"
  and region_to_section :: "'region \<Rightarrow> 'section" +
  fixes crossing :: "'region \<Rightarrow> 'section \<Rightarrow> bool" (infix "crosses" 80)
  and incidence_sections_on_bundles :: "'section \<Rightarrow> 'bundle \<Rightarrow> bool" (infix "\<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n" 80)
assumes SC1: "(R crosses S \<Longrightarrow> R overlaps S)"
 (*Write your formalisation of Axiom SC1 here*) (*1 mark*)
 and SI1: "\<And>s. (s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<longleftrightarrow> s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b') \<Longrightarrow> b = b'"
 (*Write your formalisation of Axiom SI1 here*)     (*1 mark*)
begin

definition atLeastAsRestrictiveAs :: "'section \<Rightarrow> 'bundle \<Rightarrow> 'section \<Rightarrow> bool" where
"atLeastAsRestrictiveAs s b s' \<equiv> s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s isPartOf s'"
(*Write your formalisation of atLeastAsRestrictiveAs here*) (*1 mark*)

notation
  atLeastAsRestrictiveAs ("_ \<le>\<^sub>_ _" [80, 80, 80] 80)

(*Formalise and prove that atLeastAsRestrictiveAs is reflexive, transitive and antisymmetric*) (*2 marks*)

(*Kulik and Eschenbach say 'The relation \<ge> is reflexive, transitive and antisymmetric for a given
sector bundle.' So, do they mean, given that the sections under consideration are in the bundle?
This is what we assume for reflexivity.*)
lemma atLeastAsRestrictiveAs_reflexive:
  assumes 1:"s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b"  shows "s \<le>\<^sub>b s"
proof-
  from isPartOf_reflexive
  have "s isPartOf s" by blast
  hence "s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s isPartOf s" using 1 by blast
  thus "s \<le>\<^sub>b s" using atLeastAsRestrictiveAs_def by blast
qed

lemma atLeastAsRestrictiveAs_transitive:
  assumes 0:"s1 \<le>\<^sub>b s2 \<and> s2 \<le>\<^sub>b s3" shows "s1 \<le>\<^sub>b s3"
  using assms atLeastAsRestrictiveAs_def isPartOf_transitive by blast
(*Formalise and prove that atLeastAsRestrictiveAs is transitive*)
(* proof-
  from 0
  have 1:"(s1 \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s2 \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s1 isPartOf s2 ) \<and> (s3 \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s2 \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s2 isPartOf s3)" using atLeastAsRestrictiveAs_def by blast
  hence 2: "s1 isPartOf s3" using isPartOf_transitive by blast
  hence "s1 \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s3 \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s1 isPartOf s3" using 1 2 by blast
  thus "s1 \<le>\<^sub>b s3" using atLeastAsRestrictiveAs_def by blast
qed *)

lemma atLeastAsRestrictiveAs_antisymmetric:
  assumes 1:"s1 \<le>\<^sub>b s2 \<and> s2 \<le>\<^sub>b s1" shows "s1 = s2"
  using assms atLeastAsRestrictiveAs_def isPartOf_antisymmetric by auto
(*Formalise and prove that atLeastAsRestrictiveAs is antisymmetric*)
(* proof-
  from 1
  have "(s1 \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s1 isPartOf s2 ) \<and> (s2 \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b  \<and> s2 isPartOf s1)" using atLeastAsRestrictiveAs_def by blast
    hence "s1 isPartOf s2 \<and> s2 isPartOf s1" by blast
      thus "s1 = s2" using isPartOf_antisymmetric by blast
qed *)

end

locale comparison = section_bundles incidence_points_on_sections region_to_section
 crossing incidence_sections_on_bundles
  for  incidence_points_on_sections :: "'point \<Rightarrow> 'section \<Rightarrow> bool" (infix "\<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t" 80)
  and region_to_section :: "'region \<Rightarrow> 'section"
  and crossing :: "'region \<Rightarrow> 'section \<Rightarrow> bool" (infix "crosses" 80)
  and incidence_sections_on_bundles :: "'section \<Rightarrow> 'bundle \<Rightarrow> bool" (infix "\<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n" 80)+
assumes SB2: "s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<Longrightarrow> s \<le>\<^sub>b s' \<or> s' \<le>\<^sub>b s"
assumes SC2: "R crosses S \<Longrightarrow> (\<And>S'. (S' \<le>\<^sub>b S \<Longrightarrow> R crosses S'))"
(*Write your formalisation of Axiom SB2 here*) (*1 mark*)
begin

lemma T1:
  assumes "R overlaps s" shows "(\<And>s'. (s \<le>\<^sub>b s' \<Longrightarrow> R overlaps s'))"
  using assms atLeastAsRestrictiveAs_def isPartOf_def overlaps_def by auto
(*Write your formalisation and proof of Theorem T1 here*) (*1 mark*)
(* proof-
  from 1
  have 2:"\<exists>p. p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t (region_to_section R) \<and> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t s1" using overlaps_def by blast
  have 3:" s1 \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s2 \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s1 isPartOf s2" using 1 atLeastAsRestrictiveAs_def by blast
  hence "(\<forall>p.(p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t s1 \<longrightarrow> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t s2))" using isPartOf_def by blast
  hence "\<exists>p. p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t (region_to_section R) \<and> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t s2" using 2 3 by blast
  thus "R overlaps s2" using overlaps_def by blast
qed *)

lemma T2:
  assumes 1:"R isIncludedIn s" "s \<le>\<^sub>b s'" shows " (s \<le>\<^sub>b s' \<Longrightarrow> R isIncludedIn s')"
  using assms(1) atLeastAsRestrictiveAs_def inclusion_def isPartOf_transitive by blast
(*Write your formalisation and proof of Theorem T2 here*) (*1 mark*)
(* proof-
  from 1
  have "(region_to_section R) isPartOf s1" using inclusion_def by blast
  hence 2:"(\<forall>p.(p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t (region_to_section R) \<longrightarrow> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t s1))" using isPartOf_def by blast
  have 3:" s1 \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s2 \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> s1 isPartOf s2" using 1 atLeastAsRestrictiveAs_def by blast
  hence "(\<forall>p.(p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t s1 \<longrightarrow> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t s2))" using isPartOf_def by blast
  hence "(\<forall>p.(p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t (region_to_section R) \<longrightarrow> p \<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t s2))" using 2 isPartOf_def by blast
  hence "(region_to_section R) isPartOf s2" using isPartOf_def by blast
  thus "R isIncludedIn s2" using inclusion_def by blast
qed *)

definition isCore (infix "isCoreOf" 80) where
"s isCoreOf b = (s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> (\<forall>s'. s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<longrightarrow> s \<le>\<^sub>b s'))"

definition isHull (infix "isHullOf" 80) where
"s isHullOf b = (s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> (\<forall>s'. s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<longrightarrow> s' \<le>\<^sub>b s))"
(*Write your definition of hull here*) (*1 mark*)

lemma overlaps_core:
(* assumes "R overlaps s" shows "(\<And>s'. (s \<le>\<^sub>b s' \<Longrightarrow> R overlaps s'))" *)
  assumes 1:"((R overlaps s) \<and> (s isCoreOf b))" shows "((s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<longrightarrow> R overlaps s'))"
proof-
  from 1
  have "((R overlaps s) \<and> (s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> (s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<longrightarrow> s \<le>\<^sub>b s')))" using isCore_def by blast
  hence "((s \<le>\<^sub>b s' \<longrightarrow> R overlaps s') \<and> (s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<longrightarrow> s \<le>\<^sub>b s'))" using T1 by blast
  hence "((\<not>(s \<le>\<^sub>b s') \<or>  R overlaps s') \<and> (\<not>(s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b) \<or> s \<le>\<^sub>b s'))" by blast
  hence "(\<not>(s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b) \<or> R overlaps s') \<and> (\<not>(s \<le>\<^sub>b s') \<or> s \<le>\<^sub>b s')" by blast
  thus "(s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<longrightarrow> R overlaps s')" by blast
qed
  (* using T1 assms isCore_def by blast *)

lemma crosses_hull:
  assumes 1:"R crosses s \<and> s isHullOf b" shows "((s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<longrightarrow> R overlaps s'))"
proof-
  from 1
  have "((s' \<le>\<^sub>b s \<longrightarrow> R crosses s')) \<and> s isHullOf b" using SC2 by blast
  hence "((s' \<le>\<^sub>b s \<longrightarrow> R crosses s')) \<and> (s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> (s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<longrightarrow> s' \<le>\<^sub>b s))" using isHull_def by blast
  hence "(\<not>(s' \<le>\<^sub>b s) \<or> R crosses s') \<and> s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> (\<not>(s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b) \<or>  s' \<le>\<^sub>b s)" by blast
  hence "(\<not>(s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b) \<or> R crosses s') \<and> s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> (\<not>(s' \<le>\<^sub>b s) \<or> s' \<le>\<^sub>b s)" by blast
  thus "(s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b) \<longrightarrow> R overlaps s'" using SC1 by blast
qed
  (* using SC1 SC2 assms isHull_def by blast *)

(* assumes SC1: "(R crosses S \<Longrightarrow> R overlaps S)" *)
(* assumes SC2: "R crosses S \<Longrightarrow> (\<And>S'. (S' \<le>\<^sub>b S \<Longrightarrow> R crosses S'))" *)
(* "s isHullOf b = (s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> (\<forall>s'. s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<longrightarrow> s' \<le>\<^sub>b s))" *)
(* assumes "R overlaps s" shows "(\<And>s'. (s \<le>\<^sub>b s' \<Longrightarrow> R overlaps s'))" *)

lemma not_overlap_hull:
  assumes 1: "\<not>R overlaps s \<and> s isHullOf b" shows "s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<longrightarrow> \<not>R overlaps s'"
proof-
  from 1
  have "\<not>R overlaps s \<and> s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> (s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<longrightarrow> s' \<le>\<^sub>b s)" using isHull_def by blast
  hence "\<not>R overlaps s \<and> s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> (\<not>(s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b) \<or> s' \<le>\<^sub>b s)" by blast
qed

  (* using T1 assms isHull_def by blast *)

end

locale crossing_sector = comparison incidence_points_on_sections
          region_to_section crossing incidence_sections_on_bundles
          for incidence_points_on_sections :: "'point \<Rightarrow> 'section \<Rightarrow> bool" (infix "\<iota>\<^sub>p\<^sub>o\<^sub>i\<^sub>n\<^sub>t" 80)
and region_to_section :: "'region \<Rightarrow> 'section"
and crossing :: "'region \<Rightarrow> 'section \<Rightarrow> bool" (infix "crosses" 80)
and incidence_sections_on_bundles :: "'section \<Rightarrow> 'bundle \<Rightarrow> bool" (infix "\<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n" 80) +
assumes SC2: "R crosses S \<Longrightarrow> (\<And>S'. (S' \<le>\<^sub>b S \<Longrightarrow> R crosses S'))"
(*Write your formalisation of Axiom SC2 here*) (*1 mark*)
begin

lemma overlaps_core: "(R overlaps s \<and> s isCoreOf b) \<Longrightarrow> (\<And>s'. (s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<Longrightarrow> R overlaps s'))"
  sorry
(*Write your formalisation and structured proof of the remark `If a region
overlaps the core of a section bundle then it overlaps every section of the section bundle'*)
(*4 marks*)

lemma crosses_hull: "R crosses s \<and> s isHullOf b \<Longrightarrow> (\<And>s'. (s' \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<Longrightarrow> R overlaps s'))"
  sorry
 (*Write your formalisation and structured proof of the remark `If a region
crosses the hull of a section bundle then it crosses every sector of the section bundle'*)
(*4 marks*)

lemma not_overlap_hull: "\<not>(R overlaps s1 \<and> s1 isHullOf b) \<Longrightarrow> (\<nexists>s2.(s2 \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> R overlaps s2))"
  sorry
 (*Write your formalisation and structured proof of the remark `If a region
does not overlap the hull of a section bundle, it does not overlap any of its sections'*)
(*4 marks*)

definition overlapsAsMuchAs :: "'region \<Rightarrow> 'bundle \<Rightarrow> 'region \<Rightarrow> bool"  where
"overlapsAsMuchAs R b R' == (\<forall>s. s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<longrightarrow> R' overlaps s \<longrightarrow> R overlaps s)"

notation
  overlapsAsMuchAs ("_ \<ge>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>_ _" [80, 80, 80] 80)

definition eq_overlapsAsMuchAs :: "'region \<Rightarrow> 'bundle \<Rightarrow> 'region \<Rightarrow> bool"  where
"eq_overlapsAsMuchAs R b R' == R \<ge>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b R' \<and> R' \<ge>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b R"

notation
  eq_overlapsAsMuchAs ("_ \<cong>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>_ _" [80, 80, 80] 80)

abbreviation
rev_overlapsAsMuchAs :: "'region \<Rightarrow> 'bundle \<Rightarrow> 'region \<Rightarrow> bool"  ("_ \<le>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>_ _" [80, 80, 80] 80)
where"rev_overlapsAsMuchAs R b R' == overlapsAsMuchAs R' b R"

definition more_overlapsAsMuchAs :: "'region \<Rightarrow> 'bundle \<Rightarrow> 'region \<Rightarrow> bool"  where
"more_overlapsAsMuchAs R b R' == R \<ge>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b R' \<and> \<not>(R' \<ge>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b R)"

notation
  more_overlapsAsMuchAs ("_ >\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>_ _" [80, 80, 80] 80)

abbreviation
less_overlapsAsMuchAs :: "'region \<Rightarrow> 'bundle \<Rightarrow> 'region \<Rightarrow> bool"  ("_ <\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>_ _" [80, 80, 80] 80)
where"less_overlapsAsMuchAs R b R' == more_overlapsAsMuchAs R' b R"

(*Formalise and prove that overlapsAsMuchAs is reflexive and transitive*) (*2 marks*)

lemma overlapsAsMuchAs_reflexive:"R \<ge>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b R"
(*Write your formalisation and proof that overlapsAsMuchAs is reflexive here*)

lemma overlapsAsMuchAs_transitive:"A \<ge>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b B \<and> B \<ge>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b C \<Longrightarrow> A \<ge>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b C"
(*Write your formalisation and proof that overlapsAsMuchAs is transitive here*)

lemma T3: "R >\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b R' \<longleftrightarrow> (\<exists>s. (s \<iota>\<^sub>s\<^sub>e\<^sub>c\<^sub>t\<^sub>i\<^sub>o\<^sub>n b \<and> R overlaps s \<and> \<not>(R' overlaps s)))"
(*Write your formalisation and structured proof of Theorem T3 here. You must attempt to
formalise Kulik et al.'s reasoning*) (*11 marks*)

(*In under 200 words, compare and contrast the mechanical proof that you produced with the
pen-and-paper proof by Kulik et al.\. In particular, indicate any reasoning, proof parts, and/or
useful lemmas that you had to make explicit during the mechanisation but may have been glossed over
 or assumed by the pen-and-paper proof. Also highlight any inaccuracies in their language or
notation. Note any parts where you had to diverge from their reasoning, and why.
Write your answer in a comment here.*) (*4 marks*)

lemma T4: "R >\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b R' \<or> "R \<cong>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b R' \<or> "R <\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b R'"
(*Write your formalisation and proof of Theorem T4 here*) (*1 mark*)

lemma T5: "R \<ge>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b R' \<or> R \<le>\<^sub>o\<^sub>v\<^sub>e\<^sub>r\<^sub>l\<^sub>a\<^sub>p\<^sub>s \<^sub>b R'"
(*Write your formalisation and structured proof of Theorem T5 here.
You must show it follows from T4*) (*3 marks*)

(********************Challenge problem****************************************)

definition crosses_isIncludedIn (*Write your definition of the relation ci here.
Kulik et al. say `If a region crosses or is included in a section we write ci'.*) (*2 marks*)

definition crosses_isIncludedInAsMuchAs (*Write your definition of `crosses or is included in as much
as' here*) (*2 marks*)

definition belongsAsMuchAs (*Write your definition of `belongs as much as here: definition D8 in
the paper.*) (*2 marks*)

(*Formalise and write structured proofs of Theorems T6-T8 for both crossesIncludedInAsMuchAs and
belongsAsMuchAs*) (*14 marks*)

lemma T6_crosses_isIncludedInAsMuchAs:

lemma T6_belongsAsMuchAs:

lemma T7_crosses_isIncludedInAsMuchAs:

lemma T7_belongsAsMuchAs:

lemma T8_crosses_isIncludedInAsMuchAs:

lemma T8_belongsAsMuchAs:

end

end