(*  File:       Evaluation_Function.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Evaluation Function\<close>

theory Evaluation_Function
  imports "Social_Choice_Types/Profile"
begin

text
\<open>This is the evaluation function. From a set of currently eligible alternatives,
the evaluation function computes a numerical value that is then to be used for
further (s)election, e.g., by the elimination module.\<close>

subsection \<open>Definition\<close>

type_synonym 'a Evaluation_Function = "'a  \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> nat"

subsection \<open>Property\<close>

(*
   An Evaluation function is Condorcet-rating iff the following holds:
   If a Condorcet Winner w exists, w and only w has the highest value.
*)
definition condorcet_rating :: "'a Evaluation_Function \<Rightarrow> bool" where
  "condorcet_rating f \<equiv>
    \<forall>A p w . condorcet_winner A p w \<longrightarrow>
      (\<forall>l \<in> A . l \<noteq> w \<longrightarrow> f l A p < f w A p)"

subsection \<open>Theorems\<close>

(*
   If e is Condorcet-rating, the following holds:
   If a Condorcet Winner w exists, w has the maximum evaluation value.
*)
theorem cond_winner_imp_max_eval_val:
  assumes
    rating: "condorcet_rating e" and
    f_prof: "finite_profile A p" and
    winner: "condorcet_winner A p w"
  shows "e w A p = Max {e a A p | a. a \<in> A}"
proof -
  (*
    lemma eq_max_iff: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow>
        m = Max A  \<longleftrightarrow>  m \<in> A \<and> (\<forall>a \<in> A. a \<le> m)"
  *)
  let ?set = "{e a A p | a. a \<in> A}" and
      ?eMax = "Max {e a A p | a. a \<in> A}" and
      ?eW = "e w A p"
  (*finite A*)
  from f_prof have 0: "finite ?set"
    by simp
  (*2. non-empty A*)
  have 1: "?set \<noteq> {}"
    using condorcet_winner.simps winner
    by fastforce
  (*3. m \<in> A*)
  have 2: "?eW \<in> ?set"
    using CollectI condorcet_winner.simps winner
    by (metis (mono_tags, lifting))
  (*4. (\<forall>a \<in> A. a \<le> m)*)
  have 3: "\<forall> e \<in> ?set . e \<le> ?eW"
  proof (safe)
    fix a :: "'a"
    assume aInA: "a \<in> A"
    have "\<forall>n na. (n::nat) \<noteq> na \<or> n \<le> na"
      by simp
    with aInA show "e a A p \<le> e w A p"
      using condorcet_rating_def
            less_imp_le rating winner
      by (metis (no_types))
  qed
  (*Result*)
  from 2 3 have 4:
    "?eW \<in> ?set \<and> (\<forall>a \<in> ?set. a \<le> ?eW)"
    by blast
  from 0 1 4 Max_eq_iff
  show ?thesis
    by (metis (no_types, lifting))
qed

(*
   If e is Condorcet-rating, the following holds:
   If a Condorcet Winner w exists, a non-Condorcet
   winner has a value lower than the maximum
   evaluation value.
*)
theorem non_cond_winner_not_max_eval:
  assumes
    rating: "condorcet_rating e" and
    f_prof: "finite_profile A p" and
    winner: "condorcet_winner A p w" and
    linA: "l \<in> A" and
    loser: "w \<noteq> l"
  shows "e l A p < Max {e a A p | a. a \<in> A}"
proof -
  have "e l A p < e w A p"
    using condorcet_rating_def linA loser rating winner
    by metis
  also have "e w A p = Max {e a A p |a. a \<in> A}"
    using cond_winner_imp_max_eval_val f_prof rating winner
    by fastforce
  finally show ?thesis
    by simp
qed

end


theory CS_Ch3_Ex4
imports Main
begin

type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp | Times aexp aexp
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a1 a2) s = aval a1 s + aval a2 s" |
"aval (Times a1 a2) s = aval a1 s * aval a2 s"

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i1) (N i2) = N (i1 + i2)" |
"plus (N i) a = (if i = 0 then a else Plus (N i) a)" |
"plus a (N i) = (if i = 0 then a else Plus a (N i))" |
"plus a1 a2 = Plus a1 a2"

lemma aval_plus: "aval (plus a1 a2) s = aval a1 s + aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply(auto)
done

fun times :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"times (N i1) (N i2) = N (i1 * i2)" |
"times (N i) a = (if i = 0 then (N 0) else if i = 1 then a else Times (N i) a)" |
"times a (N i) = (if i = 0 then (N 0) else if i = 1 then a else Times (N i) a)" |
"times a b = Times a b"

lemma aval_times: "aval (times a1 a2) s = aval a1 s * aval a2 s"
apply(induction a1 a2 rule: times.induct)
apply(auto)
done

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)" |
"asimp (Times a1 a2) = times (asimp a1) (asimp a2)"

lemma "aval (asimp a) s = aval a s"
apply(induction a)
apply(auto simp add: aval_plus aval_times)
done

end


(* Author: Tobias Nipkow *)

theory Def_Init_Exp
imports Vars
begin

subsection "Initialization-Sensitive Expressions Evaluation"

type_synonym state = "vname \<Rightarrow> val option"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val option" where
"aval (N i) s = Some i" |
"aval (V x) s = s x" |
"aval (Plus a\<^sub>1 a\<^sub>2) s =
  (case (aval a\<^sub>1 s, aval a\<^sub>2 s) of
     (Some i\<^sub>1,Some i\<^sub>2) \<Rightarrow> Some(i\<^sub>1+i\<^sub>2) | _ \<Rightarrow> None)"

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool option" where
"bval (Bc v) s = Some v" |
"bval (Not b) s = (case bval b s of None \<Rightarrow> None | Some bv \<Rightarrow> Some(\<not> bv))" |
"bval (And b\<^sub>1 b\<^sub>2) s = (case (bval b\<^sub>1 s, bval b\<^sub>2 s) of
  (Some bv\<^sub>1, Some bv\<^sub>2) \<Rightarrow> Some(bv\<^sub>1 & bv\<^sub>2) | _ \<Rightarrow> None)" |
"bval (Less a\<^sub>1 a\<^sub>2) s = (case (aval a\<^sub>1 s, aval a\<^sub>2 s) of
 (Some i\<^sub>1, Some i\<^sub>2) \<Rightarrow> Some(i\<^sub>1 < i\<^sub>2) | _ \<Rightarrow> None)"

lemma aval_Some: "vars a \<subseteq> dom s \<Longrightarrow> \<exists> i. aval a s = Some i"
by (induct a) auto

lemma bval_Some: "vars b \<subseteq> dom s \<Longrightarrow> \<exists> bv. bval b s = Some bv"
by (induct b) (auto dest!: aval_Some)

end


theory SFHOL imports Main
begin

(* A nonpolymorphic Embedding of Supervaluational Free Higher-Order Logic (SFHOL) in HOL *)

text \<open> Negative Free Higher-Order Modal Logic \<close>

  (* A nonpolymorphic Embedding of Negative Free Higher-Order Modal Logic (NgFHOML) in HOL *)

  typedecl i (* — Type for individuals *)
  typedecl w (* — Type of possible worlds *)
  type_synonym \<mu> = "w \<Rightarrow> bool" (* — Type of world depended formulas *)

  consts fExistenceI :: "i \<Rightarrow> \<mu>" ("E\<^sup>i") (* — Existence/definedness predicate for individuals *)
  consts fExistenceP :: "(i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" ("E\<^sup>p") (* — Existence/definedness predicate for predicates *)

  consts r :: "w \<Rightarrow> w \<Rightarrow> bool" (infixr "r" 53) (* — Accessibility relation between worlds *)

  (* Conditions on the accessibility relation *)
  abbreviation reflexive :: "bool"
    where "reflexive \<equiv> \<forall>x. x r x"
  abbreviation transitive :: "bool"
    where "transitive \<equiv> \<forall>x y z. (x r y) \<and> (y r z) \<longrightarrow> (x r z)"
  abbreviation mcKinseysAxiom :: "bool"
    where "mcKinseysAxiom \<equiv> \<forall>x. \<exists>y. (x r y) \<and> (\<forall>z. (y r z) \<longrightarrow> y = z)"
  axiomatization where S41:
    "reflexive \<and> transitive \<and> mcKinseysAxiom"

  axiomatization where nestedDomains: (* — Nested domains property: If some object exists at a world w, then it also exists in all from w reachable worlds *)
    "\<forall>x y. x r y \<longrightarrow> (\<forall>z. E\<^sup>i z x \<longrightarrow> E\<^sup>i z y)"
  (* axiomatization where Ax2: "\<exists>x. \<forall>y. x r y" *) (* — There exists a world from which every world is reachable *)
  (* axiomatization where Ax3: "\<forall>x y. x r y \<longrightarrow> (\<forall>z. ((E\<^sup>i z x) \<and> (P z x)) \<longrightarrow> (P z y))" *) (* — If some existent object in a world w has property P, this object has the same property in all from w reachable worlds *)

  definition fmIdentity :: "i \<Rightarrow> i \<Rightarrow> \<mu>" (infixr "\<^bold>=\<^sub>f\<^sub>m" 56) (* — Free modal identity *)
    where "\<phi> \<^bold>=\<^sub>f\<^sub>m \<psi> \<equiv> \<lambda>w. \<phi> = \<psi>"

  definition fmNot :: "\<mu> \<Rightarrow> \<mu>" ("\<^bold>\<not>\<^sub>f\<^sub>m_" [52]53) (* — Free modal negation *)
    where "\<^bold>\<not>\<^sub>f\<^sub>m\<phi> \<equiv> \<lambda>w. \<not>(\<phi> w)"
  definition fmOr :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu>" (infixr "\<^bold>\<or>\<^sub>f\<^sub>m" 51) (* — Free modal disjunction *)
    where "\<phi> \<^bold>\<or>\<^sub>f\<^sub>m \<psi> \<equiv> \<lambda>w. \<phi> w \<or> \<psi> w"

  definition fmBox :: "\<mu> \<Rightarrow> \<mu>" ("\<^bold>\<box>_" [52]53) (* — Free modal necessity *)
    where "\<^bold>\<box>\<phi> \<equiv> \<lambda>w. \<forall>v. w r v \<longrightarrow> \<phi> v"

  definition fmForallI :: "(i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" ("\<^bold>\<forall>\<^sup>i\<^sub>f\<^sub>m") (* — Free modal universal quantification over individuals guarded by predicate E *)
    where "\<^bold>\<forall>\<^sup>i\<^sub>f\<^sub>m\<Phi> \<equiv> \<lambda>w. \<forall>x. E\<^sup>i x w \<longrightarrow> \<Phi> x w"
  definition fmForallIBinder:: "(i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" (binder "\<^bold>\<forall>\<^sup>i\<^sub>f\<^sub>m" [8]9) (* — Binder notation *)
    where "\<^bold>\<forall>\<^sup>i\<^sub>f\<^sub>mx. \<phi> x \<equiv> \<^bold>\<forall>\<^sup>i\<^sub>f\<^sub>m\<phi>"
  definition fmForallP :: "((i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" ("\<^bold>\<forall>\<^sup>p\<^sub>f\<^sub>m") (* — Free modal universal quantification over predicates guarded by predicate E *)
    where "\<^bold>\<forall>\<^sup>p\<^sub>f\<^sub>m\<Phi> \<equiv> \<lambda>w. \<forall>x. E\<^sup>p x w \<longrightarrow> \<Phi> x w"
  definition fmForallPBinder:: "((i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" (binder "\<^bold>\<forall>\<^sup>p\<^sub>f\<^sub>m" [8]9) (* — Binder notation *)
    where "\<^bold>\<forall>\<^sup>p\<^sub>f\<^sub>mx. \<phi> x \<equiv> \<^bold>\<forall>\<^sup>p\<^sub>f\<^sub>m\<phi>"

  definition fmPredicateI :: "(i \<Rightarrow> \<mu>) \<Rightarrow> i \<Rightarrow> \<mu>" ("\<^sup>f\<^sup>m") (* — Free modal predicate guarded by predicate E *)
     where "\<^sup>f\<^sup>mP x \<equiv>  \<lambda>w. E\<^sup>i x w \<and> P x w"

  definition fmValid :: "\<mu> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>\<^sub>f\<^sub>m" [7]8) (* — Validity of lifted free modal formulas *)
    where "\<lfloor>\<phi>\<rfloor>\<^sub>f\<^sub>m \<equiv> \<forall>w. \<phi> w"

  text \<open> Further logical constants can be defined as usual \<close>

  definition fmAnd :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu>" (infixr "\<^bold>\<and>\<^sub>f\<^sub>m" 52) (* — Free modal conjunction *)
    where "\<phi> \<^bold>\<and>\<^sub>f\<^sub>m \<psi> \<equiv> \<^bold>\<not>\<^sub>f\<^sub>m(\<^bold>\<not>\<^sub>f\<^sub>m\<phi> \<^bold>\<or>\<^sub>f\<^sub>m \<^bold>\<not>\<^sub>f\<^sub>m\<psi>)"
  definition fmImp :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu>" (infixr "\<^bold>\<rightarrow>\<^sub>f\<^sub>m" 49) (* — Free modal implication *)
    where "\<phi> \<^bold>\<rightarrow>\<^sub>f\<^sub>m \<psi> \<equiv> \<^bold>\<not>\<^sub>f\<^sub>m\<phi> \<^bold>\<or>\<^sub>f\<^sub>m \<psi>"
  definition fmEquiv :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu>" (infixr "\<^bold>\<leftrightarrow>\<^sub>f\<^sub>m" 50) (* — Free modal equivalence *)
    where "\<phi> \<^bold>\<leftrightarrow>\<^sub>f\<^sub>m \<psi> \<equiv> \<phi> \<^bold>\<rightarrow>\<^sub>f\<^sub>m \<psi> \<^bold>\<and>\<^sub>f\<^sub>m \<psi> \<^bold>\<rightarrow>\<^sub>f\<^sub>m \<phi>"

  definition fmDia :: "\<mu> \<Rightarrow> \<mu>" ("\<^bold>\<diamond>_" [52]53) (* — Free modal possibility *)
    where "\<^bold>\<diamond>\<phi> \<equiv> \<^bold>\<not>\<^sub>f\<^sub>m(\<^bold>\<box>(\<^bold>\<not>\<^sub>f\<^sub>m\<phi>))"

  definition fmExistsI :: "(i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" ("\<^bold>\<exists>\<^sup>i\<^sub>f\<^sub>m") (* — Free modal existential quantification over individuals *)
    where "\<^bold>\<exists>\<^sup>i\<^sub>f\<^sub>m\<Phi> \<equiv> \<^bold>\<not>\<^sub>f\<^sub>m(\<^bold>\<forall>\<^sup>i\<^sub>f\<^sub>m(\<lambda>y. \<^bold>\<not>\<^sub>f\<^sub>m(\<Phi> y)))"
  definition fmExistsIBinder :: "(i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" (binder "\<^bold>\<exists>\<^sup>i\<^sub>f\<^sub>m" [8]9) (* — Binder notation *)
    where "\<^bold>\<exists>\<^sup>i\<^sub>f\<^sub>mx. \<phi> x \<equiv> \<^bold>\<exists>\<^sup>i\<^sub>f\<^sub>m\<phi>"
  definition fmExistsP :: "((i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" ("\<^bold>\<exists>\<^sup>p\<^sub>f\<^sub>m") (* — Free modal existential quantification over predicates *)
    where "\<^bold>\<exists>\<^sup>p\<^sub>f\<^sub>m\<Phi> \<equiv> \<^bold>\<not>\<^sub>f\<^sub>m(\<^bold>\<forall>\<^sup>p\<^sub>f\<^sub>m(\<lambda>y. \<^bold>\<not>\<^sub>f\<^sub>m(\<Phi> y)))"
  definition fmExistsPBinder :: "((i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" (binder "\<^bold>\<exists>\<^sup>p\<^sub>f\<^sub>m" [8]9) (* — Binder notation *)
    where "\<^bold>\<exists>\<^sup>p\<^sub>f\<^sub>mx. \<phi> x \<equiv> \<^bold>\<exists>\<^sup>p\<^sub>f\<^sub>m\<phi>"

  (* Introducing "Defs" as the set of the above definitions; useful for convenient unfolding *)
  named_theorems Defs declare fmIdentity_def[Defs] fmNot_def[Defs] fmOr_def[Defs]
    fmForallI_def[Defs] fmForallIBinder_def[Defs] fmForallP_def[Defs] fmForallPBinder_def[Defs]
    fmPredicateI_def[Defs] fmBox_def[Defs] fmAnd_def[Defs] fmImp_def[Defs] fmEquiv_def[Defs]
    fmExistsI_def[Defs] fmExistsIBinder_def[Defs] fmExistsP_def[Defs] fmExistsPBinder_def[Defs]
    fmDia_def[Defs] fmValid_def[Defs]

