(*  Title:       Deriving class instances for datatypes
    Author:      Christian Sternagel and René Thiemann  <christian.sternagel|rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)
section \<open>Generating Comparators\<close>

theory Comparator_Generator
imports
  "../Generator_Aux"
  "../Derive_Manager"
  Comparator
begin

typedecl ('a,'b,'c,'z)type

text \<open>In the following, we define a generator which for a given datatype @{typ "('a,'b,'c,'z)type"}
  constructs a comparator of type
  @{typ "'a comparator \<Rightarrow> 'b comparator \<Rightarrow> 'c comparator \<Rightarrow> 'z comparator \<Rightarrow> ('a,'b,'c,'z)type"}.
  To this end, we first compare the index of the constructors, then for equal constructors, we
  compare the arguments recursively and combine the results lexicographically.\<close>

hide_type "type"

subsection \<open>Lexicographic combination of @{typ order}\<close>

fun comp_lex :: "order list \<Rightarrow> order"
where
  "comp_lex (c # cs) = (case c of Eq \<Rightarrow> comp_lex cs | _ \<Rightarrow> c)" |
  "comp_lex [] = Eq"

subsection \<open>Improved code for non-lazy languages\<close>

text \<open>The following equations will eliminate all occurrences of @{term comp_lex}
  in the generated code of the comparators.\<close>

lemma comp_lex_unfolds:
  "comp_lex [] = Eq"
  "comp_lex [c] = c"
  "comp_lex (c # d # cs) = (case c of Eq \<Rightarrow> comp_lex (d # cs) | z \<Rightarrow> z)"
  by (cases c, auto)+

subsection \<open>Pointwise properties for equality, symmetry, and transitivity\<close>

text \<open>The pointwise properties are important during inductive proofs of soundness of comparators.
  They are defined in a way that are combinable with @{const comp_lex}.\<close>

lemma comp_lex_eq: "comp_lex os = Eq \<longleftrightarrow> (\<forall> ord \<in> set os. ord = Eq)"
  by (induct os) (auto split: order.splits)

definition trans_order :: "order \<Rightarrow> order \<Rightarrow> order \<Rightarrow> bool" where
  "trans_order x y z \<longleftrightarrow> x \<noteq> Gt \<longrightarrow> y \<noteq> Gt \<longrightarrow> z \<noteq> Gt \<and> ((x = Lt \<or> y = Lt) \<longrightarrow> z = Lt)"

lemma trans_orderI:
  "(x \<noteq> Gt \<Longrightarrow> y \<noteq> Gt \<Longrightarrow> z \<noteq> Gt \<and> ((x = Lt \<or> y = Lt) \<longrightarrow> z = Lt)) \<Longrightarrow> trans_order x y z"
  by (simp add: trans_order_def)

lemma trans_orderD:
  assumes "trans_order x y z" and "x \<noteq> Gt" and "y \<noteq> Gt"
  shows "z \<noteq> Gt" and "x = Lt \<or> y = Lt \<Longrightarrow> z = Lt"
  using assms by (auto simp: trans_order_def)

lemma All_less_Suc:
  "(\<forall>i < Suc x. P i) \<longleftrightarrow> P 0 \<and> (\<forall>i < x. P (Suc i))"
  using less_Suc_eq_0_disj by force

lemma comp_lex_trans:
  assumes "length xs = length ys"
    and "length ys = length zs"
    and "\<forall> i < length zs. trans_order (xs ! i) (ys ! i) (zs ! i)"
  shows "trans_order (comp_lex xs) (comp_lex ys) (comp_lex zs)"
using assms
proof (induct xs ys zs rule: list_induct3)
  case (Cons x xs y ys z zs)
  then show ?case
    by (intro trans_orderI)
       (cases x y z rule: order.exhaust [case_product order.exhaust order.exhaust],
        auto simp: All_less_Suc dest: trans_orderD)
qed (simp add: trans_order_def)

lemma comp_lex_sym:
  assumes "length xs = length ys"
    and "\<forall> i < length ys. invert_order (xs ! i) = ys ! i"
  shows "invert_order (comp_lex xs) = comp_lex ys"
  using assms by (induct xs ys rule: list_induct2, simp, case_tac x) fastforce+

declare comp_lex.simps [simp del]

definition peq_comp :: "'a comparator \<Rightarrow> 'a \<Rightarrow> bool"
where
  "peq_comp acomp x \<longleftrightarrow> (\<forall> y. acomp x y = Eq \<longleftrightarrow> x = y)"

lemma peq_compD: "peq_comp acomp x \<Longrightarrow> acomp x y = Eq \<longleftrightarrow> x = y"
  unfolding peq_comp_def by auto

lemma peq_compI: "(\<And> y. acomp x y = Eq \<longleftrightarrow> x = y) \<Longrightarrow> peq_comp acomp x"
  unfolding peq_comp_def by auto

definition psym_comp :: "'a comparator \<Rightarrow> 'a \<Rightarrow> bool" where
  "psym_comp acomp x \<longleftrightarrow> (\<forall> y. invert_order (acomp x y) = (acomp y x))"

lemma psym_compD:
  assumes "psym_comp acomp x"
  shows "invert_order (acomp x y) = (acomp y x)"
  using assms unfolding psym_comp_def by blast+

lemma psym_compI:
  assumes "\<And> y. invert_order (acomp x y) = (acomp y x)"
  shows "psym_comp acomp x"
  using assms unfolding psym_comp_def by blast

definition ptrans_comp :: "'a comparator \<Rightarrow> 'a \<Rightarrow> bool" where
  "ptrans_comp acomp x \<longleftrightarrow> (\<forall> y z. trans_order (acomp x y) (acomp y z) (acomp x z))"

lemma ptrans_compD:
  assumes "ptrans_comp acomp x"
  shows "trans_order (acomp x y) (acomp y z) (acomp x z)"
  using assms unfolding ptrans_comp_def by blast+

lemma ptrans_compI:
  assumes "\<And> y z. trans_order (acomp x y) (acomp y z) (acomp x z)"
  shows "ptrans_comp acomp x"
  using assms unfolding ptrans_comp_def by blast

subsection \<open>Separate properties of comparators\<close>

definition eq_comp :: "'a comparator \<Rightarrow> bool" where
  "eq_comp acomp \<longleftrightarrow> (\<forall> x. peq_comp acomp x)"

lemma eq_compD2: "eq_comp acomp \<Longrightarrow> peq_comp acomp x"
  unfolding eq_comp_def by blast

lemma eq_compI2: "(\<And> x. peq_comp acomp x) \<Longrightarrow> eq_comp acomp"
  unfolding eq_comp_def by blast

definition trans_comp :: "'a comparator \<Rightarrow> bool" where
  "trans_comp acomp \<longleftrightarrow> (\<forall> x. ptrans_comp acomp x)"

lemma trans_compD2: "trans_comp acomp \<Longrightarrow> ptrans_comp acomp x"
  unfolding trans_comp_def by blast

lemma trans_compI2: "(\<And> x. ptrans_comp acomp x) \<Longrightarrow> trans_comp acomp"
  unfolding trans_comp_def by blast

definition sym_comp :: "'a comparator \<Rightarrow> bool" where
  "sym_comp acomp \<longleftrightarrow> (\<forall> x. psym_comp acomp x)"

lemma sym_compD2:
  "sym_comp acomp \<Longrightarrow> psym_comp acomp x"
  unfolding sym_comp_def by blast

lemma sym_compI2: "(\<And> x. psym_comp acomp x) \<Longrightarrow> sym_comp acomp"
  unfolding sym_comp_def by blast

lemma eq_compD: "eq_comp acomp \<Longrightarrow> acomp x y = Eq \<longleftrightarrow> x = y"
  by (rule peq_compD[OF eq_compD2])

lemma eq_compI: "(\<And> x y. acomp x y = Eq \<longleftrightarrow> x = y) \<Longrightarrow> eq_comp acomp"
  by (intro eq_compI2 peq_compI)

lemma trans_compD: "trans_comp acomp \<Longrightarrow> trans_order (acomp x y) (acomp y z) (acomp x z)"
  by (rule ptrans_compD[OF trans_compD2])

lemma trans_compI: "(\<And> x y z. trans_order (acomp x y) (acomp y z) (acomp x z)) \<Longrightarrow> trans_comp acomp"
  by (intro trans_compI2 ptrans_compI)

lemma sym_compD:
  "sym_comp acomp \<Longrightarrow> invert_order (acomp x y) = (acomp y x)"
  by (rule psym_compD[OF sym_compD2])

lemma sym_compI: "(\<And> x y. invert_order (acomp x y) = (acomp y x)) \<Longrightarrow> sym_comp acomp"
  by (intro sym_compI2 psym_compI)

lemma eq_sym_trans_imp_comparator:
  assumes "eq_comp acomp" and "sym_comp acomp" and "trans_comp acomp"
  shows "comparator acomp"
proof
  fix x y z
  show "invert_order (acomp x y) = acomp y x"
    using sym_compD [OF \<open>sym_comp acomp\<close>] .
  {
    assume "acomp x y = Eq"
    with eq_compD [OF \<open>eq_comp acomp\<close>]
    show "x = y" by blast
  }
  {
    assume "acomp x y = Lt" and "acomp y z = Lt"
    with trans_orderD [OF trans_compD [OF \<open>trans_comp acomp\<close>], of x y z]
    show "acomp x z = Lt" by auto
  }
qed

lemma comparator_imp_eq_sym_trans:
  assumes "comparator acomp"
  shows "eq_comp acomp" "sym_comp acomp" "trans_comp acomp"
proof -
  interpret comparator acomp by fact
  show "eq_comp acomp" using eq by (intro eq_compI, auto)
  show "sym_comp acomp" using sym by (intro sym_compI, auto)
  show "trans_comp acomp"
  proof (intro trans_compI trans_orderI)
    fix x y z
    assume "acomp x y \<noteq> Gt" "acomp y z \<noteq> Gt"
    thus "acomp x z \<noteq> Gt \<and> (acomp x y = Lt \<or> acomp y z = Lt \<longrightarrow> acomp x z = Lt)"
      using trans [of x y z] and eq [of x y] and eq [of y z]
      by (cases "acomp x y" "acomp y z" rule: order.exhaust [case_product order.exhaust]) auto
  qed
qed

context
  fixes acomp :: "'a comparator"
  assumes c: "comparator acomp"
begin
lemma comp_to_psym_comp: "psym_comp acomp x"
  using comparator_imp_eq_sym_trans[OF c]
  by (intro sym_compD2)

lemma comp_to_peq_comp: "peq_comp acomp x"
  using comparator_imp_eq_sym_trans [OF c]
  by (intro eq_compD2)

lemma comp_to_ptrans_comp: "ptrans_comp acomp x"
  using comparator_imp_eq_sym_trans [OF c]
  by (intro trans_compD2)
end

subsection \<open>Auxiliary Lemmas for Comparator Generator\<close>

lemma forall_finite: "(\<forall> i < (0 :: nat). P i) = True"
   "(\<forall> i < Suc 0. P i) = P 0"
   "(\<forall> i < Suc (Suc x). P i) = (P 0 \<and> (\<forall> i < Suc x. P (Suc i)))"
  by (auto, case_tac i, auto)

lemma trans_order_different:
  "trans_order a b Lt"
  "trans_order Gt b c"
  "trans_order a Gt c"
  by (intro trans_orderI, auto)+

lemma length_nth_simps:
  "length [] = 0" "length (x # xs) = Suc (length xs)"
  "(x # xs) ! 0 = x" "(x # xs) ! (Suc n) = xs ! n" by auto

subsection \<open>The Comparator Generator\<close>

ML_file \<open>comparator_generator.ML\<close>

end


(*  Title:      HOL/Proofs/Extraction/Pigeonhole.thy
    Author:     Stefan Berghofer, TU Muenchen
*)

section {* The pigeonhole principle *}

theory Pigeonhole
imports Util "~~/src/HOL/Library/Code_Target_Numeral"
begin

text {*
We formalize two proofs of the pigeonhole principle, which lead
to extracted programs of quite different complexity. The original
formalization of these proofs in {\sc Nuprl} is due to
Aleksey Nogin @{cite "Nogin-ENTCS-2000"}.

This proof yields a polynomial program.
*}

theorem pigeonhole:
  "\<And>f. (\<And>i. i \<le> Suc n \<Longrightarrow> f i \<le> n) \<Longrightarrow> \<exists>i j. i \<le> Suc n \<and> j < i \<and> f i = f j"
proof (induct n)
  case 0
  hence "Suc 0 \<le> Suc 0 \<and> 0 < Suc 0 \<and> f (Suc 0) = f 0" by simp
  thus ?case by iprover
