(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_39
imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

fun count :: "Nat => Nat list => Nat" where
"count y (nil2) = Z"
| "count y (cons2 z2 ys) =
     (if x y z2 then S (count y ys) else count y ys)"

fun t2 :: "Nat => Nat => Nat" where
"t2 (Z) z = z"
| "t2 (S z2) z = S (t2 z2 z)"

theorem property0 :
  "((t2 (count n (cons2 y (nil2))) (count n xs)) =
      (count n (cons2 y xs)))"
  oops

end


theory SDL imports Main                   (* Christoph Benzmüller & Xavier Parent, 2018 *)

begin  (* SDL: Standard Deontic Logic (Modal Logic D) *)
 typedecl i (*type for possible worlds*)  type_synonym \<sigma> = "(i\<Rightarrow>bool)"
 consts r::"i\<Rightarrow>i\<Rightarrow>bool" (infixr"r"70) (*Accessibility relation.*)  cw::i (*Current world.*)

 abbreviation mtop ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
 abbreviation mbot ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
 abbreviation mnot ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
 abbreviation mand (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
 abbreviation mor  (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
 abbreviation mimp (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
 abbreviation mequ (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"
 abbreviation mobligatory ("OB") where "OB \<phi> \<equiv> \<lambda>w. \<forall>v.  w r v \<longrightarrow> \<phi>(v)" (*obligatory*)
 abbreviation mpermissible ("PE") where "PE \<phi> \<equiv> \<^bold>\<not>(OB(\<^bold>\<not>\<phi>))" (*permissible*)
 abbreviation mimpermissible ("IM") where "IM \<phi> \<equiv> OB(\<^bold>\<not>\<phi>)"  (*impermissible*)
 abbreviation omissible ("OM") where "OM \<phi> \<equiv> \<^bold>\<not>(OB \<phi>)" (*omissible*)
 abbreviation moptional ("OP") where "OP \<phi> \<equiv> (\<^bold>\<not>(OB \<phi>) \<^bold>\<and>  \<^bold>\<not>(OB(\<^bold>\<not>\<phi>)))" (*optional*)

 abbreviation ddlvalid::"\<sigma> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>"[7]105)      (*Global Validity*)
  where "\<lfloor>A\<rfloor> \<equiv> \<forall>w. A w"
 abbreviation ddlvalidcw::"\<sigma> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>\<^sub>c\<^sub>w"[7]105)  (*Local Validity (in cw)*)
  where "\<lfloor>A\<rfloor>\<^sub>c\<^sub>w \<equiv> A cw"

(* The D axiom is postulated *)
 axiomatization where D: "\<lfloor>\<^bold>\<not> ((OB \<phi>) \<^bold>\<and> (OB (\<^bold>\<not> \<phi>)))\<rfloor>"

(* Meta-level study: D corresponds to seriality *)
 lemma "\<lfloor>\<^bold>\<not> ((OB \<phi>) \<^bold>\<and> (OB (\<^bold>\<not> \<phi>)))\<rfloor> \<longleftrightarrow> (\<forall>w. \<exists>v. w r v)" by auto

(* Standardised syntax: unary operator for obligation in SDL *)
 abbreviation obligatorySDL::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>O\<^bold>\<langle>_\<^bold>\<rangle>") where "\<^bold>O\<^bold>\<langle>A\<^bold>\<rangle>  \<equiv>  OB A"

(* Consistency *)
  lemma True nitpick [satisfy] oops

 (* Unimportant *)
  sledgehammer_params [max_facts=20,timeout=20] (* Sets parameters for theorem provers *)
  nitpick_params [user_axioms,expect=genuine,show_all,format=2] (* ... and model finder. *)

end


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

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

fun map :: "('a => 'b) => 'a list => 'b list" where
  "map f (nil2) = nil2"
| "map f (cons2 y xs) = cons2 (f y) (map f xs)"

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

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

(*fun did not finish the proof*)
function mergingbu :: "(int list) list => int list" where
  "mergingbu (nil2) = nil2"
| "mergingbu (cons2 xs (nil2)) = xs"
| "mergingbu (cons2 xs (cons2 z x2)) =
     mergingbu (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu :: "int list => int list" where
  "msortbu x = mergingbu (map (% (y :: int) => cons2 y (nil2)) x)"

fun insert :: "int => int list => int list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if x <= z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "int list => int list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

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

end


(*  Title:      HOL/Proofs/Lambda/Commutation.thy
    Author:     Tobias Nipkow
    Copyright   1995  TU Muenchen
*)

section \<open>Abstract commutation and confluence notions\<close>

theory Commutation
imports MainRLT
begin

declare [[syntax_ambiguity_warning = false]]

subsection \<open>Basic definitions\<close>

definition
  square :: "['a => 'a => bool, 'a => 'a => bool, 'a => 'a => bool, 'a => 'a => bool] => bool" where
  "square R S T U =
    (\<forall>x y. R x y --> (\<forall>z. S x z --> (\<exists>u. T y u \<and> U z u)))"

definition
  commute :: "['a => 'a => bool, 'a => 'a => bool] => bool" where
  "commute R S = square R S S R"

definition
  diamond :: "('a => 'a => bool) => bool" where
  "diamond R = commute R R"

definition
  Church_Rosser :: "('a => 'a => bool) => bool" where
  "Church_Rosser R =
    (\<forall>x y. (sup R (R\<inverse>\<inverse>))\<^sup>*\<^sup>* x y \<longrightarrow> (\<exists>z. R\<^sup>*\<^sup>* x z \<and> R\<^sup>*\<^sup>* y z))"

abbreviation
  confluent :: "('a => 'a => bool) => bool" where
  "confluent R == diamond (R\<^sup>*\<^sup>*)"

subsection \<open>Basic lemmas\<close>

subsubsection \<open>\<open>square\<close>\<close>

lemma square_sym: "square R S T U ==> square S R U T"
  apply (unfold square_def)
  apply blast
  done

lemma square_subset:
    "[| square R S T U; T \<le> T' |] ==> square R S T' U"
  apply (unfold square_def)
  apply (blast dest: predicate2D)
  done

lemma square_reflcl:
    "[| square R S T (R\<^sup>=\<^sup>=); S \<le> T |] ==> square (R\<^sup>=\<^sup>=) S T (R\<^sup>=\<^sup>=)"
  apply (unfold square_def)
  apply (blast dest: predicate2D)
  done

lemma square_rtrancl:
    "square R S S T ==> square (R\<^sup>*\<^sup>*) S S (T\<^sup>*\<^sup>*)"
  apply (unfold square_def)
  apply (intro strip)
  apply (erule rtranclp_induct)
   apply blast
  apply (blast intro: rtranclp.rtrancl_into_rtrancl)
  done

lemma square_rtrancl_reflcl_commute:
    "square R S (S\<^sup>*\<^sup>*) (R\<^sup>=\<^sup>=) ==> commute (R\<^sup>*\<^sup>*) (S\<^sup>*\<^sup>*)"
  apply (unfold commute_def)
  apply (fastforce dest: square_reflcl square_sym [THEN square_rtrancl])
  done

subsubsection \<open>\<open>commute\<close>\<close>

lemma commute_sym: "commute R S ==> commute S R"
  apply (unfold commute_def)
  apply (blast intro: square_sym)
  done

lemma commute_rtrancl: "commute R S ==> commute (R\<^sup>*\<^sup>*) (S\<^sup>*\<^sup>*)"
  apply (unfold commute_def)
  apply (blast intro: square_rtrancl square_sym)
  done

lemma commute_Un:
    "[| commute R T; commute S T |] ==> commute (sup R S) T"
  apply (unfold commute_def square_def)
  apply blast
  done

subsubsection \<open>\<open>diamond\<close>, \<open>confluence\<close>, and \<open>union\<close>\<close>

lemma diamond_Un:
    "[| diamond R; diamond S; commute R S |] ==> diamond (sup R S)"
  apply (unfold diamond_def)
  apply (blast intro: commute_Un commute_sym)
  done

lemma diamond_confluent: "diamond R ==> confluent R"
  apply (unfold diamond_def)
  apply (erule commute_rtrancl)
  done

lemma square_reflcl_confluent:
    "square R R (R\<^sup>=\<^sup>=) (R\<^sup>=\<^sup>=) ==> confluent R"
  apply (unfold diamond_def)
  apply (fast intro: square_rtrancl_reflcl_commute elim: square_subset)
  done

lemma confluent_Un:
    "[| confluent R; confluent S; commute (R\<^sup>*\<^sup>*) (S\<^sup>*\<^sup>*) |] ==> confluent (sup R S)"
  apply (rule rtranclp_sup_rtranclp [THEN subst])
  apply (blast dest: diamond_Un intro: diamond_confluent)
  done

lemma diamond_to_confluence:
    "[| diamond R; T \<le> R; R \<le> T\<^sup>*\<^sup>* |] ==> confluent T"
  apply (force intro: diamond_confluent
    dest: rtranclp_subset [symmetric])
  done

subsection \<open>Church-Rosser\<close>

lemma Church_Rosser_confluent: "Church_Rosser R = confluent R"
  apply (unfold square_def commute_def diamond_def Church_Rosser_def)
  apply (tactic \<open>safe_tac (put_claset HOL_cs \<^context>)\<close>)
   apply (tactic \<open>
     blast_tac (put_claset HOL_cs \<^context> addIs
       [@{thm sup_ge2} RS @{thm rtranclp_mono} RS @{thm predicate2D} RS @{thm rtranclp_trans},
        @{thm rtranclp_converseI}, @{thm conversepI},
        @{thm sup_ge1} RS @{thm rtranclp_mono} RS @{thm predicate2D}]) 1\<close>)
  apply (erule rtranclp_induct)
   apply blast
  apply (blast del: rtranclp.rtrancl_refl intro: rtranclp_trans)
  done

subsection \<open>Newman's lemma\<close>

text \<open>Proof by Stefan Berghofer\<close>

theorem newman:
  assumes wf: "wfP (R\<inverse>\<inverse>)"
  and lc: "\<And>a b c. R a b \<Longrightarrow> R a c \<Longrightarrow>
    \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d"
  shows "\<And>b c. R\<^sup>*\<^sup>* a b \<Longrightarrow> R\<^sup>*\<^sup>* a c \<Longrightarrow>
    \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d"
  using wf
proof induct
  case (less x b c)
  have xc: "R\<^sup>*\<^sup>* x c" by fact
  have xb: "R\<^sup>*\<^sup>* x b" by fact thus ?case
  proof (rule converse_rtranclpE)
    assume "x = b"
    with xc have "R\<^sup>*\<^sup>* b c" by simp
    thus ?thesis by iprover
  next
    fix y
    assume xy: "R x y"
    assume yb: "R\<^sup>*\<^sup>* y b"
    from xc show ?thesis
    proof (rule converse_rtranclpE)
      assume "x = c"
      with xb have "R\<^sup>*\<^sup>* c b" by simp
      thus ?thesis by iprover
    next
      fix y'
      assume y'c: "R\<^sup>*\<^sup>* y' c"
      assume xy': "R x y'"
      with xy have "\<exists>u. R\<^sup>*\<^sup>* y u \<and> R\<^sup>*\<^sup>* y' u" by (rule lc)
      then obtain u where yu: "R\<^sup>*\<^sup>* y u" and y'u: "R\<^sup>*\<^sup>* y' u" by iprover
      from xy have "R\<inverse>\<inverse> y x" ..
      from this and yb yu have "\<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* u d" by (rule less)
      then obtain v where bv: "R\<^sup>*\<^sup>* b v" and uv: "R\<^sup>*\<^sup>* u v" by iprover
      from xy' have "R\<inverse>\<inverse> y' x" ..
      moreover from y'u and uv have "R\<^sup>*\<^sup>* y' v" by (rule rtranclp_trans)
      moreover note y'c
      ultimately have "\<exists>d. R\<^sup>*\<^sup>* v d \<and> R\<^sup>*\<^sup>* c d" by (rule less)
      then obtain w where vw: "R\<^sup>*\<^sup>* v w" and cw: "R\<^sup>*\<^sup>* c w" by iprover
      from bv vw have "R\<^sup>*\<^sup>* b w" by (rule rtranclp_trans)
      with cw show ?thesis by iprover
    qed
  qed
qed

text \<open>
  Alternative version.  Partly automated by Tobias
  Nipkow. Takes 2 minutes (2002).

  This is the maximal amount of automation possible using \<open>blast\<close>.
\<close>

theorem newman':
  assumes wf: "wfP (R\<inverse>\<inverse>)"
  and lc: "\<And>a b c. R a b \<Longrightarrow> R a c \<Longrightarrow>
    \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d"
  shows "\<And>b c. R\<^sup>*\<^sup>* a b \<Longrightarrow> R\<^sup>*\<^sup>* a c \<Longrightarrow>
    \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d"
  using wf
proof induct
  case (less x b c)
  note IH = \<open>\<And>y b c. \<lbrakk>R\<inverse>\<inverse> y x; R\<^sup>*\<^sup>* y b; R\<^sup>*\<^sup>* y c\<rbrakk>
                     \<Longrightarrow> \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d\<close>
  have xc: "R\<^sup>*\<^sup>* x c" by fact
  have xb: "R\<^sup>*\<^sup>* x b" by fact
  thus ?case
  proof (rule converse_rtranclpE)
    assume "x = b"
    with xc have "R\<^sup>*\<^sup>* b c" by simp
    thus ?thesis by iprover
  next
    fix y
    assume xy: "R x y"
    assume yb: "R\<^sup>*\<^sup>* y b"
    from xc show ?thesis
    proof (rule converse_rtranclpE)
      assume "x = c"
      with xb have "R\<^sup>*\<^sup>* c b" by simp
      thus ?thesis by iprover
    next
      fix y'
      assume y'c: "R\<^sup>*\<^sup>* y' c"
      assume xy': "R x y'"
      with xy obtain u where u: "R\<^sup>*\<^sup>* y u" "R\<^sup>*\<^sup>* y' u"
        by (blast dest: lc)
      from yb u y'c show ?thesis
        by (blast del: rtranclp.rtrancl_refl
            intro: rtranclp_trans
            dest: IH [OF conversepI, OF xy] IH [OF conversepI, OF xy'])
    qed
  qed
qed

text \<open>
  Using the coherent logic prover, the proof of the induction step
  is completely automatic.
\<close>

lemma eq_imp_rtranclp: "x = y \<Longrightarrow> r\<^sup>*\<^sup>* x y"
  by simp

theorem newman'':
  assumes wf: "wfP (R\<inverse>\<inverse>)"
  and lc: "\<And>a b c. R a b \<Longrightarrow> R a c \<Longrightarrow>
    \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d"
  shows "\<And>b c. R\<^sup>*\<^sup>* a b \<Longrightarrow> R\<^sup>*\<^sup>* a c \<Longrightarrow>
    \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d"
  using wf
proof induct
  case (less x b c)
  note IH = \<open>\<And>y b c. \<lbrakk>R\<inverse>\<inverse> y x; R\<^sup>*\<^sup>* y b; R\<^sup>*\<^sup>* y c\<rbrakk>
                     \<Longrightarrow> \<exists>d. R\<^sup>*\<^sup>* b d \<and> R\<^sup>*\<^sup>* c d\<close>
  show ?case
    by (coherent
      \<open>R\<^sup>*\<^sup>* x c\<close> \<open>R\<^sup>*\<^sup>* x b\<close>
      refl [where 'a='a] sym
      eq_imp_rtranclp
      r_into_rtranclp [of R]
      rtranclp_trans
      lc IH [OF conversepI]
      converse_rtranclpE)
qed

end


(*  Title:      HOL/Sum_Type.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section \<open>The Disjoint Sum of Two Types\<close>

theory Sum_Type
  imports Typedef Inductive Fun
begin

subsection \<open>Construction of the sum type and its basic abstract operations\<close>

definition Inl_Rep :: "'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool \<Rightarrow> bool"
  where "Inl_Rep a x y p \<longleftrightarrow> x = a \<and> p"

definition Inr_Rep :: "'b \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool \<Rightarrow> bool"
  where "Inr_Rep b x y p \<longleftrightarrow> y = b \<and> \<not> p"

definition "sum = {f. (\<exists>a. f = Inl_Rep (a::'a)) \<or> (\<exists>b. f = Inr_Rep (b::'b))}"

typedef ('a, 'b) sum (infixr "+" 10) = "sum :: ('a \<Rightarrow> 'b \<Rightarrow> bool \<Rightarrow> bool) set"
  unfolding sum_def by auto

lemma Inl_RepI: "Inl_Rep a \<in> sum"
  by (auto simp add: sum_def)

lemma Inr_RepI: "Inr_Rep b \<in> sum"
  by (auto simp add: sum_def)

lemma inj_on_Abs_sum: "A \<subseteq> sum \<Longrightarrow> inj_on Abs_sum A"
  by (rule inj_on_inverseI, rule Abs_sum_inverse) auto

lemma Inl_Rep_inject: "inj_on Inl_Rep A"
proof (rule inj_onI)
  show "\<And>a c. Inl_Rep a = Inl_Rep c \<Longrightarrow> a = c"
    by (auto simp add: Inl_Rep_def fun_eq_iff)
qed

lemma Inr_Rep_inject: "inj_on Inr_Rep A"
proof (rule inj_onI)
  show "\<And>b d. Inr_Rep b = Inr_Rep d \<Longrightarrow> b = d"
    by (auto simp add: Inr_Rep_def fun_eq_iff)
qed

lemma Inl_Rep_not_Inr_Rep: "Inl_Rep a \<noteq> Inr_Rep b"
  by (auto simp add: Inl_Rep_def Inr_Rep_def fun_eq_iff)

definition Inl :: "'a \<Rightarrow> 'a + 'b"
  where "Inl = Abs_sum \<circ> Inl_Rep"

definition Inr :: "'b \<Rightarrow> 'a + 'b"
  where "Inr = Abs_sum \<circ> Inr_Rep"

lemma inj_Inl [simp]: "inj_on Inl A"
  by (auto simp add: Inl_def intro!: comp_inj_on Inl_Rep_inject inj_on_Abs_sum Inl_RepI)

lemma Inl_inject: "Inl x = Inl y \<Longrightarrow> x = y"
  using inj_Inl by (rule injD)

lemma inj_Inr [simp]: "inj_on Inr A"
  by (auto simp add: Inr_def intro!: comp_inj_on Inr_Rep_inject inj_on_Abs_sum Inr_RepI)

lemma Inr_inject: "Inr x = Inr y \<Longrightarrow> x = y"
  using inj_Inr by (rule injD)

lemma Inl_not_Inr: "Inl a \<noteq> Inr b"
proof -
  have "{Inl_Rep a, Inr_Rep b} \<subseteq> sum"
    using Inl_RepI [of a] Inr_RepI [of b] by auto
  with inj_on_Abs_sum have "inj_on Abs_sum {Inl_Rep a, Inr_Rep b}" .
  with Inl_Rep_not_Inr_Rep [of a b] inj_on_contraD have "Abs_sum (Inl_Rep a) \<noteq> Abs_sum (Inr_Rep b)"
    by auto
  then show ?thesis
    by (simp add: Inl_def Inr_def)
qed

lemma Inr_not_Inl: "Inr b \<noteq> Inl a"
  using Inl_not_Inr by (rule not_sym)

lemma sumE:
  assumes "\<And>x::'a. s = Inl x \<Longrightarrow> P"
    and "\<And>y::'b. s = Inr y \<Longrightarrow> P"
  shows P
proof (rule Abs_sum_cases [of s])
  fix f
  assume "s = Abs_sum f" and "f \<in> sum"
  with assms show P
    by (auto simp add: sum_def Inl_def Inr_def)
qed

free_constructors case_sum for
  isl: Inl projl
| Inr projr
  by (erule sumE, assumption) (auto dest: Inl_inject Inr_inject simp add: Inl_not_Inr)

text \<open>Avoid name clashes by prefixing the output of \<open>old_rep_datatype\<close> with \<open>old\<close>.\<close>

setup \<open>Sign.mandatory_path "old"\<close>

old_rep_datatype Inl Inr
proof -
  fix P
  fix s :: "'a + 'b"
  assume x: "\<And>x::'a. P (Inl x)" and y: "\<And>y::'b. P (Inr y)"
  then show "P s" by (auto intro: sumE [of s])
qed (auto dest: Inl_inject Inr_inject simp add: Inl_not_Inr)

setup \<open>Sign.parent_path\<close>

text \<open>But erase the prefix for properties that are not generated by \<open>free_constructors\<close>.\<close>

setup \<open>Sign.mandatory_path "sum"\<close>

declare
  old.sum.inject[iff del]
  old.sum.distinct(1)[simp del, induct_simp del]

lemmas induct = old.sum.induct
lemmas inducts = old.sum.inducts
lemmas rec = old.sum.rec
lemmas simps = sum.inject sum.distinct sum.case sum.rec

setup \<open>Sign.parent_path\<close>

primrec map_sum :: "('a \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> 'a + 'b \<Rightarrow> 'c + 'd"
  where
    "map_sum f1 f2 (Inl a) = Inl (f1 a)"
  | "map_sum f1 f2 (Inr a) = Inr (f2 a)"

functor map_sum: map_sum
proof -
  show "map_sum f g \<circ> map_sum h i = map_sum (f \<circ> h) (g \<circ> i)" for f g h i
  proof
    show "(map_sum f g \<circ> map_sum h i) s = map_sum (f \<circ> h) (g \<circ> i) s" for s
      by (cases s) simp_all
  qed
  show "map_sum id id = id"
  proof
    show "map_sum id id s = id s" for s
      by (cases s) simp_all
  qed
qed

lemma split_sum_all: "(\<forall>x. P x) \<longleftrightarrow> (\<forall>x. P (Inl x)) \<and> (\<forall>x. P (Inr x))"
  by (auto intro: sum.induct)

lemma split_sum_ex: "(\<exists>x. P x) \<longleftrightarrow> (\<exists>x. P (Inl x)) \<or> (\<exists>x. P (Inr x))"
  using split_sum_all[of "\<lambda>x. \<not>P x"] by blast

subsection \<open>Projections\<close>

lemma case_sum_KK [simp]: "case_sum (\<lambda>x. a) (\<lambda>x. a) = (\<lambda>x. a)"
  by (rule ext) (simp split: sum.split)

lemma surjective_sum: "case_sum (\<lambda>x::'a. f (Inl x)) (\<lambda>y::'b. f (Inr y)) = f"
proof
  fix s :: "'a + 'b"
  show "(case s of Inl (x::'a) \<Rightarrow> f (Inl x) | Inr (y::'b) \<Rightarrow> f (Inr y)) = f s"
    by (cases s) simp_all
qed

lemma case_sum_inject:
  assumes a: "case_sum f1 f2 = case_sum g1 g2"
    and r: "f1 = g1 \<Longrightarrow> f2 = g2 \<Longrightarrow> P"
  shows P
proof (rule r)
  show "f1 = g1"
  proof
    fix x :: 'a
    from a have "case_sum f1 f2 (Inl x) = case_sum g1 g2 (Inl x)" by simp
    then show "f1 x = g1 x" by simp
  qed
  show "f2 = g2"
  proof
    fix y :: 'b
    from a have "case_sum f1 f2 (Inr y) = case_sum g1 g2 (Inr y)" by simp
    then show "f2 y = g2 y" by simp
  qed
qed

primrec Suml :: "('a \<Rightarrow> 'c) \<Rightarrow> 'a + 'b \<Rightarrow> 'c"
  where "Suml f (Inl x) = f x"

primrec Sumr :: "('b \<Rightarrow> 'c) \<Rightarrow> 'a + 'b \<Rightarrow> 'c"
  where "Sumr f (Inr x) = f x"

lemma Suml_inject:
  assumes "Suml f = Suml g"
  shows "f = g"
proof
  fix x :: 'a
  let ?s = "Inl x :: 'a + 'b"
  from assms have "Suml f ?s = Suml g ?s" by simp
  then show "f x = g x" by simp
qed

lemma Sumr_inject:
  assumes "Sumr f = Sumr g"
  shows "f = g"
proof
  fix x :: 'b
  let ?s = "Inr x :: 'a + 'b"
  from assms have "Sumr f ?s = Sumr g ?s" by simp
  then show "f x = g x" by simp
qed

subsection \<open>The Disjoint Sum of Sets\<close>

definition Plus :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a + 'b) set"  (infixr "<+>" 65)
  where "A <+> B = Inl ` A \<union> Inr ` B"

hide_const (open) Plus \<comment> \<open>Valuable identifier\<close>

lemma InlI [intro!]: "a \<in> A \<Longrightarrow> Inl a \<in> A <+> B"
  by (simp add: Plus_def)

lemma InrI [intro!]: "b \<in> B \<Longrightarrow> Inr b \<in> A <+> B"
  by (simp add: Plus_def)

text \<open>Exhaustion rule for sums, a degenerate form of induction\<close>

lemma PlusE [elim!]:
  "u \<in> A <+> B \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> u = Inl x \<Longrightarrow> P) \<Longrightarrow> (\<And>y. y \<in> B \<Longrightarrow> u = Inr y \<Longrightarrow> P) \<Longrightarrow> P"
  by (auto simp add: Plus_def)

lemma Plus_eq_empty_conv [simp]: "A <+> B = {} \<longleftrightarrow> A = {} \<and> B = {}"
  by auto

lemma UNIV_Plus_UNIV [simp]: "UNIV <+> UNIV = UNIV"
proof (rule set_eqI)
  fix u :: "'a + 'b"
  show "u \<in> UNIV <+> UNIV \<longleftrightarrow> u \<in> UNIV" by (cases u) auto
qed

lemma UNIV_sum: "UNIV = Inl ` UNIV \<union> Inr ` UNIV"
proof -
  have "x \<in> range Inl" if "x \<notin> range Inr" for x :: "'a + 'b"
    using that by (cases x) simp_all
  then show ?thesis by auto
qed

hide_const (open) Suml Sumr sum

end


(* Title:      Residuated Relation Algebras
   Author:     Victor Gomes <vborgesferreiragomes1 at sheffield.ac.uk>
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Residuated Relation Algebras\<close>

theory Residuated_Relation_Algebra
  imports Residuated_Boolean_Algebras Relation_Algebra.Relation_Algebra
begin

context boolean_algebra begin

text \<open>
  The notation used in the relation algebra AFP entry differs a little from ours.
\<close>

notation
  times (infixl "\<cdot>" 70)
  and plus (infixl "+" 65)
  and Groups.zero_class.zero ("0")
  and Groups.one_class.one ("1")

no_notation
  inf (infixl "\<cdot>" 70)
  and sup (infixl "+" 65)
  and bot ("0")
  and top ("1")

end

text \<open>
  We prove that a unital residuated boolean algebra enriched with two simple
  equalities form a non-associative relation algebra, that is, a relation
  algebra where the associativity law does not hold.
\<close>

class nra = unital_residuated_boolean +
  assumes conv1: "x \<rhd> y = (x \<rhd> 1)\<cdot>y"
  and conv2: "x \<lhd> y = x\<cdot>(1 \<lhd> y)"
begin

text \<open>
  When the converse operation is set to be $\lambda x.\  x \rhd 1$,
  a unital residuated boolean algebra forms a non associative relation algebra.
\<close>

lemma conv_invol: "x \<rhd> 1 \<rhd> 1 = x"
  by (metis local.conv1 local.jonsson1b local.mult_onel)

lemma conv_add: "x \<squnion> y \<rhd> 1 = (x \<rhd> 1) \<squnion> (y \<rhd> 1)"
  by (metis local.conjr2_sup)

lemma conv_contrav: "x\<cdot>y \<rhd> 1 = (y \<rhd> 1)\<cdot>(x \<rhd> 1)"
  by (metis local.conv1 local.conv2 local.jonsson1b local.jonsson2c)

lemma conv_res: "(x \<rhd> 1)\<cdot>- (x\<cdot>y) \<le> - y"
  by (metis local.comp_anti local.conjugate_r_def local.conv1 local.double_compl local.res_rc1)

text \<open>
  Similarly, for $x^\smile = 1 \lhd x$, since $x \rhd 1 = 1 \lhd x$ when
  $x \rhd 1 \rhd 1 = x$ holds.
\<close>

lemma conv_invol': "1 \<lhd> (1 \<lhd> x) = x"
  by (metis local.conv_invol local.jonsson3c)

lemma conv_add': "1 \<lhd> (x \<squnion> y) = (1 \<lhd> x) \<squnion> (1 \<lhd> y)"
  by (metis local.conjl1_sup)

lemma conv_contrav': "1 \<lhd> x\<cdot>y = (1 \<lhd> y)\<cdot>(1 \<lhd> x)"
  by (metis local.conv_contrav local.conv_invol local.jonsson3c)

lemma conv_res': "(1 \<lhd> x)\<cdot>- (x\<cdot>y) \<le> - y"
  by (metis conv_res local.conv_invol local.jonsson3c)

end (* nra *)

text \<open>
  Since the previous axioms are equivalent when multiplication is associative
  in a residuated boolean monoid, one of them are sufficient to
  derive a relation algebra.
\<close>

class residuated_ra = residuated_boolean_monoid +
  assumes conv: "x \<rhd> y = (x \<rhd> 1)\<cdot>y"
begin

subclass nra
proof (standard, fact conv)
  fix x y show "x \<lhd> y = x\<cdot>(1 \<lhd> y)"
    by (metis conv jonsson4)
qed

sublocale relation_algebra where
  composition = "(\<cdot>)" and unit = 1 and
  converse = "\<lambda>x. x \<rhd> 1"
proof
  fix x y z
  show "x\<cdot>y\<cdot>z = x\<cdot>(y\<cdot>z)"
    by (metis local.mult_assoc)
  show "x\<cdot>1 = x"
    by (metis local.mult_onel)
  show "(x \<squnion> y)\<cdot>z = x\<cdot>z \<squnion> y\<cdot>z"
    by (metis local.distr)
  show "x \<rhd> 1 \<rhd> 1 = x"
    by (metis local.conv_invol)
  show "x \<squnion> y \<rhd> 1 = (x \<rhd> 1) \<squnion> (y \<rhd> 1)"
    by (metis local.conv_add)
  show "x\<cdot>y \<rhd> 1 = (y \<rhd> 1)\<cdot>(x \<rhd> 1)"
    by (metis local.conv_contrav)
  show "(x \<rhd> 1)\<cdot>- (x\<cdot>y) \<le> - y"
    by (metis local.conv_res)
qed

end (* residuated_ra *)

end


(* Title:      Strict Recursion
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Strict Recursion\<close>

theory Recursion_Strict

imports N_Semirings Approximation

begin

class semiring_apx = n_semiring + apx +
  assumes apx_def: "x \<sqsubseteq> y \<longleftrightarrow> x \<le> y \<squnion> n(x) * L \<and> y \<le> x \<squnion> n(x) * top"
begin

lemma apx_n_order_reverse:
  "y \<sqsubseteq> x \<Longrightarrow> n(x) \<le> n(y)"
  by (metis apx_def le_iff_sup n_sup_left_absorb_mult n_dist_sup n_export)

lemma apx_n_order:
  "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> n(x) = n(y)"
  by (simp add: apx_n_order_reverse order.antisym)

lemma apx_transitive:
  assumes "x \<sqsubseteq> y"
      and "y \<sqsubseteq> z"
    shows "x \<sqsubseteq> z"
proof -
  have "n(y) * L \<le> n(x) * L"
    by (simp add: apx_n_order_reverse assms(1) mult_left_isotone)
  hence 1: "x \<le> z \<squnion> n(x) * L"
    by (smt assms sup_assoc sup_right_divisibility apx_def le_iff_sup)
  have "z \<le> x \<squnion> n(x) * top \<squnion> n(x \<squnion> n(x) * top) * top"
    by (smt (verit) assms sup_left_isotone order_refl sup_assoc sup_mono apx_def mult_left_isotone n_isotone order_trans)
  also have "... = x \<squnion> n(x) * top"
    by (simp add: n_dist_sup n_export n_sup_left_absorb_mult)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

text \<open>Theorem 16.1\<close>

subclass apx_biorder
  apply unfold_locales
  apply (simp add: apx_def)
  apply (smt (verit) order.antisym le_sup_iff apx_def eq_refl le_iff_sup n_galois apx_n_order)
  using apx_transitive by blast

lemma sup_apx_left_isotone:
  assumes "x \<sqsubseteq> y"
    shows "x \<squnion> z \<sqsubseteq> y \<squnion> z"
proof -
  have "x \<le> y \<squnion> n(x) * L \<and> y \<le> x \<squnion> n(x) * top"
    using assms apx_def by auto
  hence "z \<squnion> x \<le> z \<squnion> y \<squnion> n(z \<squnion> x) * L \<and> z \<squnion> y \<le> z \<squnion> x \<squnion> n(z \<squnion> x) * top"
    by (metis sup_assoc sup_right_isotone mult_right_sub_dist_sup_right n_dist_sup order_trans)
  thus ?thesis
    by (simp add: apx_def sup_commute)
qed

lemma mult_apx_left_isotone:
  assumes "x \<sqsubseteq> y"
    shows "x * z \<sqsubseteq> y * z"
proof -
  have "x \<le> y \<squnion> n(x) * L"
    using assms apx_def by auto
  hence "x * z \<le> y * z \<squnion> n(x) * L"
    by (smt (verit, ccfv_threshold) L_left_zero mult_left_isotone semiring.distrib_right mult_assoc)
  hence 1: "x * z \<le> y * z \<squnion> n(x * z) * L"
    by (meson mult_left_isotone n_mult_left_upper_bound order_lesseq_imp sup_mono)
  have "y * z \<le> x * z \<squnion> n(x) * top * z"
    by (metis assms apx_def mult_left_isotone mult_right_dist_sup)
  hence "y * z \<le> x * z \<squnion> n(x * z) * top"
    using mult_isotone n_mult_left_upper_bound order.trans sup_right_isotone top_greatest mult_assoc by presburger
  thus ?thesis
    using 1 by (simp add: apx_def)
qed

lemma mult_apx_right_isotone:
  assumes "x \<sqsubseteq> y"
    shows "z * x \<sqsubseteq> z * y"
proof -
  have "x \<le> y \<squnion> n(x) * L"
    using assms apx_def by auto
  hence 1: "z * x \<le> z * y \<squnion> n(z * x) * L"
    by (smt sup_assoc sup_ge1 sup_bot_right mult_assoc mult_left_dist_sup mult_right_isotone n_L_split)
  have "y \<le> x \<squnion> n(x) * top"
    using assms apx_def by auto
  hence "z * y \<le> z * x \<squnion> z * n(x) * top"
    by (smt mult_assoc mult_left_dist_sup mult_right_isotone)
  also have "... \<le> z * x \<squnion> n(z * x) * top"
    by (smt (verit) sup_assoc le_supI le_sup_iff sup_ge1 sup_bot_right mult_left_dist_sup n_L_split n_top_split order_trans)
  finally show ?thesis
    using 1 by (simp add: apx_def)
qed

text \<open>Theorem 16.1 and Theorem 16.2\<close>

subclass apx_semiring
  apply unfold_locales
  apply (metis sup_right_top sup_ge2 apx_def mult_left_one n_L top_greatest)
  apply (simp add: sup_apx_left_isotone)
  apply (simp add: mult_apx_left_isotone)
  by (simp add: mult_apx_right_isotone)

text \<open>Theorem 16.2\<close>

lemma ni_apx_isotone:
  "x \<sqsubseteq> y \<Longrightarrow> ni(x) \<sqsubseteq> ni(y)"
  using apx_n_order_reverse apx_def le_supI1 n_ni ni_def ni_n_order by force

text \<open>Theorem 17\<close>

definition kappa_apx_meet :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "kappa_apx_meet f \<equiv> apx.has_least_fixpoint f \<and> has_apx_meet (\<mu> f) (\<nu> f) \<and> \<kappa> f = \<mu> f \<triangle> \<nu> f"

definition kappa_mu_nu :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "kappa_mu_nu f \<equiv> apx.has_least_fixpoint f \<and> \<kappa> f = \<mu> f \<squnion> n(\<nu> f) * L"

definition nu_below_mu_nu :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "nu_below_mu_nu f \<equiv> \<nu> f \<le> \<mu> f \<squnion> n(\<nu> f) * top"

definition mu_nu_apx_nu :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "mu_nu_apx_nu f \<equiv> \<mu> f \<squnion> n(\<nu> f) * L \<sqsubseteq> \<nu> f"

definition mu_nu_apx_meet :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "mu_nu_apx_meet f \<equiv> has_apx_meet (\<mu> f) (\<nu> f) \<and> \<mu> f \<triangle> \<nu> f = \<mu> f \<squnion> n(\<nu> f) * L"

definition apx_meet_below_nu :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "apx_meet_below_nu f \<equiv> has_apx_meet (\<mu> f) (\<nu> f) \<and> \<mu> f \<triangle> \<nu> f \<le> \<nu> f"

lemma mu_below_l:
  "\<mu> f \<le> \<mu> f \<squnion> n(\<nu> f) * L"
  by simp

lemma l_below_nu:
  "has_least_fixpoint f \<Longrightarrow> has_greatest_fixpoint f \<Longrightarrow> \<mu> f \<squnion> n(\<nu> f) * L \<le> \<nu> f"
  by (simp add: mu_below_nu n_L_decreasing)

lemma n_l_nu:
  "has_least_fixpoint f \<Longrightarrow> has_greatest_fixpoint f \<Longrightarrow> n(\<mu> f \<squnion> n(\<nu> f) * L) = n(\<nu> f)"
  by (metis le_iff_sup mu_below_nu n_dist_sup n_n_L)

lemma l_apx_mu:
  "has_least_fixpoint f \<Longrightarrow> has_greatest_fixpoint f \<Longrightarrow> \<mu> f \<squnion> n(\<nu> f) * L \<sqsubseteq> \<mu> f"
  by (simp add: apx_def le_supI1 n_l_nu)

text \<open>Theorem 17.4 implies Theorem 17.5\<close>

lemma nu_below_mu_nu_mu_nu_apx_nu:
  "has_least_fixpoint f \<Longrightarrow> has_greatest_fixpoint f \<Longrightarrow> nu_below_mu_nu f \<Longrightarrow> mu_nu_apx_nu f"
  by (smt (z3) l_below_nu apx_def le_sup_iff sup.absorb2 sup_commute sup_monoid.add_assoc mu_nu_apx_nu_def n_l_nu nu_below_mu_nu_def)

text \<open>Theorem 17.5 implies Theorem 17.6\<close>

lemma mu_nu_apx_nu_mu_nu_apx_meet:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "mu_nu_apx_nu f"
    shows "mu_nu_apx_meet f"
proof -
  let ?l = "\<mu> f \<squnion> n(\<nu> f) * L"
  have "is_apx_meet (\<mu> f) (\<nu> f) ?l"
    apply (unfold is_apx_meet_def, intro conjI)
    apply (simp add: assms(1,2) l_apx_mu)
    using assms(3) mu_nu_apx_nu_def apply blast
    by (meson assms(1,2) l_below_nu apx_def order_trans sup_ge1 sup_left_isotone)
  thus ?thesis
    by (simp add: apx_meet_char mu_nu_apx_meet_def)
qed

text \<open>Theorem 17.6 implies Theorem 17.7\<close>

lemma mu_nu_apx_meet_apx_meet_below_nu:
  "has_least_fixpoint f \<Longrightarrow> has_greatest_fixpoint f \<Longrightarrow> mu_nu_apx_meet f \<Longrightarrow> apx_meet_below_nu f"
  using apx_meet_below_nu_def l_below_nu mu_nu_apx_meet_def by auto

text \<open>Theorem 17.7 implies Theorem 17.4\<close>

lemma apx_meet_below_nu_nu_below_mu_nu:
  assumes "apx_meet_below_nu f"
    shows "nu_below_mu_nu f"
proof -
  have "\<forall>m . m \<sqsubseteq> \<mu> f \<and> m \<sqsubseteq> \<nu> f \<and> m \<le> \<nu> f \<longrightarrow> \<nu> f \<le> \<mu> f \<squnion> n(m) * top"
    by (smt (verit) sup_assoc sup_left_isotone sup_right_top apx_def mult_left_dist_sup order_trans)
  thus ?thesis
    by (smt (verit) assms sup_right_isotone apx_greatest_lower_bound apx_meet_below_nu_def apx_reflexive mult_left_isotone n_isotone nu_below_mu_nu_def order_trans)
qed

text \<open>Theorem 17.1 implies Theorem 17.2\<close>

lemma has_apx_least_fixpoint_kappa_apx_meet:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "apx.has_least_fixpoint f"
    shows "kappa_apx_meet f"
proof -
  have "\<forall>w . w \<sqsubseteq> \<mu> f \<and> w \<sqsubseteq> \<nu> f \<longrightarrow> w \<sqsubseteq> \<kappa> f"
    by (meson assms apx_def order.trans kappa_below_nu mu_below_kappa semiring.add_right_mono)
  hence "is_apx_meet (\<mu> f) (\<nu> f) (\<kappa> f)"
    by (simp add: assms is_apx_meet_def kappa_apx_below_mu kappa_apx_below_nu)
  thus ?thesis
    by (simp add: assms(3) kappa_apx_meet_def apx_meet_char)
qed

text \<open>Theorem 17.2 implies Theorem 17.7\<close>

lemma kappa_apx_meet_apx_meet_below_nu:
  "has_greatest_fixpoint f \<Longrightarrow> kappa_apx_meet f \<Longrightarrow> apx_meet_below_nu f"
  using apx_meet_below_nu_def kappa_apx_meet_def kappa_below_nu by force

text \<open>Theorem 17.7 implies Theorem 17.3\<close>

lemma apx_meet_below_nu_kappa_mu_nu:
  assumes "has_least_fixpoint f"
      and "has_greatest_fixpoint f"
      and "isotone f"
      and "apx.isotone f"
      and "apx_meet_below_nu f"
    shows "kappa_mu_nu f"
proof -
  let ?l = "\<mu> f \<squnion> n(\<nu> f) * L"
  let ?m = "\<mu> f \<triangle> \<nu> f"
  have 1: "?l \<sqsubseteq> \<nu> f"
    using apx_meet_below_nu_nu_below_mu_nu assms(1,2,5) mu_nu_apx_nu_def nu_below_mu_nu_mu_nu_apx_nu by blast
  hence 2: "?m = ?l"
    using assms(1,2) mu_nu_apx_meet_def mu_nu_apx_nu_def mu_nu_apx_nu_mu_nu_apx_meet by blast
  have "\<mu> f \<le> f(?l)"
    by (metis assms(1,3) isotone_def mu_unfold sup_ge1)
  hence 3: "?l \<le> f(?l) \<squnion> n(?l) * L"
    using assms(1,2) semiring.add_right_mono n_l_nu by auto
  have "f(?l) \<le> f(\<nu> f)"
    using assms(1-3) l_below_nu isotone_def by blast
  also have "... \<le> ?l \<squnion> n(?l) * top"
    using 1 by (metis assms(2) apx_def nu_unfold)
  finally have 4: "?l \<sqsubseteq> f(?l)"
    using 3 apx_def by blast
  have 5: "f(?l) \<sqsubseteq> \<mu> f"
    by (metis assms(1,2,4) apx.isotone_def is_least_fixpoint_def least_fixpoint l_apx_mu)
  have "f(?l) \<sqsubseteq> \<nu> f"
    using 1 by (metis assms(2,4) apx.isotone_def greatest_fixpoint is_greatest_fixpoint_def)
  hence "f(?l) \<sqsubseteq> ?l"
    using 2 5 apx_meet_below_nu_def assms(5) apx_greatest_lower_bound by fastforce
  hence "f(?l) = ?l"
    using 4 by (simp add: apx.order.antisym)
  thus ?thesis
    using 1 by (smt (verit, del_insts) assms(1,2) sup_left_isotone apx_antisymmetric apx_def apx.least_fixpoint_char greatest_fixpoint apx.is_least_fixpoint_def is_greatest_fixpoint_def is_least_fixpoint_def least_fixpoint n_l_nu order_trans kappa_mu_nu_def)
qed

text \<open>Theorem 17.3 implies Theorem 17.1\<close>

lemma kappa_mu_nu_has_apx_least_fixpoint:
  "kappa_mu_nu f \<Longrightarrow> apx.has_least_fixpoint f"
  using kappa_mu_nu_def by auto

text \<open>Theorem 17.4 implies Theorem 17.3\<close>

lemma nu_below_mu_nu_kappa_mu_nu:
  "has_least_fixpoint f \<Longrightarrow> has_greatest_fixpoint f \<Longrightarrow> isotone f \<Longrightarrow> apx.isotone f \<Longrightarrow> nu_below_mu_nu f \<Longrightarrow> kappa_mu_nu f"
  using apx_meet_below_nu_kappa_mu_nu mu_nu_apx_meet_apx_meet_below_nu mu_nu_apx_nu_mu_nu_apx_meet nu_below_mu_nu_mu_nu_apx_nu by blast

text \<open>Theorem 17.3 implies Theorem 17.4\<close>

lemma kappa_mu_nu_nu_below_mu_nu:
  "has_least_fixpoint f \<Longrightarrow> has_greatest_fixpoint f \<Longrightarrow> kappa_mu_nu f \<Longrightarrow> nu_below_mu_nu f"
  by (simp add: apx_meet_below_nu_nu_below_mu_nu has_apx_least_fixpoint_kappa_apx_meet kappa_apx_meet_apx_meet_below_nu kappa_mu_nu_def)

definition kappa_mu_nu_ni :: "('a \<Rightarrow> 'a) \<Rightarrow> bool"
  where "kappa_mu_nu_ni f \<equiv> apx.has_least_fixpoint f \<and> \<kappa> f = \<mu> f \<squnion> ni(\<nu> f)"

lemma kappa_mu_nu_ni_kappa_mu_nu:
  "kappa_mu_nu_ni f \<longleftrightarrow> kappa_mu_nu f"
  by (simp add: kappa_mu_nu_def kappa_mu_nu_ni_def ni_def)

lemma nu_below_mu_nu_kappa_mu_nu_ni:
  "has_least_fixpoint f \<Longrightarrow> has_greatest_fixpoint f \<Longrightarrow> isotone f \<Longrightarrow> apx.isotone f \<Longrightarrow> nu_below_mu_nu f \<Longrightarrow> kappa_mu_nu_ni f"
  by (simp add: kappa_mu_nu_ni_kappa_mu_nu nu_below_mu_nu_kappa_mu_nu)

lemma kappa_mu_nu_ni_nu_below_mu_nu:
  "has_least_fixpoint f \<Longrightarrow> has_greatest_fixpoint f \<Longrightarrow> kappa_mu_nu_ni f \<Longrightarrow> nu_below_mu_nu f"
  using kappa_mu_nu_ni_kappa_mu_nu kappa_mu_nu_nu_below_mu_nu by blast

end

class itering_apx = n_itering + semiring_apx
begin

text \<open>Theorem 16.3\<close>

lemma circ_apx_isotone:
  assumes "x \<sqsubseteq> y"
    shows "x\<^sup>\<circ> \<sqsubseteq> y\<^sup>\<circ>"
proof -
  have 1: "x \<le> y \<squnion> n(x) * L \<and> y \<le> x \<squnion> n(x) * top"
    using assms apx_def by auto
  hence "y\<^sup>\<circ> \<le> x\<^sup>\<circ> \<squnion> x\<^sup>\<circ> * n(x) * top"
    by (metis circ_isotone circ_left_top circ_unfold_sum mult_assoc)
  also have "... \<le> x\<^sup>\<circ> \<squnion> n(x\<^sup>\<circ> * x) * top"
    by (smt le_sup_iff n_isotone n_top_split order_refl order_trans right_plus_below_circ zero_right_mult_decreasing)
  also have "... \<le> x\<^sup>\<circ> \<squnion> n(x\<^sup>\<circ>) * top"
    by (simp add: circ_plus_same n_circ_left_unfold)
  finally have 2: "y\<^sup>\<circ> \<le> x\<^sup>\<circ> \<squnion> n(x\<^sup>\<circ>) * top"
    .
  have "x\<^sup>\<circ> \<le> y\<^sup>\<circ> \<squnion> y\<^sup>\<circ> * n(x) * L"
    using 1 by (metis L_left_zero circ_isotone circ_unfold_sum mult_assoc)
  also have "... = y\<^sup>\<circ> \<squnion> n(y\<^sup>\<circ> * x) * L"
    by (metis sup_assoc sup_bot_right mult_assoc mult_zero_sup_circ_2 n_L_split n_mult_right_bot)
  also have "... \<le> y\<^sup>\<circ> \<squnion> n(x\<^sup>\<circ> * x) * L \<squnion> n(x\<^sup>\<circ>) * n(top * x) * L"
    using 2 by (metis sup_assoc sup_right_isotone mult_assoc mult_left_isotone mult_right_dist_sup n_dist_sup n_export n_isotone)
  finally have "x\<^sup>\<circ> \<le> y\<^sup>\<circ> \<squnion> n(x\<^sup>\<circ>) * L"
    by (metis sup_assoc circ_plus_same n_sup_left_absorb_mult n_circ_left_unfold n_dist_sup n_export ni_def ni_dist_sup)
  thus ?thesis
    using 2 by (simp add: apx_def)
qed

end

class omega_algebra_apx = n_omega_algebra_2 + semiring_apx

sublocale omega_algebra_apx < star: itering_apx where circ = star ..

sublocale omega_algebra_apx < nL_omega: itering_apx where circ = Omega ..

context omega_algebra_apx
begin

text \<open>Theorem 16.4\<close>

lemma omega_apx_isotone:
  assumes "x \<sqsubseteq> y"
    shows "x\<^sup>\<omega> \<sqsubseteq> y\<^sup>\<omega>"
proof -
  have 1: "x \<le> y \<squnion> n(x) * L \<and> y \<le> x \<squnion> n(x) * top"
    using assms apx_def by auto
  hence "y\<^sup>\<omega> \<le> x\<^sup>\<star> * n(x) * top * (x\<^sup>\<star> * n(x) * top)\<^sup>\<omega> \<squnion> x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * n(x) * top * (x\<^sup>\<star> * n(x) * top)\<^sup>\<star> * x\<^sup>\<omega>"
    by (smt sup_assoc mult_assoc mult_left_one mult_right_dist_sup omega_decompose omega_isotone omega_unfold star_left_unfold_equal)
  also have "... \<le> x\<^sup>\<star> * n(x) * top \<squnion> x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * n(x) * top * (x\<^sup>\<star> * n(x) * top)\<^sup>\<star> * x\<^sup>\<omega>"
    using mult_top_omega omega_unfold sup_left_isotone by auto
  also have "... = x\<^sup>\<star> * n(x) * top \<squnion> x\<^sup>\<omega>"
    by (smt (z3) mult_left_dist_sup sup_assoc sup_commute sup_left_top mult_assoc)
  also have "... \<le> n(x\<^sup>\<star> * x) * top \<squnion> x\<^sup>\<star> * bot \<squnion> x\<^sup>\<omega>"
    using n_top_split semiring.add_left_mono sup_commute by fastforce
  also have "... \<le> n(x\<^sup>\<star> * x) * top \<squnion> x\<^sup>\<omega>"
    using semiring.add_right_mono star_bot_below_omega sup_commute by fastforce
  finally have 2: "y\<^sup>\<omega> \<le> x\<^sup>\<omega> \<squnion> n(x\<^sup>\<omega>) * top"
    by (metis sup_commute sup_right_isotone mult_left_isotone n_star_below_n_omega n_star_left_unfold order_trans star.circ_plus_same)
  have "x\<^sup>\<omega> \<le> (y \<squnion> n(x) * L)\<^sup>\<omega>"
    using 1 by (simp add: omega_isotone)
  also have "... = y\<^sup>\<star> * n(x) * L * (y\<^sup>\<star> * n(x) * L)\<^sup>\<omega> \<squnion> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * n(x) * L * (y\<^sup>\<star> * n(x) * L)\<^sup>\<star> * y\<^sup>\<omega>"
    by (smt sup_assoc mult_assoc mult_left_one mult_right_dist_sup omega_decompose omega_isotone omega_unfold star_left_unfold_equal)
  also have "... = y\<^sup>\<star> * n(x) * L \<squnion> y\<^sup>\<omega>"
    using L_left_zero sup_assoc sup_monoid.add_commute mult_assoc by force
  also have "... \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * bot \<squnion> n(y\<^sup>\<star> * x) * L"
    by (simp add: n_L_split sup_assoc sup_commute)
  also have "... \<le> y\<^sup>\<omega> \<squnion> n(x\<^sup>\<star> * x) * L \<squnion> n(x\<^sup>\<star>) * n(top * x) * L"
    using 1 by (metis sup_right_isotone sup_bot_right apx_def mult_assoc mult_left_dist_sup mult_left_isotone mult_right_dist_sup n_dist_sup n_export n_isotone star.circ_apx_isotone star_mult_omega sup_assoc)
  finally have "x\<^sup>\<omega> \<le> y\<^sup>\<omega> \<squnion> n(x\<^sup>\<omega>) * L"
    by (smt (verit, best) le_supE sup.orderE sup_commute sup_assoc sup_isotone mult_right_dist_sup n_sup_left_absorb_mult n_star_left_unfold ni_def ni_star_below_ni_omega order_refl order_trans star.circ_plus_same)
  thus ?thesis
    using 2 by (simp add: apx_def)
qed

end

class omega_algebra_apx_extra = omega_algebra_apx +
  assumes n_split_omega: "x\<^sup>\<omega> \<le> x\<^sup>\<star> * bot \<squnion> n(x\<^sup>\<omega>) * top"
begin

lemma omega_n_star:
  "x\<^sup>\<omega> \<squnion> n(x\<^sup>\<star>) * top \<le> x\<^sup>\<star> * n(x\<^sup>\<omega>) * top"
proof -
  have 1: "n(x\<^sup>\<star>) * top \<le> n(x\<^sup>\<omega>) * top"
    by (simp add: mult_left_isotone n_star_below_n_omega)
  have "... \<le> x\<^sup>\<star> * n(x\<^sup>\<omega>) * top"
    by (simp add: star_n_omega_top)
  thus ?thesis
    using 1 by (metis le_sup_iff n_split_omega order_trans star_n_omega_top)
qed

lemma n_omega_zero:
  "n(x\<^sup>\<omega>) = bot \<longleftrightarrow> n(x\<^sup>\<star>) = bot \<and> x\<^sup>\<omega> \<le> x\<^sup>\<star> * bot"
  by (metis sup_bot_right order.eq_iff mult_left_zero n_mult_bot n_split_omega star_bot_below_omega)

lemma n_split_nu_mu:
  "y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z \<le> y\<^sup>\<star> * z \<squnion> n(y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) * top"
proof -
  have "y\<^sup>\<omega> \<le> y\<^sup>\<star> * bot \<squnion> n(y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) * top"
    by (smt sup_ge1 sup_right_isotone mult_left_isotone n_isotone n_split_omega order_trans)
  also have "... \<le> y\<^sup>\<star> * z \<squnion> n(y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) * top"
    using nL_star.star_zero_below_circ_mult sup_left_isotone by auto
  finally show ?thesis
    by simp
qed

lemma loop_exists:
  "\<nu> (\<lambda>x . y * x \<squnion> z) \<le> \<mu> (\<lambda>x . y * x \<squnion> z) \<squnion> n(\<nu> (\<lambda>x . y * x \<squnion> z)) * top"
  by (metis n_split_nu_mu omega_loop_nu star_loop_mu)

lemma loop_apx_least_fixpoint:
  "apx.is_least_fixpoint (\<lambda>x . y * x \<squnion> z) (\<mu> (\<lambda>x . y * x \<squnion> z) \<squnion> n(\<nu> (\<lambda>x . y * x \<squnion> z)) * L)"
  using apx.least_fixpoint_char affine_apx_isotone affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone kappa_mu_nu_def nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu loop_exists by auto

lemma loop_has_apx_least_fixpoint:
  "apx.has_least_fixpoint (\<lambda>x . y * x \<squnion> z)"
  using affine_apx_isotone affine_has_greatest_fixpoint affine_has_least_fixpoint affine_isotone kappa_mu_nu_def nu_below_mu_nu_def nu_below_mu_nu_kappa_mu_nu loop_exists by auto

lemma loop_semantics:
  "\<kappa> (\<lambda>x . y * x \<squnion> z) = \<mu> (\<lambda>x . y * x \<squnion> z) \<squnion> n(\<nu> (\<lambda>x . y * x \<squnion> z)) * L"
  using apx.least_fixpoint_char loop_apx_least_fixpoint by auto

lemma loop_apx_least_fixpoint_ni:
  "apx.is_least_fixpoint (\<lambda>x . y * x \<squnion> z) (\<mu> (\<lambda>x . y * x \<squnion> z) \<squnion> ni(\<nu> (\<lambda>x . y * x \<squnion> z)))"
  using ni_def loop_apx_least_fixpoint by auto

lemma loop_semantics_ni:
  "\<kappa> (\<lambda>x . y * x \<squnion> z) = \<mu> (\<lambda>x . y * x \<squnion> z) \<squnion> ni(\<nu> (\<lambda>x . y * x \<squnion> z))"
  using ni_def loop_semantics by auto

text \<open>Theorem 18\<close>

lemma loop_semantics_kappa_mu_nu:
  "\<kappa> (\<lambda>x . y * x \<squnion> z) = n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * z"
proof -
  have "\<kappa> (\<lambda>x . y * x \<squnion> z) = y\<^sup>\<star> * z \<squnion> n(y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) * L"
    by (metis loop_semantics omega_loop_nu star_loop_mu)
  thus ?thesis
    by (smt sup_assoc sup_commute le_iff_sup mult_right_dist_sup n_L_decreasing n_dist_sup)
qed

end

class omega_algebra_apx_extra_2 = omega_algebra_apx +
  assumes omega_n_star: "x\<^sup>\<omega> \<le> x\<^sup>\<star> * n(x\<^sup>\<omega>) * top"
begin

subclass omega_algebra_apx_extra
  apply unfold_locales
  using omega_n_star star_n_omega_top by auto

end

end


(*  Title:      CCL/ex/Flag.thy
    Author:     Martin Coen, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section \<open>Dutch national flag program -- except that the point of Dijkstra's example was to use
  arrays and this uses lists.\<close>

theory Flag
imports List
begin

definition Colour :: "i set"
  where "Colour == Unit + Unit + Unit"

definition red :: "i"
  where "red == inl(one)"

definition white :: "i"
  where "white == inr(inl(one))"

definition blue :: "i"
  where "blue == inr(inr(one))"

definition ccase :: "[i,i,i,i]\<Rightarrow>i"
  where "ccase(c,r,w,b) == when(c, \<lambda>x. r, \<lambda>wb. when(wb, \<lambda>x. w, \<lambda>x. b))"

definition flag :: "i"
  where
    "flag == lam l. letrec
      flagx l be lcase(l,<[],<[],[]>>,
                       \<lambda>h t. split(flagx(t), \<lambda>lr p. split(p, \<lambda>lw lb.
                            ccase(h, <red$lr,<lw,lb>>,
                                     <lr,<white$lw,lb>>,
                                     <lr,<lw,blue$lb>>))))
      in flagx(l)"

axiomatization Perm :: "i \<Rightarrow> i \<Rightarrow> o"
definition Flag :: "i \<Rightarrow> i \<Rightarrow> o" where
  "Flag(l,x) == ALL lr:List(Colour).ALL lw:List(Colour).ALL lb:List(Colour).
                x = <lr,<lw,lb>> \<longrightarrow>
              (ALL c:Colour.(c mem lr = true \<longrightarrow> c=red) \<and>
                            (c mem lw = true \<longrightarrow> c=white) \<and>
                            (c mem lb = true \<longrightarrow> c=blue)) \<and>
              Perm(l,lr @ lw @ lb)"

lemmas flag_defs = Colour_def red_def white_def blue_def ccase_def

lemma ColourXH: "a : Colour \<longleftrightarrow> (a=red | a=white | a=blue)"
  unfolding simp_type_defs flag_defs by blast

lemma redT: "red : Colour"
  and whiteT: "white : Colour"
  and blueT: "blue : Colour"
  unfolding ColourXH by blast+

lemma ccaseT:
  "\<lbrakk>c:Colour; c=red \<Longrightarrow> r : C(red); c=white \<Longrightarrow> w : C(white); c=blue \<Longrightarrow> b : C(blue)\<rbrakk>
    \<Longrightarrow> ccase(c,r,w,b) : C(c)"
  unfolding flag_defs by ncanT

lemma "flag : List(Colour)->List(Colour)*List(Colour)*List(Colour)"
  apply (unfold flag_def)
  apply (typechk redT whiteT blueT ccaseT)
  apply clean_ccs
  apply (erule ListPRI [THEN ListPR_wf [THEN wfI]])
  apply assumption
  done

lemma "flag : PROD l:List(Colour).{x:List(Colour)*List(Colour)*List(Colour).Flag(x,l)}"
  apply (unfold flag_def)
  apply (gen_ccs redT whiteT blueT ccaseT)
  oops

end


section \<open>Extending FOL by a modified version of HOL set theory\<close>

theory Set
imports "~~/src/FOL/FOL"
begin

declare [[eta_contract]]

typedecl 'a set
instance set :: ("term") "term" ..

subsection \<open>Set comprehension and membership\<close>

axiomatization Collect :: "['a \<Rightarrow> o] \<Rightarrow> 'a set"
  and mem :: "['a, 'a set] \<Rightarrow> o"  (infixl ":" 50)
where mem_Collect_iff: "(a : Collect(P)) \<longleftrightarrow> P(a)"
  and set_extension: "A = B \<longleftrightarrow> (ALL x. x:A \<longleftrightarrow> x:B)"

syntax
  "_Coll" :: "[idt, o] \<Rightarrow> 'a set"  ("(1{_./ _})")
translations
  "{x. P}" == "CONST Collect(\<lambda>x. P)"

lemma CollectI: "P(a) \<Longrightarrow> a : {x. P(x)}"
  apply (rule mem_Collect_iff [THEN iffD2])
  apply assumption
  done

lemma CollectD: "a : {x. P(x)} \<Longrightarrow> P(a)"
  apply (erule mem_Collect_iff [THEN iffD1])
  done

lemmas CollectE = CollectD [elim_format]

lemma set_ext: "(\<And>x. x:A \<longleftrightarrow> x:B) \<Longrightarrow> A = B"
  apply (rule set_extension [THEN iffD2])
  apply simp
  done

subsection \<open>Bounded quantifiers\<close>

definition Ball :: "['a set, 'a \<Rightarrow> o] \<Rightarrow> o"
  where "Ball(A, P) == ALL x. x:A \<longrightarrow> P(x)"

definition Bex :: "['a set, 'a \<Rightarrow> o] \<Rightarrow> o"
  where "Bex(A, P) == EX x. x:A \<and> P(x)"

syntax
  "_Ball" :: "[idt, 'a set, o] \<Rightarrow> o"  ("(ALL _:_./ _)" [0, 0, 0] 10)
  "_Bex" :: "[idt, 'a set, o] \<Rightarrow> o"  ("(EX _:_./ _)" [0, 0, 0] 10)
translations
  "ALL x:A. P"  == "CONST Ball(A, \<lambda>x. P)"
  "EX x:A. P"   == "CONST Bex(A, \<lambda>x. P)"

lemma ballI: "(\<And>x. x:A \<Longrightarrow> P(x)) \<Longrightarrow> ALL x:A. P(x)"
  by (simp add: Ball_def)

lemma bspec: "\<lbrakk>ALL x:A. P(x); x:A\<rbrakk> \<Longrightarrow> P(x)"
  by (simp add: Ball_def)

lemma ballE: "\<lbrakk>ALL x:A. P(x); P(x) \<Longrightarrow> Q; \<not> x:A \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  unfolding Ball_def by blast

lemma bexI: "\<lbrakk>P(x); x:A\<rbrakk> \<Longrightarrow> EX x:A. P(x)"
  unfolding Bex_def by blast

lemma bexCI: "\<lbrakk>EX x:A. \<not>P(x) \<Longrightarrow> P(a); a:A\<rbrakk> \<Longrightarrow> EX x:A. P(x)"
  unfolding Bex_def by blast

lemma bexE: "\<lbrakk>EX x:A. P(x); \<And>x. \<lbrakk>x:A; P(x)\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  unfolding Bex_def by blast

(*Trival rewrite rule;   (! x:A.P)=P holds only if A is nonempty!*)
lemma ball_rew: "(ALL x:A. True) \<longleftrightarrow> True"
  by (blast intro: ballI)

subsubsection \<open>Congruence rules\<close>

lemma ball_cong:
  "\<lbrakk>A = A'; \<And>x. x:A' \<Longrightarrow> P(x) \<longleftrightarrow> P'(x)\<rbrakk> \<Longrightarrow>
    (ALL x:A. P(x)) \<longleftrightarrow> (ALL x:A'. P'(x))"
  by (blast intro: ballI elim: ballE)

lemma bex_cong:
  "\<lbrakk>A = A'; \<And>x. x:A' \<Longrightarrow> P(x) \<longleftrightarrow> P'(x)\<rbrakk> \<Longrightarrow>
    (EX x:A. P(x)) \<longleftrightarrow> (EX x:A'. P'(x))"
  by (blast intro: bexI elim: bexE)

subsection \<open>Further operations\<close>

definition subset :: "['a set, 'a set] \<Rightarrow> o"  (infixl "<=" 50)
  where "A <= B == ALL x:A. x:B"

definition mono :: "['a set \<Rightarrow> 'b set] \<Rightarrow> o"
  where "mono(f) == (ALL A B. A <= B \<longrightarrow> f(A) <= f(B))"

definition singleton :: "'a \<Rightarrow> 'a set"  ("{_}")
  where "{a} == {x. x=a}"

definition empty :: "'a set"  ("{}")
  where "{} == {x. False}"

definition Un :: "['a set, 'a set] \<Rightarrow> 'a set"  (infixl "Un" 65)
  where "A Un B == {x. x:A | x:B}"

definition Int :: "['a set, 'a set] \<Rightarrow> 'a set"  (infixl "Int" 70)
  where "A Int B == {x. x:A \<and> x:B}"

definition Compl :: "('a set) \<Rightarrow> 'a set"
  where "Compl(A) == {x. \<not>x:A}"

subsection \<open>Big Intersection / Union\<close>

definition INTER :: "['a set, 'a \<Rightarrow> 'b set] \<Rightarrow> 'b set"
  where "INTER(A, B) == {y. ALL x:A. y: B(x)}"

definition UNION :: "['a set, 'a \<Rightarrow> 'b set] \<Rightarrow> 'b set"
  where "UNION(A, B) == {y. EX x:A. y: B(x)}"

syntax
  "_INTER" :: "[idt, 'a set, 'b set] \<Rightarrow> 'b set"  ("(INT _:_./ _)" [0, 0, 0] 10)
  "_UNION" :: "[idt, 'a set, 'b set] \<Rightarrow> 'b set"  ("(UN _:_./ _)" [0, 0, 0] 10)
translations
  "INT x:A. B" == "CONST INTER(A, \<lambda>x. B)"
  "UN x:A. B" == "CONST UNION(A, \<lambda>x. B)"

definition Inter :: "(('a set)set) \<Rightarrow> 'a set"
  where "Inter(S) == (INT x:S. x)"

definition Union :: "(('a set)set) \<Rightarrow> 'a set"
  where "Union(S) == (UN x:S. x)"

subsection \<open>Rules for subsets\<close>

lemma subsetI: "(\<And>x. x:A \<Longrightarrow> x:B) \<Longrightarrow> A <= B"
  unfolding subset_def by (blast intro: ballI)

(*Rule in Modus Ponens style*)
lemma subsetD: "\<lbrakk>A <= B; c:A\<rbrakk> \<Longrightarrow> c:B"
  unfolding subset_def by (blast elim: ballE)

(*Classical elimination rule*)
lemma subsetCE: "\<lbrakk>A <= B; \<not>(c:A) \<Longrightarrow> P; c:B \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (blast dest: subsetD)

lemma subset_refl: "A <= A"
  by (blast intro: subsetI)

lemma subset_trans: "\<lbrakk>A <= B; B <= C\<rbrakk> \<Longrightarrow> A <= C"
  by (blast intro: subsetI dest: subsetD)

subsection \<open>Rules for equality\<close>

(*Anti-symmetry of the subset relation*)
lemma subset_antisym: "\<lbrakk>A <= B; B <= A\<rbrakk> \<Longrightarrow> A = B"
  by (blast intro: set_ext dest: subsetD)

lemmas equalityI = subset_antisym

(* Equality rules from ZF set theory -- are they appropriate here? *)
lemma equalityD1: "A = B \<Longrightarrow> A<=B"
  and equalityD2: "A = B \<Longrightarrow> B<=A"
  by (simp_all add: subset_refl)

lemma equalityE: "\<lbrakk>A = B; \<lbrakk>A <= B; B <= A\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (simp add: subset_refl)

lemma equalityCE: "\<lbrakk>A = B; \<lbrakk>c:A; c:B\<rbrakk> \<Longrightarrow> P; \<lbrakk>\<not> c:A; \<not> c:B\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (blast elim: equalityE subsetCE)

lemma trivial_set: "{x. x:A} = A"
  by (blast intro: equalityI subsetI CollectI dest: CollectD)

subsection \<open>Rules for binary union\<close>

lemma UnI1: "c:A \<Longrightarrow> c : A Un B"
  and UnI2: "c:B \<Longrightarrow> c : A Un B"
  unfolding Un_def by (blast intro: CollectI)+

(*Classical introduction rule: no commitment to A vs B*)
lemma UnCI: "(\<not>c:B \<Longrightarrow> c:A) \<Longrightarrow> c : A Un B"
  by (blast intro: UnI1 UnI2)

lemma UnE: "\<lbrakk>c : A Un B; c:A \<Longrightarrow> P; c:B \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  unfolding Un_def by (blast dest: CollectD)

subsection \<open>Rules for small intersection\<close>

lemma IntI: "\<lbrakk>c:A; c:B\<rbrakk> \<Longrightarrow> c : A Int B"
  unfolding Int_def by (blast intro: CollectI)

lemma IntD1: "c : A Int B \<Longrightarrow> c:A"
  and IntD2: "c : A Int B \<Longrightarrow> c:B"
  unfolding Int_def by (blast dest: CollectD)+

lemma IntE: "\<lbrakk>c : A Int B; \<lbrakk>c:A; c:B\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (blast dest: IntD1 IntD2)

subsection \<open>Rules for set complement\<close>

lemma ComplI: "(c:A \<Longrightarrow> False) \<Longrightarrow> c : Compl(A)"
  unfolding Compl_def by (blast intro: CollectI)

(*This form, with negated conclusion, works well with the Classical prover.
  Negated assumptions behave like formulae on the right side of the notional
  turnstile...*)
lemma ComplD: "c : Compl(A) \<Longrightarrow> \<not>c:A"
  unfolding Compl_def by (blast dest: CollectD)

lemmas ComplE = ComplD [elim_format]

subsection \<open>Empty sets\<close>

lemma empty_eq: "{x. False} = {}"
  by (simp add: empty_def)

lemma emptyD: "a : {} \<Longrightarrow> P"
  unfolding empty_def by (blast dest: CollectD)

lemmas emptyE = emptyD [elim_format]

lemma not_emptyD:
  assumes "\<not> A={}"
  shows "EX x. x:A"
proof -
  have "\<not> (EX x. x:A) \<Longrightarrow> A = {}"
    by (rule equalityI) (blast intro!: subsetI elim!: emptyD)+
  with assms show ?thesis by blast
qed

subsection \<open>Singleton sets\<close>

lemma singletonI: "a : {a}"
  unfolding singleton_def by (blast intro: CollectI)

lemma singletonD: "b : {a} \<Longrightarrow> b=a"
  unfolding singleton_def by (blast dest: CollectD)

lemmas singletonE = singletonD [elim_format]

subsection \<open>Unions of families\<close>

(*The order of the premises presupposes that A is rigid; b may be flexible*)
lemma UN_I: "\<lbrakk>a:A; b: B(a)\<rbrakk> \<Longrightarrow> b: (UN x:A. B(x))"
  unfolding UNION_def by (blast intro: bexI CollectI)

lemma UN_E: "\<lbrakk>b : (UN x:A. B(x)); \<And>x. \<lbrakk>x:A; b: B(x)\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding UNION_def by (blast dest: CollectD elim: bexE)

lemma UN_cong: "\<lbrakk>A = B; \<And>x. x:B \<Longrightarrow> C(x) = D(x)\<rbrakk> \<Longrightarrow> (UN x:A. C(x)) = (UN x:B. D(x))"
  by (simp add: UNION_def cong: bex_cong)

subsection \<open>Intersections of families\<close>

lemma INT_I: "(\<And>x. x:A \<Longrightarrow> b: B(x)) \<Longrightarrow> b : (INT x:A. B(x))"
  unfolding INTER_def by (blast intro: CollectI ballI)

lemma INT_D: "\<lbrakk>b : (INT x:A. B(x)); a:A\<rbrakk> \<Longrightarrow> b: B(a)"
  unfolding INTER_def by (blast dest: CollectD bspec)

(*"Classical" elimination rule -- does not require proving X:C *)
lemma INT_E: "\<lbrakk>b : (INT x:A. B(x)); b: B(a) \<Longrightarrow> R; \<not> a:A \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding INTER_def by (blast dest: CollectD bspec)

lemma INT_cong: "\<lbrakk>A = B; \<And>x. x:B \<Longrightarrow> C(x) = D(x)\<rbrakk> \<Longrightarrow> (INT x:A. C(x)) = (INT x:B. D(x))"
  by (simp add: INTER_def cong: ball_cong)

subsection \<open>Rules for Unions\<close>

(*The order of the premises presupposes that C is rigid; A may be flexible*)
lemma UnionI: "\<lbrakk>X:C; A:X\<rbrakk> \<Longrightarrow> A : Union(C)"
  unfolding Union_def by (blast intro: UN_I)

lemma UnionE: "\<lbrakk>A : Union(C); \<And>X. \<lbrakk> A:X; X:C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding Union_def by (blast elim: UN_E)

subsection \<open>Rules for Inter\<close>

lemma InterI: "(\<And>X. X:C \<Longrightarrow> A:X) \<Longrightarrow> A : Inter(C)"
  unfolding Inter_def by (blast intro: INT_I)

(*A "destruct" rule -- every X in C contains A as an element, but
  A:X can hold when X:C does not!  This rule is analogous to "spec". *)
lemma InterD: "\<lbrakk>A : Inter(C);  X:C\<rbrakk> \<Longrightarrow> A:X"
  unfolding Inter_def by (blast dest: INT_D)

(*"Classical" elimination rule -- does not require proving X:C *)
lemma InterE: "\<lbrakk>A : Inter(C); A:X \<Longrightarrow> R; \<not> X:C \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding Inter_def by (blast elim: INT_E)

section \<open>Derived rules involving subsets; Union and Intersection as lattice operations\<close>

subsection \<open>Big Union -- least upper bound of a set\<close>

lemma Union_upper: "B:A \<Longrightarrow> B <= Union(A)"
  by (blast intro: subsetI UnionI)

lemma Union_least: "(\<And>X. X:A \<Longrightarrow> X<=C) \<Longrightarrow> Union(A) <= C"
  by (blast intro: subsetI dest: subsetD elim: UnionE)

subsection \<open>Big Intersection -- greatest lower bound of a set\<close>

lemma Inter_lower: "B:A \<Longrightarrow> Inter(A) <= B"
  by (blast intro: subsetI dest: InterD)

lemma Inter_greatest: "(\<And>X. X:A \<Longrightarrow> C<=X) \<Longrightarrow> C <= Inter(A)"
  by (blast intro: subsetI InterI dest: subsetD)

subsection \<open>Finite Union -- the least upper bound of 2 sets\<close>

lemma Un_upper1: "A <= A Un B"
  by (blast intro: subsetI UnI1)

lemma Un_upper2: "B <= A Un B"
  by (blast intro: subsetI UnI2)

lemma Un_least: "\<lbrakk>A<=C; B<=C\<rbrakk> \<Longrightarrow> A Un B <= C"
  by (blast intro: subsetI elim: UnE dest: subsetD)

subsection \<open>Finite Intersection -- the greatest lower bound of 2 sets\<close>

lemma Int_lower1: "A Int B <= A"
  by (blast intro: subsetI elim: IntE)

lemma Int_lower2: "A Int B <= B"
  by (blast intro: subsetI elim: IntE)

lemma Int_greatest: "\<lbrakk>C<=A; C<=B\<rbrakk> \<Longrightarrow> C <= A Int B"
  by (blast intro: subsetI IntI dest: subsetD)

subsection \<open>Monotonicity\<close>

lemma monoI: "(\<And>A B. A <= B \<Longrightarrow> f(A) <= f(B)) \<Longrightarrow> mono(f)"
  unfolding mono_def by blast

lemma monoD: "\<lbrakk>mono(f); A <= B\<rbrakk> \<Longrightarrow> f(A) <= f(B)"
  unfolding mono_def by blast

lemma mono_Un: "mono(f) \<Longrightarrow> f(A) Un f(B) <= f(A Un B)"
  by (blast intro: Un_least dest: monoD intro: Un_upper1 Un_upper2)

lemma mono_Int: "mono(f) \<Longrightarrow> f(A Int B) <= f(A) Int f(B)"
  by (blast intro: Int_greatest dest: monoD intro: Int_lower1 Int_lower2)

subsection \<open>Automated reasoning setup\<close>

lemmas [intro!] = ballI subsetI InterI INT_I CollectI ComplI IntI UnCI singletonI
  and [intro] = bexI UnionI UN_I
  and [elim!] = bexE UnionE UN_E CollectE ComplE IntE UnE emptyE singletonE
  and [elim] = ballE InterD InterE INT_D INT_E subsetD subsetCE

lemma mem_rews:
  "(a : A Un B)   \<longleftrightarrow>  (a:A | a:B)"
  "(a : A Int B)  \<longleftrightarrow>  (a:A \<and> a:B)"
  "(a : Compl(B)) \<longleftrightarrow>  (\<not>a:B)"
  "(a : {b})      \<longleftrightarrow>  (a=b)"
  "(a : {})       \<longleftrightarrow>   False"
  "(a : {x. P(x)}) \<longleftrightarrow>  P(a)"
  by blast+

lemmas [simp] = trivial_set empty_eq mem_rews
  and [cong] = ball_cong bex_cong INT_cong UN_cong

section \<open>Equalities involving union, intersection, inclusion, etc.\<close>

subsection \<open>Binary Intersection\<close>

lemma Int_absorb: "A Int A = A"
  by (blast intro: equalityI)

lemma Int_commute: "A Int B  =  B Int A"
  by (blast intro: equalityI)

lemma Int_assoc: "(A Int B) Int C  =  A Int (B Int C)"
  by (blast intro: equalityI)

lemma Int_Un_distrib: "(A Un B) Int C  =  (A Int C) Un (B Int C)"
  by (blast intro: equalityI)

lemma subset_Int_eq: "(A<=B) \<longleftrightarrow> (A Int B = A)"
  by (blast intro: equalityI elim: equalityE)

subsection \<open>Binary Union\<close>

lemma Un_absorb: "A Un A = A"
  by (blast intro: equalityI)

lemma Un_commute: "A Un B  =  B Un A"
  by (blast intro: equalityI)

lemma Un_assoc: "(A Un B) Un C  =  A Un (B Un C)"
  by (blast intro: equalityI)

lemma Un_Int_distrib: "(A Int B) Un C  =  (A Un C) Int (B Un C)"
  by (blast intro: equalityI)

lemma Un_Int_crazy:
    "(A Int B) Un (B Int C) Un (C Int A) = (A Un B) Int (B Un C) Int (C Un A)"
  by (blast intro: equalityI)

lemma subset_Un_eq: "(A<=B) \<longleftrightarrow> (A Un B = B)"
  by (blast intro: equalityI elim: equalityE)

subsection \<open>Simple properties of \<open>Compl\<close> -- complement of a set\<close>

lemma Compl_disjoint: "A Int Compl(A) = {x. False}"
  by (blast intro: equalityI)

lemma Compl_partition: "A Un Compl(A) = {x. True}"
  by (blast intro: equalityI)

lemma double_complement: "Compl(Compl(A)) = A"
  by (blast intro: equalityI)

lemma Compl_Un: "Compl(A Un B) = Compl(A) Int Compl(B)"
  by (blast intro: equalityI)

lemma Compl_Int: "Compl(A Int B) = Compl(A) Un Compl(B)"
  by (blast intro: equalityI)

lemma Compl_UN: "Compl(UN x:A. B(x)) = (INT x:A. Compl(B(x)))"
  by (blast intro: equalityI)

lemma Compl_INT: "Compl(INT x:A. B(x)) = (UN x:A. Compl(B(x)))"
  by (blast intro: equalityI)

(*Halmos, Naive Set Theory, page 16.*)
lemma Un_Int_assoc_eq: "((A Int B) Un C = A Int (B Un C)) \<longleftrightarrow> (C<=A)"
  by (blast intro: equalityI elim: equalityE)

subsection \<open>Big Union and Intersection\<close>

lemma Union_Un_distrib: "Union(A Un B) = Union(A) Un Union(B)"
  by (blast intro: equalityI)

lemma Union_disjoint:
    "(Union(C) Int A = {x. False}) \<longleftrightarrow> (ALL B:C. B Int A = {x. False})"
  by (blast intro: equalityI elim: equalityE)

lemma Inter_Un_distrib: "Inter(A Un B) = Inter(A) Int Inter(B)"
  by (blast intro: equalityI)

subsection \<open>Unions and Intersections of Families\<close>

lemma UN_eq: "(UN x:A. B(x)) = Union({Y. EX x:A. Y=B(x)})"
  by (blast intro: equalityI)

(*Look: it has an EXISTENTIAL quantifier*)
lemma INT_eq: "(INT x:A. B(x)) = Inter({Y. EX x:A. Y=B(x)})"
  by (blast intro: equalityI)

lemma Int_Union_image: "A Int Union(B) = (UN C:B. A Int C)"
  by (blast intro: equalityI)

lemma Un_Inter_image: "A Un Inter(B) = (INT C:B. A Un C)"
  by (blast intro: equalityI)

section \<open>Monotonicity of various operations\<close>

lemma Union_mono: "A<=B \<Longrightarrow> Union(A) <= Union(B)"
  by blast

lemma Inter_anti_mono: "B <= A \<Longrightarrow> Inter(A) <= Inter(B)"
  by blast

lemma UN_mono: "\<lbrakk>A <= B; \<And>x. x:A \<Longrightarrow> f(x)<=g(x)\<rbrakk> \<Longrightarrow> (UN x:A. f(x)) <= (UN x:B. g(x))"
  by blast

lemma INT_anti_mono: "\<lbrakk>B <= A; \<And>x. x:A \<Longrightarrow> f(x) <= g(x)\<rbrakk> \<Longrightarrow> (INT x:A. f(x)) <= (INT x:A. g(x))"
  by blast

lemma Un_mono: "\<lbrakk>A <= C; B <= D\<rbrakk> \<Longrightarrow> A Un B <= C Un D"
  by blast

lemma Int_mono: "\<lbrakk>A <= C; B <= D\<rbrakk> \<Longrightarrow> A Int B <= C Int D"
  by blast

lemma Compl_anti_mono: "A <= B \<Longrightarrow> Compl(B) <= Compl(A)"
  by blast

end


theory T19
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory test_logic
  imports Main
begin
 declare [[simp_trace]]
declare [[simp_trace_depth_limit=10]]

lemma "P\<and>Q\<Longrightarrow>P"
proof -
  assume "P\<and>Q"
  thus P by (rule conjunct1)
qed
lemma tt:"P\<Longrightarrow>P\<or>Q"
proof -
  assume P
  thus "P\<or>Q" by (rule disjI1)
qed
lemma "P\<Longrightarrow>P\<or>Q"
  apply (insert tt)
  apply(rule disjI1)
  apply assumption
  done
lemma " \<not>P\<Longrightarrow>P\<longrightarrow>Q"
proof -
  assume "\<not>P"
  show "P\<longrightarrow>Q"
  proof (rule impI)
    assume  "P"
    from `\<not>P` `P`  show "Q" by (rule notE)
  qed
qed
thm disj_not1

lemma "A\<Longrightarrow>(A\<Longrightarrow>B)\<Longrightarrow>B"
proof -
  assume 1:"A"
  assume 2:"A\<Longrightarrow>B"
  from 1 2 show "B" by simp
qed

lemma "A\<longrightarrow>(A\<longrightarrow>B)\<longrightarrow>B" by simp

lemma "A\<Longrightarrow>A\<longrightarrow>B\<Longrightarrow>B" by simp

lemma wy111 :"(P=Q) \<Longrightarrow> (~ P) \<Longrightarrow>~ Q"
apply auto
done

lemma "\<not> (P\<longrightarrow>Q) \<Longrightarrow>P"
proof -
  assume "\<not> (P\<longrightarrow>Q)"
(*    have "(\<not>P\<or>Q) = (P\<longrightarrow>Q )" by (rule disj_not1) *)
  have "(\<not>P\<or>Q) = (P\<longrightarrow>Q )" by (rule disj_not1)
    then have "(P\<longrightarrow>Q) =(\<not>P\<or>Q) " by (rule sym)
    then have "(\<not>(P\<longrightarrow>Q)) = (\<not>(\<not>P\<or>Q)) " by (rule arg_cong)
    then have "(\<not>(P\<longrightarrow>Q)) \<longrightarrow> (\<not>(\<not>P\<or>Q)) " by rule
    from `(\<not>(P\<longrightarrow>Q))  \<longrightarrow> (\<not>(\<not>P\<or>Q))`  `(\<not>(P\<longrightarrow>Q))`  have  "\<not> (\<not>P\<or>Q)" by (rule mp)
    from this have "((~~P)\<and>\<not>Q)" by (rule Meson.not_disjD)
    from this have "(\<not> \<not>P)" by (rule conjunct1)
    from this show "P" by (rule notnotD)
  qed

lemma "\<not> (P\<longrightarrow>Q) \<Longrightarrow>P"
proof -
  assume "\<not> (P\<longrightarrow>Q)"
(*    have "(\<not>P\<or>Q) = (P\<longrightarrow>Q )" by (rule disj_not1) *)
  have "(\<not>P\<or>Q) = (P\<longrightarrow>Q )" by (rule disj_not1)
    then have "(P\<longrightarrow>Q) =(\<not>P\<or>Q) " by (rule sym)
    then have "(\<not>(P\<longrightarrow>Q)) = (\<not>(\<not>P\<or>Q)) " by (rule arg_cong)
    from `(\<not>(P\<longrightarrow>Q)) = (\<not>(\<not>P\<or>Q))` `(\<not>(P\<longrightarrow>Q))`  have  "\<not> (\<not>P\<or>Q)" by (rule iffD1)
    from this have "((~~P)\<and>\<not>Q)" by (rule Meson.not_disjD)
    from this have "(\<not> \<not>P)" by (rule conjunct1)
    from this show "P" by (rule notnotD)
  qed

lemma "\<not> (P\<longrightarrow>Q) \<Longrightarrow>P"
proof -
  assume "\<not> (P\<longrightarrow>Q)"
  have "(\<not>P\<or>Q) = (P\<longrightarrow>Q )" by (rule disj_not1) (*<-> is same with =*)
  then have "(P\<longrightarrow>Q) =(\<not>P\<or>Q) " by (rule sym)
  from   `(P\<longrightarrow>Q) =(\<not>P\<or>Q) ` `\<not> (P\<longrightarrow>Q)`  have  "\<not> (\<not>P\<or>Q)" by (rule subst)
  from this have "((~~P)\<and>\<not>Q)" by (rule Meson.not_disjD)
    from this have "(\<not> \<not>P)" by (rule conjunct1)
    from this show "P" by (rule notnotD)
qed
lemma "\<not> (P\<longrightarrow>Q) \<Longrightarrow>P"
proof -
  assume "\<not> (P\<longrightarrow>Q)"
  have "(\<not>P\<or>Q) \<longleftrightarrow>(P\<longrightarrow>Q )" by (rule disj_not1)
  then have "(P\<longrightarrow>Q) =(\<not>P\<or>Q) " by (rule sym)
  from   `(P\<longrightarrow>Q) =(\<not>P\<or>Q) ` `\<not> (P\<longrightarrow>Q)`  have  "\<not> (\<not>P\<or>Q)" by (rule subst)
  from this have "((~~P)\<and>\<not>Q)" by (rule Meson.not_disjD)
    from this have "(\<not> \<not>P)" by (rule conjunct1)
    from this show "P" by (rule notnotD)
  qed

lemma "(\<And>x. P x ) \<Longrightarrow>(\<forall> x. P x )" by auto

lemma " (\<forall> x. P x ) \<Longrightarrow> (\<And>x. P x ) " by auto

lemma " (A \<and>C\<Longrightarrow>B) \<Longrightarrow> (B\<Longrightarrow>A\<and>C) \<Longrightarrow> ((A\<and>C)\<equiv>B)" by linarith

lemma " ((A \<Longrightarrow>C)\<Longrightarrow>(B\<Longrightarrow>D)) \<Longrightarrow> ((B\<Longrightarrow>D)\<Longrightarrow>(A\<Longrightarrow>C)) \<Longrightarrow> ((A\<Longrightarrow>C) \<equiv>(B\<Longrightarrow>D))" sorry

lemma " (P\<Longrightarrow>False)   \<Longrightarrow> (( (P\<Longrightarrow>False) \<Longrightarrow>False ) \<Longrightarrow>False ) " by auto

lemma "(( (P\<Longrightarrow>False) \<Longrightarrow>False ) \<Longrightarrow>False ) \<Longrightarrow> (P\<Longrightarrow>False) " by auto

lemma " (( (P\<Longrightarrow>False) \<Longrightarrow>False ) \<Longrightarrow>False ) \<equiv> (P\<Longrightarrow>False)" sorry

lemma "  P   \<equiv> ( (P\<Longrightarrow>False) \<Longrightarrow>False ) " oops

lemma " ( P\<Longrightarrow>False)  ( ( (P\<Longrightarrow>False) \<Longrightarrow>False ) \<Longrightarrow>False ) " sorry

lemma " ( (\<And>x. P x \<Longrightarrow>False) \<Longrightarrow>False ) \<Longrightarrow> (\<exists> x. P x )" by auto

lemma "(\<exists> x. P x)  \<Longrightarrow> ( (\<And>x. P x \<Longrightarrow>False) \<Longrightarrow>False )" by auto

lemma "(true (\<exists> x. P x)) \<equiv> ( (\<And>x. P x \<Longrightarrow>False) \<Longrightarrow>False )" by auto

lemma " ( (A\<Longrightarrow>False) \<Longrightarrow>B ) \<Longrightarrow>A \<or> B" by auto

lemma "A \<or> B \<Longrightarrow> ( (A\<Longrightarrow>False) \<Longrightarrow>B )  " by auto

lemma " (A  \<Longrightarrow> B ) \<Longrightarrow> (B\<Longrightarrow>A) \<Longrightarrow> A\<equiv>B  " by auto

lemma "    \<lbrakk> A \<or> B \<rbrakk> \<equiv> ( (A\<Longrightarrow>False) \<Longrightarrow>B ) " by auto

lemma "(true (A \<or> B) ) \<equiv> ( (A\<Longrightarrow>False) \<Longrightarrow>B )  " by auto

lemma "A\<longrightarrow>B\<longrightarrow>C \<Longrightarrow> (A\<Longrightarrow>B\<Longrightarrow>C ) " by auto

lemma "(A\<Longrightarrow>B\<Longrightarrow>C) \<Longrightarrow> A\<longrightarrow>B\<longrightarrow>C " by auto

lemma " ( ( A\<Longrightarrow>B\<Longrightarrow>False ) \<Longrightarrow>False )  \<Longrightarrow> A\<and>B " by auto

lemma "A\<and>B \<Longrightarrow> ( ( A\<Longrightarrow>B\<Longrightarrow>False ) \<Longrightarrow>False )" by auto

lemma " ( A \<Longrightarrow>False )  \<Longrightarrow> \<not>A" by auto

lemma " ( (A\<Longrightarrow>False) \<Longrightarrow>False )  \<Longrightarrow> A" by auto

lemma wy222:"(! x. P (x))\<Longrightarrow> (? x. P x)"  by simp

lemma "(! x y. A (x, y) )\<Longrightarrow> ? y. ! x. A(x,y)"
proof -
  assume "! x y. A (x, y)"
  then have "! y x . A( x,y)" by blast
  then have "! y .! x . A(x,y)" by blast
  then show "? y. ! x. A(x,y)" by blast
qed

lemma "(! x y. A (x, y) )\<Longrightarrow> ! y. ! x. A(x,y)"
proof -
  assume 1:  "! x y. A (x, y)"
  show "! y. ! x. A(x,y)"
  proof
    fix y
    show "! x. A(x,y)"
    proof
      fix x
      from 1 have "! y. A(x,y)" by rule
      then show "A(x,y)" by rule
    qed
  qed
    qed

lemma "(? x. !y. A (x, y) )\<Longrightarrow> ! y. ? x. A(x,y)"
proof -
  assume 1:"(? x. !y. A (x, y) )"
  then obtain x where "!y. A (x, y)" by rule
  show "! y. ? x. A(x,y)"
  proof
    fix y
    show "? x . A(x,y)"
    proof
      have "!y. A (x, y)" by fact
      then show "A(x,y)" by rule
    qed
   qed
 qed

lemma "(? x. !y. A (x, y) )\<Longrightarrow> ! y. ? x. A(x,y)"
proof -
  assume 1:"(? x. !y. A (x, y) )"
  then obtain x where "!y. A (x, y)" by rule
  have 2:"!y. A (x, y)" by fact
  show "! y. ? x . A(x,y)"
  proof
    fix y
    from 2 have "A(x,y)"  by rule
    then show "? x . A(x,y)" by rule
  qed
qed

lemma "(? x. ? y. A(x, y) ) = (? y. ? x. A(x,y))"
proof
  assume "(? x. ? y. A(x, y) )"
  then obtain x where "? y. A (x, y)" by rule
  then obtain y where "A(x,y)" by rule
  then have "? x . A(x,y)" by rule
  then show "? y. ? x . A(x,y)" by rule
next
  assume "(? y. ? x. A(x, y) )"
  then obtain y where "? x. A (x, y)" by rule
  then obtain x where "A(x,y)" by rule
  then have "? y . A(x,y)" by rule
  then show "? x. ? y . A(x,y)" by rule
qed

lemma ex_or:"(? x . A x \<or> B x )= ((? x. A x) \<or> (? x . B x))"
proof
  assume "(? x . A x \<or> B x )"
  then obtain x where 1: "A x \<or> B x" by rule
  then show "(? x. A x) \<or> (? x . B x)"
  proof
    assume "A x"
    then have "? x. A x" by rule
    then show "(? x. A x) \<or> (? x . B x)" by rule
  next
    assume "B x"
    then have "? x. B x" by rule
    then show "(? x. A x) \<or> (? x . B x)" by rule
  qed
next
  assume "(? x. A x) \<or> (? x . B x)"
  then show "(? x . A x \<or> B x )"
  proof
    assume "(? x. A x)"
    then obtain x where " A x" by rule
    then have "( A x \<or> B x )" by rule
    then show "(? x . A x \<or> B x )" by rule
  next
    assume "(? x. B x)"
    then show "(? x . A x \<or> B x )" by auto
  qed
qed

lemma "(! x . A x \<and> B x )= ((! x. A x) \<and> (! x . B x))"
proof
  assume 1:"(! x . A x \<and> B x )"

    have 3:"! x .A x "
    proof
      fix x
      from 1 have 2: "(A x \<and> B x)" by rule
      then have "A x"  by rule
      show "A x" by fact
    qed
    from 1 have  4: "! x. B x" by auto
    from 3 4 show    "(! x. A x) \<and> (! x . B x)" by rule
  next
    assume "(! x. A x) \<and> (! x . B x)"
    then show "(! x . A x \<and> B x )" by auto
qed

lemma "(! x . A x \<and> B x )= ((! x. A x) \<and> (! x . B x))"
proof
  assume 1:"(! x . A x \<and> B x )"
  show    "(! x. A x) \<and> (! x . B x)"
    proof -
    have 3:"! x .A x "
    proof
      fix x
      from 1 have 2: "(A x \<and> B x)" by rule
      then have "A x"  by rule
      show "A x" by fact
    qed
    from 1 have  4: "! x. B x" by auto
    from 3 4 show    "(! x. A x) \<and> (! x . B x)" by auto
 next
    oops

lemma wy333:"P \<and> ~ P \<Longrightarrow>False"
  apply (auto)
done

lemma "(~ (? x. A x)) = (! x . ~(A x))"
proof
  assume 1:"~ (? x. A x)"
  show "(! x . ~(A x))"
  proof
    fix x
    show " ~ (A x)"
    proof
      assume "A x"
      then have 2:" (? x. A x)" by rule
      from 1  2 show "False" by rule
    qed
  qed
next
  assume 1:"(! x . ~(A x))"
  show "~ (? x. A x)"
  proof
    assume "(? x. A x)"
    then obtain x where 2:"(A x)" by rule
    from 1 have 3:"~(A x)" by rule
    (*from 2 3 show  "False" by rule    ----doenst work*)
    from 3 2 show  "False" by rule
  qed
qed
lemma "(~ (! x. A x)) = (? x . ~(A x))"
proof -
  have "(~ (? x. A x)) = (! x . ~(A x))" by auto
  then have "(~(~ (? x. A x))) = (~(! x . ~(A x)))" by simp
  then have "(? x. A x) = (~(! x . ~(A x)))" by simp
  then have "(? x. (~ (A x)) ) = (~(! x . (A x)))" by simp
  then show "(~ (! x. A x)) = (? x . ~(A x))" by rule
qed

(* lemma "(! x . A \<or> B(x)) =A \<or>(! x. B x)"
proof
  assume 1: "(! x . A \<or> B(x))"
  fix x
  from 1  have "A \<or>( B x)" by rule
  then have "A \<or>(! x. B x)"
  proof
    assume "A"
    have "A" by fact
    then show "A \<or>(! x. B x)" by rule
  next
    assume 2:"( B x)"
    then have "(! x . B x)" by auto
    then show "A \<or>(! x. B x)" by rule
  qed
next *)

lemma "(! x . A \<or> B(x)) = (A \<or>(! x. B x))"
proof
  assume 1: "(! x . A \<or> B(x))"
  have "~A\<or>A" by rule
  then show "A \<or>(! x. B x)"
  proof
    assume 2:"~A"
    have "! x .B(x)"
    proof
      fix x
      from 1 have 3:"A\<or>B(x)" by rule
      from  2 3 show "B(x)" by simp
    qed
    then show "A \<or>(! x. B x)" by rule
  next
    assume 2:"A"
    have "A" by fact
    then show "A \<or>(! x. B x)" by rule
  qed
next
  assume 0:"(A \<or>(! x. B x))"
  have "~A\<or>A" by rule
  then show "(! x . A \<or> B(x))"
  proof
    assume A
    then show "(! x . A \<or> B(x))" by simp
  next
    assume 1: "~A"
    from 0 1 have 2:"(! x. B x)" by simp
    show "(! x . A \<or> B(x))"
    proof
      fix x
      from 2 have "B( x)" by rule
      then show "A \<or> B(x)" by rule
    qed
  qed
qed
lemma "(? x . A \<and> (B x)) =(A \<and> (? x . B x))"
proof
  assume "(? x . A \<and> (B x)) "
  then obtain x where 1: "A \<and> B x" by rule
  then have "B x" by rule
  then have 0:"? x . B x " by rule
  from 1  have "A" by rule
  from `A` 0 show "(A \<and> (? x . B x))" by rule
next
  assume 1: "(A \<and> (? x . B x))"
  then have A by rule
  from 1 have "(? x .(B x) )" by rule
  then obtain x where "B x" by rule
  from `A` `B x` have "A \<and> B(x)"  by rule
  then show "? x . A \<and> (B x)" by rule
qed
lemma temp:"(P\<longrightarrow>Q) = (~ P \<or>Q) " by simp
lemma temp2 :" (~ P \<or>Q) =(P\<longrightarrow>Q)" by simp
lemma temp3 :" (~ P \<or>Q) =(P\<longrightarrow>Q)" by simp

find_theorems "(~ ?P \<or>?Q) =(?P\<longrightarrow>?Q)"

thm temp
  thm temp2
lemma wy444:"(? x . A(x) \<longrightarrow>B(x)  ) =(  (! x .A (x) ) \<longrightarrow> (? x .B(x)) )"
proof -
  have 1:"(? x . A(x) \<longrightarrow>B(x)  ) = (? x.  ~ A x \<or> B x)"  by simp
  have 2:" (? x.  ~ A x \<or> B x) = ( (? x . ~ A x) \<or> (? x . B x) ) " by auto
  from 1  2 have 3:"(? x . A(x) \<longrightarrow>B(x)  ) =  ( (? x . ~ A x) \<or> (? x . B x) ) " by (simp)
  from 3 have 4: "(? x . A(x) \<longrightarrow>B(x)  ) =  ( ~(! x . A x) \<or> (? x . B x) ) "   by simp
  have 5:"( (~(! x . A x)) \<or> (? x . B x) ) = ( (! x .A (x) ) \<longrightarrow> (? x .B(x)) ) " by (rule temp2)
  from 4 5 show "(? x . A(x) \<longrightarrow>B(x)  ) = ( (! x .A (x) ) \<longrightarrow> (? x .B(x)) )" by simp
qed
print_claset
print_simpset
thm wy444

lemma "( (! x .A x ) \<longrightarrow>B ) = (? x . (A x \<longrightarrow>B))"
proof -
  have "( (! x .A x ) \<longrightarrow>B )  = ( ~(! x .A x ) \<or> B) " by auto
  then have "( (! x .A x ) \<longrightarrow>B ) = ( (? x . ~A x ) \<or> B)" by auto
  then have "( (! x .A x ) \<longrightarrow>B ) = ( (? x . (~A x)  \<or> B) )" by auto
  then show "( (! x .A x ) \<longrightarrow>B ) = (? x . (A x \<longrightarrow>B))" by auto
qed

lemma "( (? x .A x ) \<longrightarrow>B ) = (! x . (A x \<longrightarrow>B))" by auto

lemma "((? x .A x ) \<longrightarrow> (! x. B x) ) \<Longrightarrow> ! x .(A (x) \<longrightarrow>B(x) )"
proof -
  assume "(? x .A x ) \<longrightarrow> (! x. B x)"
  then have  "(~(? x .A x )) \<or> (! x. B x)" by blast
  then show " ! x .(A (x) \<longrightarrow>B(x) ) "
  proof
    assume "(~(? x .A x ))"
    then have 1:"! x . ~ (A x)"  by simp
    then show "! x .(A (x) \<longrightarrow>B(x) ) " by auto
  next
    assume  "(! x. B x)"
    then show "! x .(A (x) \<longrightarrow>B(x) ) " by auto
  qed
qed

lemma "((? x .A x ) \<longrightarrow> (! x. B x) ) \<Longrightarrow> ! x .(A (x) \<longrightarrow>B(x) )"
proof -
  assume "(? x .A x ) \<longrightarrow> (! x. B x)"
  then have  "(~(? x .A x )) \<or> (! x. B x)" by blast
  then show " ! x .(A (x) \<longrightarrow>B(x) ) "
  proof
    assume "(~(? x .A x ))"
    then have 1:"! x . ~ (A x)"  by simp
    show "! x .(A (x) \<longrightarrow>B(x) ) "
    proof
      fix x
      from 1 have "~(A x)" by rule
      then have 2: "~(A x) \<or> B x" by rule
      then show "(A x) \<longrightarrow> (B x)" by auto
    qed
  next
    assume  3:"(! x. B x)"
    show "! x .(A (x) \<longrightarrow>B(x) )"
    proof
      fix x
      from 3 have "B x" by rule
      then show "(A x) \<longrightarrow>(B x)" by rule
  qed
qed
qed

lemma drinker:"\<exists>x.( drunk x \<longrightarrow> (\<forall>x. drunk x) )"
proof -
  have "(\<exists> x.( drunk x \<longrightarrow> (\<forall>x. drunk x) ) ) = (\<exists> x.( ~ (drunk x) \<or> (\<forall>x. drunk x) ) )" by auto
  have "(\<exists> x.( ~ (drunk x) \<or> (\<forall>x. drunk x) ) ) =(\<exists> x.( ~ (drunk x)) \<or>(\<exists> x. (\<forall>x. drunk x) ) ) " by auto
  have "(\<exists> x. (\<forall>x. drunk x)) = ( \<forall>x. drunk x) " by auto
  have "(\<exists> x.( drunk x \<longrightarrow> (\<forall>x. drunk x) ) ) = (\<exists> x.( ~ (drunk x)))\<or> ( \<forall>x. drunk x)  " by auto
  have "(\<exists> x.( drunk x \<longrightarrow> (\<forall>x. drunk x) ) ) = (\<exists> x.( ~ (drunk x)))\<or> ~( ? x.~ drunk x)  " by auto
  then have "(\<exists> x.( drunk x \<longrightarrow> (\<forall>x. drunk x) ) ) =True" by auto
  then show "(\<exists> x.( drunk x \<longrightarrow> (\<forall>x. drunk x) ) )" by simp
qed

lemma pornp: "P \<or> ~P" by blast

theorem rich_grandfather: "\<forall>x. \<not> rich x \<longrightarrow> rich (father x) \<Longrightarrow>
  \<exists>x. rich x \<and> rich (father (father x))"
proof -
  assume 1:"\<forall>x. \<not> rich x \<longrightarrow> rich (father x)"
  then have 1:"\<forall>x. rich x \<or> rich (father x)" by (blast)
  have "(\<exists>x. rich x \<and> ~rich(father x) )  \<or> ~(\<exists>x. rich x \<and> ~rich(father x) )  " by (rule pornp)
  then show "\<exists>x. rich x \<and> rich (father (father x))"
  proof
    assume "(\<exists>x. rich x \<and> ~rich(father x) )"
    then obtain x where 3:"rich x \<and> ~rich(father x) " by rule
    then have 2:" ~rich(father x)" by rule
    from 1 2 have 4:"rich (father(father x))" by blast
    from 3 have 5:"rich x" by rule
    from 4 5 have "rich x \<and> rich (father (father x))" by  simp
    then show "\<exists>x. rich x \<and> rich (father (father x))" by rule
  next
    assume "~(\<exists>x. rich x \<and> ~rich(father x) )"
    then have 6:"! x. (rich x) \<longrightarrow>rich(father x)" by simp
    have 10:"(\<exists>x. rich x)"
    proof  (rule ccontr)  (* doenst work without this (rule ccontr) *)
      assume 8:"~ (\<exists>x. rich x)"
      then have "! x. (~ rich x)" by simp
      then obtain x where 7: "~ (rich x)" by rule
      from 7 1 have "rich (father x)" by blast
      then have 9:"(\<exists>x. rich x)" by rule
      from 8 9 show "False" by simp
    qed
    from 10 obtain x where 11:"rich x" by rule
    from 6 this have "rich(father x)" by simp
    from 6 this have "rich(father(father x) )" by simp
    from 11 this have "(rich x) \<and> rich(father(father x)) " by rule
    then show "\<exists>x. rich x \<and> rich (father (father x))" by rule
  qed
qed

 theorem rich_grandfather_again: "\<forall>x. \<not> rich x \<longrightarrow> rich (father x) \<Longrightarrow>
  \<exists>x. rich x \<and> rich (father (father x))"
proof -
  assume 1:"\<forall>x. \<not> rich x \<longrightarrow> rich (father x)"
  then have 1:"\<forall>x. rich x \<or> rich (father x)" by (blast)
  have "(\<exists>x. rich x \<and> ~rich(father x) )  \<or> ~(\<exists>x. rich x \<and> ~rich(father x) )  " by (rule pornp)
  then show "\<exists>x. rich x \<and> rich (father (father x))"
  proof
    assume "(\<exists>x. rich x \<and> ~rich(father x) )"
    then obtain x where 3:"rich x \<and> ~rich(father x) " by rule
    then have 2:" ~rich(father x)" by rule
    from 1 2 have 4:"rich (father(father x))" by blast
    from 3 have 5:"rich x" by rule
    from 4 5 have "rich x \<and> rich (father (father x))" by  simp
    then show "\<exists>x. rich x \<and> rich (father (father x))" by rule
  next
    assume "~(\<exists>x. rich x \<and> ~rich(father x) )"
    then have 6:"! x. (rich x) \<longrightarrow>rich(father x)" by simp
    have 10:"~~(\<exists>x. rich x)"  (* changed to not form *)
    proof
      assume 8:"~ (\<exists>x. rich x)"
      then have "! x. (~ rich x)" by simp
      then obtain x where 7: "~ (rich x)" by rule
      from 7 1 have "rich (father x)" by blast
      then have 9:"(\<exists>x. rich x)" by rule
      from 8 9 show "False" by simp
    qed
    from 10 have "(\<exists>x. rich x)" by simp
    then obtain x where 11:"rich x" by rule
    from 6 this have "rich(father x)" by simp
    from 6 this have "rich(father(father x) )" by simp
    from 11 this have "(rich x) \<and> rich(father(father x)) " by rule
    then show "\<exists>x. rich x \<and> rich (father (father x))" by rule
  qed
qed
lemma fake111:"! x y. ( x=(y::nat)) \<Longrightarrow> ! x y .~(x=y)" by auto

lemma " (x= (y::nat)) \<Longrightarrow> (p=(q::nat))" oops

(*
lemma fake222: "( x=(y::nat))" sorry
thm fake222

lemma fake333: "(1::nat) = 2" by (rule fake222)
lemma fake444: "~( x=(y::nat))"
  proof -
    have 1:"~((1::nat) =2)" by auto
    have 2:"(1::nat) = 2" by (rule fake333)
    from 1 2 have "False" by auto
    then show  "~( x=(y::nat))" by auto
  qed
*)

(* play with set notation *)
lemma "{1} : {{1}}" by auto

lemma " (~( P=Q) )  = ( P = (~ Q) )" by auto
lemma "! P Q. (~( P=Q) )  = ( P = (~ Q) )" by auto
lemma "(! P Q. (~( P=Q) ) ) = (! P Q . ( P = (~ Q) ))" by auto
lemma "(~(! P Q. (( P=Q) ) )) = (! P Q . ( P = (~ Q) ))" oops

lemma " (~( P x =Q x) )  = ( P x = (~ Q x ))" by auto
lemma " ! x . (~( P x =Q x) )  = ( P x = (~ Q x ))" by auto
lemma " (! x . (~( P x =Q x) ))  =(! x . ( P x = (~ Q x )) )" by auto
lemma " ~(! x . (( P x =Q x) ))  =(! x . ( P x = (~ Q x )) )" oops
lemma "(1::nat) : {x::nat . x=x}" by auto

lemma "(! x . (P x) \<longrightarrow>  (Q x)) \<Longrightarrow>(! x . ~(Q x)\<longrightarrow> ~(P x)) " by auto

lemma "( ! x y::nat . x = y ) \<Longrightarrow> ( ! x y . \<not> (x = y) )"  by auto

lemma "( \<And> x y .x = ( y::nat) ) \<Longrightarrow> ( \<not> (x = y) )"  by auto

lemma "( x = ( y::nat) ) \<Longrightarrow> ( \<not> (x = y) )"  by sorry

lemma " ( \<And> x .P x) \<Longrightarrow> ( \<And> x. (\<And> x. P x) )" by auto

lemma " P \<Longrightarrow> (\<And> x. P)" by auto

lemma " P x \<Longrightarrow> (\<forall> x. P x)" by auto

lemma " f \<equiv> g \<Longrightarrow> f x \<equiv> g x" by auto

lemma "   f x \<equiv> g x \<Longrightarrow> f \<equiv> g" by auto
lemma " (\<And> x.  f x \<equiv> g x) \<Longrightarrow> f \<equiv> g" by auto

lemma " (\<And> x. P x) \<Longrightarrow> (P x)" by auto

lemma t1:"(PP::nat list\<Rightarrow> bool)[]" sorry

lemma t2:" (PP::nat list\<Rightarrow> bool)[] \<Longrightarrow> PP ( x#[])" sorry

lemma t3: "PP (x#[])"
proof -
  from t1 t2 show "PP(x#[])"  by auto
qed

lemma "\<And> x. PP (x#[])" by (auto simp add:t3)

lemma t4: "F x"  sorry

lemma t5: "\<And> x F .F x" using t4 by auto

lemma t6: "F x \<Longrightarrow> (\<And> F x . F x)" by auto

notepad
begin
  {
    assume " (x= (y::int))"
    then have "(1::int) =(2::int)" by auto

  have "!X Y.(X\<longrightarrow>Y) = ((~ X) \<or>Y) " by simp
  have "( (~(! x . A (x))) \<or> (? x . B( x)) ) = ( (! x .A (x) ) \<longrightarrow> (? x .B(x)) ) " by auto
}

end