text \<open> Some Tests \<close>

  lemma Kf: "\<lfloor>(\<^bold>\<box>((\<^sup>f\<^sup>m\<phi> x) \<^bold>\<rightarrow>\<^sub>f\<^sub>m (\<^sup>f\<^sup>m\<psi> x))) \<^bold>\<rightarrow>\<^sub>f\<^sub>m ((\<^bold>\<box>(\<^sup>f\<^sup>m\<phi> x)) \<^bold>\<rightarrow>\<^sub>f\<^sub>m (\<^bold>\<box>(\<^sup>f\<^sup>m\<psi> x)))\<rfloor>\<^sub>f\<^sub>m" unfolding Defs by blast (* — Verifying K principle *)
  lemma NECf: "\<lfloor>\<^sup>f\<^sup>m\<phi> x\<rfloor>\<^sub>f\<^sub>m \<Longrightarrow> \<lfloor>\<^bold>\<box>(\<^sup>f\<^sup>m\<phi> x)\<rfloor>\<^sub>f\<^sub>m" unfolding Defs by blast (* — Verifying necessitation rule *)

  lemma "\<lfloor>(\<^bold>\<forall>\<^sup>i\<^sub>f\<^sub>mx. \<^sup>f\<^sup>mP x) \<^bold>\<rightarrow>\<^sub>f\<^sub>m (\<^sup>f\<^sup>mP x)\<rfloor>\<^sub>f\<^sub>m" nitpick [user_axioms=true, show_all, format=2, card w=3] oops (* properly invalid *)
  lemma "\<lfloor>((\<^bold>\<forall>\<^sup>i\<^sub>f\<^sub>mx. (\<^sup>f\<^sup>mP x)) \<^bold>\<and>\<^sub>f\<^sub>m (E\<^sup>i x)) \<^bold>\<rightarrow>\<^sub>f\<^sub>m (\<^sup>f\<^sup>mP x)\<rfloor>\<^sub>f\<^sub>m" unfolding Defs by blast (* properly valid *)

  lemma "\<lfloor>(\<^sup>f\<^sup>mP x) \<^bold>\<rightarrow>\<^sub>f\<^sub>m (\<^bold>\<exists>\<^sup>i\<^sub>f\<^sub>mx. \<^sup>f\<^sup>mP x)\<rfloor>\<^sub>f\<^sub>m" unfolding Defs by blast (* properly valid *)
  lemma "\<lfloor>(\<^sup>f\<^sup>mP x) \<^bold>\<rightarrow>\<^sub>f\<^sub>m (E\<^sup>i x)\<rfloor>\<^sub>f\<^sub>m" unfolding Defs by blast (* properly valid *)
  lemma "\<lfloor>(\<^sup>f\<^sup>mP x) \<^bold>\<and>\<^sub>f\<^sub>m (\<^bold>\<exists>\<^sup>i\<^sub>f\<^sub>mx. \<^sup>f\<^sup>mP x)\<rfloor>\<^sub>f\<^sub>m" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)

  lemma "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>\<^sup>i\<^sub>f\<^sub>mx. E\<^sup>i x)\<rfloor>\<^sub>f\<^sub>m" unfolding Defs by simp (* properly valid *)
  lemma "\<lfloor>\<^bold>\<box>(E\<^sup>i x)\<rfloor>\<^sub>f\<^sub>m" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "\<lfloor>\<^bold>\<forall>\<^sup>i\<^sub>f\<^sub>mx. \<^bold>\<box>(E\<^sup>i x)\<rfloor>\<^sub>f\<^sub>m" unfolding Defs using nestedDomains by blast (* properly valid *)
  lemma "\<lfloor>(\<^bold>\<box>(\<^bold>\<forall>\<^sup>i\<^sub>f\<^sub>mx. \<^sup>f\<^sup>mP x)) \<^bold>\<leftrightarrow>\<^sub>f\<^sub>m (\<^bold>\<forall>\<^sup>i\<^sub>f\<^sub>mx. \<^bold>\<box>(\<^sup>f\<^sup>mP x))\<rfloor>\<^sub>f\<^sub>m" unfolding Defs by blast (* properly valid *)

  lemma "\<lfloor>(a \<^bold>=\<^sub>f\<^sub>m b) \<^bold>\<rightarrow>\<^sub>f\<^sub>m (\<^bold>\<box>(a \<^bold>=\<^sub>f\<^sub>m b))\<rfloor>\<^sub>f\<^sub>m" unfolding Defs by simp (* properly valid *)

text \<open> Supervaluational Free Higher-Order Logic \<close>

  definition sIdentity :: "i \<Rightarrow> i \<Rightarrow> \<mu>" (infixr "\<^bold>=\<^sub>s" 56) (* — Supervaluational free identity *)
    where "\<phi> \<^bold>=\<^sub>s \<psi> \<equiv> \<phi> \<^bold>=\<^sub>f\<^sub>m \<psi>"

  definition sNot :: "\<mu> \<Rightarrow> \<mu>" ("\<^bold>\<not>\<^sub>s_" [52]53) (* — Supervaluational free negation *)
    where "\<^bold>\<not>\<^sub>s\<phi> \<equiv> \<^bold>\<not>\<^sub>f\<^sub>m\<phi>"
  definition sOr :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu>" (infixr "\<^bold>\<or>\<^sub>s" 51) (* — Supervaluational free disjunction *)
    where "\<phi> \<^bold>\<or>\<^sub>s \<psi> \<equiv> \<phi> \<^bold>\<or>\<^sub>f\<^sub>m \<psi>"

  definition sForallI :: "(i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" ("\<^bold>\<forall>\<^sup>i\<^sub>s") (* — Supervaluational free universal quantification over individuals *)
    where "\<^bold>\<forall>\<^sup>i\<^sub>s\<Phi> \<equiv> \<^bold>\<forall>\<^sup>i\<^sub>f\<^sub>mx. \<Phi> x"
  definition sForallIBinder:: "(i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" (binder "\<^bold>\<forall>\<^sup>i\<^sub>s" [8]9) (* — Binder notation *)
    where "\<^bold>\<forall>\<^sup>i\<^sub>sx. \<phi> x \<equiv> \<^bold>\<forall>\<^sup>i\<^sub>s\<phi>"
  definition sForallP :: "((i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" ("\<^bold>\<forall>\<^sup>p\<^sub>s") (* — Supervaluational free universal quantification over predicates *)
    where "\<^bold>\<forall>\<^sup>p\<^sub>s\<Phi> \<equiv> \<^bold>\<forall>\<^sup>p\<^sub>f\<^sub>mx. \<Phi> x"
  definition sForallPBinder:: "((i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" (binder "\<^bold>\<forall>\<^sup>p\<^sub>s" [8]9) (* — Binder notation *)
    where "\<^bold>\<forall>\<^sup>p\<^sub>sx. \<phi> x \<equiv> \<^bold>\<forall>\<^sup>p\<^sub>s\<phi>"

  definition sPredicateI :: "(i \<Rightarrow> \<mu>) \<Rightarrow> i \<Rightarrow> \<mu>" ("\<^sup>s") (* — Supervaluational free predicate *)
    where "\<^sup>sP x \<equiv> (E\<^sup>i x \<^bold>\<rightarrow>\<^sub>f\<^sub>m (\<^sup>f\<^sup>mP x)) \<^bold>\<and>\<^sub>f\<^sub>m (\<^bold>\<not>\<^sub>f\<^sub>m(E\<^sup>i x) \<^bold>\<rightarrow>\<^sub>f\<^sub>m (\<^bold>\<box>(\<^bold>\<diamond>(\<^sup>f\<^sup>mP x))))"

  text \<open> Further logical constants can be defined as usual \<close>

  definition sAnd :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu>" (infixr "\<^bold>\<and>\<^sub>s" 52) (* — Supervaluational free conjunction *)
    where "\<phi> \<^bold>\<and>\<^sub>s \<psi> \<equiv> \<^bold>\<not>\<^sub>s(\<^bold>\<not>\<^sub>s\<phi> \<^bold>\<or>\<^sub>s \<^bold>\<not>\<^sub>s\<psi>)"
  definition sImp :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu>" (infixr "\<^bold>\<rightarrow>\<^sub>s" 49) (* — Supervaluational free implication *)
    where "\<phi> \<^bold>\<rightarrow>\<^sub>s \<psi> \<equiv> \<^bold>\<not>\<^sub>s\<phi> \<^bold>\<or>\<^sub>s \<psi>"
  definition sEquiv :: "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<mu>" (infixr "\<^bold>\<leftrightarrow>\<^sub>s" 50) (* — Supervaluational free equivalence *)
    where "\<phi> \<^bold>\<leftrightarrow>\<^sub>s \<psi> \<equiv> \<phi> \<^bold>\<rightarrow>\<^sub>s \<psi> \<^bold>\<and>\<^sub>s \<psi> \<^bold>\<rightarrow>\<^sub>s \<phi>"

  definition sExistsI :: "(i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" ("\<^bold>\<exists>\<^sup>i\<^sub>s") (* — Supervaluational free existential quantification over individuals *)
    where "\<^bold>\<exists>\<^sup>i\<^sub>s\<Phi> \<equiv> \<^bold>\<not>\<^sub>s(\<^bold>\<forall>\<^sup>i\<^sub>s(\<lambda>y. \<^bold>\<not>\<^sub>s(\<Phi> y)))"
  definition sExistsIBinder :: "(i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" (binder "\<^bold>\<exists>\<^sup>i\<^sub>s" [8]9) (* — Binder notation *)
    where "\<^bold>\<exists>\<^sup>i\<^sub>sx. \<phi> x \<equiv> \<^bold>\<exists>\<^sup>i\<^sub>s\<phi>"
  definition sExistsP :: "((i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" ("\<^bold>\<exists>\<^sup>p\<^sub>s") (* — Supervaluational free existential quantification over predicates *)
    where "\<^bold>\<exists>\<^sup>p\<^sub>s\<Phi> \<equiv> \<^bold>\<not>\<^sub>s(\<^bold>\<forall>\<^sup>p\<^sub>s(\<lambda>y. \<^bold>\<not>\<^sub>s(\<Phi> y)))"
  definition sExistsPBinder :: "((i \<Rightarrow> \<mu>) \<Rightarrow> \<mu>) \<Rightarrow> \<mu>" (binder "\<^bold>\<exists>\<^sup>p\<^sub>s" [8]9) (* — Binder notation *)
    where "\<^bold>\<exists>\<^sup>p\<^sub>sx. \<phi> x \<equiv> \<^bold>\<exists>\<^sup>p\<^sub>s\<phi>"

  definition sValid :: "\<mu> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>\<^sub>s" [7]8) (* — Validity of supervaluational free formulas *)
    where "\<lfloor>\<phi>\<rfloor>\<^sub>s \<equiv> \<forall>w. \<phi> w"

  declare sIdentity_def[Defs] sNot_def[Defs] sOr_def[Defs] sForallI_def[Defs]
    sForallIBinder_def[Defs] sForallP_def[Defs] sForallPBinder_def[Defs] sPredicateI_def[Defs]
    sAnd_def[Defs] sImp_def[Defs] sEquiv_def[Defs] sExistsI_def[Defs] sExistsIBinder_def[Defs]
    sExistsP_def[Defs] sExistsPBinder_def[Defs] sValid_def[Defs]