next
  case (Suc n)
  {
    fix k
    have
      "k \<le> Suc (Suc n) \<Longrightarrow>
      (\<And>i j. Suc k \<le> i \<Longrightarrow> i \<le> Suc (Suc n) \<Longrightarrow> j < i \<Longrightarrow> f i \<noteq> f j) \<Longrightarrow>
      (\<exists>i j. i \<le> k \<and> j < i \<and> f i = f j)"
    proof (induct k)
      case 0
      let ?f = "\<lambda>i. if f i = Suc n then f (Suc (Suc n)) else f i"
      have "\<not> (\<exists>i j. i \<le> Suc n \<and> j < i \<and> ?f i = ?f j)"
      proof
        assume "\<exists>i j. i \<le> Suc n \<and> j < i \<and> ?f i = ?f j"
        then obtain i j where i: "i \<le> Suc n" and j: "j < i"
          and f: "?f i = ?f j" by iprover
        from j have i_nz: "Suc 0 \<le> i" by simp
        from i have iSSn: "i \<le> Suc (Suc n)" by simp
        have S0SSn: "Suc 0 \<le> Suc (Suc n)" by simp
        show False
        proof cases
          assume fi: "f i = Suc n"
          show False
          proof cases
            assume fj: "f j = Suc n"
            from i_nz and iSSn and j have "f i \<noteq> f j" by (rule 0)
            moreover from fi have "f i = f j"
              by (simp add: fj [symmetric])
            ultimately show ?thesis ..
          next
            from i and j have "j < Suc (Suc n)" by simp
            with S0SSn and le_refl have "f (Suc (Suc n)) \<noteq> f j"
              by (rule 0)
            moreover assume "f j \<noteq> Suc n"
            with fi and f have "f (Suc (Suc n)) = f j" by simp
            ultimately show False ..
          qed
        next
          assume fi: "f i \<noteq> Suc n"
          show False
          proof cases
            from i have "i < Suc (Suc n)" by simp
            with S0SSn and le_refl have "f (Suc (Suc n)) \<noteq> f i"
              by (rule 0)
            moreover assume "f j = Suc n"
            with fi and f have "f (Suc (Suc n)) = f i" by simp
            ultimately show False ..
          next
            from i_nz and iSSn and j
            have "f i \<noteq> f j" by (rule 0)
            moreover assume "f j \<noteq> Suc n"
            with fi and f have "f i = f j" by simp
            ultimately show False ..
          qed
        qed
      qed
      moreover have "\<And>i. i \<le> Suc n \<Longrightarrow> ?f i \<le> n"
      proof -
        fix i assume "i \<le> Suc n"
        hence i: "i < Suc (Suc n)" by simp
        have "f (Suc (Suc n)) \<noteq> f i"
          by (rule 0) (simp_all add: i)
        moreover have "f (Suc (Suc n)) \<le> Suc n"
          by (rule Suc) simp
        moreover from i have "i \<le> Suc (Suc n)" by simp
        hence "f i \<le> Suc n" by (rule Suc)
        ultimately show "?thesis i"
          by simp
      qed
      hence "\<exists>i j. i \<le> Suc n \<and> j < i \<and> ?f i = ?f j"
        by (rule Suc)
      ultimately show ?case ..
    next
      case (Suc k)
      from search [OF nat_eq_dec] show ?case
      proof
        assume "\<exists>j<Suc k. f (Suc k) = f j"
        thus ?case by (iprover intro: le_refl)
      next
        assume nex: "\<not> (\<exists>j<Suc k. f (Suc k) = f j)"
        have "\<exists>i j. i \<le> k \<and> j < i \<and> f i = f j"
        proof (rule Suc)
          from Suc show "k \<le> Suc (Suc n)" by simp
          fix i j assume k: "Suc k \<le> i" and i: "i \<le> Suc (Suc n)"
            and j: "j < i"
          show "f i \<noteq> f j"
          proof cases
            assume eq: "i = Suc k"
            show ?thesis
            proof
              assume "f i = f j"
              hence "f (Suc k) = f j" by (simp add: eq)
              with nex and j and eq show False by iprover
            qed
          next
            assume "i \<noteq> Suc k"
            with k have "Suc (Suc k) \<le> i" by simp
            thus ?thesis using i and j by (rule Suc)
          qed
        qed
        thus ?thesis by (iprover intro: le_SucI)
      qed
    qed
  }
  note r = this
  show ?case by (rule r) simp_all
qed

text {*
The following proof, although quite elegant from a mathematical point of view,
leads to an exponential program:
*}

theorem pigeonhole_slow:
  "\<And>f. (\<And>i. i \<le> Suc n \<Longrightarrow> f i \<le> n) \<Longrightarrow> \<exists>i j. i \<le> Suc n \<and> j < i \<and> f i = f j"
proof (induct n)
  case 0
  have "Suc 0 \<le> Suc 0" ..
  moreover have "0 < Suc 0" ..
  moreover from 0 have "f (Suc 0) = f 0" by simp
  ultimately show ?case by iprover
next
  case (Suc n)
  from search [OF nat_eq_dec] show ?case
  proof
    assume "\<exists>j < Suc (Suc n). f (Suc (Suc n)) = f j"
    thus ?case by (iprover intro: le_refl)
  next
    assume "\<not> (\<exists>j < Suc (Suc n). f (Suc (Suc n)) = f j)"
    hence nex: "\<forall>j < Suc (Suc n). f (Suc (Suc n)) \<noteq> f j" by iprover
    let ?f = "\<lambda>i. if f i = Suc n then f (Suc (Suc n)) else f i"
    have "\<And>i. i \<le> Suc n \<Longrightarrow> ?f i \<le> n"
    proof -
      fix i assume i: "i \<le> Suc n"
      show "?thesis i"
      proof (cases "f i = Suc n")
        case True
        from i and nex have "f (Suc (Suc n)) \<noteq> f i" by simp
        with True have "f (Suc (Suc n)) \<noteq> Suc n" by simp
        moreover from Suc have "f (Suc (Suc n)) \<le> Suc n" by simp
        ultimately have "f (Suc (Suc n)) \<le> n" by simp
        with True show ?thesis by simp
      next
        case False
        from Suc and i have "f i \<le> Suc n" by simp
        with False show ?thesis by simp
      qed
    qed
    hence "\<exists>i j. i \<le> Suc n \<and> j < i \<and> ?f i = ?f j" by (rule Suc)
    then obtain i j where i: "i \<le> Suc n" and ji: "j < i" and f: "?f i = ?f j"
      by iprover
    have "f i = f j"
    proof (cases "f i = Suc n")
      case True
      show ?thesis
      proof (cases "f j = Suc n")
        assume "f j = Suc n"
        with True show ?thesis by simp
      next
        assume "f j \<noteq> Suc n"
        moreover from i ji nex have "f (Suc (Suc n)) \<noteq> f j" by simp
        ultimately show ?thesis using True f by simp
      qed
    next
      case False
      show ?thesis
      proof (cases "f j = Suc n")
        assume "f j = Suc n"
        moreover from i nex have "f (Suc (Suc n)) \<noteq> f i" by simp
        ultimately show ?thesis using False f by simp
      next
        assume "f j \<noteq> Suc n"
        with False f show ?thesis by simp
      qed
    qed
    moreover from i have "i \<le> Suc (Suc n)" by simp
    ultimately show ?thesis using ji by iprover
  qed
qed

extract pigeonhole pigeonhole_slow

text {*
The programs extracted from the above proofs look as follows:
@{thm [display] pigeonhole_def}
@{thm [display] pigeonhole_slow_def}
The program for searching for an element in an array is
@{thm [display,eta_contract=false] search_def}
The correctness statement for @{term "pigeonhole"} is
@{thm [display] pigeonhole_correctness [no_vars]}

In order to analyze the speed of the above programs,
we generate ML code from them.
*}

instantiation nat :: default
begin

definition "default = (0::nat)"

instance ..

end

instantiation prod :: (default, default) default
begin

definition "default = (default, default)"

instance ..

end

definition
  "test n u = pigeonhole (nat_of_integer n) (\<lambda>m. m - 1)"
definition
  "test' n u = pigeonhole_slow (nat_of_integer n) (\<lambda>m. m - 1)"
definition
  "test'' u = pigeonhole 8 (List.nth [0, 1, 2, 3, 4, 5, 6, 3, 7, 8])"

ML_val "timeit (@{code test} 10)"
ML_val "timeit (@{code test'} 10)"
ML_val "timeit (@{code test} 20)"
ML_val "timeit (@{code test'} 20)"
ML_val "timeit (@{code test} 25)"
ML_val "timeit (@{code test'} 25)"
ML_val "timeit (@{code test} 500)"
ML_val "timeit @{code test''}"

end


(*  Title:      ZF/Induct/Primrec.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Primitive Recursive Functions: the inductive definition\<close>

theory Primrec imports ZF begin

text \<open>
  Proof adopted from \<^cite>\<open>szasz93\<close>.

  See also \<^cite>\<open>\<open>page 250, exercise 11\<close> in mendelson\<close>.
\<close>

subsection \<open>Basic definitions\<close>

definition
  SC :: "i"  where
  "SC \<equiv> \<lambda>l \<in> list(nat). list_case(0, \<lambda>x xs. succ(x), l)"

definition
  CONSTANT :: "i\<Rightarrow>i"  where
  "CONSTANT(k) \<equiv> \<lambda>l \<in> list(nat). k"

definition
  PROJ :: "i\<Rightarrow>i"  where
  "PROJ(i) \<equiv> \<lambda>l \<in> list(nat). list_case(0, \<lambda>x xs. x, drop(i,l))"

definition
  COMP :: "[i,i]\<Rightarrow>i"  where
  "COMP(g,fs) \<equiv> \<lambda>l \<in> list(nat). g ` map(\<lambda>f. f`l, fs)"

definition
  PREC :: "[i,i]\<Rightarrow>i"  where
  "PREC(f,g) \<equiv>
     \<lambda>l \<in> list(nat). list_case(0,
                      \<lambda>x xs. rec(x, f`xs, \<lambda>y r. g ` Cons(r, Cons(y, xs))), l)"
  \<comment> \<open>Note that \<open>g\<close> is applied first to \<^term>\<open>PREC(f,g)`y\<close> and then to \<open>y\<close>!\<close>

consts
  ACK :: "i\<Rightarrow>i"
primrec
  "ACK(0) = SC"
  "ACK(succ(i)) = PREC (CONSTANT (ACK(i) ` [1]), COMP(ACK(i), [PROJ(0)]))"

abbreviation
  ack :: "[i,i]\<Rightarrow>i" where
  "ack(x,y) \<equiv> ACK(x) ` [y]"

text \<open>
  \medskip Useful special cases of evaluation.
\<close>

lemma SC: "\<lbrakk>x \<in> nat;  l \<in> list(nat)\<rbrakk> \<Longrightarrow> SC ` (Cons(x,l)) = succ(x)"
  by (simp add: SC_def)

lemma CONSTANT: "l \<in> list(nat) \<Longrightarrow> CONSTANT(k) ` l = k"
  by (simp add: CONSTANT_def)

lemma PROJ_0: "\<lbrakk>x \<in> nat;  l \<in> list(nat)\<rbrakk> \<Longrightarrow> PROJ(0) ` (Cons(x,l)) = x"
  by (simp add: PROJ_def)

lemma COMP_1: "l \<in> list(nat) \<Longrightarrow> COMP(g,[f]) ` l = g` [f`l]"
  by (simp add: COMP_def)

lemma PREC_0: "l \<in> list(nat) \<Longrightarrow> PREC(f,g) ` (Cons(0,l)) = f`l"
  by (simp add: PREC_def)

lemma PREC_succ:
  "\<lbrakk>x \<in> nat;  l \<in> list(nat)\<rbrakk>
    \<Longrightarrow> PREC(f,g) ` (Cons(succ(x),l)) =
      g ` Cons(PREC(f,g)`(Cons(x,l)), Cons(x,l))"
  by (simp add: PREC_def)

subsection \<open>Inductive definition of the PR functions\<close>

consts
  prim_rec :: i

inductive
  domains prim_rec \<subseteq> "list(nat)->nat"
  intros
    "SC \<in> prim_rec"
    "k \<in> nat \<Longrightarrow> CONSTANT(k) \<in> prim_rec"
    "i \<in> nat \<Longrightarrow> PROJ(i) \<in> prim_rec"
    "\<lbrakk>g \<in> prim_rec; fs\<in>list(prim_rec)\<rbrakk> \<Longrightarrow> COMP(g,fs) \<in> prim_rec"
    "\<lbrakk>f \<in> prim_rec; g \<in> prim_rec\<rbrakk> \<Longrightarrow> PREC(f,g) \<in> prim_rec"
  monos list_mono
  con_defs SC_def CONSTANT_def PROJ_def COMP_def PREC_def
  type_intros nat_typechecks list.intros
    lam_type list_case_type drop_type map_type
    apply_type rec_type

lemma prim_rec_into_fun [TC]: "c \<in> prim_rec \<Longrightarrow> c \<in> list(nat) -> nat"
  by (erule subsetD [OF prim_rec.dom_subset])

lemmas [TC] = apply_type [OF prim_rec_into_fun]

declare prim_rec.intros [TC]
declare nat_into_Ord [TC]
declare rec_type [TC]

lemma ACK_in_prim_rec [TC]: "i \<in> nat \<Longrightarrow> ACK(i) \<in> prim_rec"
  by (induct set: nat) simp_all

lemma ack_type [TC]: "\<lbrakk>i \<in> nat;  j \<in> nat\<rbrakk> \<Longrightarrow>  ack(i,j) \<in> nat"
  by auto

subsection \<open>Ackermann's function cases\<close>

lemma ack_0: "j \<in> nat \<Longrightarrow> ack(0,j) = succ(j)"
  \<comment> \<open>PROPERTY A 1\<close>
  by (simp add: SC)

lemma ack_succ_0: "ack(succ(i), 0) = ack(i,1)"
  \<comment> \<open>PROPERTY A 2\<close>
  by (simp add: CONSTANT PREC_0)

lemma ack_succ_succ:
  "\<lbrakk>i\<in>nat;  j\<in>nat\<rbrakk> \<Longrightarrow> ack(succ(i), succ(j)) = ack(i, ack(succ(i), j))"
  \<comment> \<open>PROPERTY A 3\<close>
  by (simp add: CONSTANT PREC_succ COMP_1 PROJ_0)

lemmas [simp] = ack_0 ack_succ_0 ack_succ_succ ack_type
  and [simp del] = ACK.simps

lemma lt_ack2: "i \<in> nat \<Longrightarrow> j \<in> nat \<Longrightarrow> j < ack(i,j)"
  \<comment> \<open>PROPERTY A 4\<close>
  apply (induct i arbitrary: j set: nat)
   apply simp
  apply (induct_tac j)
   apply (erule_tac [2] succ_leI [THEN lt_trans1])
   apply (rule nat_0I [THEN nat_0_le, THEN lt_trans])
   apply auto
  done

lemma ack_lt_ack_succ2: "\<lbrakk>i\<in>nat; j\<in>nat\<rbrakk> \<Longrightarrow> ack(i,j) < ack(i, succ(j))"
  \<comment> \<open>PROPERTY A 5-, the single-step lemma\<close>
  by (induct set: nat) (simp_all add: lt_ack2)

lemma ack_lt_mono2: "\<lbrakk>j<k; i \<in> nat; k \<in> nat\<rbrakk> \<Longrightarrow> ack(i,j) < ack(i,k)"
  \<comment> \<open>PROPERTY A 5, monotonicity for \<open><\<close>\<close>
  apply (frule lt_nat_in_nat, assumption)
  apply (erule succ_lt_induct)
    apply assumption
   apply (rule_tac [2] lt_trans)
    apply (auto intro: ack_lt_ack_succ2)
  done

lemma ack_le_mono2: "\<lbrakk>j\<le>k;  i\<in>nat;  k\<in>nat\<rbrakk> \<Longrightarrow> ack(i,j) \<le> ack(i,k)"
  \<comment> \<open>PROPERTY A 5', monotonicity for \<open>\<le>\<close>\<close>
  apply (rule_tac f = "\<lambda>j. ack (i,j) " in Ord_lt_mono_imp_le_mono)
     apply (assumption | rule ack_lt_mono2 ack_type [THEN nat_into_Ord])+
  done

lemma ack2_le_ack1:
  "\<lbrakk>i\<in>nat;  j\<in>nat\<rbrakk> \<Longrightarrow> ack(i, succ(j)) \<le> ack(succ(i), j)"
  \<comment> \<open>PROPERTY A 6\<close>
  apply (induct_tac j)
   apply simp_all
  apply (rule ack_le_mono2)
    apply (rule lt_ack2 [THEN succ_leI, THEN le_trans])
      apply auto
  done

lemma ack_lt_ack_succ1: "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow> ack(i,j) < ack(succ(i),j)"
  \<comment> \<open>PROPERTY A 7-, the single-step lemma\<close>
  apply (rule ack_lt_mono2 [THEN lt_trans2])
     apply (rule_tac [4] ack2_le_ack1)
      apply auto
  done

lemma ack_lt_mono1: "\<lbrakk>i<j; j \<in> nat; k \<in> nat\<rbrakk> \<Longrightarrow> ack(i,k) < ack(j,k)"
  \<comment> \<open>PROPERTY A 7, monotonicity for \<open><\<close>\<close>
  apply (frule lt_nat_in_nat, assumption)
  apply (erule succ_lt_induct)
    apply assumption
   apply (rule_tac [2] lt_trans)
    apply (auto intro: ack_lt_ack_succ1)
  done

lemma ack_le_mono1: "\<lbrakk>i\<le>j; j \<in> nat; k \<in> nat\<rbrakk> \<Longrightarrow> ack(i,k) \<le> ack(j,k)"
  \<comment> \<open>PROPERTY A 7', monotonicity for \<open>\<le>\<close>\<close>
  apply (rule_tac f = "\<lambda>j. ack (j,k) " in Ord_lt_mono_imp_le_mono)
     apply (assumption | rule ack_lt_mono1 ack_type [THEN nat_into_Ord])+
  done

lemma ack_1: "j \<in> nat \<Longrightarrow> ack(1,j) = succ(succ(j))"
  \<comment> \<open>PROPERTY A 8\<close>
  by (induct set: nat) simp_all

lemma ack_2: "j \<in> nat \<Longrightarrow> ack(succ(1),j) = succ(succ(succ(j#+j)))"
  \<comment> \<open>PROPERTY A 9\<close>
  by (induct set: nat) (simp_all add: ack_1)

lemma ack_nest_bound:
  "\<lbrakk>i1 \<in> nat; i2 \<in> nat; j \<in> nat\<rbrakk>
    \<Longrightarrow> ack(i1, ack(i2,j)) < ack(succ(succ(i1#+i2)), j)"
  \<comment> \<open>PROPERTY A 10\<close>
  apply (rule lt_trans2 [OF _ ack2_le_ack1])
    apply simp
    apply (rule add_le_self [THEN ack_le_mono1, THEN lt_trans1])
       apply auto
  apply (force intro: add_le_self2 [THEN ack_lt_mono1, THEN ack_lt_mono2])
  done

lemma ack_add_bound:
  "\<lbrakk>i1 \<in> nat; i2 \<in> nat; j \<in> nat\<rbrakk>
    \<Longrightarrow> ack(i1,j) #+ ack(i2,j) < ack(succ(succ(succ(succ(i1#+i2)))), j)"
  \<comment> \<open>PROPERTY A 11\<close>
  apply (rule_tac j = "ack (succ (1), ack (i1 #+ i2, j))" in lt_trans)
   apply (simp add: ack_2)
   apply (rule_tac [2] ack_nest_bound [THEN lt_trans2])
      apply (rule add_le_mono [THEN leI, THEN leI])
         apply (auto intro: add_le_self add_le_self2 ack_le_mono1)
  done

lemma ack_add_bound2:
     "\<lbrakk>i < ack(k,j);  j \<in> nat;  k \<in> nat\<rbrakk>
      \<Longrightarrow> i#+j < ack(succ(succ(succ(succ(k)))), j)"
  \<comment> \<open>PROPERTY A 12.\<close>
  \<comment> \<open>Article uses existential quantifier but the ALF proof used \<^term>\<open>k#+#4\<close>.\<close>
  \<comment> \<open>Quantified version must be nested \<open>\<exists>k'. \<forall>i,j \<dots>\<close>.\<close>
  apply (rule_tac j = "ack (k,j) #+ ack (0,j) " in lt_trans)
   apply (rule_tac [2] ack_add_bound [THEN lt_trans2])
      apply (rule add_lt_mono)
         apply auto
  done

subsection \<open>Main result\<close>

declare list_add_type [simp]

lemma SC_case: "l \<in> list(nat) \<Longrightarrow> SC ` l < ack(1, list_add(l))"
    unfolding SC_def
  apply (erule list.cases)
   apply (simp add: succ_iff)
  apply (simp add: ack_1 add_le_self)
  done

lemma lt_ack1: "\<lbrakk>i \<in> nat; j \<in> nat\<rbrakk> \<Longrightarrow> i < ack(i,j)"
  \<comment> \<open>PROPERTY A 4'? Extra lemma needed for \<open>CONSTANT\<close> case, constant functions.\<close>
  apply (induct_tac i)
   apply (simp add: nat_0_le)
  apply (erule lt_trans1 [OF succ_leI ack_lt_ack_succ1])
   apply auto
  done

lemma CONSTANT_case:
    "\<lbrakk>l \<in> list(nat);  k \<in> nat\<rbrakk> \<Longrightarrow> CONSTANT(k) ` l < ack(k, list_add(l))"
  by (simp add: CONSTANT_def lt_ack1)

lemma PROJ_case [rule_format]:
    "l \<in> list(nat) \<Longrightarrow> \<forall>i \<in> nat. PROJ(i) ` l < ack(0, list_add(l))"
    unfolding PROJ_def
  apply simp
  apply (erule list.induct)
   apply (simp add: nat_0_le)
  apply simp
  apply (rule ballI)
  apply (erule_tac n = i in natE)
   apply (simp add: add_le_self)
  apply simp
  apply (erule bspec [THEN lt_trans2])
   apply (rule_tac [2] add_le_self2 [THEN succ_leI])
   apply auto
  done

text \<open>
  \medskip \<open>COMP\<close> case.
\<close>

lemma COMP_map_lemma:
  "fs \<in> list({f \<in> prim_rec. \<exists>kf \<in> nat. \<forall>l \<in> list(nat). f`l < ack(kf, list_add(l))})
    \<Longrightarrow> \<exists>k \<in> nat. \<forall>l \<in> list(nat).
      list_add(map(\<lambda>f. f ` l, fs)) < ack(k, list_add(l))"
  apply (induct set: list)
   apply (rule_tac x = 0 in bexI)
    apply (simp_all add: lt_ack1 nat_0_le)
  apply clarify
  apply (rule ballI [THEN bexI])
  apply (rule add_lt_mono [THEN lt_trans])
       apply (rule_tac [5] ack_add_bound)
         apply blast
        apply auto
  done

lemma COMP_case:
 "\<lbrakk>kg\<in>nat;
     \<forall>l \<in> list(nat). g`l < ack(kg, list_add(l));
     fs \<in> list({f \<in> prim_rec .
                 \<exists>kf \<in> nat. \<forall>l \<in> list(nat).
                        f`l < ack(kf, list_add(l))})\<rbrakk>
   \<Longrightarrow> \<exists>k \<in> nat. \<forall>l \<in> list(nat). COMP(g,fs)`l < ack(k, list_add(l))"
  apply (simp add: COMP_def)
  apply (frule list_CollectD)
  apply (erule COMP_map_lemma [THEN bexE])
  apply (rule ballI [THEN bexI])
   apply (erule bspec [THEN lt_trans])
    apply (rule_tac [2] lt_trans)
     apply (rule_tac [3] ack_nest_bound)
       apply (erule_tac [2] bspec [THEN ack_lt_mono2])
         apply auto
  done

text \<open>
  \medskip \<open>PREC\<close> case.
\<close>

lemma PREC_case_lemma:
 "\<lbrakk>\<forall>l \<in> list(nat). f`l #+ list_add(l) < ack(kf, list_add(l));
     \<forall>l \<in> list(nat). g`l #+ list_add(l) < ack(kg, list_add(l));
     f \<in> prim_rec;  kf\<in>nat;
     g \<in> prim_rec;  kg\<in>nat;
     l \<in> list(nat)\<rbrakk>
  \<Longrightarrow> PREC(f,g)`l #+ list_add(l) < ack(succ(kf#+kg), list_add(l))"
    unfolding PREC_def
  apply (erule list.cases)
   apply (simp add: lt_trans [OF nat_le_refl lt_ack2])
  apply simp
  apply (erule ssubst)  \<comment> \<open>get rid of the needless assumption\<close>
  apply (induct_tac a)
   apply simp_all
   txt \<open>base case\<close>
   apply (rule lt_trans, erule bspec, assumption)
   apply (simp add: add_le_self [THEN ack_lt_mono1])
  txt \<open>ind step\<close>
  apply (rule succ_leI [THEN lt_trans1])
   apply (rule_tac j = "g ` ll #+ mm" for ll mm in lt_trans1)
    apply (erule_tac [2] bspec)
    apply (rule nat_le_refl [THEN add_le_mono])
       apply typecheck
   apply (simp add: add_le_self2)
   txt \<open>final part of the simplification\<close>
  apply simp
  apply (rule add_le_self2 [THEN ack_le_mono1, THEN lt_trans1])
     apply (erule_tac [4] ack_lt_mono2)
      apply auto
  done

lemma PREC_case:
   "\<lbrakk>f \<in> prim_rec;  kf\<in>nat;
       g \<in> prim_rec;  kg\<in>nat;
       \<forall>l \<in> list(nat). f`l < ack(kf, list_add(l));
       \<forall>l \<in> list(nat). g`l < ack(kg, list_add(l))\<rbrakk>
    \<Longrightarrow> \<exists>k \<in> nat. \<forall>l \<in> list(nat). PREC(f,g)`l< ack(k, list_add(l))"
  apply (rule ballI [THEN bexI])
   apply (rule lt_trans1 [OF add_le_self PREC_case_lemma])
          apply typecheck
     apply (blast intro: ack_add_bound2 list_add_type)+
  done

lemma ack_bounds_prim_rec:
    "f \<in> prim_rec \<Longrightarrow> \<exists>k \<in> nat. \<forall>l \<in> list(nat). f`l < ack(k, list_add(l))"
  apply (induct set: prim_rec)
  apply (auto intro: SC_case CONSTANT_case PROJ_case COMP_case PREC_case)
  done

theorem ack_not_prim_rec:
    "(\<lambda>l \<in> list(nat). list_case(0, \<lambda>x xs. ack(x,x), l)) \<notin> prim_rec"
  apply (rule notI)
  apply (drule ack_bounds_prim_rec)
  apply force
  done

end


theory Undirected_Graph_Walks imports Undirected_Graph_Basics
begin

section \<open>Walks, Paths and Cycles \<close>
text \<open> The definition of walks, paths, cycles, and related concepts are foundations of graph theory,
yet there can be some differences in literature between definitions. This formalisation draws inspiration
from Noschinski's Graph Library \<^cite>\<open>"noschinski_2015"\<close>, however focuses on an undirected graph context
compared to a directed graph context, and extends on some definitions, as required to formalise
Balog Szemeredi Gowers theorem. \<close>

context ulgraph
begin

subsection \<open> Walks\<close>

text\<open>This definition is taken from the directed graph library, however edges are undirected\<close>
fun walk_edges :: "'a list \<Rightarrow> 'a edge list" where
    "walk_edges [] = []"
  | "walk_edges [x] = []"
  | "walk_edges (x # y # ys) = {x,y} # walk_edges (y # ys)"

lemma walk_edges_app: "walk_edges (xs @ [y, x]) = walk_edges (xs @ [y]) @ [{y, x}]"
  by (induct xs rule: walk_edges.induct, simp_all)

lemma walk_edges_tl_ss: "set (walk_edges (tl xs)) \<subseteq> set (walk_edges xs)"
  by (induct xs rule: walk_edges.induct)  auto

lemma walk_edges_rev: "rev (walk_edges xs) = walk_edges (rev xs)"
proof (induct xs rule: walk_edges.induct, simp_all)
  fix x y ys assume assm: "rev (walk_edges (y # ys)) = walk_edges (rev ys @ [y])"
  then show "walk_edges (rev ys @ [y]) @ [{x, y}] = walk_edges (rev ys @ [y, x])"
    using walk_edges_app by fastforce
qed

lemma walk_edges_append_ss1: "set (walk_edges (ys)) \<subseteq> set (walk_edges (xs@ys))"
proof (induct xs rule: walk_edges.induct)
  case 1
  then show ?case by simp
next
  case (2 x)
  then show ?case
    using walk_edges_tl_ss by fastforce
next
  case (3 x y ys)
  then show ?case by (simp add: subset_iff)
qed

lemma walk_edges_append_ss2: "set (walk_edges (xs)) \<subseteq> set (walk_edges (xs@ys))"
  by (induct xs rule: walk_edges.induct) auto

lemma walk_edges_singleton_app: "ys \<noteq> [] \<Longrightarrow> walk_edges ([x]@ys) = {x, hd ys} # walk_edges ys"
  using list.exhaust_sel walk_edges.simps(3) by (metis Cons_eq_appendI eq_Nil_appendI)

lemma walk_edges_append_union: "xs \<noteq> [] \<Longrightarrow> ys \<noteq> [] \<Longrightarrow>
    set (walk_edges (xs@ys)) = set (walk_edges (xs)) \<union> set (walk_edges ys) \<union> {{last xs, hd ys}}"
  using walk_edges_singleton_app  by (induct xs rule: walk_edges.induct) auto

lemma walk_edges_decomp_ss: "set (walk_edges (xs@[y]@zs)) \<subseteq> set (walk_edges (xs@[y]@ys@[y]@zs))"
proof -
  have half_ss: "set (walk_edges (xs@[y])) \<subseteq> set (walk_edges (xs@[y]@ys@[y]))"
    using walk_edges_append_ss2 by fastforce
  thus ?thesis proof (cases "zs = []")
    case True
    then show ?thesis using half_ss by auto
  next
    case False
    then have decomp1: "set (walk_edges (xs@[y]@zs)) = set (walk_edges (xs@[y])) \<union> set (walk_edges (zs)) \<union> {{y, hd zs}}"
      using walk_edges_append_union
      by (metis append_assoc append_is_Nil_conv last_snoc neq_Nil_conv)
    have "set (walk_edges (xs@[y]@ys@[y]@zs)) =  set (walk_edges (xs@[y]@ys@[y])) \<union> set (walk_edges (zs)) \<union> {{y, hd zs}}"
      using walk_edges_append_union False
      by (metis append_assoc append_is_Nil_conv empty_iff empty_set last_snoc list.set_intros(1))
    then show ?thesis using decomp1 half_ss by auto
  qed
qed

definition walk_length :: "'a list \<Rightarrow> nat" where
  "walk_length p \<equiv> length (walk_edges p)"

lemma walk_length_conv: "walk_length p = length p - 1"
  by (induct p rule: walk_edges.induct) (auto simp: walk_length_def)

lemma walk_length_rev: "walk_length p = walk_length (rev p)"
  using walk_edges_rev walk_length_def
  by (metis length_rev)

lemma walk_length_app: "xs \<noteq> [] \<Longrightarrow> ys \<noteq> [] \<Longrightarrow> walk_length (xs @ ys) = walk_length xs + walk_length ys + 1"
  apply (induct xs rule: walk_edges.induct)
    apply (simp_all add: walk_length_def)
  using walk_edges_singleton_app by force

lemma walk_length_app_ineq: "walk_length (xs @ ys) \<ge> walk_length xs + walk_length ys \<and>
  walk_length (xs @ ys) \<le> walk_length xs + walk_length ys + 1"
proof (cases "xs = [] \<or> ys = []")
  case True
  then show ?thesis using walk_length_def by auto
next
  case False
  then show ?thesis
    by (simp add: walk_length_app)
qed

text \<open> Note that while the trivial walk is allowed, the empty walk is not \<close>
definition is_walk :: "'a list \<Rightarrow> bool" where
"is_walk xs \<equiv> set xs \<subseteq> V \<and> set (walk_edges xs) \<subseteq> E \<and> xs \<noteq> []"

lemma is_walkI: "set xs \<subseteq> V \<Longrightarrow> set (walk_edges xs) \<subseteq> E \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> is_walk xs"
  using is_walk_def by simp

lemma is_walk_wf: "is_walk xs \<Longrightarrow> set xs \<subseteq> V"
  by (simp add: is_walk_def)

lemma is_walk_wf_hd: "is_walk xs \<Longrightarrow> hd xs \<in> V"
  using is_walk_wf hd_in_set is_walk_def by blast

lemma is_walk_wf_last: "is_walk xs \<Longrightarrow> last xs \<in> V"
  using is_walk_wf last_in_set is_walk_def by blast

lemma is_walk_singleton: "u \<in> V \<Longrightarrow> is_walk [u]"
  unfolding is_walk_def using walk_edges.simps by simp

lemma is_walk_not_empty: "is_walk xs \<Longrightarrow> xs \<noteq> []"
  unfolding is_walk_def by simp

lemma is_walk_not_empty2: "is_walk [] = False"
  unfolding is_walk_def by simp

text \<open>Reasoning on transformations of a walk \<close>
lemma is_walk_rev: "is_walk xs \<longleftrightarrow> is_walk (rev xs)"
  unfolding is_walk_def using walk_edges_rev
  by (metis rev_is_Nil_conv set_rev)

lemma is_walk_tl: "length xs \<ge> 2 \<Longrightarrow> is_walk xs \<Longrightarrow> is_walk (tl xs)"
  using walk_edges_tl_ss is_walk_def in_mono list.set_sel(2) tl_Nil by fastforce

lemma is_walk_append:
  assumes "is_walk xs"
  assumes "is_walk ys"
  assumes "last xs = hd ys"
  shows "is_walk (xs @ (tl ys))"
proof (intro is_walkI subsetI)
  show "xs @ tl ys \<noteq> []" using is_walk_def assms by auto
  show "\<And>x. x \<in> set (xs @ tl ys) \<Longrightarrow> x \<in> V" using assms is_walk_def is_walk_wf
    by (metis Un_iff in_mono list_set_tl set_append)
next
  fix x assume xin: "x \<in> set (walk_edges (xs @ tl ys))"
  show "x \<in> E" proof (cases "tl ys = []")
    case True
    then show ?thesis using assms(1) is_walk_def xin by auto
  next
    case False
    then have xin2: "x \<in> (set (walk_edges xs) \<union> set (walk_edges (tl ys)) \<union> {{last xs, hd (tl ys)}})"
      using walk_edges_append_union is_walk_not_empty assms xin by auto
    have 1: "set (walk_edges xs) \<subseteq> E" using assms(1) is_walk_def
      by simp
    have 2: "set (walk_edges (tl ys)) \<subseteq> E" using assms(2) is_walk_def
      by (meson dual_order.trans walk_edges_tl_ss)
    have "{last xs, hd (tl ys)} \<in> E" using is_walk_def assms(2) assms(3)
      by (metis False hd_Cons_tl insert_subset list.simps(15) walk_edges.simps(3))
    then show ?thesis using 1 2 xin2 by auto
  qed
qed

lemma is_walk_decomp:
  assumes "is_walk (xs@[y]@ys@[y]@zs)" (is "is_walk ?w")
  shows "is_walk (xs@[y]@zs)"
proof (intro is_walkI)
  show "set (xs @ [y] @ zs) \<subseteq> V"  using assms is_walk_def by simp
  show "xs @ [y] @ zs \<noteq> []" by simp
  show "set (walk_edges (xs @ [y] @ zs)) \<subseteq> E"
    using walk_edges_decomp_ss assms(1) is_walk_def by blast
qed

lemma is_walk_hd_tl:
  assumes "is_walk (y # ys)"
  assumes "{x, y} \<in> E"
  shows "is_walk (x # y # ys)"
proof (intro is_walkI)
  show "set (x # y # ys) \<subseteq> V"
    using assms by (simp add: is_walk_def wellformed_alt_fst)
  show "set (walk_edges (x # y # ys)) \<subseteq> E"
    using walk_edges.simps assms is_walk_def by simp
  show "x # y # ys \<noteq> []" by simp
qed

lemma is_walk_drop_hd:
  assumes "ys \<noteq> []"
  assumes "is_walk (y # ys)"
  shows "is_walk ys"
proof (intro is_walkI)
  show "set ys \<subseteq> V"
    using assms is_walk_wf by fastforce
  show "set (walk_edges ys) \<subseteq> E"
    using assms is_walk_def walk_edges_tl_ss by force
  show "ys \<noteq> []" using assms by simp
qed

lemma walk_edges_index:
  assumes "i \<ge> 0" "i < walk_length w"
  assumes "is_walk w"
  shows "(walk_edges w) ! i \<in> E"
  using assms
proof (induct w arbitrary: i rule: walk_edges.induct, simp add: is_walk_not_empty2,
    simp add: walk_length_def)
  case (3 x y ys)
  then show ?case proof (cases "i = 0")
    case True
    then show ?thesis
      using "3.prems"(3) is_walk_def by fastforce
  next
    case False
    have gt: "0 \<le> i -1" using False by simp
    have lt: "i - 1 < walk_length (y # ys)"
      using "3.prems"(2) False walk_length_conv by auto
    have "is_walk (y # ys)"
      using "3.prems"(3) is_walk_def by fastforce
    then show ?thesis using "3.hyps"[of "i -1"]
      by (metis "3.prems"(1) False gt lt le_neq_implies_less nth_Cons_pos walk_edges.simps(3))
  qed
qed

lemma is_walk_index:
  assumes "i \<ge> 0" "Suc i < (length w)"
  assumes "is_walk w"
  shows "{w ! i, w ! (i + 1)} \<in> E"
  using assms proof (induct w arbitrary: i rule: walk_edges.induct, simp, simp)
  fix x y ys i
  assume IH: "\<And>j. 0 \<le> j \<Longrightarrow> Suc j < length (y # ys) \<Longrightarrow> is_walk (y # ys) \<Longrightarrow> {(y # ys) ! j, (y # ys) ! (j + 1)} \<in> E"
  assume 1: " 0 \<le> i" and 2: "Suc i < length (x # y # ys)" and 3: "is_walk (x # y # ys)"
  show "{(x # y # ys) ! i, (x # y # ys) ! (i + 1)} \<in> E"
  proof (cases "i = 0")
    case True
    then show ?thesis using 3 is_walk_def
      by simp
  next
    case False
    have "is_walk (y # ys)" using is_walk_def 3 by fastforce
    then show ?thesis using 2 IH[of "i - 1"]
      by (simp add: False nat_less_le)
  qed
qed

lemma is_walk_take:
  assumes "is_walk w"
  assumes "n > 0"
  assumes "n \<le> length w"
  shows "is_walk (take n w)"
  using assms proof (induct w arbitrary: n rule: walk_edges.induct)
  case 1
  then show ?case by simp
next
  case (2 x)
  then have "n = 1" using 2 by auto
  then show ?case by (simp add: "2.prems"(1))
next
  case (3 x y ys)
  then show ?case proof (cases "n = 1")
    case True
    then have "take n (x # y # ys) = [x]"
      by simp
    then show ?thesis using is_walk_def "3.prems"(1) by simp
  next
    case False
    then have ngt: "n \<ge> 2" using "3.prems"(2) by auto
    then have tk_split1: "take n (x # y # ys) = x # take (n - 1) (y # ys)" using 3
      by (simp add: take_Cons')
    then have tk_split: "take n (x # y # ys) = x # y # (take (n - 2) ys)"
      using 3 ngt take_Cons'[of "n -1" "y" "ys"]
      by (metis False diff_diff_left less_one nat_neq_iff one_add_one zero_less_diff)
    have w: "is_walk (y # ys)" using is_walk_tl
      using "3.prems"(1) is_walk_def by force
    have "n - 1 \<le> length (y # ys)" using "3.prems"(3) by simp
    then have w_tl: "is_walk (take (n - 1) (y # ys))" using "3.hyps"[of "n - 1"] w "3.prems" ngt
      by linarith
    have "{x, y} \<in> E" using is_walk_def walk_edges.simps "3.prems"(1) by auto
    then show ?thesis using is_walk_hd_tl[of y "(take (n - 2) ys)" x] tk_split
      using tk_split1 w_tl by force
  qed
qed

lemma is_walk_drop:
  assumes "is_walk w"
  assumes "n < length w"
  shows "is_walk (drop n w)"
  using assms proof (induct w arbitrary: n rule: walk_edges.induct)
  case 1
  then show ?case by simp
next
  case (2 x)
  then have "n = 0" using 2 by auto
  then show ?case by (simp add: "2.prems"(1))
next
  case (3 x y ys)
  then show ?case proof (cases "n \<ge> 2")
    case True
    then have ngt: "n \<ge> 2" using "3.prems"(2) by auto
    then have tk_split1: "drop n (x # y # ys) = drop (n - 1) (y # ys)" using 3
      by (simp add: drop_Cons')
    then have tk_split: "drop n (x # y # ys) = (drop (n - 2) ys)"
      using 3 ngt drop_Cons'[of "n -1" "y" "ys"] True
      by (metis Suc_1 Suc_le_eq diff_diff_left less_not_refl nat_1_add_1 zero_less_diff)
    have w: "is_walk (y # ys)" using is_walk_tl
      using "3.prems"(1) is_walk_def by force
    have "n - 1 < length (y # ys)" using "3.prems"(2) by simp
    then have w_tl: "is_walk (drop (n - 1) (y # ys))" using "3.hyps"[of "n - 1"] w "3.prems" ngt
      by linarith
    have "{x, y} \<in> E" using is_walk_def walk_edges.simps "3.prems"(1) by auto
    then show ?thesis using is_walk_hd_tl[of y "(take (n - 2) ys)" x] tk_split
      using tk_split1 w_tl by force
  next
    case False
    then have or: "n = 0 \<or> n = 1"
      by auto
    have walk: "is_walk (y # ys)" using is_walk_drop_hd 3 by blast
    have n0: "n = 0 \<Longrightarrow> (drop n (x # y # ys)) = (x # y # ys)" by simp
    have "n = 1 \<Longrightarrow> (drop n (x # y # ys)) = y # ys" by simp
    then show ?thesis using n0 3 walk or by auto
  qed
qed

definition walks :: "'a list set" where
  "walks \<equiv> {p. is_walk p}"

definition is_open_walk :: "'a list \<Rightarrow> bool" where
"is_open_walk xs \<equiv> is_walk xs \<and> hd xs \<noteq> last xs"

lemma is_open_walk_rev: "is_open_walk xs \<longleftrightarrow> is_open_walk (rev xs)"
  unfolding is_open_walk_def using is_walk_rev
  by (metis hd_rev last_rev)

definition is_closed_walk :: "'a list \<Rightarrow> bool" where
"is_closed_walk xs \<equiv> is_walk xs \<and> hd xs = last xs"

lemma is_closed_walk_rev: "is_closed_walk xs \<longleftrightarrow> is_closed_walk (rev xs)"
  unfolding is_closed_walk_def using is_walk_rev
  by (metis hd_rev last_rev)

definition is_trail :: "'a list \<Rightarrow> bool" where
"is_trail xs \<equiv> is_walk xs \<and> distinct (walk_edges xs)"

lemma is_trail_rev: "is_trail xs \<longleftrightarrow> is_trail (rev xs)"
  unfolding is_trail_def using is_walk_rev
  by (metis distinct_rev walk_edges_rev)

subsection \<open>Paths\<close>

text \<open>There are two common definitions of a path. The first, given below, excludes the case
where a path is a cycle. Note this also excludes the trivial path $[x]$\<close>
definition is_path :: "'a list \<Rightarrow> bool" where
"is_path xs \<equiv> (is_open_walk xs \<and> distinct (xs))"

lemma is_path_rev: "is_path xs \<longleftrightarrow> is_path (rev xs)"
  unfolding is_path_def using is_open_walk_rev
  by (metis distinct_rev)

lemma is_path_walk: "is_path xs \<Longrightarrow> is_walk xs"
  unfolding is_path_def is_open_walk_def by auto

definition paths :: "'a list set" where
"paths \<equiv> {p . is_path p}"

lemma paths_ss_walk: "paths \<subseteq> walks"
  unfolding paths_def walks_def is_path_def is_open_walk_def by auto

text \<open> A more generic definition of a path - used when a cycle is considered a path, and
therefore includes the trivial path $[x]$ \<close>
definition is_gen_path:: "'a list \<Rightarrow> bool" where
"is_gen_path p \<equiv> is_walk p \<and> ((distinct (tl p) \<and> hd p = last p) \<or> distinct p)"

lemma is_path_gen_path: "is_path p \<Longrightarrow> is_gen_path p"
  unfolding is_path_def is_gen_path_def is_open_walk_def by (auto simp add: distinct_tl)

lemma is_gen_path_rev: "is_gen_path p \<longleftrightarrow> is_gen_path (rev p)"
  unfolding is_gen_path_def using is_walk_rev distinct_tl_rev
  by (metis distinct_rev hd_rev last_rev)

lemma is_gen_path_distinct: "is_gen_path p \<Longrightarrow> hd p \<noteq> last p \<Longrightarrow> distinct p"
  unfolding is_gen_path_def by auto

lemma is_gen_path_distinct_tl:
  assumes "is_gen_path p" and "hd p = last p"
  shows "distinct (tl p)"
proof (cases "length p > 1")
  case True
  then show ?thesis
    using assms(1) distinct_tl is_gen_path_def by auto
next
  case False
  then show ?thesis
    using assms(1) distinct_tl is_gen_path_def by auto
qed

lemma is_gen_path_trivial: "x \<in> V \<Longrightarrow> is_gen_path [x]"
  unfolding is_gen_path_def is_walk_def by simp

definition gen_paths :: "'a list set" where
"gen_paths \<equiv> {p . is_gen_path p}"

lemma gen_paths_ss_walks: "gen_paths \<subseteq> walks"
  unfolding gen_paths_def walks_def is_gen_path_def by auto

subsection \<open> Cycles \<close>
text \<open>Note, a cycle must be non trivial (i.e. have an edge), but as we let a loop by a cycle
we broaden the definition in comparison to Noschinski \<^cite>\<open>"noschinski_2015"\<close> for a cycle to be of
length greater than 1 rather than 3 \<close>
definition is_cycle :: "'a list \<Rightarrow> bool" where
"is_cycle xs \<equiv> is_closed_walk xs \<and> walk_length xs \<ge> 1 \<and> distinct (tl xs)"

lemma is_gen_path_cycle: "is_cycle p \<Longrightarrow> is_gen_path p"
  unfolding is_cycle_def is_gen_path_def is_closed_walk_def by auto

lemma is_cycle_alt_gen_path: "is_cycle xs \<longleftrightarrow> is_gen_path xs \<and> walk_length xs \<ge> 1 \<and> hd xs = last xs"
proof (intro iffI)
  show "is_cycle xs \<Longrightarrow> is_gen_path xs \<and> 1 \<le> walk_length xs \<and> hd xs = last xs"
    using is_gen_path_cycle is_cycle_def is_closed_walk_def
    by auto
  show "is_gen_path xs \<and> 1 \<le> walk_length xs \<and> hd xs = last xs \<Longrightarrow> is_cycle xs"
    using distinct_tl is_closed_walk_def is_cycle_def is_gen_path_def by blast
qed

lemma is_cycle_alt: "is_cycle xs \<longleftrightarrow> is_walk xs \<and> distinct (tl xs) \<and> walk_length xs \<ge> 1 \<and> hd xs = last xs"
proof (intro iffI)
  show "is_cycle xs \<Longrightarrow> is_walk xs \<and> distinct (tl xs) \<and> 1 \<le> walk_length xs \<and> hd xs = last xs"
    using is_cycle_alt_gen_path is_cycle_def is_gen_path_def by blast
  show "is_walk xs \<and> distinct (tl xs) \<and> 1 \<le> walk_length xs \<and> hd xs = last xs \<Longrightarrow> is_cycle xs"
    by (simp add: is_cycle_alt_gen_path is_gen_path_def)
qed

lemma is_cycle_rev: "is_cycle xs \<longleftrightarrow> is_cycle (rev xs)"
proof -
  have len: "1 \<le> walk_length xs \<longleftrightarrow> 1 \<le> walk_length (rev xs)"
    by (metis length_rev walk_edges_rev walk_length_def)
  have "hd xs = last xs \<Longrightarrow> distinct (tl xs) \<longleftrightarrow> distinct (tl (rev xs))"
    using distinct_tl_rev by blast
  then show ?thesis using len is_cycle_def
    using is_closed_walk_def is_closed_walk_rev by auto
qed

lemma cycle_tl_is_path: "is_cycle xs \<and> walk_length xs \<ge> 3 \<Longrightarrow> is_path (tl xs)"
proof (simp add: is_cycle_def is_path_def is_open_walk_def is_closed_walk_def walk_length_conv,
    elim conjE, intro conjI, simp add: is_walk_tl)
  assume w: "is_walk xs" and eq: "hd xs = last xs" and  "3 \<le> length xs - Suc 0" and
    dis: "distinct (tl xs)"
  then have len: "4 \<le> length xs"
    by linarith
  then have lentl: "3 \<le> length (tl xs)" by simp
  then have lentltl: "2 \<le> length (tl (tl xs))" by simp
  have "last (tl (tl xs)) = last (tl xs)"
    by (metis One_nat_def Suc_1 \<open>3 \<le> length xs - Suc 0\<close> diff_is_0_eq' is_walk_def is_walk_tl last_tl
        lentl not_less_eq_eq numeral_le_one_iff one_le_numeral order.trans semiring_norm(70) w)
  then have "last (tl xs) \<in> set (tl (tl xs))"
    using  last_in_list_tl_set lentltl by (metis last_in_set list.sel(2))
  moreover have "hd (tl xs) \<notin> set (tl (tl xs))" using dis lentltl
    by (metis distinct.simps(2) hd_Cons_tl list.sel(2) list.size(3) not_numeral_le_zero)
  ultimately show "hd (tl xs) \<noteq> last (tl xs)" by fastforce
qed

lemma is_gen_path_path:
  assumes "is_gen_path p" and "walk_length p > 0" and "(\<not> is_cycle p)"
  shows "is_path p"
proof (simp add: is_gen_path_def is_path_def is_open_walk_def, intro conjI)
  show "is_walk p" using is_gen_path_def assms(1) by simp
  show ne: "hd p \<noteq> last p"
    using assms(1) assms(2) assms(3) is_cycle_alt_gen_path by auto
  have "((distinct (tl p) \<and> hd p = last p) \<or> distinct p)" using is_gen_path_def assms(1) by auto
  thus "distinct p" using ne by auto
qed

lemma is_gen_path_options: "is_gen_path p \<longleftrightarrow> is_cycle p \<or> is_path p \<or> (\<exists> v \<in> V. p = [v])"
proof (intro iffI)
  assume a: "is_gen_path p"
  then have "p \<noteq> []" unfolding is_gen_path_def is_walk_def by auto
  then have "(\<forall> v \<in> V . p \<noteq> [v]) \<Longrightarrow> walk_length p > 0" using walk_length_def
    by (metis a is_gen_path_def is_walk_wf_hd length_greater_0_conv list.collapse list.distinct(1) walk_edges.simps(3))
  then show "is_cycle p \<or> is_path p \<or> (\<exists> v \<in> V. p = [v])"
    using a is_gen_path_path by auto
next
  show "is_cycle p \<or> is_path p \<or> (\<exists> v \<in> V. p = [v]) \<Longrightarrow> is_gen_path p "
    using is_gen_path_cycle is_path_gen_path is_gen_path_trivial by auto
qed

definition cycles :: "'a list set" where
  "cycles \<equiv> {p. is_cycle p}"

lemma cycles_ss_gen_paths: "cycles \<subseteq> gen_paths"
  unfolding cycles_def gen_paths_def using is_gen_path_cycle by auto

lemma gen_paths_ss: "gen_paths \<subseteq> cycles \<union> paths \<union> {[v] | v. v \<in> V}"
  unfolding gen_paths_def cycles_def paths_def using is_gen_path_options by auto

text \<open>Walk edges are distinct in a path and cycle \<close>
lemma distinct_edgesI:
  assumes "distinct p" shows "distinct (walk_edges p)"
proof -
  from assms have "?thesis" "\<And>u. u \<notin> set p \<Longrightarrow> (\<And>v. u \<noteq> v \<Longrightarrow> {u,v} \<notin> set (walk_edges p))"
    by (induct p rule: walk_edges.induct) auto
  then show ?thesis by simp
qed

lemma scycles_distinct_edges:
  assumes "c \<in> cycles" "3 \<le> walk_length c" shows "distinct (walk_edges c)"
proof -
  from assms  have c_props: "distinct (tl c)" "4 \<le> length c" "hd c = last c"
    by (auto simp add: cycles_def is_cycle_def is_closed_walk_def walk_length_conv)
  then have "{hd c, hd (tl c)} \<notin> set (walk_edges (tl c))"
  proof (induct c rule: walk_edges.induct)
    case (3 x y ys)
    then have "hd ys \<noteq> last ys" by (cases ys) auto
    moreover
    from 3 have "walk_edges (y # ys) = {y, hd ys} # walk_edges ys"
      by (cases ys) auto
    moreover
    { fix xs have "set (walk_edges xs) \<subseteq> Pow (set xs)"
        by (induct xs rule: walk_edges.induct) auto }
    ultimately
    show ?case using 3 by auto
  qed simp_all
  moreover
  from assms have "distinct (walk_edges (tl c))"
    by (intro distinct_edgesI) (simp add: cycles_def is_cycle_def)
  ultimately
  show ?thesis by(cases c, simp_all)
      (metis distinct.simps(1) distinct.simps(2) list.sel(1) list.sel(3) walk_edges.elims)
qed

end

context fin_ulgraph
begin

lemma finite_paths: "finite paths"
proof -
  have ss: "paths \<subseteq> {xs. set xs \<subseteq> V \<and> length xs \<le> (card (V))}"
  proof (rule, simp, intro conjI)
    show 1: "\<And>x. x \<in> paths \<Longrightarrow> set x \<subseteq> V"
      unfolding paths_def is_path_def is_open_walk_def is_walk_def by simp
    fix x assume a: "x \<in> paths"
    then have "distinct x"
      using paths_def is_path_def by simp_all
    then have eq: "length x = card (set x)"
      by (simp add: distinct_card)
    then show "length x \<le> order" using a 1
      by (simp add: card_mono finV)
  qed
  have "finite {xs. set xs \<subseteq> V \<and> length xs \<le> (card (V))}"
    using finV by (simp add: finite_lists_length_le)
  thus ?thesis using ss finite_subset by auto
qed

lemma finite_cycles: "finite (cycles)"
proof -
  have "cycles \<subseteq> {xs. set xs \<subseteq> V \<and> length xs \<le> Suc (card (V))}"
  proof (rule, simp)
    fix p assume "p \<in> cycles"
    then have "distinct (tl p)" and "set p \<subseteq> V"
      unfolding cycles_def walks_def is_cycle_def is_closed_walk_def is_walk_def
      by (simp_all)
    then have "set (tl p) \<subseteq> V"
      by (cases p) auto
    with finV have "card (set (tl p)) \<le> card (V)"
      by (rule card_mono)
    then have "length (p) \<le> 1 + card (V)"
      using distinct_card[OF \<open>distinct (tl p)\<close>] by auto
    then show "set p \<subseteq> V \<and> length p \<le> Suc (card (V))"
      by (simp add: \<open>set p \<subseteq> V\<close>)
  qed
  moreover
  have "finite {xs. set xs \<subseteq> V \<and> length xs \<le> Suc (card (V))}"
    using finV by (rule finite_lists_length_le)
  ultimately
  show ?thesis by (rule finite_subset)
qed

lemma finite_gen_paths: "finite (gen_paths)"
proof -
  have "finite ({[v] | v . v \<in> V})" using finV by auto
  thus ?thesis  using gen_paths_ss finite_cycles finite_paths finite_subset by auto
qed

end

end


(*  Title:      HOL/ex/CTL.thy
    Author:     Gertrud Bauer
*)

section \<open>CTL formulae\<close>

theory CTL
imports Main
begin

text \<open>
  We formalize basic concepts of Computational Tree Logic (CTL) @{cite
  "McMillan-PhDThesis" and "McMillan-LectureNotes"} within the simply-typed
  set theory of HOL.

  By using the common technique of ``shallow embedding'', a CTL formula is
  identified with the corresponding set of states where it holds.
  Consequently, CTL operations such as negation, conjunction, disjunction
  simply become complement, intersection, union of sets. We only require a
  separate operation for implication, as point-wise inclusion is usually not
  encountered in plain set-theory.
\<close>

lemmas [intro!] = Int_greatest Un_upper2 Un_upper1 Int_lower1 Int_lower2

type_synonym 'a ctl = "'a set"

definition imp :: "'a ctl \<Rightarrow> 'a ctl \<Rightarrow> 'a ctl"  (infixr "\<rightarrow>" 75)
  where "p \<rightarrow> q = - p \<union> q"

lemma [intro!]: "p \<inter> p \<rightarrow> q \<subseteq> q" unfolding imp_def by auto
lemma [intro!]: "p \<subseteq> (q \<rightarrow> p)" unfolding imp_def by rule

text \<open>
  \<^smallskip>
  The CTL path operators are more interesting; they are based on an arbitrary,
  but fixed model \<open>\<M>\<close>, which is simply a transition relation over states
  @{typ 'a}.
\<close>

axiomatization \<M> :: "('a \<times> 'a) set"

text \<open>
  The operators \<open>\<^bold>E\<^bold>X\<close>, \<open>\<^bold>E\<^bold>F\<close>, \<open>\<^bold>E\<^bold>G\<close> are taken as primitives, while \<open>\<^bold>A\<^bold>X\<close>,
  \<open>\<^bold>A\<^bold>F\<close>, \<open>\<^bold>A\<^bold>G\<close> are defined as derived ones. The formula \<open>\<^bold>E\<^bold>X p\<close> holds in a
  state \<open>s\<close>, iff there is a successor state \<open>s'\<close> (with respect to the model
  \<open>\<M>\<close>), such that \<open>p\<close> holds in \<open>s'\<close>. The formula \<open>\<^bold>E\<^bold>F p\<close> holds in a state
  \<open>s\<close>, iff there is a path in \<open>\<M>\<close>, starting from \<open>s\<close>, such that there exists a
  state \<open>s'\<close> on the path, such that \<open>p\<close> holds in \<open>s'\<close>. The formula \<open>\<^bold>E\<^bold>G p\<close>
  holds in a state \<open>s\<close>, iff there is a path, starting from \<open>s\<close>, such that for
  all states \<open>s'\<close> on the path, \<open>p\<close> holds in \<open>s'\<close>. It is easy to see that \<open>\<^bold>E\<^bold>F
  p\<close> and \<open>\<^bold>E\<^bold>G p\<close> may be expressed using least and greatest fixed points
  @{cite "McMillan-PhDThesis"}.
\<close>

definition EX  ("\<^bold>E\<^bold>X _" [80] 90)
  where [simp]: "\<^bold>E\<^bold>X p = {s. \<exists>s'. (s, s') \<in> \<M> \<and> s' \<in> p}"

definition EF ("\<^bold>E\<^bold>F _" [80] 90)
  where [simp]: "\<^bold>E\<^bold>F p = lfp (\<lambda>s. p \<union> \<^bold>E\<^bold>X s)"

definition EG ("\<^bold>E\<^bold>G _" [80] 90)
  where [simp]: "\<^bold>E\<^bold>G p = gfp (\<lambda>s. p \<inter> \<^bold>E\<^bold>X s)"

text \<open>
  \<open>\<^bold>A\<^bold>X\<close>, \<open>\<^bold>A\<^bold>F\<close> and \<open>\<^bold>A\<^bold>G\<close> are now defined dually in terms of \<open>\<^bold>E\<^bold>X\<close>,
  \<open>\<^bold>E\<^bold>F\<close> and \<open>\<^bold>E\<^bold>G\<close>.
\<close>

definition AX  ("\<^bold>A\<^bold>X _" [80] 90)
  where [simp]: "\<^bold>A\<^bold>X p = - \<^bold>E\<^bold>X - p"
definition AF  ("\<^bold>A\<^bold>F _" [80] 90)
  where [simp]: "\<^bold>A\<^bold>F p = - \<^bold>E\<^bold>G - p"
definition AG  ("\<^bold>A\<^bold>G _" [80] 90)
  where [simp]: "\<^bold>A\<^bold>G p = - \<^bold>E\<^bold>F - p"

subsection \<open>Basic fixed point properties\<close>

text \<open>
  First of all, we use the de-Morgan property of fixed points.
\<close>

lemma lfp_gfp: "lfp f = - gfp (\<lambda>s::'a set. - (f (- s)))"
proof
  show "lfp f \<subseteq> - gfp (\<lambda>s. - f (- s))"
  proof
    show "x \<in> - gfp (\<lambda>s. - f (- s))" if l: "x \<in> lfp f" for x
    proof
      assume "x \<in> gfp (\<lambda>s. - f (- s))"
      then obtain u where "x \<in> u" and "u \<subseteq> - f (- u)"
        by (auto simp add: gfp_def)
      then have "f (- u) \<subseteq> - u" by auto
      then have "lfp f \<subseteq> - u" by (rule lfp_lowerbound)
      from l and this have "x \<notin> u" by auto
      with \<open>x \<in> u\<close> show False by contradiction
    qed
  qed
  show "- gfp (\<lambda>s. - f (- s)) \<subseteq> lfp f"
  proof (rule lfp_greatest)
    fix u
    assume "f u \<subseteq> u"
    then have "- u \<subseteq> - f u" by auto
    then have "- u \<subseteq> - f (- (- u))" by simp
    then have "- u \<subseteq> gfp (\<lambda>s. - f (- s))" by (rule gfp_upperbound)
    then show "- gfp (\<lambda>s. - f (- s)) \<subseteq> u" by auto
  qed
qed

lemma lfp_gfp': "- lfp f = gfp (\<lambda>s::'a set. - (f (- s)))"
  by (simp add: lfp_gfp)

lemma gfp_lfp': "- gfp f = lfp (\<lambda>s::'a set. - (f (- s)))"
  by (simp add: lfp_gfp)

text \<open>
  In order to give dual fixed point representations of @{term "\<^bold>A\<^bold>F p"} and
  @{term "\<^bold>A\<^bold>G p"}:
\<close>

lemma AF_lfp: "\<^bold>A\<^bold>F p = lfp (\<lambda>s. p \<union> \<^bold>A\<^bold>X s)"
  by (simp add: lfp_gfp)

lemma AG_gfp: "\<^bold>A\<^bold>G p = gfp (\<lambda>s. p \<inter> \<^bold>A\<^bold>X s)"
  by (simp add: lfp_gfp)

lemma EF_fp: "\<^bold>E\<^bold>F p = p \<union> \<^bold>E\<^bold>X \<^bold>E\<^bold>F p"
proof -
  have "mono (\<lambda>s. p \<union> \<^bold>E\<^bold>X s)" by rule auto
  then show ?thesis by (simp only: EF_def) (rule lfp_unfold)
qed

lemma AF_fp: "\<^bold>A\<^bold>F p = p \<union> \<^bold>A\<^bold>X \<^bold>A\<^bold>F p"
proof -
  have "mono (\<lambda>s. p \<union> \<^bold>A\<^bold>X s)" by rule auto
  then show ?thesis by (simp only: AF_lfp) (rule lfp_unfold)
qed

lemma EG_fp: "\<^bold>E\<^bold>G p = p \<inter> \<^bold>E\<^bold>X \<^bold>E\<^bold>G p"
proof -
  have "mono (\<lambda>s. p \<inter> \<^bold>E\<^bold>X s)" by rule auto
  then show ?thesis by (simp only: EG_def) (rule gfp_unfold)
qed

text \<open>
  From the greatest fixed point definition of @{term "\<^bold>A\<^bold>G p"}, we derive as
  a consequence of the Knaster-Tarski theorem on the one hand that @{term
  "\<^bold>A\<^bold>G p"} is a fixed point of the monotonic function
  @{term "\<lambda>s. p \<inter> \<^bold>A\<^bold>X s"}.
\<close>

lemma AG_fp: "\<^bold>A\<^bold>G p = p \<inter> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p"
proof -
  have "mono (\<lambda>s. p \<inter> \<^bold>A\<^bold>X s)" by rule auto
  then show ?thesis by (simp only: AG_gfp) (rule gfp_unfold)
qed

text \<open>
  This fact may be split up into two inequalities (merely using transitivity
  of \<open>\<subseteq>\<close>, which is an instance of the overloaded \<open>\<le>\<close> in Isabelle/HOL).
\<close>

lemma AG_fp_1: "\<^bold>A\<^bold>G p \<subseteq> p"
proof -
  note AG_fp also have "p \<inter> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p \<subseteq> p" by auto
  finally show ?thesis .
qed

lemma AG_fp_2: "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p"
proof -
  note AG_fp also have "p \<inter> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p" by auto
  finally show ?thesis .
qed

text \<open>
  On the other hand, we have from the Knaster-Tarski fixed point theorem that
  any other post-fixed point of @{term "\<lambda>s. p \<inter> \<^bold>A\<^bold>X s"} is smaller than
  @{term "\<^bold>A\<^bold>G p"}. A post-fixed point is a set of states \<open>q\<close> such that @{term
  "q \<subseteq> p \<inter> \<^bold>A\<^bold>X q"}. This leads to the following co-induction principle for
  @{term "\<^bold>A\<^bold>G p"}.
\<close>

lemma AG_I: "q \<subseteq> p \<inter> \<^bold>A\<^bold>X q \<Longrightarrow> q \<subseteq> \<^bold>A\<^bold>G p"
  by (simp only: AG_gfp) (rule gfp_upperbound)

subsection \<open>The tree induction principle \label{sec:calc-ctl-tree-induct}\<close>

text \<open>
  With the most basic facts available, we are now able to establish a few more
  interesting results, leading to the \<^emph>\<open>tree induction\<close> principle for \<open>\<^bold>A\<^bold>G\<close>
  (see below). We will use some elementary monotonicity and distributivity
  rules.
\<close>

lemma AX_int: "\<^bold>A\<^bold>X (p \<inter> q) = \<^bold>A\<^bold>X p \<inter> \<^bold>A\<^bold>X q" by auto
lemma AX_mono: "p \<subseteq> q \<Longrightarrow> \<^bold>A\<^bold>X p \<subseteq> \<^bold>A\<^bold>X q" by auto
lemma AG_mono: "p \<subseteq> q \<Longrightarrow> \<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>G q"
  by (simp only: AG_gfp, rule gfp_mono) auto

text \<open>
  The formula @{term "AG p"} implies @{term "AX p"} (we use substitution of
  \<open>\<subseteq>\<close> with monotonicity).
\<close>

lemma AG_AX: "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>X p"
proof -
  have "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p" by (rule AG_fp_2)
  also have "\<^bold>A\<^bold>G p \<subseteq> p" by (rule AG_fp_1)
  moreover note AX_mono
  finally show ?thesis .
qed

text \<open>
  Furthermore we show idempotency of the \<open>\<^bold>A\<^bold>G\<close> operator. The proof is a good
  example of how accumulated facts may get used to feed a single rule step.
\<close>

lemma AG_AG: "\<^bold>A\<^bold>G \<^bold>A\<^bold>G p = \<^bold>A\<^bold>G p"
proof
  show "\<^bold>A\<^bold>G \<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>G p" by (rule AG_fp_1)
next
  show "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>G \<^bold>A\<^bold>G p"
  proof (rule AG_I)
    have "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>G p" ..
    moreover have "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p" by (rule AG_fp_2)
    ultimately show "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>G p \<inter> \<^bold>A\<^bold>X \<^bold>A\<^bold>G p" ..
  qed
qed

text \<open>
  \<^smallskip>
  We now give an alternative characterization of the \<open>\<^bold>A\<^bold>G\<close> operator, which
  describes the \<open>\<^bold>A\<^bold>G\<close> operator in an ``operational'' way by tree induction:
  In a state holds @{term "AG p"} iff in that state holds \<open>p\<close>, and in all
  reachable states \<open>s\<close> follows from the fact that \<open>p\<close> holds in \<open>s\<close>, that \<open>p\<close>
  also holds in all successor states of \<open>s\<close>. We use the co-induction principle
  @{thm [source] AG_I} to establish this in a purely algebraic manner.
\<close>

theorem AG_induct: "p \<inter> \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p) = \<^bold>A\<^bold>G p"
proof
  show "p \<inter> \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p) \<subseteq> \<^bold>A\<^bold>G p"  (is "?lhs \<subseteq> _")
  proof (rule AG_I)
    show "?lhs \<subseteq> p \<inter> \<^bold>A\<^bold>X ?lhs"
    proof
      show "?lhs \<subseteq> p" ..
      show "?lhs \<subseteq> \<^bold>A\<^bold>X ?lhs"
      proof -
        {
          have "\<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p) \<subseteq> p \<rightarrow> \<^bold>A\<^bold>X p" by (rule AG_fp_1)
          also have "p \<inter> p \<rightarrow> \<^bold>A\<^bold>X p \<subseteq> \<^bold>A\<^bold>X p" ..
          finally have "?lhs \<subseteq> \<^bold>A\<^bold>X p" by auto
        }
        moreover
        {
          have "p \<inter> \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p) \<subseteq> \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p)" ..
          also have "\<dots> \<subseteq> \<^bold>A\<^bold>X \<dots>" by (rule AG_fp_2)
          finally have "?lhs \<subseteq> \<^bold>A\<^bold>X \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p)" .
        }
        ultimately have "?lhs \<subseteq> \<^bold>A\<^bold>X p \<inter> \<^bold>A\<^bold>X \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p)" ..
        also have "\<dots> = \<^bold>A\<^bold>X ?lhs" by (simp only: AX_int)
        finally show ?thesis .
      qed
    qed
  qed
next
  show "\<^bold>A\<^bold>G p \<subseteq> p \<inter> \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p)"
  proof
    show "\<^bold>A\<^bold>G p \<subseteq> p" by (rule AG_fp_1)
    show "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p)"
    proof -
      have "\<^bold>A\<^bold>G p = \<^bold>A\<^bold>G \<^bold>A\<^bold>G p" by (simp only: AG_AG)
      also have "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>X p" by (rule AG_AX) moreover note AG_mono
      also have "\<^bold>A\<^bold>X p \<subseteq> (p \<rightarrow> \<^bold>A\<^bold>X p)" .. moreover note AG_mono
      finally show ?thesis .
    qed
  qed
qed

subsection \<open>An application of tree induction \label{sec:calc-ctl-commute}\<close>

text \<open>
  Further interesting properties of CTL expressions may be demonstrated with
  the help of tree induction; here we show that \<open>\<^bold>A\<^bold>X\<close> and \<open>\<^bold>A\<^bold>G\<close> commute.
\<close>

theorem AG_AX_commute: "\<^bold>A\<^bold>G \<^bold>A\<^bold>X p = \<^bold>A\<^bold>X \<^bold>A\<^bold>G p"
proof -
  have "\<^bold>A\<^bold>G \<^bold>A\<^bold>X p = \<^bold>A\<^bold>X p \<inter> \<^bold>A\<^bold>X \<^bold>A\<^bold>G \<^bold>A\<^bold>X p" by (rule AG_fp)
  also have "\<dots> = \<^bold>A\<^bold>X (p \<inter> \<^bold>A\<^bold>G \<^bold>A\<^bold>X p)" by (simp only: AX_int)
  also have "p \<inter> \<^bold>A\<^bold>G \<^bold>A\<^bold>X p = \<^bold>A\<^bold>G p"  (is "?lhs = _")
  proof
    have "\<^bold>A\<^bold>X p \<subseteq> p \<rightarrow> \<^bold>A\<^bold>X p" ..
    also have "p \<inter> \<^bold>A\<^bold>G (p \<rightarrow> \<^bold>A\<^bold>X p) = \<^bold>A\<^bold>G p" by (rule AG_induct)
    also note Int_mono AG_mono
    ultimately show "?lhs \<subseteq> \<^bold>A\<^bold>G p" by fast
  next
    have "\<^bold>A\<^bold>G p \<subseteq> p" by (rule AG_fp_1)
    moreover
    {
      have "\<^bold>A\<^bold>G p = \<^bold>A\<^bold>G \<^bold>A\<^bold>G p" by (simp only: AG_AG)
      also have "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>X p" by (rule AG_AX)
      also note AG_mono
      ultimately have "\<^bold>A\<^bold>G p \<subseteq> \<^bold>A\<^bold>G \<^bold>A\<^bold>X p" .
    }
    ultimately show "\<^bold>A\<^bold>G p \<subseteq> ?lhs" ..
  qed
  finally show ?thesis .
qed

end


theory Practical
imports Main
begin

section \<open>Part 1\<close>

(* 1 mark *)
lemma disjunction_idempotence:
  "A \<or> A \<longleftrightarrow> A"
  apply(rule iffI)
   apply(erule disjE)
    apply(assumption)+
  apply(rule disjI1)
  by assumption

(* 1 mark *)
lemma conjunction_idempotence:
  "A \<and> A \<longleftrightarrow> A"
  apply(rule iffI)
   apply(erule conjE)
   apply(assumption)
  apply(rule conjI)
  by assumption

(* 1 mark *)
lemma disjunction_to_conditional:
  "(\<not> P \<or> R) \<longrightarrow> (P \<longrightarrow> R)"
  apply(rule impI)+
  apply(erule disjE)
   apply(erule notE)
  by assumption

(* 1 mark *)
lemma
  "(\<exists>x. P x \<and> Q x) \<longrightarrow> (\<exists>x. P x) \<and> (\<exists>x. Q x)"
  apply(rule impI)
  apply(rule conjI)
   apply(erule exE)+
   apply(erule conjE)+
   apply(erule exI)
  apply(erule exE)
  apply(erule conjE)
  apply(rule exI)
  by assumption

(* 1 mark *)
lemma
  "(\<not> (\<exists>x. \<not>P x) \<or> R) \<longrightarrow> ((\<exists>x. \<not> P x) \<longrightarrow> R)"
  apply(rule impI)+
  apply(erule disjE)
   apply(erule exE)
   apply(erule notE)
   apply(rule exI)
   apply(rule notI)
   apply(erule notE)
   apply(assumption)
  apply(erule exE)
  by assumption

(* 2 marks *)
lemma
  "(\<forall>x. P x) \<longrightarrow> \<not> (\<exists>x. \<not> P x)"
  apply(rule impI)
  apply(rule notI)
  apply(erule exE)
  apply(erule allE)
  apply(erule notE)
  by assumption

(* 3 marks *)
text \<open>Prove using ccontr\<close>
lemma excluded_middle:
  "P \<or> \<not> P"
  apply(cut_tac P="P" and Q="P" in impI)
   apply(assumption)
  apply(rule ccontr)
  apply(erule impE)
   apply(rule ccontr)
   apply(erule notE)
   apply(rule disjI2)
   apply(assumption)
  apply(erule notE)
  apply(rule disjI1)
  by assumption

(* 3 marks *)
text \<open>Prove using excluded middle\<close>
lemma notnotD:
  "\<not>\<not> P \<Longrightarrow> P"
  apply(cut_tac P="P" in excluded_middle)
   apply(erule disjE)
  apply(assumption)
   apply(erule notE)
  by assumption+

(* 3 marks *)
text \<open>Prove using double-negation (rule notnotD)\<close>
lemma classical:
  "(\<not> P \<Longrightarrow> P) \<Longrightarrow> P"
  apply(rule notnotD)
  apply(drule impI)
  apply(rule notI)
  apply(erule impE)
   apply(assumption)
  apply(erule notE)
  by assumption

(* 3 marks *)
text \<open>Prove using classical\<close>
lemma ccontr:
  "(\<not> P \<Longrightarrow> False) \<Longrightarrow> P"
  apply(rule classical)
  apply(drule impI)
  apply(erule impE)
   apply(assumption)
  apply(erule notE)
  apply(cut_tac P="\<not>P" in notI)
   apply(assumption)
  apply(erule notE)
  apply(rule notI)
  by assumption

(* 3 marks *)
lemma
  "(\<not> (\<forall>x. P x \<or> R x)) = (\<exists>x. \<not> P x \<and> \<not> R x)"
  apply(rule iffI)
   apply(rule ccontr)
   apply(erule notE)
   apply(rule allI)
   apply(rule ccontr)
   apply(erule notE)
   apply(rule_tac x="x" in exI)
   apply(rule conjI)
    apply(rule notI)
    apply(erule notE)
    apply(rule disjI1)
    apply(assumption)
   apply(rule notI)
   apply(erule notE)
   apply(rule disjI2)
   apply(assumption)
  apply(rule notI)
  apply(erule exE)
  apply(erule_tac x="x" in allE)
  apply(erule conjE)
  apply(erule disjE)
   apply(erule notE)
   apply(assumption)
  apply(erule notE)+
  by assumption

(* 3 marks *)
lemma
  "(\<exists>x. P x \<or> R x) = (\<not>((\<forall>x. \<not> P x) \<and> \<not> (\<exists>x. R x)))"
  apply(rule iffI)
   apply(rule notI)
   apply(erule exE)
   apply(erule conjE)
   apply(erule disjE)
    apply(erule_tac x="x" in allE)
    apply(erule notE)
    apply(rule_tac x="x" in exI)
    apply(erule notE)
    apply(assumption)
   apply(erule_tac x="x" in allE)
   apply(erule notE)
   apply(rule_tac x="x" in exI)
   apply(assumption)
  apply(rule ccontr)
  apply(erule notE)
  apply(rule conjI)
   apply(rule allI)
   apply(rule notI)
   apply(erule notE)
   apply(rule_tac x="x" in exI)
   apply(rule disjI1)
   apply(assumption)
  apply(rule notI)
  apply(erule notE)
  apply(erule exE)
  apply(rule_tac x="x" in exI)
  apply(rule disjI2)
  by assumption

section \<open>Part 2.1\<close>

locale partof =
  fixes partof :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "\<sqsubseteq>" 100)
begin

(* 1 mark *)
definition properpartof :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "\<sqsubset>" 100) where
  "x \<sqsubset> y \<equiv> x \<sqsubseteq> y \<and> x \<noteq> y"

(* 1 mark *)
definition overlaps :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "\<frown>" 100) where
  "x \<frown> y \<equiv> \<exists>z. z \<sqsubseteq> x \<and> z \<sqsubseteq> y"

definition disjoint :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "\<asymp>" 100) where
  "x \<asymp> y \<equiv> \<not> x \<frown> y"

(* 1 mark *)
definition partialoverlap :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "~\<frown>" 100) where
  "x ~\<frown> y \<equiv> x \<frown> y \<and> \<not>x \<sqsubseteq> y \<and> \<not>y \<sqsubseteq> x"