text \<open> Some Tests \<close>

  lemma "\<lfloor>(\<^bold>\<forall>\<^sup>i\<^sub>sx. \<^sup>sP x) \<^bold>\<rightarrow>\<^sub>s (\<^sup>sP x)\<rfloor>\<^sub>s" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "\<lfloor>((\<^bold>\<forall>\<^sup>i\<^sub>sx. (\<^sup>sP x)) \<^bold>\<and>\<^sub>s (E\<^sup>i x)) \<^bold>\<rightarrow>\<^sub>s (\<^sup>sP x)\<rfloor>\<^sub>s" unfolding Defs by blast (* properly valid *)

  lemma "\<lfloor>(\<^sup>sP x) \<^bold>\<rightarrow>\<^sub>s (\<^bold>\<exists>\<^sup>i\<^sub>sx. \<^sup>sP x)\<rfloor>\<^sub>s" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "\<lfloor>((\<^sup>sP x) \<^bold>\<and>\<^sub>s (E\<^sup>i x)) \<^bold>\<rightarrow>\<^sub>s (\<^bold>\<exists>\<^sup>i\<^sub>sx. \<^sup>sP x)\<rfloor>\<^sub>s" unfolding Defs by blast (* properly valid *)
  lemma "\<lfloor>(\<^sup>sP x) \<^bold>\<rightarrow>\<^sub>s (E\<^sup>i x)\<rfloor>\<^sub>s" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "\<lfloor>(\<^sup>sP x) \<^bold>\<and>\<^sub>s (\<^bold>\<exists>\<^sup>i\<^sub>sx. \<^sup>sP x)\<rfloor>\<^sub>s" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)

  lemma "\<lfloor>(\<^sup>sP x) \<^bold>\<or>\<^sub>s (\<^bold>\<not>\<^sub>s(\<^sup>sP x))\<rfloor>\<^sub>s" unfolding Defs by blast (* properly valid *)
  lemma "\<lfloor>(\<^sup>sP x) \<^bold>\<and>\<^sub>s (\<^bold>\<not>\<^sub>s(\<^sup>sP x))\<rfloor>\<^sub>s" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "\<lfloor>\<^bold>\<not>\<^sub>s((\<^sup>sP x) \<^bold>\<and>\<^sub>s (\<^bold>\<not>\<^sub>s(\<^sup>sP x)))\<rfloor>\<^sub>s" unfolding Defs by blast (* properly valid *)

  lemma "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>\<^sup>i\<^sub>sx. E\<^sup>i x)\<rfloor>\<^sub>s" unfolding Defs by simp (* properly valid *)
  lemma "\<lfloor>\<^bold>\<box>(E\<^sup>i x)\<rfloor>\<^sub>s" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "\<lfloor>\<^bold>\<forall>\<^sup>i\<^sub>sx. \<^bold>\<box>(E\<^sup>i x)\<rfloor>\<^sub>s" unfolding Defs by (simp add: nestedDomains) (* properly valid *)
  lemma "\<lfloor>(\<^bold>\<box>(\<^bold>\<forall>\<^sup>i\<^sub>sx. \<^sup>sP x)) \<^bold>\<leftrightarrow>\<^sub>s (\<^bold>\<forall>\<^sup>i\<^sub>sx. \<^bold>\<box>(\<^sup>sP x))\<rfloor>\<^sub>s" unfolding Defs by blast (* properly valid *)

  lemma "\<lfloor>(a \<^bold>=\<^sub>s b) \<^bold>\<rightarrow>\<^sub>s (\<^bold>\<box>(a \<^bold>=\<^sub>s b))\<rfloor>\<^sub>s" unfolding Defs by simp (* properly valid *)

  consts sIndividual1 :: "i" ("i\<^sub>1")
  axiomatization where sUndefIndividual1Axiom: "\<exists>w. \<not>(E\<^sup>i i\<^sub>1 w)"

  lemma "\<lfloor>x \<^bold>=\<^sub>s x\<rfloor>\<^sub>s" unfolding Defs by simp (* properly valid *)
  lemma "\<lfloor>i\<^sub>1 \<^bold>=\<^sub>s i\<^sub>1\<rfloor>\<^sub>s" unfolding Defs by simp (* properly valid *)

  lemma "\<lfloor>\<^sup>sP i\<^sub>1\<rfloor>\<^sub>s" nitpick [user_axioms=true, show_all, format=2] nitpick [satisfy, user_axioms=true, show_all, format=2, card w=2] oops (* should be truth-valueless *)
  lemma "\<lfloor>\<^bold>\<not>\<^sub>s(\<^sup>sP i\<^sub>1)\<rfloor>\<^sub>s" nitpick [user_axioms=true, show_all, format=2] nitpick [satisfy, user_axioms=true, show_all, format=2] oops (* should be truth-valueless *)
  lemma "(\<lfloor>(\<^sup>sP i\<^sub>1) \<^bold>\<or>\<^sub>s (\<^bold>\<not>\<^sub>s(\<^sup>sP i\<^sub>1))\<rfloor>\<^sub>s)" unfolding Defs nitpick [satisfy, user_axioms=true, show_all, format=2] by blast (* properly valid *)
  lemma "(\<lfloor>(\<^sup>sP i\<^sub>1) \<^bold>\<or>\<^sub>s (\<^bold>\<not>\<^sub>s(\<^sup>sP i\<^sub>1))\<rfloor>\<^sub>s)" unfolding Defs nitpick [satisfy, user_axioms=true, show_all, format=2, card i=1, card w=2] by blast (* properly valid *)
  lemma "\<lfloor>\<^bold>\<exists>\<^sup>p\<^sub>sP. \<^sup>sP i\<^sub>1\<rfloor>\<^sub>s" nitpick [user_axioms=true, show_all, format=2] oops (* properly invalid *)
  lemma "\<lfloor>\<^bold>\<not>\<^sub>s(\<^bold>\<exists>\<^sup>p\<^sub>sP. \<^sup>sP i\<^sub>1)\<rfloor>\<^sub>s" nitpick [user_axioms=true, show_all, format=2] nitpick [satisfy, user_axioms=true, show_all, format=2, card=2] oops (* properly invalid *)

  lemma test_True: "True" by simp
  lemma test_False: "False" nitpick [satisfy, user_axioms=true] oops


text\<open> 29 October 2021: Exercise for Homework Assignment 08 in CS 511 \<close>
text\<open> Your task to remove the invocations of the pre-defined method
      'blast' by an equivalent sequence of 'apply' steps \<close>

theory HW08
  imports Main
begin

text\<open> 'blast' is invoked three times, once in the proof of each of
      lemmas K1, L1, and M1 below \<close>

(* lemma K1 is the same in Exercise 2.3.9 (k), page 161, in [LCS] *)
lemma K1 : "\<forall> x. (P x \<and> Q x) \<Longrightarrow> (\<forall> x. P x) \<and> (\<forall> x. Q x)"
  apply (rule conjI)
   apply (rule allI)
   apply (erule allE)
   apply (erule conjE)
   apply assumption
  apply (rule allI)
  apply (erule allE)
  apply (erule conjE)
  apply assumption
  done

(* lemma L1 is the same in Exercise 2.3.9 (l), page 161, in [LCS] *)
lemma L1 : "(\<forall> x. P x) \<or> (\<forall> x. Q x) \<Longrightarrow> \<forall> x. (P x \<or> Q x)"
  apply (rule allI)
  apply (erule disjE)
   apply (rule disjI1)
   apply (erule allE)
   apply assumption
  apply (rule disjI2)
  apply (erule allE)
  apply assumption
  done

(* lemma M1 is the same in Exercise 2.3.9 (m), page 161, in [LCS] *)
lemma M1 : "\<exists> x. (P x \<and> Q x) \<Longrightarrow> (\<exists> x. P x) \<and> (\<exists> x. Q x)"
  apply (erule exE)
  apply (rule conjI)
   apply (rule exI)
   apply (erule conjE)
   apply assumption
  apply (erule conjE)
  apply (rule exI)
  apply assumption
  done

end


(*
  File: Int.thy
  Author: Bohua Zhan

  Construction of integers (as pairs of natural numbers, under the equivalence
  relation (a,b) ~ (c,d) iff a + d = b + c.
*)

theory Int
  imports Nat Ring EquivRel
begin

section \<open>Integers as a quotient set\<close>

definition int_rel_space :: i where [rewrite]:
  "int_rel_space = nat\<times>nat"

definition int_rel :: i where [rewrite]:
  "int_rel = Equiv(int_rel_space, \<lambda>p q. let \<langle>a,b\<rangle> = p; \<langle>c,d\<rangle> = q in a +\<^sub>\<nat> d = b +\<^sub>\<nat> c)"
notation int_rel ("\<R>")

lemma int_rel_spaceI [typing]: "x \<in> nat \<Longrightarrow> y \<in> nat \<Longrightarrow> \<langle>x,y\<rangle> \<in>. \<R>" by auto2
lemma int_rel_spaceD [forward]: "p \<in>. \<R> \<Longrightarrow> p = \<langle>fst(p),snd(p)\<rangle> \<and> fst(p) \<in> nat \<and> snd(p) \<in> nat" by auto2
setup {* del_prfstep_thm @{thm int_rel_space_def} *}

lemma int_rel_trans [backward2]:
  "a1 \<in>. \<nat> \<Longrightarrow> a2 \<in>. \<nat> \<Longrightarrow> b1 \<in>. \<nat> \<Longrightarrow> b2 \<in>. \<nat> \<Longrightarrow> c1 \<in>. \<nat> \<Longrightarrow> c2 \<in>. \<nat> \<Longrightarrow>
   a1 +\<^sub>\<nat> b2 = a2 +\<^sub>\<nat> b1 \<Longrightarrow> b1 +\<^sub>\<nat> c2 = b2 +\<^sub>\<nat> c1 \<Longrightarrow> a1 +\<^sub>\<nat> c2 = a2 +\<^sub>\<nat> c1"
@proof
  @have "(a1 +\<^sub>\<nat> c2) +\<^sub>\<nat> b2 = (a1 +\<^sub>\<nat> b2) +\<^sub>\<nat> c2"
  @have "(a2 +\<^sub>\<nat> b1) +\<^sub>\<nat> c2 = a2 +\<^sub>\<nat> (b1 +\<^sub>\<nat> c2)"
  @have "a2 +\<^sub>\<nat> (b2 +\<^sub>\<nat> c1) = (a2 +\<^sub>\<nat> c1) +\<^sub>\<nat> b2"
@qed

lemma int_rel_is_rel [typing]: "\<R> \<in> equiv_space(int_rel_space)" by auto2
setup {* del_prfstep_thm @{thm int_rel_trans} *}

lemma int_rel_eval:
  "x \<in>. \<R> \<Longrightarrow> y \<in>. \<R> \<Longrightarrow> x \<sim>\<^sub>\<R> y \<longleftrightarrow> fst(x) +\<^sub>\<nat> snd(y) = snd(x) +\<^sub>\<nat> fst(y)" by auto2
setup {* add_rewrite_rule_cond @{thm int_rel_eval} [with_cond "?x \<noteq> ?y"] *}
setup {* del_prfstep_thm @{thm int_rel_def} *}

definition int :: i where int_def [rewrite_bidir]:
  "int = carrier(\<R>) // \<R>"

abbreviation Int :: "i \<Rightarrow> i" where "Int(p) \<equiv> equiv_class(\<R>,p)"

section \<open>Integers as a ring\<close>

definition int_add_raw :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "int_add_raw(p,q) = \<langle>fst(p)+\<^sub>\<nat>fst(q),snd(p)+\<^sub>\<nat>snd(q)\<rangle>"
setup {* register_wellform_data ("int_add_raw(p,q)", ["p \<in>. \<R>", "q \<in>. \<R>"]) *}

lemma int_add_raw_eval [rewrite]: "int_add_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>) = \<langle>a+\<^sub>\<nat>c, b+\<^sub>\<nat>d\<rangle>" by auto2
setup {* del_prfstep_thm @{thm int_add_raw_def} *}

definition int_mult_raw :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "int_mult_raw(p,q) = \<langle>fst(p)*\<^sub>\<nat>fst(q) +\<^sub>\<nat> snd(p)*\<^sub>\<nat>snd(q), fst(p)*\<^sub>\<nat>snd(q) +\<^sub>\<nat> snd(p)*\<^sub>\<nat>fst(q)\<rangle>"
setup {* register_wellform_data ("int_mult_raw(p,q)", ["p \<in>. \<R>", "q \<in>. \<R>"]) *}

lemma int_mult_raw_eval [rewrite]: "int_mult_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>) = \<langle>a*\<^sub>\<nat>c +\<^sub>\<nat> b*\<^sub>\<nat>d, a*\<^sub>\<nat>d +\<^sub>\<nat> b*\<^sub>\<nat>c\<rangle>" by auto2
setup {* del_prfstep_thm @{thm int_mult_raw_def} *}

definition nonneg_int_raw :: "i \<Rightarrow> o" where [rewrite]:
  "nonneg_int_raw(p) \<longleftrightarrow> fst(p) \<ge>\<^sub>\<nat> snd(p)"

definition nonneg_int :: "i \<Rightarrow> o" where [rewrite]:
  "nonneg_int(x) \<longleftrightarrow> nonneg_int_raw(rep(\<R>,x))"

definition nonneg_ints :: i where [rewrite]:
  "nonneg_ints = {x\<in>int. nonneg_int(x)}"

definition int_ring :: i where [rewrite]:
  "int_ring = Ring(int, Int(\<langle>0,0\<rangle>), \<lambda>x y. Int(int_add_raw(rep(\<R>,x), rep(\<R>,y))),
                        Int(\<langle>1,0\<rangle>), \<lambda>x y. Int(int_mult_raw(rep(\<R>,x), rep(\<R>,y))))"

lemma int_ring_is_ring_raw [forward]: "ring_form(int_ring)" by auto2

definition int_ord_ring :: i  ("\<int>") where [rewrite]:
  "int_ord_ring = ord_ring_from_nonneg(int_ring, nonneg_ints)"

lemma int_is_ring_raw [forward]: "is_ring_raw(\<int>)" by auto2
lemma int_carrier [rewrite_bidir]: "carrier(\<int>) = int" by auto2
lemma int_evals [rewrite]:
  "\<zero>\<^sub>\<int> = Int(\<langle>0,0\<rangle>)"
  "\<one>\<^sub>\<int> = Int(\<langle>1,0\<rangle>)"
  "x \<in>. \<int> \<Longrightarrow> y \<in>. \<int> \<Longrightarrow> x +\<^sub>\<int> y = Int(int_add_raw(rep(\<R>,x), rep(\<R>,y)))"
  "x \<in>. \<int> \<Longrightarrow> y \<in>. \<int> \<Longrightarrow> x *\<^sub>\<int> y = Int(int_mult_raw(rep(\<R>,x), rep(\<R>,y)))" by auto2+

lemma int_is_ord_ring_prep [forward]:
  "is_comm_ring(\<int>) \<Longrightarrow> nonneg_compat(\<int>,nonneg_ints) \<Longrightarrow> is_ord_ring(\<int>)" by auto2

setup {* fold del_prfstep_thm [@{thm int_ring_def}, @{thm int_ord_ring_def}] *}

lemma int_choose_rep: "x \<in>. \<int> \<Longrightarrow> x = Int(rep(\<R>,x))" by auto2
setup {* add_rewrite_rule_cond @{thm int_choose_rep} [with_filt (size1_filter "x")] *}

section \<open>Addition on integers\<close>

lemma int_add_eval [rewrite]:
  "x \<in>. \<R> \<Longrightarrow> y \<in>. \<R> \<Longrightarrow> Int(x) +\<^sub>\<int> Int(y) = Int(int_add_raw(x,y))"
@proof
  @have "compat_meta_bin1(\<R>, int_add_raw)" @with
    @have (@rule) "\<forall>a b c d a' b'. \<langle>c,d\<rangle> \<in>. \<R> \<longrightarrow> \<langle>a',b'\<rangle> \<sim>\<^sub>\<R> \<langle>a,b\<rangle> \<longrightarrow>
                   int_add_raw(\<langle>a',b'\<rangle>,\<langle>c,d\<rangle>) \<sim>\<^sub>\<R> int_add_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>)" @with
      @have "(a' +\<^sub>\<nat> c) +\<^sub>\<nat> (b +\<^sub>\<nat> d) = (a' +\<^sub>\<nat> b) +\<^sub>\<nat> (c +\<^sub>\<nat> d)"
      @have "(b' +\<^sub>\<nat> d) +\<^sub>\<nat> (a +\<^sub>\<nat> c) = (b' +\<^sub>\<nat> a) +\<^sub>\<nat> (c +\<^sub>\<nat> d)"
    @end
  @end
  @have "compat_meta_bin2(\<R>, int_add_raw)" @with
    @have (@rule) "\<forall>a b c d c' d'. \<langle>a,b\<rangle> \<in>. \<R> \<longrightarrow> \<langle>c',d'\<rangle> \<sim>\<^sub>\<R> \<langle>c,d\<rangle> \<longrightarrow>
                   int_add_raw(\<langle>a,b\<rangle>,\<langle>c',d'\<rangle>) \<sim>\<^sub>\<R> int_add_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>)" @with
      @have "(a +\<^sub>\<nat> c') +\<^sub>\<nat> (b +\<^sub>\<nat> d) = (a +\<^sub>\<nat> b) +\<^sub>\<nat> (c' +\<^sub>\<nat> d)"
      @have "(b +\<^sub>\<nat> d') +\<^sub>\<nat> (a +\<^sub>\<nat> c) = (a +\<^sub>\<nat> b) +\<^sub>\<nat> (d' +\<^sub>\<nat> c)"
    @end
  @end
  @have "compat_meta_bin(\<R>, int_add_raw)"
@qed
setup {* del_prfstep_thm @{thm int_evals(3)} *}

lemma int_add_comm [forward]: "is_plus_comm(\<int>)" by auto2
lemma int_add_assoc [forward]: "is_plus_assoc(\<int>)" by auto2

section \<open>Multiplication on integers\<close>

lemma int_mult_eval [rewrite]:
  "x \<in>. \<R> \<Longrightarrow> y \<in>. \<R> \<Longrightarrow> Int(x) *\<^sub>\<int> Int(y) = Int(int_mult_raw(x,y))"
@proof
  @have "compat_meta_bin1(\<R>, int_mult_raw)" @with
    @have (@rule) "\<forall>a b c d a' b'. \<langle>c,d\<rangle> \<in>. \<R> \<longrightarrow> \<langle>a',b'\<rangle> \<sim>\<^sub>\<R> \<langle>a,b\<rangle> \<longrightarrow>
                   int_mult_raw(\<langle>a',b'\<rangle>,\<langle>c,d\<rangle>) \<sim>\<^sub>\<R> int_mult_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>)" @with
      @have "(a'*\<^sub>\<nat>c +\<^sub>\<nat> b'*\<^sub>\<nat>d) +\<^sub>\<nat> (a*\<^sub>\<nat>d +\<^sub>\<nat> b*\<^sub>\<nat>c) = (a'+\<^sub>\<nat>b) *\<^sub>\<nat> c +\<^sub>\<nat> (b'+\<^sub>\<nat>a) *\<^sub>\<nat> d"
      @have "(a'*\<^sub>\<nat>d +\<^sub>\<nat> b'*\<^sub>\<nat>c) +\<^sub>\<nat> (a*\<^sub>\<nat>c +\<^sub>\<nat> b*\<^sub>\<nat>d) = (b'+\<^sub>\<nat>a) *\<^sub>\<nat> c +\<^sub>\<nat> (a'+\<^sub>\<nat>b) *\<^sub>\<nat> d"
    @end
  @end
  @have "compat_meta_bin2(\<R>, int_mult_raw)" @with
    @have (@rule) "\<forall>a b c d c' d'. \<langle>a,b\<rangle> \<in>. \<R> \<longrightarrow> \<langle>c',d'\<rangle> \<sim>\<^sub>\<R> \<langle>c,d\<rangle> \<longrightarrow>
                   int_mult_raw(\<langle>a,b\<rangle>,\<langle>c',d'\<rangle>) \<sim>\<^sub>\<R> int_mult_raw(\<langle>a,b\<rangle>,\<langle>c,d\<rangle>)" @with
      @have "(a*\<^sub>\<nat>c' +\<^sub>\<nat> b*\<^sub>\<nat>d') +\<^sub>\<nat> (a*\<^sub>\<nat>d +\<^sub>\<nat> b*\<^sub>\<nat>c) = (c'+\<^sub>\<nat>d) *\<^sub>\<nat> a +\<^sub>\<nat> (d'+\<^sub>\<nat>c) *\<^sub>\<nat> b"
      @have "(a*\<^sub>\<nat>d' +\<^sub>\<nat> b*\<^sub>\<nat>c') +\<^sub>\<nat> (a*\<^sub>\<nat>c +\<^sub>\<nat> b*\<^sub>\<nat>d) = (d'+\<^sub>\<nat>c) *\<^sub>\<nat> a +\<^sub>\<nat> (c'+\<^sub>\<nat>d) *\<^sub>\<nat> b"
    @end
  @end
  @have "compat_meta_bin(\<R>, int_mult_raw)"
@qed
setup {* del_prfstep_thm @{thm int_evals(4)} *}

lemma int_mult_comm [forward]: "is_times_comm(\<int>)" by auto2
lemma int_mult_assoc [forward]: "is_times_assoc(\<int>)" by auto2
lemma int_distrib_l [forward]: "is_left_distrib(\<int>)" by auto2

section \<open>0 and 1\<close>

lemma int_is_add_id [forward]: "is_add_id(\<int>)" by auto2
lemma int_is_mult_id [forward]: "is_mult_id(\<int>)" by auto2
lemma int_zero_neq_one [resolve]: "\<zero>\<^sub>\<int> \<noteq> \<one>\<^sub>\<int>" by auto2

section \<open>Negation and subtraction on integers\<close>

definition int_neg_raw :: "i \<Rightarrow> i" where [rewrite]:
  "int_neg_raw(p) = \<langle>snd(p), fst(p)\<rangle>"

definition int_neg :: "i \<Rightarrow> i" where [rewrite]:
  "int_neg(x) = Int(int_neg_raw(rep(\<R>,x)))"

lemma int_neg_typing [typing]: "x \<in>. \<int> \<Longrightarrow> int_neg(x) \<in>. \<int>" by auto2
lemma int_has_add_inverse [forward]: "has_add_inverse(\<int>)"
@proof @have "\<forall>x\<in>.\<int>. x +\<^sub>\<int> int_neg(x) = \<zero>\<^sub>\<int>" @qed

lemma int_is_comm_ring [forward]: "is_comm_ring(\<int>)" by auto2

section \<open>Nonnegative integers\<close>

lemma nonneg_int_eval [rewrite]:
  "x \<in>. \<R> \<Longrightarrow> nonneg_int(Int(x)) \<longleftrightarrow> nonneg_int_raw(x)"
@proof
  @have (@rule) "\<forall>a b c d. \<langle>a,b\<rangle> \<sim>\<^sub>\<R> \<langle>c,d\<rangle> \<longrightarrow> a \<ge>\<^sub>\<nat> b \<longrightarrow> c \<ge>\<^sub>\<nat> d" @with
    @contradiction @have "a +\<^sub>\<nat> d >\<^sub>\<nat> b +\<^sub>\<nat> c"
  @end
@qed
setup {* del_prfstep_thm @{thm nonneg_int_def} *}

lemma int_neg_eval [rewrite]: "x \<in>. \<R> \<Longrightarrow> -\<^sub>\<int> Int(x) = Int(int_neg_raw(x))"
@proof @have "Int(x) +\<^sub>\<int> Int(int_neg_raw(x)) = \<zero>\<^sub>\<int>" @qed

lemma nonneg_int_raw_mult [backward2]:
  "\<langle>a,b\<rangle> \<in>. \<R> \<Longrightarrow> \<langle>c,d\<rangle> \<in>. \<R> \<Longrightarrow> nonneg_int_raw(\<langle>a,b\<rangle>) \<Longrightarrow> nonneg_int_raw(\<langle>c,d\<rangle>) \<Longrightarrow>
   nonneg_int_raw(int_mult_raw(\<langle>a,b\<rangle>, \<langle>c,d\<rangle>))"
@proof
  @obtain "p\<in>nat" where "a = b +\<^sub>\<nat> p"
  @obtain "q\<in>nat" where "c = d +\<^sub>\<nat> q"
  @have "(b+\<^sub>\<nat>p)*\<^sub>\<nat>d +\<^sub>\<nat> b*\<^sub>\<nat>(d+\<^sub>\<nat>q) +\<^sub>\<nat> p*\<^sub>\<nat>q = (b+\<^sub>\<nat>p)*\<^sub>\<nat>(d+\<^sub>\<nat>q) +\<^sub>\<nat> b*\<^sub>\<nat>d"
@qed

lemma int_nonneg_compat [resolve]: "nonneg_compat(\<int>, nonneg_ints)" by auto2
setup {* fold del_prfstep_thm [@{thm nonneg_int_eval}, @{thm nonneg_int_raw_mult},
  @{thm nonneg_int_raw_def}, @{thm nonneg_ints_def}] *}

lemma int_is_ord_ring [forward]: "is_ord_ring(\<int>)"
@proof @have "nonneg_compat(\<int>, nonneg_ints)" @qed
setup {* del_prfstep_thm @{thm int_is_ord_ring_prep} *}

section \<open>Integers as integral domain\<close>

lemma int_is_domain_raw [forward]:
  "x1 \<in>. \<nat> \<Longrightarrow> y1 \<in>. \<nat> \<Longrightarrow> x2 \<in>. \<nat> \<Longrightarrow> y2 \<in>. \<nat> \<Longrightarrow>
   x1 *\<^sub>\<nat> x2 +\<^sub>\<nat> y1 *\<^sub>\<nat> y2 = x1 *\<^sub>\<nat> y2 +\<^sub>\<nat> y1 *\<^sub>\<nat> x2 \<Longrightarrow> x1 = y1 \<or> x2 = y2"
@proof
  @case "x1 <\<^sub>\<nat> y1" @with
    @obtain "p\<in>nat" where "p \<noteq> 0" "y1 = x1 +\<^sub>\<nat> p"
    @have "x1 *\<^sub>\<nat> x2 +\<^sub>\<nat> (x1 +\<^sub>\<nat> p) *\<^sub>\<nat> y2 = (x1 *\<^sub>\<nat> x2 +\<^sub>\<nat> x1 *\<^sub>\<nat> y2) +\<^sub>\<nat> p *\<^sub>\<nat> y2"
    @have "x1 *\<^sub>\<nat> y2 +\<^sub>\<nat> (x1 +\<^sub>\<nat> p) *\<^sub>\<nat> x2 = (x1 *\<^sub>\<nat> x2 +\<^sub>\<nat> x1 *\<^sub>\<nat> y2) +\<^sub>\<nat> p *\<^sub>\<nat> x2" @end
  @case "x1 >\<^sub>\<nat> y1" @with
    @obtain "p\<in>nat" where "p \<noteq> 0" "x1 = y1 +\<^sub>\<nat> p"
    @have "(y1 +\<^sub>\<nat> p) *\<^sub>\<nat> x2 +\<^sub>\<nat> y1 *\<^sub>\<nat> y2 = (y1 *\<^sub>\<nat> x2 +\<^sub>\<nat> y1 *\<^sub>\<nat> y2) +\<^sub>\<nat> p *\<^sub>\<nat> x2"
    @have "(y1 +\<^sub>\<nat> p) *\<^sub>\<nat> y2 +\<^sub>\<nat> y1 *\<^sub>\<nat> x2 = (y1 *\<^sub>\<nat> x2 +\<^sub>\<nat> y1 *\<^sub>\<nat> y2) +\<^sub>\<nat> p *\<^sub>\<nat> y2" @end
@qed

lemma int_is_domain [forward]: "integral_domain(\<int>)" by auto2

section \<open>Integer as a difference of two natural numbers\<close>

lemma int_of_nat [rewrite]: "n \<in> nat \<Longrightarrow> of_nat(\<int>,n) = Int(\<langle>n,0\<rangle>)"
@proof @var_induct "n \<in> nat" @qed

lemma int_diff_eval [rewrite]:
  "\<langle>a,b\<rangle> \<in>. \<R> \<Longrightarrow> \<langle>c,d\<rangle> \<in>. \<R> \<Longrightarrow> Int(\<langle>a,b\<rangle>) -\<^sub>\<int> Int(\<langle>c,d\<rangle>) = Int(\<langle>a+\<^sub>\<nat>d,b+\<^sub>\<nat>c\<rangle>)"
@proof @have "Int(\<langle>a,b\<rangle>) -\<^sub>\<int> Int(\<langle>c,d\<rangle>) = Int(\<langle>a,b\<rangle>) +\<^sub>\<int> (-\<^sub>\<int> Int(\<langle>c,d\<rangle>))" @qed

lemma int_is_diff [backward]:
  "n \<in> int \<Longrightarrow> \<exists>a\<in>.\<nat>. \<exists>b\<in>.\<nat>. n = of_nat(\<int>,a) -\<^sub>\<int> of_nat(\<int>,b)"
@proof
  @let "p = rep(\<R>,n)"
  @have "n = of_nat(\<int>,fst(p)) -\<^sub>\<int> of_nat(\<int>,snd(p))"
@qed

section \<open>Definition of int\_act\<close>

definition int_act_raw :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "int_act_raw(R,p,x) = nat_act(R,fst(p),x) -\<^sub>R nat_act(R,snd(p),x)"

lemma int_act_raw_eval [rewrite]:
  "int_act_raw(R,\<langle>a,b\<rangle>,x) = nat_act(R,a,x) -\<^sub>R nat_act(R,b,x)" by auto2
setup {* del_prfstep_thm @{thm int_act_raw_def} *}

lemma comm_ring_switch_sides4 [resolve]:
  "is_abgroup(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> c \<in>. R \<Longrightarrow> d \<in>. R \<Longrightarrow>
   a +\<^sub>R d = b +\<^sub>R c \<Longrightarrow> a -\<^sub>R b = c -\<^sub>R d"
@proof @have "a -\<^sub>R b +\<^sub>R (b +\<^sub>R d) = c -\<^sub>R d +\<^sub>R (b +\<^sub>R d)" @qed

definition int_act :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "int_act(R,z,x) = int_act_raw(R,rep(\<R>,z),x)"
setup {* register_wellform_data ("int_act(R,z,x)", ["z \<in>. \<int>"]) *}

lemma int_act_eval [rewrite]:
  "is_abgroup(R) \<Longrightarrow> p \<in>. \<R> \<Longrightarrow> x \<in>. R \<Longrightarrow> int_act(R,Int(p),x) = int_act_raw(R,p,x)"