(* 1 mark *)
definition sumregions :: "'region set \<Rightarrow> 'region \<Rightarrow> bool" ("\<Squnion> _ _" [100, 100] 100) where
  "\<Squnion> \<alpha> x \<equiv> (\<forall>y. y \<in> \<alpha> \<and>  y \<sqsubseteq> x) \<and> (\<forall>y. y \<sqsubseteq> x \<longrightarrow> (\<exists>z. z \<in> \<alpha> \<and> y \<frown> z))"

end

(* 1+1+1=3 marks *)
locale mereology = partof +
  assumes A1: "\<forall>x y z. x \<sqsubseteq> y \<and> y \<sqsubseteq> z \<longrightarrow> x \<sqsubseteq> z"
      and A2: "\<forall>\<alpha>. \<alpha> \<noteq> {} \<longrightarrow> (\<exists>x. \<Squnion> \<alpha> x)"
      and A2': "\<forall>\<alpha> x y. \<Squnion> \<alpha> x \<and> \<Squnion> \<alpha> y \<longrightarrow> x = y"
begin

section \<open>Part 2.2\<close>

(* 2 marks *)
theorem overlaps_sym:
  "(x \<frown> y) = (y \<frown> x)"
  apply(unfold overlaps_def)
  apply(rule iffI)
  apply(erule exE)
   apply(rule_tac x="z" in exI)
   apply(rule conjI)
    apply(erule conjE)
    apply(assumption)
   apply(erule conjE)
   apply(assumption)
  apply(erule exE)
  apply(rule_tac x="z" in exI)
  apply(rule conjI)
   apply(erule conjE)
   apply(assumption)
  apply(erule conjE)
  by assumption