@proof
  @have (@rule) "\<forall>a b c d. \<langle>a,b\<rangle> \<sim>\<^sub>\<R> \<langle>c,d\<rangle> \<longrightarrow> int_act_raw(R,\<langle>a,b\<rangle>,x) = int_act_raw(R,\<langle>c,d\<rangle>,x)" @with
    @have "nat_act(R,a,x) +\<^sub>R nat_act(R,d,x) = nat_act(R,b,x) +\<^sub>R nat_act(R,c,x)"
  @end
@qed
setup {* del_prfstep_thm @{thm int_act_def} *}

lemma int_act_type [typing]:
  "is_abgroup(R) \<Longrightarrow> a \<in>. \<int> \<Longrightarrow> x \<in>. R \<Longrightarrow> int_act(R,a,x) \<in>. R" by auto2

lemma int_act_eval_diff [rewrite]:
  "is_abgroup(R) \<Longrightarrow> a \<in> nat \<Longrightarrow> b \<in> nat \<Longrightarrow> x \<in>. R \<Longrightarrow>
   int_act(R,of_nat(\<int>,a) -\<^sub>\<int> of_nat(\<int>,b),x) = nat_act(R,a,x) -\<^sub>R nat_act(R,b,x)" by auto2

lemma int_act_of_nat [rewrite]:
  "is_abgroup(R) \<Longrightarrow> n \<in> nat \<Longrightarrow> x \<in>. R \<Longrightarrow> int_act(R,of_nat(\<int>,n),x) = nat_act(R,n,x)" by auto2

lemma int_act_zero [rewrite]:
  "is_abgroup(R) \<Longrightarrow> r \<in>. R \<Longrightarrow> int_act(R,\<zero>\<^sub>\<int>,r) = \<zero>\<^sub>R" by auto2

lemma int_act_one [rewrite]:
  "is_abgroup(R) \<Longrightarrow> r \<in>. R \<Longrightarrow> int_act(R,\<one>\<^sub>\<int>,r) = r" by auto2

lemma int_act_zero_right [rewrite]:
  "is_abgroup(R) \<Longrightarrow> n \<in>. \<int> \<Longrightarrow> int_act(R,n,\<zero>\<^sub>R) = \<zero>\<^sub>R" by auto2

setup {* del_prfstep_thm @{thm int_of_nat} *}
setup {* fold del_prfstep_thm [@{thm int_act_raw_eval}, @{thm int_act_eval}] *}
setup {* fold del_prfstep_thm [@{thm int_def}, @{thm int_rel_spaceI}, @{thm int_rel_spaceD}] *}
setup {* fold del_prfstep_thm @{thms int_evals(1-2)} *}
setup {* fold del_prfstep_thm [@{thm int_choose_rep}, @{thm int_neg_eval}, @{thm int_add_eval},
  @{thm int_diff_eval}, @{thm int_mult_eval}] *}
no_notation int_rel ("\<R>")
hide_const Int

section \<open>Further properties of int\_act\<close>

lemma int_act_add [rewrite_bidir]:
  "is_abgroup(R) \<Longrightarrow> x \<in>. \<int> \<Longrightarrow> y \<in>. \<int> \<Longrightarrow> r \<in>. R \<Longrightarrow> int_act(R,x +\<^sub>\<int> y,r) = int_act(R,x,r) +\<^sub>R int_act(R,y,r)"
@proof
  @obtain "a\<in>.\<nat>" "b\<in>.\<nat>" where "x = of_nat(\<int>,a) -\<^sub>\<int> of_nat(\<int>,b)"
  @obtain "c\<in>.\<nat>" "d\<in>.\<nat>" where "y = of_nat(\<int>,c) -\<^sub>\<int> of_nat(\<int>,d)"
  @let "za = of_nat(\<int>,a)" "zb = of_nat(\<int>,b)" "zc = of_nat(\<int>,c)" "zd = of_nat(\<int>,d)"
  @let "ra = nat_act(R,a,r)" "rb = nat_act(R,b,r)" "rc = nat_act(R,c,r)" "rd = nat_act(R,d,r)"
  @have "(za -\<^sub>\<int> zb) +\<^sub>\<int> (zc -\<^sub>\<int> zd) = (za +\<^sub>\<int> zc) -\<^sub>\<int> (zb +\<^sub>\<int> zd)"
  @have "(ra -\<^sub>R rb) +\<^sub>R (rc -\<^sub>R rd) = (ra +\<^sub>R rc) -\<^sub>R (rb +\<^sub>R rd)"
@qed

lemma int_act_uminus [rewrite_bidir]:
  "is_abgroup(R) \<Longrightarrow> x \<in>. \<int> \<Longrightarrow> r \<in>. R \<Longrightarrow> int_act(R,-\<^sub>\<int> x, r) = -\<^sub>R int_act(R,x,r)"
@proof @have "int_act(R,-\<^sub>\<int> x,r) +\<^sub>R int_act(R,x,r) = \<zero>\<^sub>R" @qed

lemma int_act_minus [rewrite_bidir]:
  "is_abgroup(R) \<Longrightarrow> x \<in>. \<int> \<Longrightarrow> y \<in>. \<int> \<Longrightarrow> r \<in>. R \<Longrightarrow> int_act(R,x -\<^sub>\<int> y,r) = int_act(R,x,r) -\<^sub>R int_act(R,y,r)"
@proof @have "int_act(R,x,r) -\<^sub>R int_act(R,y,r) = int_act(R,x,r) +\<^sub>R (-\<^sub>R int_act(R,y,r))" @qed

lemma int_act_add_right [rewrite_bidir]:
  "is_abgroup(R) \<Longrightarrow> x \<in>. \<int> \<Longrightarrow> r \<in>. R \<Longrightarrow> s \<in>. R \<Longrightarrow> int_act(R,x,r +\<^sub>R s) = int_act(R,x,r) +\<^sub>R int_act(R,x,s)"
@proof
  @obtain "a\<in>.\<nat>" "b\<in>.\<nat>" where "x = of_nat(\<int>,a) -\<^sub>\<int> of_nat(\<int>,b)"
  @have "(nat_act(R,a,r) +\<^sub>R nat_act(R,a,s)) -\<^sub>R (nat_act(R,b,r) +\<^sub>R nat_act(R,b,s)) =
         (nat_act(R,a,r) -\<^sub>R nat_act(R,b,r)) +\<^sub>R (nat_act(R,a,s) -\<^sub>R nat_act(R,b,s))"
@qed

lemma int_act_uminus_right [rewrite_bidir]:
  "is_abgroup(R) \<Longrightarrow> x \<in>. \<int> \<Longrightarrow> r \<in>. R \<Longrightarrow> int_act(R,x,-\<^sub>R r) = -\<^sub>R int_act(R,x,r)"
@proof @have "int_act(R,x,-\<^sub>R r) +\<^sub>R int_act(R,x,r) = \<zero>\<^sub>R" @qed

lemma int_act_sub_right [rewrite_bidir]:
  "is_abgroup(R) \<Longrightarrow> x \<in>. \<int> \<Longrightarrow> r \<in>. R \<Longrightarrow> s \<in>. R \<Longrightarrow> int_act(R,x,r -\<^sub>R s) = int_act(R,x,r) -\<^sub>R int_act(R,x,s)"
@proof @have "int_act(R,x,r) -\<^sub>R int_act(R,x,s) = int_act(R,x,r) +\<^sub>R (-\<^sub>R int_act(R,x,s))" @qed

lemma int_act_mult [rewrite_bidir]:
  "is_abgroup(R) \<Longrightarrow> x \<in>. \<int> \<Longrightarrow> y \<in>. \<int> \<Longrightarrow> r \<in>. R \<Longrightarrow> int_act(R,x *\<^sub>\<int> y, r) = int_act(R,x,int_act(R,y,r))"
@proof
  @obtain "a\<in>.\<nat>" "b\<in>.\<nat>" where "x = of_nat(\<int>,a) -\<^sub>\<int> of_nat(\<int>,b)"
  @obtain "c\<in>.\<nat>" "d\<in>.\<nat>" where "y = of_nat(\<int>,c) -\<^sub>\<int> of_nat(\<int>,d)"
  @let "za = of_nat(\<int>,a)" "zb = of_nat(\<int>,b)" "zc = of_nat(\<int>,c)" "zd = of_nat(\<int>,d)"
  @have "(za -\<^sub>\<int> zb) *\<^sub>\<int> (zc -\<^sub>\<int> zd) = (za *\<^sub>\<int> zc +\<^sub>\<int> zb *\<^sub>\<int> zd) -\<^sub>\<int> (za *\<^sub>\<int> zd +\<^sub>\<int> zb *\<^sub>\<int> zc)"
@qed

section \<open>Definition of of\_int\<close>

definition of_int :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite_bidir]:
  "of_int(R,z) = int_act(R,z,\<one>\<^sub>R)"
setup {* register_wellform_data ("of_int(R,z)", ["z \<in>. \<int>"]) *}

lemma of_int_type [typing]:
  "is_comm_ring(R) \<Longrightarrow> a \<in>. \<int> \<Longrightarrow> of_int(R,a) \<in>. R" by auto2

lemma of_int_of_nat [rewrite]:
  "is_comm_ring(R) \<Longrightarrow> n \<in> nat \<Longrightarrow> of_int(R,of_nat(\<int>,n)) = of_nat(R,n)" by auto2

lemma of_int_add [rewrite_bidir]:
  "is_comm_ring(R) \<Longrightarrow> x \<in>. \<int> \<Longrightarrow> y \<in>. \<int> \<Longrightarrow> of_int(R,x) +\<^sub>R of_int(R,y) = of_int(R,x +\<^sub>\<int> y)" by auto2

lemma of_int_uminus [rewrite_bidir]:
  "is_comm_ring(R) \<Longrightarrow> x \<in>. \<int> \<Longrightarrow> -\<^sub>R of_int(R,x) = of_int(R,-\<^sub>\<int> x)" by auto2

lemma of_int_sub [rewrite_bidir]:
  "is_comm_ring(R) \<Longrightarrow> x \<in>. \<int> \<Longrightarrow> y \<in>. \<int> \<Longrightarrow> of_int(R,x) -\<^sub>R of_int(R,y) = of_int(R,x -\<^sub>\<int> y)" by auto2

setup {* del_prfstep_thm_str "" @{thm of_int_def} *}

lemma of_int_mult [rewrite_bidir]:
  "is_comm_ring(R) \<Longrightarrow> x \<in>. \<int> \<Longrightarrow> y \<in>. \<int> \<Longrightarrow> of_int(R,x) *\<^sub>R of_int(R,y) = of_int(R,x *\<^sub>\<int> y)"
@proof
  @obtain "a\<in>.\<nat>" "b\<in>.\<nat>" where "x = of_nat(\<int>,a) -\<^sub>\<int> of_nat(\<int>,b)"
  @obtain "c\<in>.\<nat>" "d\<in>.\<nat>" where "y = of_nat(\<int>,c) -\<^sub>\<int> of_nat(\<int>,d)"
  @let "za = of_nat(\<int>,a)" "zb = of_nat(\<int>,b)" "zc = of_nat(\<int>,c)" "zd = of_nat(\<int>,d)"
  @let "ra = of_nat(R,a)" "rb = of_nat(R,b)" "rc = of_nat(R,c)" "rd = of_nat(R,d)"
  @have "(za -\<^sub>\<int> zb) *\<^sub>\<int> (zc -\<^sub>\<int> zd) = (za *\<^sub>\<int> zc +\<^sub>\<int> zb *\<^sub>\<int> zd) -\<^sub>\<int> (za *\<^sub>\<int> zd +\<^sub>\<int> zb *\<^sub>\<int> zc)"
  @have "(ra -\<^sub>R rb) *\<^sub>R (rc -\<^sub>R rd) = (ra *\<^sub>R rc +\<^sub>R rb *\<^sub>R rd) -\<^sub>R (ra *\<^sub>R rd +\<^sub>R rb *\<^sub>R rc)"
@qed

lemma ord_ring_switch_sides4 [resolve]:
  "is_ord_ring(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> c \<in>. R \<Longrightarrow> d \<in>. R \<Longrightarrow>
   a -\<^sub>R b \<le>\<^sub>R c -\<^sub>R d \<Longrightarrow> a +\<^sub>R d \<le>\<^sub>R b +\<^sub>R c" by auto2

lemma ord_ring_switch_sides4' [resolve]:
  "is_ord_ring(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> c \<in>. R \<Longrightarrow> d \<in>. R \<Longrightarrow>
   a +\<^sub>R d \<le>\<^sub>R b +\<^sub>R c \<Longrightarrow> a -\<^sub>R b \<le>\<^sub>R c -\<^sub>R d" by auto2

lemma ord_ring_switch_sides4_less [resolve]:
  "is_ord_ring(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> c \<in>. R \<Longrightarrow> d \<in>. R \<Longrightarrow>
   a -\<^sub>R b <\<^sub>R c -\<^sub>R d \<Longrightarrow> a +\<^sub>R d <\<^sub>R b +\<^sub>R c" by auto2

lemma ord_ring_switch_sides4_less' [resolve]:
  "is_ord_ring(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> c \<in>. R \<Longrightarrow> d \<in>. R \<Longrightarrow>
   a +\<^sub>R d <\<^sub>R b +\<^sub>R c \<Longrightarrow> a -\<^sub>R b <\<^sub>R c -\<^sub>R d" by auto2

lemma ord_ring_of_int_le [backward]:
  "is_ord_ring(R) \<Longrightarrow> x \<le>\<^sub>\<int> y \<Longrightarrow> of_int(R,x) \<le>\<^sub>R of_int(R,y)"
@proof
  @obtain "a\<in>.\<nat>" "b\<in>.\<nat>" where "x = of_nat(\<int>,a) -\<^sub>\<int> of_nat(\<int>,b)"
  @obtain "c\<in>.\<nat>" "d\<in>.\<nat>" where "y = of_nat(\<int>,c) -\<^sub>\<int> of_nat(\<int>,d)"
  @have "of_nat(\<int>,a) +\<^sub>\<int> of_nat(\<int>,d) \<le>\<^sub>\<int> of_nat(\<int>,b) +\<^sub>\<int> of_nat(\<int>,c)"
  @have "of_nat(R,a) +\<^sub>R of_nat(R,d) \<le>\<^sub>R of_nat(R,b) +\<^sub>R of_nat(R,c)"
@qed

lemma ord_ring_of_int_less [backward]:
  "is_ord_ring(R) \<Longrightarrow> x <\<^sub>\<int> y \<Longrightarrow> of_int(R,x) <\<^sub>R of_int(R,y)"
@proof
  @obtain "a\<in>.\<nat>" "b\<in>.\<nat>" where "x = of_nat(\<int>,a) -\<^sub>\<int> of_nat(\<int>,b)"
  @obtain "c\<in>.\<nat>" "d\<in>.\<nat>" where "y = of_nat(\<int>,c) -\<^sub>\<int> of_nat(\<int>,d)"
  @have "of_nat(\<int>,a) +\<^sub>\<int> of_nat(\<int>,d) <\<^sub>\<int> of_nat(\<int>,b) +\<^sub>\<int> of_nat(\<int>,c)"
  @have "of_nat(R,a) +\<^sub>R of_nat(R,d) <\<^sub>R of_nat(R,b) +\<^sub>R of_nat(R,c)"
@qed

lemma ord_ring_of_int_le_back [forward]:
  "is_ord_ring(R) \<Longrightarrow> x \<in>. \<int> \<Longrightarrow> y \<in>. \<int> \<Longrightarrow> of_int(R,x) \<le>\<^sub>R of_int(R,y) \<Longrightarrow> x \<le>\<^sub>\<int> y"
@proof @case "of_int(R,y) <\<^sub>R of_int(R,x)" @qed

lemma ord_ring_of_int_eq [forward]:
  "is_ord_ring(R) \<Longrightarrow> x \<in>. \<int> \<Longrightarrow> y \<in>. \<int> \<Longrightarrow> of_int(R,x) = of_int(R,y) \<Longrightarrow> x = y"
@proof
  @case "x <\<^sub>\<int> y" @with @have "of_int(R,x) <\<^sub>R of_int(R,y)" @end
  @case "x >\<^sub>\<int> y" @with @have "of_int(R,x) >\<^sub>R of_int(R,y)" @end
@qed

lemma ord_ring_of_int_positive:
  "is_ord_ring(R) \<Longrightarrow> b >\<^sub>\<int> 0\<^sub>\<int> \<Longrightarrow> of_int(R,b) >\<^sub>R 0\<^sub>R"
@proof @have "of_int(R,b) >\<^sub>R of_int(R,0\<^sub>\<int>)" @qed
setup {* add_forward_prfstep_cond @{thm ord_ring_of_int_positive} [with_term "of_int(?R,?b)"] *}

lemma int_gt_to_ge [backward]:
  "x >\<^sub>\<int> y \<Longrightarrow> x \<ge>\<^sub>\<int> y +\<^sub>\<int> 1\<^sub>\<int>"
@proof
  @obtain "a\<in>.\<nat>" "b\<in>.\<nat>" where "x = of_nat(\<int>,a) -\<^sub>\<int> of_nat(\<int>,b)"
  @obtain "c\<in>.\<nat>" "d\<in>.\<nat>" where "y = of_nat(\<int>,c) -\<^sub>\<int> of_nat(\<int>,d)"
  @have "of_nat(\<int>,a) +\<^sub>\<int> of_nat(\<int>,d) >\<^sub>\<int> of_nat(\<int>,b) +\<^sub>\<int> of_nat(\<int>,c)"
  @have "of_nat(\<int>,a) +\<^sub>\<int> of_nat(\<int>,d) \<ge>\<^sub>\<int> of_nat(\<int>,b) +\<^sub>\<int> of_nat(\<int>,c) +\<^sub>\<int> 1\<^sub>\<int>"
  @have "of_nat(\<int>,a) -\<^sub>\<int> of_nat(\<int>,b) \<ge>\<^sub>\<int> of_nat(\<int>,c) -\<^sub>\<int> of_nat(\<int>,d) +\<^sub>\<int> 1\<^sub>\<int>"
@qed

lemma int_gt_to_ge_one [resolve]:
  "x >\<^sub>\<int> 0\<^sub>\<int> \<Longrightarrow> x \<ge>\<^sub>\<int> 1\<^sub>\<int>"
@proof @have "1\<^sub>\<int> = 0\<^sub>\<int> +\<^sub>\<int> 1\<^sub>\<int>" @qed

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
section \<open>Set-Theoretic Orders\<close>
theory SOrders
  imports
    SBinary_Relations_Antisymmetric
    SBinary_Relations_Connected
    SBinary_Relations_Reflexive
    SBinary_Relations_Transitive
begin

definition "partial_order D R \<equiv>
  reflexive D R \<and> transitive D R \<and> antisymmetric D R"

definition "linear_order D R \<equiv> connected D R \<and> partial_order D R"

definition "well_founded D R \<equiv>
  \<forall>X. X \<subseteq> D \<and> X \<noteq> {} \<longrightarrow> (\<exists>a \<in> X. \<forall>x \<in> X. \<langle>x, a\<rangle> \<in> R \<longrightarrow> x = a)"

lemma well_foundedI:
  assumes "\<And>X. \<lbrakk>X \<subseteq> D; X \<noteq> {}\<rbrakk> \<Longrightarrow> \<exists>a \<in> X. \<forall>x \<in> X. \<langle>x, a\<rangle> \<in> R \<longrightarrow> x = a"
  shows "well_founded D R"
  using assms unfolding well_founded_def by auto

definition "well_order D R \<equiv> linear_order D R \<and> well_founded D R"

end


theory ivt

imports Complex_Main

begin

theorem ivt:
  fixes f :: "real \<Rightarrow> real" and a b :: real
  assumes ctsf: "continuous_on {a..b} f"
      and "a < b" and fa1: "f a < 0" and fa2: "f b > 0"
  shows "\<exists> x \<in> {a..b}. f x = 0"
proof -
  have "a \<in> {a..b}" using assms by auto
  have [simp]: "a \<in> {x. x \<in> {a..b} \<and> f x < 0}" using assms by auto
  have "bdd_above {a..b}" by auto
  have "bdd_above {x. x \<in> {a..b} \<and> f x < 0}" by auto
  define y where "y = Sup {x. x \<in> {a..b} \<and> f x < 0}"
  have "y \<in> {a..b}"
    by (smt \<open>a \<in> {x \<in> {a..b}. f x < 0}\<close> \<open>bdd_above {a..b}\<close>
          \<open>bdd_above {x \<in> {a..b}. f x < 0}\<close> atLeastAtMost_iff
          cSup_atLeastAtMost cSup_mono empty_iff mem_Collect_eq y_def)
  have "\<not> f y < 0"
  proof
    assume "f y < 0"
    hence "- f y > 0" by linarith
    with ctsf have "\<exists> \<delta>. \<delta> > 0 \<and>
        (\<forall> x. x \<in> {a..b} \<and> abs (x - y) < \<delta> \<longrightarrow> abs (f x - f y) < - f y)"
      apply (simp add: continuous_on_def tendsto_iff dist_real_def
              eventually_at)
      by (metis \<open>0 < - f y\<close> \<open>y \<in> {a..b}\<close> abs_zero atLeastAtMost_iff
            cancel_comm_monoid_add_class.diff_cancel)
    then obtain \<delta> where "\<delta> > 0" and
        h: "\<And>x. x \<in> {a..b} \<Longrightarrow> abs (x - y) < \<delta> \<Longrightarrow> abs (f x - f y) < - f y"
      by auto
    let ?\<delta>' = "min (\<delta> / 2) (b - y)"
    let ?y' = "y + ?\<delta>'"
    from \<open>y \<in> {a..b}\<close> \<open>f y < 0\<close> \<open>f b > 0\<close> have "y < b"
      by (smt atLeastAtMost_iff)
    with \<open>\<delta> > 0\<close> have "?y' > y" by linarith
    from \<open>y \<in> {a..b}\<close> \<open>\<delta> > 0\<close> have "?y' \<in> {a..b}" and "abs (?y' - y) < \<delta>"
      by auto
    hence "abs (f ?y' - f y) < - f y" by (auto intro: h)
    with \<open>- f y > 0\<close> have "f ?y' < 0" by auto
    with \<open>?y' \<in> {a..b}\<close> have "y \<ge> ?y'"
      by - (subst (3) y_def, rule cSup_upper, auto)
    thus False
      using \<open>0 < \<delta>\<close> \<open>y < b\<close> by linarith
  qed
  moreover have "\<not> f y > 0"
  proof
    assume "f y > 0"
    with ctsf have "\<exists> \<delta>. \<delta> > 0 \<and>
        (\<forall> x. x \<in> {a..b} \<and> abs (x - y) < \<delta> \<longrightarrow> abs (f x - f y) < f y)"
      apply (simp add: continuous_on_def tendsto_iff dist_real_def
              eventually_at)
      by (metis \<open>0 < f y\<close> \<open>y \<in> {a..b}\<close> abs_zero atLeastAtMost_iff
            cancel_comm_monoid_add_class.diff_cancel)
    then obtain \<delta> where "\<delta> > 0" and
        h: "\<And>x. x \<in> {a..b} \<Longrightarrow> abs (x - y) < \<delta> \<Longrightarrow> abs (f x - f y) < f y"
      by auto
    from \<open>y \<in> {a..b}\<close> \<open>f y > 0\<close> \<open>f a < 0\<close> have "y > a"
      by (smt atLeastAtMost_iff)
    let ?\<delta>' = "min (\<delta> / 2) (y - a)"
    let ?y' = "y - ?\<delta>'"
    from \<open>0 < \<delta>\<close> \<open>a < y\<close> \<open>a \<in> {x. x \<in> {a..b} \<and> f x < 0}\<close>
        have "\<exists> y'' \<in> {x. x \<in> {a..b} \<and> f x < 0}. ?y' < y''"
      by (subst y_def, subst less_cSup_iff [symmetric], auto)
    then obtain y'' where "y'' > ?y'"
           and hy'': "y'' \<in> {x. x \<in> {a..b} \<and> f x < 0}" by auto
    hence "y'' \<le> y"
      by (metis \<open>bdd_above {x \<in> {a..b}. f x < 0}\<close> cSup_upper y_def)
    with \<open>y'' > ?y'\<close> \<open>y \<in> {a..b}\<close> \<open>\<delta> > 0\<close> hy'' have "abs (f y'' - f y) < f y"
      by (auto intro: h)
    hence "f y'' > 0" by auto
    with hy'' show False by auto
  qed
  ultimately have "f y = 0" by linarith
  with \<open>y \<in> {a..b}\<close> show ?thesis by blast
qed

theorem ivt_original_beginning:
  fixes f :: "real \<Rightarrow> real" and a b :: real
  assumes ctsf: "continuous_on {a..b} f"
      and "a < b" and fa1: "f a < 0" and fa2: "f b > 0"
  shows "True"
proof -
  define y where "y = Sup {x. x \<in> {a..b} \<and> f x < 0}"
  have "y \<in> {a..b}"
  proof -
    have "y \<le> Sup {a..b}"
      apply (subst y_def)
      apply (rule cSup_mono)
      using assms apply auto
      apply (rule_tac x = "a" in exI)
      by auto
    hence "y \<le> b" using \<open>a < b\<close> by auto
    moreover have "a \<le> y"
      apply (auto simp add: y_def)
      apply (rule cSup_upper)
      using assms by auto
    ultimately show ?thesis by auto
  qed
  show ?thesis by auto
qed

end

(* Notes
To state the theorem, need to remember {a..b}, and find notation Sup in file.

The problem is that the library is deep.

Sledgehammer didn't get y \<in> {a..b} or even y \<le> b, so I added y \<le> Sup {a..b}.

Golfed down -- automation

Arithmetic -- auto, smt, and linarith

Two places where sledgehammer might have helped: figuring out how to go from continuity to the
property I knew it had, and little properties of suprema. (In generality. Side conditions, set
not empty, bounded above.)
*)