(* 1 mark *)
theorem in_sum_set_partof:
  "m \<in> \<alpha> \<and> \<Squnion> \<alpha> r \<Longrightarrow> m \<sqsubseteq> r"
proof -
  have "\<Squnion> \<alpha> r \<Longrightarrow> (\<forall>y. y \<in> \<alpha> \<and>  y \<sqsubseteq> r)" using sumregions_def by simp
  thus "m \<in> \<alpha> \<and> \<Squnion> \<alpha> r \<Longrightarrow> m \<sqsubseteq> r" by simp
qed

(* 3 marks *)
theorem overlaps_refl:
  "x \<frown> x"
proof -
  have 0: "{x} \<noteq> {} \<Longrightarrow> \<exists>z. \<Squnion> {x} z" using sumregions_def A2 by blast
  from 0 have 1: "{x} \<noteq> {} \<Longrightarrow> \<Squnion> {x} x" using sumregions_def A2 by fastforce
  thus "x \<frown> x" using "1" sumregions_def by auto
qed

(* 1 mark *)
theorem all_has_partof:
  "\<exists>p. p \<sqsubseteq> r"
  using A2 overlaps_def sumregions_def by fastforce

(* 2 marks *)
theorem partof_overlaps:
  assumes a: "z \<sqsubseteq> x \<and> x \<sqsubseteq> y"
  shows "x \<frown> y"
proof -
  from a have "z \<sqsubseteq> y" using A1 by blast
  moreover
  from a have "z \<sqsubseteq> x" by simp
  ultimately show "x \<frown> y" using overlaps_def by auto
qed

(* 1 mark *)
theorem sum_parts_eq:
  "\<Squnion> {p. p \<sqsubseteq> x} x"
proof -
  have 0: "\<exists>y. \<Squnion> {p. p \<sqsubseteq> x} y" using A2 all_has_partof by auto
  thus "\<Squnion> {p. p \<sqsubseteq> x} x" using UNIV_eq_I sumregions_def by fastforce
qed

(* 2 marks *)
theorem sum_relation_is_same':
  assumes "\<And>c. r y c \<Longrightarrow> c \<sqsubseteq> y"
      and "\<And>f. y \<frown> f \<Longrightarrow> \<exists>g. r y g \<and> g \<frown> f"
      and "\<Squnion> {y} x"
  shows "\<Squnion> {k. r y k} x"
proof -
  let ?\<beta> = "{k. r y k}"
  let ?\<alpha> = "{k. k \<sqsubseteq> x}"
  have 0: "\<Squnion> ?\<alpha> x" using assms(3) sumregions_def by auto
  have 1: "y \<sqsubseteq> x \<Longrightarrow> r y y" using assms sumregions_def by fastforce
  from 1 have 2: "p \<sqsubseteq> x \<Longrightarrow> r y p" using sumregions_def assms by force
  have 3: "?\<beta> = ?\<alpha>" using sumregions_def 1 assms(3) by fastforce
  thus "\<Squnion> ?\<beta> x" using 0 by simp