(* 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.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_74
imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

fun take :: "Nat => 'a list => 'a list" where
"take (Z) z = nil2"
| "take (S z2) (nil2) = nil2"
| "take (S z2) (cons2 x2 x3) = cons2 x2 (take z2 x3)"

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

fun len :: "'a list => Nat" where
"len (nil2) = Z"
| "len (cons2 z xs) = S (len xs)"

fun drop :: "Nat => 'a list => 'a list" where
"drop (Z) z = z"
| "drop (S z2) (nil2) = nil2"
| "drop (S z2) (cons2 x2 x3) = drop z2 x3"

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

theorem property0 :
  "((rev (take i xs)) = (drop (t2 (len xs) i) (rev xs)))"
  oops

end


(*
  Title: Duality Based on a Data Type
  Author: Georg Struth
  Maintainer:Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Duality Based on a Data Type\<close>

theory Order_Lattice_Props_Wenzel
  imports Main
begin

unbundle lattice_syntax

subsection \<open>Wenzel's Approach Revisited\<close>

text \<open>This approach is similar to, but inferior to the explicit class-based one. The main caveat is that duality is not involutive
with this approach, and this allows dualising less theorems.\<close>

text \<open>I copy Wenzel's development \<^cite>\<open>"Wenzel"\<close> in this subsection and extend it with additional properties. I show only the most important properties.\<close>

datatype 'a dual = dual (un_dual: 'a) ("\<partial>")

notation un_dual ("\<partial>\<^sup>-")

lemma dual_inj: "inj \<partial>"
  using injI by fastforce

lemma dual_surj: "surj \<partial>"
  using dual.exhaust_sel by blast

lemma dual_bij: "bij \<partial>"
  by (simp add: bijI dual_inj dual_surj)

text \<open>Dual is not idempotent, and I see no way of imposing this condition. Yet at least an inverse exists --- namely un-dual..\<close>

lemma dual_inv1 [simp]: "\<partial>\<^sup>- \<circ> \<partial> = id"
  by fastforce

lemma dual_inv2 [simp]: "\<partial> \<circ> \<partial>\<^sup>- = id"
  by fastforce

lemma dual_inv_surj: "surj \<partial>\<^sup>-"
  by (metis dual.sel surj_def)

lemma dual_inv_bij: "bij \<partial>\<^sup>-"
  by (simp add: bij_def dual_inv_inj dual_inv_surj)

text \<open>Isabelle data types come with a number of generic functions.\<close>

text \<open>The functor map-dual lifts functions to dual types. Isabelle's generic definition is not straightforward to
understand and use. Yet conceptually it can be explained as follows.\<close>

lemma map_dual_def_var [simp]: "(map_dual::('a \<Rightarrow> 'b) \<Rightarrow> 'a dual \<Rightarrow> 'b dual) f = \<partial> \<circ> f \<circ> \<partial>\<^sup>-"
  unfolding fun_eq_iff comp_def by (metis dual.map_sel dual_iff)

lemma map_dual_def_var2: "\<partial>\<^sup>- \<circ> map_dual f = f \<circ> \<partial>\<^sup>-"
  by (simp add: rewriteL_comp_comp)

lemma map_dual_func1: "map_dual (f \<circ> g) = map_dual f \<circ> map_dual g"
  unfolding fun_eq_iff comp_def by (metis dual.exhaust dual.map)

lemma map_dual_func2 : "map_dual id = id"
  by simp

text \<open>The functor map-dual has an inverse functor as well.\<close>

definition map_dual_inv :: "('a dual \<Rightarrow> 'b dual) => ('a => 'b)" where
  "map_dual_inv f = \<partial>\<^sup>- \<circ> f \<circ> \<partial>"

lemma map_dual_inv_func1: "map_dual_inv id = id"
  by (simp add: map_dual_inv_def)

lemma map_dual_inv_func2: "map_dual_inv (f \<circ> g) = map_dual_inv f \<circ> map_dual_inv g"
  unfolding fun_eq_iff comp_def map_dual_inv_def by (metis dual_iff)

lemma map_dual_inv1: "map_dual \<circ> map_dual_inv = id"
  unfolding fun_eq_iff map_dual_def_var map_dual_inv_def comp_def id_def
  by (metis dual_iff)

lemma map_dual_inv2: "map_dual_inv \<circ> map_dual = id"
  unfolding fun_eq_iff map_dual_def_var map_dual_inv_def comp_def id_def
  by (metis dual_iff)

text \<open>Hence dual is an isomorphism between categories.\<close>

lemma subset_dual: "(\<partial> ` X = Y) \<longleftrightarrow> (X = \<partial>\<^sup>- ` Y)"
  by (metis dual_inj image_comp image_inv_f_f inv_o_cancel dual_inv2)

lemma subset_dual1: "(X \<subseteq> Y) \<longleftrightarrow> (\<partial> ` X \<subseteq> \<partial> ` Y)"
  by (simp add: dual_inj inj_image_subset_iff)

lemma dual_ball: "(\<forall>x \<in> X. P (\<partial> x)) \<longleftrightarrow> (\<forall>y \<in> \<partial> ` X. P y)"
  by simp

lemma dual_inv_ball: "(\<forall>x \<in> X. P (\<partial>\<^sup>- x)) \<longleftrightarrow> (\<forall>y \<in> \<partial>\<^sup>- ` X. P y)"
  by simp

lemma dual_all: "(\<forall>x. P (\<partial> x)) \<longleftrightarrow> (\<forall>y. P y)"
  by (metis dual.collapse)

lemma dual_inv_all: "(\<forall>x. P (\<partial>\<^sup>- x)) \<longleftrightarrow> (\<forall>y. P y)"
  by (metis dual_inv_surj surj_def)

lemma dual_ex: "(\<exists>x. P (\<partial> x)) \<longleftrightarrow> (\<exists>y. P y)"
  by (metis UNIV_I bex_imageD dual_surj)

lemma dual_inv_ex: "(\<exists>x. P (\<partial>\<^sup>- x)) \<longleftrightarrow> (\<exists>y. P y)"
  by (metis dual.sel)

lemma dual_Collect: "{\<partial> x |x. P (\<partial> x)} = {y. P y}"
  by (metis dual.exhaust)

lemma dual_inv_Collect: "{\<partial>\<^sup>- x |x. P (\<partial>\<^sup>- x)} = {y. P y}"
  by (metis dual.collapse dual.inject)

lemma fun_dual1: "(f \<circ> \<partial> = g) \<longleftrightarrow> (f = g \<circ> \<partial>\<^sup>-)"
  by auto

lemma fun_dual2: "(\<partial> \<circ> f = g) \<longleftrightarrow> (f = \<partial>\<^sup>- \<circ> g)"
  by auto

lemma fun_dual3: "(f \<circ> (`) \<partial> = g) \<longleftrightarrow> (f = g \<circ> (`) \<partial>\<^sup>-)"
  unfolding fun_eq_iff comp_def by (metis subset_dual)

lemma fun_dual4: "(f = \<partial>\<^sup>- \<circ> g \<circ> (`) \<partial>) \<longleftrightarrow> (\<partial> \<circ> f \<circ> (`) \<partial>\<^sup>- = g)"
  by (metis fun_dual2 fun_dual3 o_assoc)

text \<open>The next facts show incrementally that the dual of a complete lattice is a complete lattice.
This follows once again Wenzel.\<close>

instantiation dual :: (ord) ord
begin

definition less_eq_dual_def: "(\<le>) = rel_dual (\<ge>)"

definition less_dual_def: "(<) = rel_dual (>)"

instance..

end

lemma less_eq_dual_def_var: "(x \<le> y) = (\<partial>\<^sup>- y \<le> \<partial>\<^sup>- x)"
  apply (rule antisym)
  apply (simp add: dual.rel_sel less_eq_dual_def)
  by (simp add: dual.rel_sel less_eq_dual_def)

lemma less_dual_def_var: "(x < y) = (\<partial>\<^sup>- y < \<partial>\<^sup>- x)"
  by (simp add: dual.rel_sel less_dual_def)

instance dual :: (preorder) preorder
  apply standard
  apply (simp add: less_dual_def_var less_eq_dual_def_var less_le_not_le)
  apply (simp add: less_eq_dual_def_var)
  by (meson less_eq_dual_def_var order_trans)

instance dual :: (order) order
  by (standard, simp add: dual.expand less_eq_dual_def_var)

lemma dual_anti: "x \<le> y \<Longrightarrow> \<partial> y \<le> \<partial> x"
  by (simp add: dual_inj less_eq_dual_def the_inv_f_f)

lemma dual_anti_iff: "(x \<le> y) = (\<partial> y \<le> \<partial> x)"
  by (simp add: dual_inj less_eq_dual_def the_inv_f_f)

text \<open>map-dual does not map isotone functions to antitone ones. It simply lifts the type!\<close>

lemma "mono f \<Longrightarrow> mono (map_dual f)"
  unfolding map_dual_def_var mono_def by (metis comp_apply dual_anti less_eq_dual_def_var)

instantiation dual :: (lattice) lattice
begin

definition inf_dual_def: "x \<sqinter> y = \<partial> (\<partial>\<^sup>- x \<squnion> \<partial>\<^sup>- y)"

definition sup_dual_def: "x \<squnion> y = \<partial> (\<partial>\<^sup>- x \<sqinter> \<partial>\<^sup>- y)"

instance
  by (standard, simp_all add: dual_inj inf_dual_def sup_dual_def less_eq_dual_def_var the_inv_f_f)

end

instantiation dual :: (complete_lattice) complete_lattice
begin

definition Inf_dual_def: "Inf = \<partial> \<circ> Sup \<circ> (`) \<partial>\<^sup>-"

definition Sup_dual_def: "Sup = \<partial> \<circ> Inf \<circ> (`) \<partial>\<^sup>-"

definition bot_dual_def: "\<bottom> = \<partial> \<top>"

definition top_dual_def: "\<top> = \<partial> \<bottom>"

instance
   by (standard, simp_all add: Inf_dual_def top_dual_def Sup_dual_def bot_dual_def dual_inj le_INF_iff SUP_le_iff INF_lower SUP_upper less_eq_dual_def_var the_inv_f_f)

end

text \<open>Next, directed and filtered sets, upsets, downsets, filters and ideals in posets are defined.\<close>

context ord
begin

definition directed :: "'a set \<Rightarrow> bool" where
 "directed X = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. y \<le> x))"

definition filtered :: "'a set \<Rightarrow> bool" where
 "filtered X = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X. \<forall>y \<in> Y. x \<le> y))"

definition downset_set :: "'a set \<Rightarrow> 'a set" ("\<Down>") where
  "\<Down>X = {y. \<exists>x \<in> X. y \<le> x}"

definition upset_set :: "'a set \<Rightarrow> 'a set" ("\<Up>") where
 "\<Up>X = {y. \<exists>x \<in> X. x \<le> y}"

end

subsection \<open>Examples that Do Not Dualise\<close>

text \<open>Filtered and directed sets are dual.\<close>

text \<open>Proofs could be simplified if dual was idempotent.\<close>

lemma filtered_directed_dual: "filtered \<circ> (`) \<partial> = directed"
proof-
  {fix X::"'a set"
    have "(filtered \<circ> (`) \<partial>) X = (\<forall>Y. finite (\<partial>\<^sup>- ` Y) \<and> \<partial>\<^sup>- ` Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X.\<forall>y \<in> (\<partial>\<^sup>- ` Y). \<partial> x \<le> \<partial> y))"
      unfolding filtered_def comp_def by (simp, metis dual_iff finite_subset_image subset_dual subset_dual1)
    also have "... = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X.\<forall>y \<in> Y. y \<le> x))"
      by (metis dual_anti_iff dual_inv_surj finite_subset_image top.extremum)
    finally have "(filtered \<circ> (`) \<partial>) X = directed X"
      using directed_def by auto}
  thus ?thesis
    unfolding fun_eq_iff by simp
qed

lemma directed_filtered_dual: "directed \<circ> (`) \<partial> = filtered"
proof-
  {fix X::"'a set"
    have "(directed \<circ> (`) \<partial>) X = (\<forall>Y. finite (\<partial>\<^sup>- ` Y) \<and> \<partial>\<^sup>- ` Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X.\<forall>y \<in> (\<partial>\<^sup>- ` Y). \<partial> y \<le> \<partial> x))"
      unfolding directed_def comp_def by (simp, metis dual_iff finite_subset_image subset_dual subset_dual1)
  also have "... = (\<forall>Y. finite Y \<and> Y \<subseteq> X \<longrightarrow> (\<exists>x \<in> X.\<forall>y \<in> Y. x \<le> y))"
    unfolding dual_anti_iff[symmetric] by (metis dual_inv_surj finite_subset_image top_greatest)
  finally have "(directed \<circ> (`) \<partial>) X = filtered X"
    using filtered_def by auto}
  thus ?thesis
    unfolding fun_eq_iff by simp
qed

text \<open>This example illustrates the deficiency of the approach. In the class-based approach the second proof is trivial.\<close>

text \<open>The next example shows that this is a systematic problem.\<close>

lemma downset_set_upset_set_dual: "(`) \<partial> \<circ> \<Down> = \<Up> \<circ> (`) \<partial>"
  proof-
    {fix X::"'a set"
  have "((`) \<partial> \<circ> \<Down>) X = {\<partial> y |y. \<exists>x \<in> X. y \<le> x}"
    by (simp add: downset_set_def setcompr_eq_image)
  also have "... = {\<partial> y |y. \<exists>x \<in> X. \<partial> x \<le> \<partial> y}"
    by (meson dual_anti_iff)
  also have "... = {y. \<exists>x \<in> \<partial> ` X. x \<le> y}"
    by (metis (mono_tags, opaque_lifting) dual.exhaust image_iff)
  finally have "((`) \<partial> \<circ> \<Down>) X = (\<Up> \<circ> (`) \<partial>) X"
    by (simp add: upset_set_def)}
  thus ?thesis
    unfolding fun_eq_iff by simp
qed

lemma upset_set_downset_set_dual: "(`) \<partial> \<circ> \<Up> = \<Down> \<circ> (`) \<partial>"
  unfolding downset_set_def upset_set_def fun_eq_iff comp_def
  apply (safe, force simp: dual_anti)
  by (metis (mono_tags, lifting) dual.exhaust dual_anti_iff mem_Collect_eq rev_image_eqI)

end


theory Ex014
imports Main
begin

(*commutativity of "and"*)

lemma "A \<and> B \<longleftrightarrow> B \<and> A"
proof -
{
  assume "A \<and> B"
  hence A by (rule conjE)
  from \<open>A \<and> B\<close> have B  by (rule conjE)
  from this and  \<open>A\<close> have "B \<and> A" by (rule conjI)
} (*A \<and> B \<Longrightarrow> B \<and> A*)
{
  assume "B \<and> A"
  hence A by (rule conjE)
  from \<open>B \<and> A\<close> have B  by (rule conjE)
  with  \<open>A\<close> have "A \<and> B" by (rule conjI)
}
from  \<open>A \<and> B \<Longrightarrow> B \<and> A\<close> and this show ?thesis by (rule iffI)
qed

(*using moreover and ultimately to collect facts*)

lemma "A \<and> B \<longleftrightarrow> B \<and> A"
proof -
{
  assume "A \<and> B"
  hence A by (rule conjE)
  from \<open>A \<and> B\<close> have B  by (rule conjE)
  from this and  \<open>A\<close> have "B \<and> A" by (rule conjI)
} (*A \<and> B \<Longrightarrow> B \<and> A*)
moreover
{
  assume "B \<and> A"
  hence A by (rule conjE)
  from \<open>B \<and> A\<close> have B  by (rule conjE)
  with  \<open>A\<close> have "A \<and> B" by (rule conjI)
}
ultimately show ?thesis by (rule iffI)
qed


theory lec8 imports Main begin

text {*
  Proving two examples from Logic and Proof lecture 8
*}

lemma " \<forall>x.\<exists>y. \<not>(P(y,x) \<longleftrightarrow> \<not>P(y,y))"
  apply(rule allI)
  apply(rule exI)
  apply(rule notI)
  apply(erule iffE)
  apply (erule impE)
   apply (rule classical)
   apply (erule mp)
   apply assumption
  apply (erule impE)
   apply assumption
  apply(erule notE)
  apply assumption
  done

lemma "(((\<exists>x. P \<longrightarrow> Q x) \<and> ((\<exists>x. Q x \<longrightarrow> P)) \<longrightarrow> ( \<exists>x. (P = Q x)))) "
  apply(rule impI)
  apply(erule conjE)
  apply(erule exE)+
  apply(rule classical)
  apply (rule exI)
  apply (rule iffI)
   apply (erule notE)
   apply(erule impE)
    apply assumption
   apply (rule exI)
   apply (rule iffI)
    apply assumption
  apply assumption
  apply (erule impE)
   apply (erule impE)
    apply assumption
   apply assumption
  apply (erule impE)
   apply assumption+
  done


theory ex2_7
imports Main
begin

datatype 'a tree = Leaf | Node "'a tree" 'a "'a tree"

fun mirror :: "'a tree \<Rightarrow> 'a tree" where
"mirror Leaf = Leaf" |
"mirror (Node l x r) = Node (mirror r) x (mirror l)"

fun pre_order :: "'a tree \<Rightarrow> 'a list" where
"pre_order Leaf =[]" |
"pre_order (Node l x r) = [x]@(pre_order l)@(pre_order r)"

fun post_order :: "'a tree \<Rightarrow> 'a list" where
"post_order Leaf = []" |
"post_order (Node l x r) = (post_order l)@(post_order r)@[x]"

value "mirror(Node (Node Leaf a Leaf) b t)"
value "pre_order (Node (Node Leaf a Leaf) b t)"
value "post_order (Node (Node Leaf a Leaf) b t)"

lemma order : "pre_order (mirror t) = rev (post_order t)"
apply (induction t)
apply (auto)
done

end


theory Ugraphs
imports
  Girth_Chromatic_Misc
begin

section {* Undirected Simple Graphs *}

text {*
  In this section, we define some basics of graph theory needed to formalize
  the Chromatic-Girth theorem.
*}

text {*
  For readability, we introduce synonyms for the types of vertexes, edges,
  graphs and walks.
*}
type_synonym uvert = nat
type_synonym uedge = "nat set"
type_synonym ugraph = "uvert set \<times> uedge set"
type_synonym uwalk = "uvert list"

abbreviation uedges :: "ugraph \<Rightarrow> uedge set" where
  "uedges G \<equiv> snd G"

abbreviation uverts :: "ugraph \<Rightarrow> uvert set" where
  "uverts G \<equiv> fst G"

fun mk_uedge :: "uvert \<times> uvert \<Rightarrow> uedge" where
   "mk_uedge (u,v) = {u,v}"

text {* All edges over a set of vertexes @{term S}: *}
definition "all_edges S \<equiv> mk_uedge ` {uv \<in> S \<times> S. fst uv \<noteq> snd uv}"

definition uwellformed :: "ugraph \<Rightarrow> bool" where
  "uwellformed G \<equiv> (\<forall>e\<in>uedges G. card e = 2 \<and> (\<forall>u \<in> e. u \<in> uverts G))"

fun uwalk_edges :: "uwalk \<Rightarrow> uedge list" where
    "uwalk_edges [] = []"
  | "uwalk_edges [x] = []"
  | "uwalk_edges (x # y # ys) = {x,y} # uwalk_edges (y # ys)"

definition uwalk_length :: "uwalk \<Rightarrow> nat" where
  "uwalk_length p \<equiv> length (uwalk_edges p)"

definition uwalks :: "ugraph \<Rightarrow> uwalk set" where
  "uwalks G \<equiv> {p. set p \<subseteq> uverts G \<and> set (uwalk_edges p) \<subseteq> uedges G \<and> p \<noteq> []}"

definition ucycles :: "ugraph \<Rightarrow> uwalk set" where
  "ucycles G \<equiv> {p. uwalk_length p \<ge> 3 \<and> p \<in> uwalks G \<and> distinct (tl p) \<and> hd p = last p}"

definition remove_vertex :: "ugraph \<Rightarrow> nat \<Rightarrow> ugraph" ("_ -- _" [60,60] 60) where
  "remove_vertex G u \<equiv> (uverts G - {u}, uedges G - {A \<in> uedges G. u \<in> A})"

subsection {* Basic Properties *}

lemma uwalk_length_conv: "uwalk_length p = length p - 1"
  by (induct p rule: uwalk_edges.induct) (auto simp: uwalk_length_def)

lemma all_edges_mono:
  "vs \<subseteq> ws \<Longrightarrow> all_edges vs \<subseteq> all_edges ws"
using assms unfolding all_edges_def by auto

lemma all_edges_subset_Pow: "all_edges A \<subseteq> Pow A"
  by (auto simp: all_edges_def)

lemma in_mk_uedge_img: "(a,b) \<in> A \<or> (b,a) \<in> A \<Longrightarrow> {a,b} \<in> mk_uedge ` A"
  by (auto intro: rev_image_eqI)

lemma distinct_edgesI:
  assumes "distinct p" shows "distinct (uwalk_edges p)"
proof -
  from assms have "?thesis" "\<And>u. u \<notin> set p \<Longrightarrow> (\<And>v. u \<noteq> v \<Longrightarrow> {u,v} \<notin> set (uwalk_edges p))"
    by (induct p rule: uwalk_edges.induct) auto
  then show ?thesis by simp
qed

lemma finite_ucycles:
  assumes "finite (uverts G)"
  shows "finite (ucycles G)"
proof -
  have "ucycles G \<subseteq> {xs. set xs \<subseteq> uverts G \<and> length xs \<le> Suc (card (uverts G))}"
  proof (rule, simp)
    fix p assume "p \<in> ucycles G"
    then have "distinct (tl p)" and "set p \<subseteq> uverts G"
      unfolding ucycles_def uwalks_def by auto
    moreover
    then have "set (tl p) \<subseteq> uverts G"
      by (auto simp: list_set_tl)
    with assms have "card (set (tl p)) \<le> card (uverts G)"
      by (rule card_mono)
    then have "length (p) \<le> 1 + card (uverts G)"
      using distinct_card[OF `distinct (tl p)`] by auto
    ultimately show "set p \<subseteq> uverts G \<and> length p \<le> Suc (card (uverts G))" by auto
  qed
  moreover
  have "finite {xs. set xs \<subseteq> uverts G \<and> length xs \<le> Suc (card (uverts G))}"
    using assms by (rule finite_lists_length_le)
  ultimately
  show ?thesis by (rule finite_subset)
qed

lemma ucycles_distinct_edges:
  assumes "c \<in> ucycles G" shows "distinct (uwalk_edges c)"
proof -
  from assms have c_props: "distinct (tl c)" "4 \<le> length c" "hd c = last c"
    by (auto simp add: ucycles_def uwalk_length_conv)
  then have "{hd c, hd (tl c)} \<notin> set (uwalk_edges (tl c))"
  proof (induct c rule: uwalk_edges.induct)
    case (3 x y ys)
    then have "hd ys \<noteq> last ys" by (cases ys) auto
    moreover
    from 3 have "uwalk_edges (y # ys) = {y, hd ys} # uwalk_edges ys"
      by (cases ys) auto
    moreover
    { fix xs have "set (uwalk_edges xs) \<subseteq> Pow (set xs)"
        by (induct xs rule: uwalk_edges.induct) auto }
    ultimately
    show ?case using 3 by auto
  qed simp_all
  moreover
  from assms have "distinct (uwalk_edges (tl c))"
    by (intro distinct_edgesI) (simp add: ucycles_def)
  ultimately
  show ?thesis by (cases c rule: list_exhaust3) auto
qed

lemma card_left_less_pair:
  fixes A :: "('a :: linorder) set"
  assumes "finite A"
  shows "card {(a,b). a \<in> A \<and> b \<in> A \<and> a < b}
    = (card A * (card A - 1)) div 2"
using assms
proof (induct A)
  case (insert x A)

  show ?case
  proof (cases "card A")
    case (Suc n)
    have "{(a,b). a \<in> insert x A \<and> b \<in> insert x A \<and> a < b}
        = {(a,b). a \<in> A \<and> b \<in> A \<and> a < b} \<union> (\<lambda>a. if a < x then (a,x) else (x,a)) ` A"
      using `x \<notin> A` by (auto simp: order_less_le)
    moreover
    have "finite {(a,b). a \<in> A \<and> b \<in> A \<and> a < b}"
      using insert by (auto intro: finite_subset[of _ "A \<times> A"])
    moreover
    have "{(a,b). a \<in> A \<and> b \<in> A \<and> a < b} \<inter> (\<lambda>a. if a < x then (a,x) else (x,a)) ` A = {}"
      using `x \<notin> A` by auto
    moreover have "inj_on (\<lambda>a. if a < x then (a, x) else (x, a)) A"
      by (auto intro: inj_onI split: split_if_asm)
    ultimately show ?thesis using insert Suc
      by (simp add: card_Un_disjoint card_image del: if_image_distrib)
  qed (simp add: card_0_iff insert)
qed simp

lemma card_all_edges:
  assumes "finite A"
  shows "card (all_edges A) = card A choose 2"
proof -
  have inj_on_mk_uedge: "inj_on mk_uedge {(a,b). a < b}"
    by (rule inj_onI) (auto simp: doubleton_eq_iff)
  have "all_edges A = mk_uedge ` {(a,b). a \<in> A \<and> b \<in> A \<and> a < b}" (is "?L = ?R")
    by (auto simp: all_edges_def intro!: in_mk_uedge_img)
  then have "card ?L = card ?R" by simp
  also have "\<dots> = card {(a,b). a \<in> A \<and> b \<in> A \<and> a < b}"
    using inj_on_mk_uedge by (blast intro: card_image subset_inj_on)
  also have "\<dots> = (card A * (card A - 1)) div 2"
    using card_left_less_pair using assms by simp
  also have "\<dots> = (card A choose 2)"
    by (simp add: n_choose_2_nat)
  finally show ?thesis .
qed

lemma verts_Gu: "uverts (G -- u) = uverts G - {u}"
  unfolding remove_vertex_def by simp

lemma edges_Gu: "uedges (G -- u) \<subseteq> uedges G"
  unfolding remove_vertex_def by auto

subsection {* Girth, Independence and Vertex Colorings *}

definition girth :: "ugraph \<Rightarrow> enat" where
  "girth G \<equiv> INF p: ucycles G. enat (uwalk_length p)"

definition independent_sets :: "ugraph \<Rightarrow> uvert set set" where
  "independent_sets Gr \<equiv> {vs. vs \<subseteq> uverts Gr \<and> all_edges vs \<inter> uedges Gr = {}}"

definition \<alpha> :: "ugraph \<Rightarrow> enat" where
   "\<alpha> G \<equiv> SUP vs: independent_sets G. enat (card vs)"

definition vertex_colorings :: "ugraph \<Rightarrow> uvert set set set" where
  "vertex_colorings G \<equiv> {C. \<Union>C = uverts G \<and> (\<forall>c1\<in>C. \<forall>c2\<in>C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {}) \<and>
    (\<forall>c\<in>C. c \<noteq> {} \<and> (\<forall>u \<in> c. \<forall>v \<in> c. {u,v} \<notin> uedges G))}"