qed

(* 1 mark *)
theorem overlap_has_partof_overlap:
  assumes "\<And>e f. e \<frown> f"
  shows "\<exists>x. x \<sqsubseteq> e \<and> x \<frown> f"
  using assms overlaps_def by blast

(* 1 marks *)
theorem sum_parts_of_one_eq:
  assumes "\<Squnion> {x} x"
  shows "\<Squnion> {p. p \<sqsubseteq> x} x"
  using sum_relation_is_same' [where x = "x" and y = "x" and r = "\<lambda>x y. y \<sqsubseteq> x"]
  by (simp add: sum_parts_eq)

(* 5 marks *)
theorem both_partof_eq:
assumes "x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
  shows "x = y"
proof -
  have 0: "\<Squnion> {z. z \<sqsubseteq> x} y"
  proof (rule ccontr)
    assume a: "\<not> \<Squnion> {z. z \<sqsubseteq> x} y"
    have 1: "\<exists>w. w \<sqsubseteq> x \<and> \<not> w \<sqsubseteq> y \<Longrightarrow> False"
    proof -
      assume b: "\<exists>w. w \<sqsubseteq> x \<and> \<not> w \<sqsubseteq> y"
      have 2: "w \<sqsubseteq> x \<Longrightarrow> w \<sqsubseteq> y" using assms A1 by blast
      from 2 have 3: "\<not>(\<exists>w. w \<sqsubseteq> x \<and> \<not> w \<sqsubseteq> y)" using A1 assms by blast
      thus "False" using b sumregions_def sum_parts_eq a by auto
    qed
    moreover
    have 4: "\<exists>w. \<forall>v. v \<sqsubseteq> x \<and> w \<sqsubseteq> y \<and> v \<asymp> w \<Longrightarrow> False"
    proof -
      assume c: "\<exists>w. \<forall>v. v \<sqsubseteq> x \<and> w \<sqsubseteq> y \<and> v \<asymp> w"
      fix w
      have 5: "y \<sqsubseteq> x \<Longrightarrow> y \<asymp> w" using c disjoint_def overlaps_refl by blast
      thus "False" using c disjoint_def overlaps_refl by blast
    qed
    ultimately show "False" using sumregions_def a overlaps_def sum_parts_eq by simp
  qed
  thus "x = y" using 0 A2' sum_parts_eq by blast
qed

(* 4 marks *)
theorem sum_all_with_parts_overlapping:
  assumes "\<Squnion> {z. \<forall>p. p \<sqsubseteq> z \<and> p \<frown> y} x"
  shows "\<Squnion> {y} x"
proof -
  have "\<Squnion> {y} x"
  proof (rule ccontr)
    assume a: "\<not> \<Squnion> {y} x"
    have 0: "\<not> y \<sqsubseteq> x" using A2' a assms sumregions_def by fastforce
    have 1: "\<exists>w. w \<sqsubseteq> x \<and> w \<asymp> y" using 0 assms sumregions_def by blast
    thus "False" using 0 assms sumregions_def by blast
  qed
  thus "\<Squnion> {y} x" by simp
qed

(* 2 marks *)
theorem sum_one_is_self:
  "\<Squnion> {x} x"
proof -
  have 0: "\<exists>y. \<Squnion> {x} y" using A2 by simp
  thus "\<Squnion> {x} x" using A2 sumregions_def by fastforce
qed

(* 2 marks *)
theorem sum_all_with_parts_overlapping_self:
  "\<Squnion> {z. \<forall>p. p \<sqsubseteq> z \<and> p \<frown> x} x"
  using sumregions_def sum_one_is_self by auto

(* 4 marks *)
theorem proper_have_nonoverlapping_proper:
  assumes "s \<sqsubset> r"
  shows "\<exists>z. z \<sqsubset> r \<and> z \<asymp> s"
proof -
  have 0: "\<Squnion> {z. z \<sqsubset> r} y" using A2 sumregions_def properpartof_def assms by auto
  from 0 have 1: "y \<noteq> s" using sumregions_def properpartof_def by auto
  from 1 have 2: "{z. z \<sqsubset> r} \<noteq> {s}" using 0 sum_one_is_self A2' by fastforce
  thus "\<exists>z. z \<sqsubset> r \<and> z \<asymp> s" using 0 properpartof_def sumregions_def by auto
qed

(* 1 mark *)
sublocale parthood_partial_order: order "(\<sqsubseteq>)" "(\<sqsubset>)"
proof
  show "\<And>x y. x \<sqsubset> y = (x \<sqsubseteq> y \<and> \<not> y \<sqsubseteq> x)" using properpartof_def A2 sumregions_def by auto
next
  show "\<And>x. x \<sqsubseteq> x" using sumregions_def sum_one_is_self by simp
next
  show "\<And>x y z. \<lbrakk>x \<sqsubseteq> y; y \<sqsubseteq> z\<rbrakk> \<Longrightarrow> x \<sqsubseteq> z" using A1 by blast
next
  show "\<And>x y. \<lbrakk>x \<sqsubseteq> y; y \<sqsubseteq> x\<rbrakk> \<Longrightarrow> x = y" using both_partof_eq by simp
qed

end

section \<open>Part 2.3\<close>

locale sphere =
  fixes sphere :: "'a \<Rightarrow> bool"
begin

abbreviation AllSpheres :: "('a \<Rightarrow> bool) \<Rightarrow> bool" (binder "\<forall>\<degree>" 10) where
  "\<forall>\<degree>x. P x \<equiv> \<forall>x. sphere x \<longrightarrow> P x"

abbreviation ExSpheres :: "('a \<Rightarrow> bool) \<Rightarrow> bool" (binder "\<exists>\<degree>" 10) where
  "\<exists>\<degree>x. P x \<equiv> \<exists>x. sphere x \<and> P x"

end

locale mereology_sphere = mereology partof + sphere sphere
  for partof :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "\<sqsubseteq>" 100)
  and sphere :: "'region \<Rightarrow> bool"
begin

definition exttan :: "'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "exttan a b \<equiv> sphere a \<and> sphere b \<and> a \<asymp> b \<and> (\<forall>\<degree>x y. a \<sqsubseteq> x \<and> a \<sqsubseteq> y \<and> b \<asymp> x \<and> b \<asymp> y
                                                        \<longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x)"

definition inttan :: "'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "inttan a b \<equiv> sphere a \<and> sphere b \<and> a \<asymp> b \<and> (\<forall>\<degree>x y. a \<sqsubseteq> x \<and> a \<sqsubseteq> y \<and> x \<sqsubseteq> b \<and> y \<sqsubseteq> b
                                                        \<longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x)"

definition extdiam :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "extdiam a b c \<equiv> exttan a c \<and> exttan b c
                 \<and> (\<forall>\<degree>x y. x \<asymp> c \<and> y \<asymp> c \<and> a \<sqsubseteq> x \<and> b \<sqsubseteq> y \<longrightarrow> x \<asymp> y)"

definition intdiam :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "intdiam a b c \<equiv> inttan a c \<and> inttan b c
                 \<and> (\<forall>\<degree>x y. x \<asymp> c \<and> y \<asymp> c \<and> exttan a x \<and> exttan b y \<longrightarrow> x \<asymp> y)"

abbreviation properconcentric :: "'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "properconcentric a b \<equiv> a \<sqsubset> b
                        \<and> (\<forall>\<degree>x y. extdiam x y a \<and> inttan x b \<and> inttan y b \<longrightarrow> intdiam x y b)"

definition concentric :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "\<odot>" 100) where
  "a \<odot> b \<equiv> sphere a \<and> sphere b \<and> (a = b \<or> properconcentric a b \<or> properconcentric b a)"

definition onboundary :: "'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "onboundary s r \<equiv> sphere s \<and> (\<forall>s'. s' \<odot> s \<longrightarrow> s' \<frown> r \<and> \<not> s' \<sqsubseteq> r)"

definition equidistant3 :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "equidistant3 x y z \<equiv> \<exists>\<degree>z'. z' \<odot> z \<and> onboundary y z' \<and> onboundary x z'"

definition betw :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" ("[_ _ _]" [100, 100, 100] 100) where
  "[x y z] \<equiv> sphere x \<and> sphere z
             \<and> (x \<odot> y \<or> y \<odot> z
                \<or> (\<exists>x' y' z' v w. x' \<odot> x \<and> y' \<odot> y \<and> z' \<odot> z
                                  \<and> extdiam x' y' v \<and> extdiam v w y' \<and> extdiam y' z' w))"

definition mid :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "mid x y z \<equiv> [x y z] \<and> (\<exists>\<degree>y'. y' \<odot> y \<and> onboundary x y' \<and> onboundary z y')"

definition equidistant4 :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" ("_ _ \<doteq> _ _" [100, 100, 100, 100] 100) where
  "x y \<doteq> z w \<equiv> \<exists>\<degree>u v. mid w u y \<and> mid x u v \<and> equidistant3 v z y"

definition oninterior :: "'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "oninterior s r \<equiv> \<exists>s'. s' \<odot> s \<and> s' \<sqsubseteq> r"

definition nearer :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "nearer w x y z \<equiv> \<exists>\<degree>x'. [w x x'] \<and> \<not> x \<odot> x' \<and> w x' \<doteq> y z"

end

locale partial_region_geometry = mereology_sphere partof sphere
  for partof :: "'region \<Rightarrow> 'region \<Rightarrow> bool" (infix "\<sqsubseteq>" 100)
  and sphere :: "'region \<Rightarrow> bool" +
  assumes A4: "\<lbrakk>x \<odot> y; y \<odot> z\<rbrakk> \<Longrightarrow> x \<odot> z"
      and A5: "\<lbrakk>x y \<doteq> z w; x' \<odot> x\<rbrakk> \<Longrightarrow> x' y \<doteq> z w"
      and A6: "\<lbrakk>sphere x; sphere y; \<not> x \<odot> y\<rbrakk>
               \<Longrightarrow> \<exists>\<degree>s. \<forall>\<degree>z. oninterior z s = nearer x z x y"
      and A7: "sphere x \<Longrightarrow> \<exists>\<degree>y. \<not> x \<odot> y \<and> (\<forall>\<degree>z. oninterior z x = nearer x z x y)"
      and A8: "x \<sqsubseteq> y = (\<forall>s. oninterior s x \<longrightarrow> oninterior s y)"
      and A9: "\<exists>\<degree>s. s \<sqsubseteq> r"
begin

(* 2 marks *)
thm equiv_def
theorem conc_equiv:
  "equiv {z. sphere z} {(x,y). x \<odot> y}"
proof -
  let ?\<alpha> = "{(x,y). x \<odot> y}"
  have 0: "refl_on (Collect sphere) ?\<alpha>"
    using concentric_def parthood_partial_order.antisym sum_all_with_parts_overlapping_self sumregions_def A7 A9 by fastforce
  have 1: "sym ?\<alpha>"
    using concentric_def A7 parthood_partial_order.antisym sum_all_with_parts_overlapping_self sumregions_def 0 A9 by fastforce
  have 2: "trans ?\<alpha>"
    using A7 concentric_def parthood_partial_order.antisym sum_all_with_parts_overlapping_self sumregions_def 0 A9 by fastforce
  thus "equiv {z. sphere z} {(x,y). x \<odot> y}" using equiv_def 0 1 by blast
qed

(* 6 marks *)
theorem region_is_spherical_sum:
  "\<Squnion> {p. p \<sqsubseteq> x \<and> sphere p} x"
proof -
  have 0: "\<exists>y. \<Squnion> {p. p \<sqsubseteq> x \<and> sphere p} y"
    using A7 A9 sumregions_def concentric_def parthood_partial_order.antisym sum_all_with_parts_overlapping_self by auto
  thus "\<Squnion> {p. p \<sqsubseteq> x \<and> sphere p} x" using sumregions_def by auto
qed

(* 1 mark *)
theorem region_spherical_interior:
  "oninterior s r \<Longrightarrow> \<exists>\<degree>s'. s' \<sqsubseteq> r \<and> oninterior s s'"
  using oninterior_def concentric_def by auto

(* 2 marks *)
(* Only A8 is needed for this proof as it defines parthood using region interiors (if every
internal region of x is also a part of y it means that x must be a part of y), we can therefore use
this to prove x = y using region interiors by obtaining x \<sqsubseteq> y and y \<sqsubseteq> x from our assumption *)
theorem equal_interiors_equal_regions:
  assumes "oninterior p x \<longleftrightarrow> oninterior p y"
  shows "x = y"
  using A8 sum_one_is_self sumregions_def by simp

(* 2 marks *)
theorem proper_have_nonoverlapping_proper_sphere:
  assumes "s \<sqsubset> r"
  shows "\<exists>\<degree>p. p \<sqsubset> r \<and> p \<asymp> s"
proof -
  have "s \<sqsubset> r \<Longrightarrow> \<exists>\<degree>p. p \<sqsubseteq> r \<and> p \<asymp> s"
    using parthood_partial_order.leD sum_one_is_self sumregions_def by auto
  thus "\<exists>\<degree>p. p \<sqsubset> r \<and> p \<asymp> s" using properpartof_def sumregions_def assms sum_one_is_self by simp
qed

(* 4 marks *)
theorem not_sphere_spherical_parts_gt1:
  assumes "\<Squnion> {p. p \<sqsubseteq> r \<and> sphere p} r"
      and "\<not> sphere r"
    shows "\<exists>\<degree>a b. a \<noteq> b \<and> a \<sqsubseteq> r \<and> b \<sqsubseteq> r"
proof -
  have 0: "\<Squnion> {x} r \<Longrightarrow> \<not> sphere x"
    using A9 assms(2) parthood_partial_order.antisym sum_parts_eq sumregions_def by blast
  thus "\<exists>\<degree>a b. a \<noteq> b \<and> a \<sqsubseteq> r \<and> b \<sqsubseteq> r" using sum_one_is_self sumregions_def assms(1) by auto
qed

end

section \<open>Part 3\<close>

context mereology_sphere
begin

(* 3 marks *)
lemma
  assumes T4: "\<And>x y. \<lbrakk>sphere x; sphere y\<rbrakk> \<Longrightarrow> x y \<doteq> y x"
      and A9: "\<exists>\<degree>s. s \<sqsubseteq> r"
    shows False
proof -
  have 0: "\<And>x y. \<lbrakk>sphere x; sphere y\<rbrakk> \<Longrightarrow> x y \<doteq> y x \<Longrightarrow> False"
    using equidistant3_def equidistant4_def onboundary_def by auto
  moreover
  have 1: "\<exists>\<degree>s. s \<sqsubseteq> r \<Longrightarrow> False" using T4 calculation by blast
  ultimately show "False" using A9 by blast
qed

(* 3 marks *)
(* The issue was that the geometry definitions treated these arguments as regions and not spheres.
I fixed it by adding sphere conditions using conjunctions to the definition. *)
definition equidistant3' :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" where
  "equidistant3' x y z \<equiv> \<exists>\<degree>z'. z' \<odot> z \<and> onboundary y z' \<and> onboundary x z' \<and> sphere x \<and> sphere y \<and> sphere z"

no_notation equidistant4 ("_ _ \<doteq> _ _" [100, 100, 100, 100] 100)

definition equidistant4' :: "'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> 'region \<Rightarrow> bool" ("_ _ \<doteq> _ _" [100, 100, 100, 100] 100) where
  "x y \<doteq> z w \<equiv> \<exists>\<degree>u v. mid w u y \<and> mid x u v \<and> equidistant3' v z y"

end

datatype two_reg = Left | Right | Both

(* 2 marks *)
definition tworeg_partof :: "two_reg \<Rightarrow> two_reg \<Rightarrow> bool" (infix "\<sqsubseteq>" 100) where
  "x \<sqsubseteq> y \<equiv> x = y \<or> y = Both"

abbreviation sumregions_abbrev :: "two_reg set \<Rightarrow> two_reg \<Rightarrow> bool" ("\<Squnion> _ _") where
"\<Squnion> \<alpha> x \<equiv> partof.sumregions (\<sqsubseteq>) \<alpha> x"

abbreviation overlaps_abbrev :: "two_reg \<Rightarrow> two_reg \<Rightarrow> bool" ("_ \<frown>  _") where
"x \<frown> y \<equiv> partof.overlaps (\<sqsubseteq>) x y"

(* 12 marks *)
interpretation mereology "(\<sqsubseteq>)"
proof
  show "\<forall>x y z. x \<sqsubseteq> y \<and> y \<sqsubseteq> z \<longrightarrow> x \<sqsubseteq> z"
  proof -
    have 0: "x \<sqsubseteq> y \<and> y \<sqsubseteq> x \<longrightarrow> x \<sqsubseteq> x" using two_reg.exhaust tworeg_partof_def by auto
    thus "\<forall>x y z. x \<sqsubseteq> y \<and> y \<sqsubseteq> z \<longrightarrow> x \<sqsubseteq> z" using impI tworeg_partof_def by auto
  qed
next
  show "\<forall>\<alpha>. \<alpha> \<noteq> {} \<longrightarrow> (\<exists>x. \<Squnion> \<alpha> x)"
  proof -
    have 1: "\<alpha> \<noteq> {} \<Longrightarrow> \<exists>y x. y \<in> \<alpha> \<and> y \<sqsubseteq> x"
      using tworeg_partof_def by auto
    have 2: "\<alpha> \<noteq> {} \<Longrightarrow> \<exists>y x z. y \<in> \<alpha> \<and> y \<sqsubseteq> x \<and> z \<in> \<alpha> \<and> y \<frown> z"
      using tworeg_partof_def partof.overlaps_def by (metis 1)
    thus "\<forall>\<alpha>. \<alpha> \<noteq> {} \<longrightarrow> (\<exists>x. \<Squnion> \<alpha> x)" by sorry
  qed
next
  show "\<forall>\<alpha> x y. \<Squnion> \<alpha> x \<and> \<Squnion> \<alpha> y \<longrightarrow> x = y"
    by (metis (full_types) partof.sumregions_def tworeg_partof_def)
qed

end