text {* The chromatic number $\chi$: *}
definition chromatic_number :: "ugraph \<Rightarrow> enat" where
  "chromatic_number G \<equiv> INF c: (vertex_colorings G). enat (card c)"

lemma independent_sets_mono:
  "vs \<in> independent_sets G \<Longrightarrow> us \<subseteq> vs \<Longrightarrow> us \<in> independent_sets G"
  using Int_mono[OF all_edges_mono, of us vs "uedges G" "uedges G"]
  unfolding independent_sets_def by auto

lemma le_\<alpha>_iff:
  assumes "0 < k"
  shows "k \<le> \<alpha> Gr \<longleftrightarrow> k \<in> card ` independent_sets Gr" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  then obtain vs where "vs \<in> independent_sets Gr" and "k \<le> card vs"
    using assms unfolding \<alpha>_def SUP_def enat_le_Sup_iff by auto
  moreover
  then obtain us where "us \<subseteq> vs" and "k = card us"
    using card_Ex_subset by auto
  ultimately
  have "us \<in> independent_sets Gr"  by (auto intro: independent_sets_mono)
  then show ?R using `k = card us` by auto
qed (auto intro: SUP_upper simp: \<alpha>_def)

lemma zero_less_\<alpha>:
  assumes "uverts G \<noteq> {}"
  shows "0 < \<alpha> G"
proof -
  from assms obtain a where "a \<in> uverts G" by auto
  then have "0 < enat (card {a})" "{a} \<in> independent_sets G"
    by (auto simp: independent_sets_def all_edges_def)
  then show ?thesis unfolding \<alpha>_def less_SUP_iff ..
qed

lemma \<alpha>_le_card:
  assumes "finite (uverts G)"
  shows "\<alpha> G \<le> card(uverts G)"
proof -
  { fix x assume "x \<in> independent_sets G"
    then have "x \<subseteq> uverts G" by (auto simp: independent_sets_def) }
  with assms show ?thesis unfolding \<alpha>_def
    by (intro SUP_least) (auto intro: card_mono)
qed

lemma \<alpha>_fin: "finite (uverts G) \<Longrightarrow> \<alpha> G \<noteq> \<infinity>"
  using \<alpha>_le_card[of G] by (cases "\<alpha> G") auto

lemma \<alpha>_remove_le:
  shows "\<alpha> (G -- u) \<le> \<alpha> G"
proof -
  have "independent_sets (G -- u) \<subseteq> independent_sets G" (is "?L \<subseteq> ?R")
    using all_edges_subset_Pow by (simp add: independent_sets_def remove_vertex_def) blast
  then show ?thesis unfolding \<alpha>_def
    by (rule SUP_subset_mono) simp
qed

text {*
  A lower bound for the chromatic number of a graph can be given in terms of
  the independence number
*}
lemma chromatic_lb:
  assumes wf_G: "uwellformed G"
    and fin_G: "finite (uverts G)"
    and neG: "uverts G \<noteq> {}"
  shows "card (uverts G) / \<alpha> G \<le> chromatic_number G"
proof -
  from wf_G have "(\<lambda>v. {v}) ` uverts G \<in> vertex_colorings G"
    by (auto simp: vertex_colorings_def uwellformed_def)
  then have "chromatic_number G \<noteq> top"
    by (simp add: chromatic_number_def) (auto simp: top_enat_def)
  then obtain vc where vc_vc: "vc \<in> vertex_colorings G"
    and vc_size:"chromatic_number G = card vc"
    unfolding chromatic_number_def by (rule enat_in_INF)

  have fin_vc_elems: "\<And>c. c \<in> vc \<Longrightarrow> finite c"
    using vc_vc by (intro finite_subset[OF _ fin_G]) (auto simp: vertex_colorings_def)

  { have "vc \<subseteq> Pow (uverts G)" "finite (Pow (uverts G))"
      using assms vc_vc by (auto simp: vertex_colorings_def)
    then have "finite vc" by (rule finite_subset)
    with fin_vc_elems have "(\<Sum>c \<in> vc. card c) = card (uverts G)"
      using vc_vc unfolding vertex_colorings_def
      by (simp add: card_Union_disjoint[symmetric]) }
  note sum_vc_card = this

  have "\<And>c. c \<in> vc \<Longrightarrow> c \<in> independent_sets G"
    using vc_vc by (auto simp: vertex_colorings_def independent_sets_def all_edges_def)
  then have "\<And>c. c \<in> vc \<Longrightarrow> card c \<le> \<alpha> G"
    using vc_vc fin_vc_elems by (subst le_\<alpha>_iff) (auto simp add: vertex_colorings_def)
  then have "(\<Sum>c\<in>vc. card c) \<le> card vc * \<alpha> G"
    using setsum_bounded[of vc card "\<alpha> G"]
    by (simp add: of_nat_eq_enat[symmetric] of_nat_setsum)
  then have "ereal_of_enat (card (uverts G)) \<le> ereal_of_enat (\<alpha> G) * ereal_of_enat (card vc)"
    by (simp add: sum_vc_card ereal_of_enat_pushout ac_simps del: ereal_of_enat_simps)
  with zero_less_\<alpha>[OF neG] \<alpha>_fin[OF fin_G] vc_size show ?thesis
    by (simp add: ereal_divide_le_pos)
qed

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 Main
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^--1))^** x y --> (\<exists>z. R^** x z \<and> R^** y z))"

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

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^==); S \<le> T |] ==> square (R^==) S T (R^==)"
  apply (unfold square_def)
  apply (blast dest: predicate2D)
  done

lemma square_rtrancl:
    "square R S S T ==> square (R^**) S S (T^**)"
  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^**) (R^==) ==> commute (R^**) (S^**)"
  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^**) (S^**)"
  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^==) (R^==) ==> 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^**) (S^**) |] ==> 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^** |] ==> 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