theory PredTrans
  imports Assertions
begin

type_synonym 'a ptran = "'a pred \<Rightarrow> 'a pred"

(* Commands in Predicate Transformer Semantics *)

definition abort :: "'a ptran" where
  "abort q \<equiv> bot"

definition magic :: "'a ptran" where
  "magic q \<equiv> top"

definition skip :: "'a ptran" where
  "skip \<equiv> id"

definition assumption :: "'a pred \<Rightarrow> 'a ptran" ("\<lfloor>_\<rfloor>" [50] 100) where
  "\<lfloor>p\<rfloor> \<equiv> \<lambda>q. -p \<squnion> q"

definition seq :: "'a ptran \<Rightarrow> 'a ptran \<Rightarrow> 'a ptran" (infixl ";" 60) where
  "seq \<equiv> op o"

definition cond :: "'a pred \<Rightarrow> 'a ptran \<Rightarrow> 'a ptran \<Rightarrow> 'a ptran" where
  "cond b F G \<equiv> (\<lfloor>b\<rfloor> o F) \<sqinter> (\<lfloor>-b\<rfloor> o G)"

primrec pow :: "'a ptran \<Rightarrow> nat \<Rightarrow> 'a ptran" where
  "pow F 0 = \<top>"
| "pow F (Suc n) = F o (pow F n)"

lemma iso_pow: "mono F \<Longrightarrow> F \<le> G \<Longrightarrow> pow F n \<le> pow G n"
  apply (induct n)
  apply simp
  apply auto
  apply (simp add: le_fun_def)
  apply (rule allI)
  apply (erule_tac x=x in allE)
  apply (erule_tac x="pow G n x" in allE)
  apply (rule order_trans[rotated])
  apply assumption
  apply (rule monoE)
  apply assumption+
done

definition iteration :: "'a ptran \<Rightarrow> 'a ptran" ("_\<^sup>\<omega>" [999] 1000) where
  "F\<^sup>\<omega> \<equiv> \<Sqinter>{pow F n | n. True}"

lemma iso_iter: "mono F \<Longrightarrow> F \<le> G \<Longrightarrow> F\<^sup>\<omega> \<le> G\<^sup>\<omega>"
  apply (auto simp: iteration_def intro!: Inf_mono)
  apply (rule_tac x="pow F n" in exI)
  apply (auto intro: iso_pow)
done

definition cwhile :: "'a pred \<Rightarrow> 'a ptran \<Rightarrow> 'a ptran" where
  "cwhile b F \<equiv> (\<lfloor>b\<rfloor> o F)\<^sup>\<omega> o \<lfloor>-b\<rfloor>"

lemma iso_while: "mono F \<Longrightarrow> F \<le> G \<Longrightarrow> cwhile b F \<le> cwhile b G"
proof (auto simp: cwhile_def)
  assume a: "F \<le> G" and "mono F"
  hence "mono (\<lfloor>b\<rfloor> \<circ> F)"
    by (auto simp: mono_def assumption_def)
  moreover have "\<lfloor>b\<rfloor> \<circ> F \<le> \<lfloor>b\<rfloor> \<circ> G"
    using a by (auto simp: assumption_def le_fun_def)
  ultimately have "(\<lfloor>b\<rfloor> \<circ> F)\<^sup>\<omega> \<le> (\<lfloor>b\<rfloor> \<circ> G)\<^sup>\<omega>"
    by (auto intro!: iso_iter)
  thus "(\<lfloor>b\<rfloor> \<circ> F)\<^sup>\<omega> \<circ> \<lfloor>- b\<rfloor> \<le> (\<lfloor>b\<rfloor> \<circ> G)\<^sup>\<omega> \<circ> \<lfloor>- b\<rfloor>"
    by (auto simp: le_fun_def)
qed

text {* Annotated programs for automatic verification *}

definition awhile :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a ptran \<Rightarrow> 'a ptran" where
  "awhile i b x \<equiv> cwhile b x"

definition apre :: "'a pred \<Rightarrow> 'a ptran \<Rightarrow> 'a ptran" where
  "apre p x \<equiv> x"

definition apost :: "'a ptran \<Rightarrow> 'a pred\<Rightarrow> 'a ptran" where
  "apost x q \<equiv> x; apre q skip"

definition aprog :: "'a pred \<Rightarrow> 'a ptran \<Rightarrow> 'a pred \<Rightarrow> 'a ptran" where
  "aprog p x q \<equiv> x"

(* Algebraic Structure *)

lemma seq_assoc: "(x; y); z = x; (y; z)"
  by (auto simp: seq_def)

interpretation PT!: near_quantale_unital id "op o" Inf Sup inf less_eq less sup bot "top :: 'a ptran"
  by default auto

(* Commands are co-continue *)

definition cocontinuity :: "('a :: complete_lattice \<Rightarrow> 'a) \<Rightarrow> bool" where
  "cocontinuity f \<equiv> \<forall>X. \<Sqinter> (f ` X) = f (\<Sqinter> X)"

lemma cc_mono: "cocontinuity f \<Longrightarrow> mono f"
  by (simp add: Inf_continuity_mono cocontinuity_def monoI)

named_theorems ccptran

lemma cc_eq: "cocontinuity f \<longleftrightarrow> (\<forall>X. f (\<Sqinter>X) = \<Sqinter>{f x | x. x \<in> X})"
  apply (auto simp: cocontinuity_def)
  apply (metis Collect_mem_eq Inf_image_eq image_Collect)
  by (metis Collect_mem_eq Inf_image_eq image_Collect)

lemma cc_top [ccptran]: "cocontinuity \<top>"
  by (auto simp: cocontinuity_def magic_def)

lemma cc_magic [ccptran]: "cocontinuity (magic)"
  by (auto simp: cocontinuity_def magic_def)

lemma cc_skip [ccptran]: "cocontinuity (skip)"
  by (auto simp: cocontinuity_def skip_def)

lemma cc_assumption [ccptran]: "cocontinuity (\<lfloor>p\<rfloor>)"
  by (auto simp: cocontinuity_def assumption_def)

lemma cc_apply [ccptran]: "cocontinuity F \<Longrightarrow> cocontinuity G \<Longrightarrow> cocontinuity (F o G)"
  by (auto simp: cc_eq cocontinuity_def intro!: Inf_eqI Inf_lower Inf_greatest) force

lemma cc_seq [ccptran]: "cocontinuity F \<Longrightarrow> cocontinuity G \<Longrightarrow> cocontinuity (F; G)"
  by (auto simp: seq_def intro!: ccptran)

lemma cc_inf [ccptran]: "cocontinuity F \<Longrightarrow> cocontinuity G \<Longrightarrow> cocontinuity (F \<sqinter> G)"
  apply (auto simp: cocontinuity_def)
  by (metis INF_inf_distrib)

lemma cc_cond [ccptran]: "cocontinuity F \<Longrightarrow> cocontinuity G \<Longrightarrow> cocontinuity (cond b F G)"
  by (auto simp: cond_def intro: ccptran)

lemma cc_pow [ccptran]: "cocontinuity F \<Longrightarrow> cocontinuity (pow F n)"
  by (induct n) (auto intro: ccptran)

lemma cc_Inf [ccptran]: "\<forall>f \<in> F. cocontinuity f \<Longrightarrow> cocontinuity (\<Sqinter>F)"
proof (simp add: cc_eq, rule allI)
  fix X
  assume assm: "\<forall>f \<in> F. \<forall>X. f (\<Sqinter>X) = \<Sqinter>{f x |x. x \<in> X}"
  hence "(INF f:F. f (\<Sqinter>X)) = (INF f:F. \<Sqinter> {f x| x. x \<in> X})"
    by (auto intro: INF_cong)
  also have "... = \<Sqinter> {(INF f:F. f x) | x. x \<in> X}"
    apply (auto intro!: INF_eqI)
    apply (rule Inf_mono)
    apply auto
    apply (rule_tac x="(INF f:F. f x)" in exI)
    apply auto
    apply (rule INF_lower)
    apply simp
    apply (rule Inf_greatest)
    apply auto
    apply (rule INF_greatest)
    apply (subgoal_tac "\<Sqinter>{f x |x. x \<in> X} \<le> f xa")
    apply force
    apply (rule Inf_lower)
    by auto
  finally show "(INF f:F. f (\<Sqinter>X)) = \<Sqinter>{INF f:F. f x |x. x \<in> X}"
    by auto
qed

lemma cc_iter [ccptran]: "cocontinuity F \<Longrightarrow> cocontinuity (F\<^sup>\<omega>)"
  by (auto simp: iteration_def intro!: ccptran)

lemma cc_while [ccptran]: "cocontinuity F \<Longrightarrow> cocontinuity (cwhile b F)"
  by (auto simp: cwhile_def intro: ccptran)

lemma cc_awhile [ccptran]: "cocontinuity F \<Longrightarrow> cocontinuity (awhile i b F)"
  by (auto simp: awhile_def intro: ccptran)

lemma cc_apre [ccptran]: "cocontinuity F \<Longrightarrow> cocontinuity (apre p F)"
  by (auto simp: apre_def intro: ccptran)

lemma cc_apost [ccptran]: "cocontinuity F \<Longrightarrow> cocontinuity (apost F q)"
  by (auto simp: apost_def intro: ccptran)

lemma cc_aprog [ccptran]: "cocontinuity F \<Longrightarrow> cocontinuity (aprog p F q)"
  by (auto simp: aprog_def intro: ccptran)

(* Commands are monotone *)

named_theorems mptran

lemma mono_top [mptran]: "mono (\<top> :: 'a ptran)"
  by (auto intro: cc_mono ccptran)

lemma mono_magic [mptran]: "mono (magic)"
  by (auto simp: magic_def intro: cc_mono ccptran)

lemma mono_skip [mptran]: "mono (skip)"
  by (auto intro!: cc_mono ccptran)

lemma mono_assumption [mptran]: "mono (\<lfloor>p\<rfloor>)"
  by (auto intro!: cc_mono ccptran)

lemma mono_apply [mptran]: "mono F \<Longrightarrow> mono G \<Longrightarrow> mono (F o G)"
  by (auto simp: mono_def)

lemma mono_seq [mptran]: "mono F \<Longrightarrow> mono G \<Longrightarrow> mono (F; G)"
  by (auto simp: seq_def intro!: mptran)

lemma mono_inf [mptran]: "mono F \<Longrightarrow> mono G \<Longrightarrow> mono (F \<sqinter> G)"
  by (auto simp: mono_def le_infI1 le_infI2)

lemma mono_cond [mptran]: "mono F \<Longrightarrow> mono G \<Longrightarrow> mono (cond b F G)"
  by (auto simp: cond_def intro: mptran)

lemma mono_pow [mptran]: "mono F \<Longrightarrow> mono (pow F n)"
  by (induct n) (auto intro: mptran)

lemma mono_Inf [mptran]: "\<forall>(f :: 'a :: complete_lattice \<Rightarrow> 'a) \<in> F. mono f \<Longrightarrow> mono (\<Sqinter> F)"
  by (auto simp: order_class.mono_def, rule INF_mono) auto

lemma mono_iter [mptran]: "mono F \<Longrightarrow> mono (F\<^sup>\<omega>)"
  by (auto simp: iteration_def intro!: mptran)

lemma mono_while [mptran]: "mono F \<Longrightarrow> mono (cwhile b F)"
  by (auto simp: cwhile_def intro: mptran)

lemma mono_awhile [mptran]: "mono F \<Longrightarrow> mono (awhile i b F)"
  by (auto simp: awhile_def intro: mptran)

lemma mono_apre [mptran]: "mono F \<Longrightarrow> mono (apre p F)"
  by (auto simp: apre_def intro: mptran)

lemma mono_apost [mptran]: "mono F \<Longrightarrow> mono (apost F q)"
  by (auto simp: apost_def intro: mptran)

lemma mono_aprog [mptran]: "mono F \<Longrightarrow> mono (aprog p F q)"
  by (auto simp: aprog_def intro: mptran)

(* Locality *)

abbreviation local_pred :: "'a pred \<Rightarrow> bool" where
  "local_pred \<equiv> bbi.intuitionistic"

definition local :: "'a ptran \<Rightarrow> 'a pred \<Rightarrow> bool" where
  "local F r \<equiv> \<forall>q. (F q) * r \<le> F (q * r)"

(* Commands are local *)

named_theorems lptran

lemma local_top [lptran]: "local \<top> r"
  by (auto simp: local_def)

lemma local_abort [lptran]: "local (abort) r"
  by (auto simp: local_def abort_def)

lemma local_magic [lptran]: "local (magic) r"
  by (auto simp: local_def magic_def)

lemma local_skip [lptran]: "local (skip) r"
  by (auto simp: local_def skip_def)

lemma local_assumption [lptran]: "local_pred (-p) \<Longrightarrow> local (\<lfloor>p\<rfloor>) r"
  apply (simp add: local_def assumption_def)
  using Assertions.bbi.intuitionistic_upward_closure_var bbi.Sup.qdistr by blast

lemma local_apply [lptran]: "mono F \<Longrightarrow> local F r \<Longrightarrow> local G r \<Longrightarrow> local (F o G) r"
proof (subst local_def, rule allI, simp)
  fix q assume assm: "mono F" "local F r" "local G r"
  hence "F (G q) * r \<le> F (G q * r)"
    by (simp add: local_def)
  also have "... \<le> F (G (q * r))"
    using assm by (simp add: local_def mono_def)
  finally show "F (G q) * r \<subseteq> F (G (q * r))"
    by (simp add: local_def)
qed

lemma local_seq [lptran]: "mono F \<Longrightarrow> local F r \<Longrightarrow> local G r \<Longrightarrow> local (F; G) r"
  by (auto simp: seq_def intro: lptran)

lemma local_inf [lptran]: "local F r \<Longrightarrow> local G r \<Longrightarrow> local (F \<sqinter> G) r"
  apply (auto simp: local_def)
  using Assertions.bbi.qmeet_subdistr apply blast
  using Assertions.bbi.qmeet_subdistr apply blast
done

lemma local_cond [lptran]: "local_pred b \<Longrightarrow> local_pred (-b) \<Longrightarrow> local F r \<Longrightarrow> local G r \<Longrightarrow> local (cond b F G) r"
  by (auto simp: cond_def intro!: ccptran mptran lptran)

lemma local_pow [lptran]: "mono F \<Longrightarrow> local F r \<Longrightarrow> local (pow F n) r"
  by (induct n) (auto intro: lptran)

lemma local_Inf [lptran]: "\<forall>f \<in> F. local f r \<Longrightarrow> local (\<Sqinter>F) r"
  apply (simp add: local_def, rule allI)
  apply (rule INF_greatest)
  apply auto
by (metis (no_types) INF_lower2 bbi.Sup.qisol order_refl sep_comm subsetCE)

lemma local_iter [lptran]: "mono F \<Longrightarrow> local F r \<Longrightarrow> local (F\<^sup>\<omega>) r"
  by (auto simp: iteration_def intro: lptran)

lemma local_while [lptran]: "local_pred b \<Longrightarrow> local_pred (-b) \<Longrightarrow> mono F \<Longrightarrow> local F r \<Longrightarrow> local (cwhile b F) r"
  by (auto simp: cwhile_def intro!: lptran mptran)

lemma local_awhile [lptran]: "mono F \<Longrightarrow> local_pred b \<Longrightarrow> local_pred (-b) \<Longrightarrow> local F r \<Longrightarrow> local (awhile i b F) r"
  by (auto simp: awhile_def intro!: lptran mptran)

lemma local_apre [lptran]: "local F r \<Longrightarrow> local (apre p F) r"
  by (auto simp: apre_def intro: lptran)

lemma local_apost [lptran]: "mono F \<Longrightarrow> local F r \<Longrightarrow> local (apost F q) r"
  by (auto simp: apost_def intro!: lptran)

lemma local_aprog [lptran]: "local F r \<Longrightarrow> local (aprog p F q) r"
  by (auto simp: aprog_def intro: lptran)

(* Separation logic *)

named_theorems sl

definition ht :: "'a pred \<Rightarrow> 'a ptran \<Rightarrow> 'a pred \<Rightarrow> bool" where
  "ht p F q \<equiv> p \<le> F q"

lemma hl_skip [sl]: "p \<le> q \<Longrightarrow> ht p skip q"
  by (auto simp: ht_def skip_def)

lemma hl_apply [sl]: "mono F \<Longrightarrow> ht p F r \<Longrightarrow> ht r G q \<Longrightarrow> ht p (F o G) q"
  apply (simp add: ht_def mono_def seq_def)
  apply (rule order_trans)
  apply assumption
  apply (erule_tac x=r in allE)
  apply (erule_tac x="G q" in allE)
  by force

lemma hl_seq [sl]: "mono F \<Longrightarrow> ht p F r \<Longrightarrow> ht r G q \<Longrightarrow> ht p (F; G) q"
  by (auto simp: seq_def intro: sl)

lemma hl_asumption [sl]: "ht (b \<sqinter> p) F q \<Longrightarrow> ht p (\<lfloor>b\<rfloor> o F) q"
  by (simp add: ht_def seq_def assumption_def) blast

lemma hl_inf [sl]: "ht p F q \<Longrightarrow> ht p G q \<Longrightarrow> ht p (F \<sqinter> G) q"
  by (simp add: ht_def)

lemma hl_cond [sl]: "ht (b \<sqinter> p) F q \<Longrightarrow> ht (-b \<sqinter> p) G q \<Longrightarrow> ht p (cond b F G) q"
  by (auto simp: cond_def intro!: sl)

lemma "(F :: 'a ptran) \<le> F\<^sup>\<omega>"
  apply (auto simp: iteration_def)
  apply (rule Inf_greatest)
  apply auto
  apply (induct_tac n)
  apply (auto simp: le_fun_def)
oops

lemma hl_pow [sl]: "mono F \<Longrightarrow> p \<le> F p \<Longrightarrow> p \<le> pow F n p"
  apply (induct n)
  apply force
  apply simp
  apply (rule order_trans)
  apply assumption back
  apply (rule monoE)
  apply assumption+
done

lemma hl_iter [sl]: "mono F \<Longrightarrow> ht p F p \<Longrightarrow> ht p F\<^sup>\<omega> p"
  apply (simp add: ht_def iteration_def)
  apply (rule INF_greatest)
  apply auto
  using hl_pow by blast

lemma hl_while [sl]: "mono F \<Longrightarrow> ht (b \<sqinter> i) F i \<Longrightarrow> ht i (cwhile b F) (-b \<sqinter> i)"
  apply (auto simp: cwhile_def intro!: sl mptran)
  by (auto simp: ht_def assumption_def)

lemma sl_frame: "local F r \<Longrightarrow> ht p F q \<Longrightarrow> ht (p * r) F (q * r)"
  apply (auto simp: local_def ht_def)
  by (meson Assertions.bbi.sep_implE1 Assertions.bbi.sep_implI1 contra_subsetD dual_order.trans)

lemma sl_frame2: "local F r \<Longrightarrow> ht p F q \<Longrightarrow> ht (r * p) F (r * q)"
  by (simp add: sep_comm sl_frame)

text {* Weakening / Strengthening / Consequence Rules *}

lemma hl_pre: "P \<le> P' \<Longrightarrow> ht P' F Q \<Longrightarrow> ht P F Q"
  by (fastforce simp: ht_def)

lemma hl_post: "mono F \<Longrightarrow> Q' \<le> Q \<Longrightarrow> ht P F Q' \<Longrightarrow> ht P F Q"
  by (meson hl_pre ht_def mono_def)

lemma hl_classic: "mono F \<Longrightarrow> P \<le> P' \<Longrightarrow> Q' \<le> Q \<Longrightarrow> ht P' F Q' \<Longrightarrow> ht P F Q"
  by (rule hl_pre, assumption, rule hl_post, auto)

text {* Annotated programs *}

lemma hl_awhile [sl]: "mono F \<Longrightarrow> P \<subseteq> i \<Longrightarrow> -b \<inter> i \<subseteq> Q \<Longrightarrow> ht (b \<sqinter> i) F i \<Longrightarrow> ht P (awhile i b F) Q"
  by (rule hl_classic) (auto simp: awhile_def intro: mptran sl)

lemma hl_apre_classic [sl]: "P \<le> P' \<Longrightarrow> ht P' F Q \<Longrightarrow> ht P (apre P' F) Q"
  by (auto simp: apre_def intro: hl_pre)

lemma hl_apost_classic [sl]: "mono F \<Longrightarrow> Q' \<le> Q \<Longrightarrow> ht P F Q' \<Longrightarrow> ht P (apost F Q') Q"
  by (auto simp: apost_def intro!: sl)

lemma hl_aprog_classic [sl]: "mono F \<Longrightarrow> P \<le> P' \<Longrightarrow> Q' \<le> Q \<Longrightarrow> ht P' F Q' \<Longrightarrow> ht P (aprog P' F Q') Q"
  by (auto simp: aprog_def intro: sl hl_classic)

lemma hl_exs: "(\<And>x. ht (P x) F Q) \<Longrightarrow> ht (EXS x. P x) F Q"
  by (auto simp: ht_def)

lemma hl_exs2: "mono F \<Longrightarrow> (\<forall>x . ht (P x) F (Q x)) \<Longrightarrow> ht (EXS x. P x) F (EXS x. Q x)"
  apply (auto simp: ht_def)
  apply (erule_tac x=x in allE)
  apply (erule monoE)
  apply (rule pred_le_exI)
  apply force
done

lemma hl_exs3: "mono F \<Longrightarrow> (\<And>x . ht P F (Q x)) \<Longrightarrow> ht P F (EXS x. Q x)"
  apply (auto simp: ht_def)
  apply (erule monoE)
  apply (rule pred_le_exI)
  apply force
done

end


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

section \<open>Semirings\<close>

text \<open>
This theory develops a hierarchy of idempotent semirings.
All kinds of semiring considered here are bounded semilattices, but many lack additional properties typically assumed for semirings.
In particular, we consider the variants of semirings, in which
\begin{itemize}
\item multiplication is not required to be associative;
\item a right zero and unit of multiplication need not exist;
\item multiplication has a left residual;
\item multiplication from the left is not required to distribute over addition;
\item the semilattice order has a greatest element.
\end{itemize}
We have applied results from this theory a number of papers for unifying computation models.
For example, see \<^cite>\<open>"Guttmann2012c"\<close> for various relational and matrix-based computation models and \<^cite>\<open>"BerghammerGuttmann2015b"\<close> for multirelational models.

The main results in this theory relate different ways of defining reflexive-transitive closures as discussed in \<^cite>\<open>"BerghammerGuttmann2015b"\<close>.
\<close>

theory Semirings

imports Fixpoints

begin

subsection \<open>Idempotent Semirings\<close>

text \<open>
The following definitions are standard for relations.
Putting them into a general class that depends only on the signature facilitates reuse.
Coreflexives are sometimes called partial identities, subidentities, monotypes or tests.
\<close>

class times_one_ord = times + one + ord
begin

abbreviation reflexive   :: "'a \<Rightarrow> bool" where "reflexive x   \<equiv> 1 \<le> x"
abbreviation coreflexive :: "'a \<Rightarrow> bool" where "coreflexive x \<equiv> x \<le> 1"

abbreviation transitive  :: "'a \<Rightarrow> bool" where "transitive x  \<equiv> x * x \<le> x"
abbreviation dense_rel   :: "'a \<Rightarrow> bool" where "dense_rel x   \<equiv> x \<le> x * x"
abbreviation idempotent  :: "'a \<Rightarrow> bool" where "idempotent x  \<equiv> x * x = x"

abbreviation preorder    :: "'a \<Rightarrow> bool" where "preorder x    \<equiv> reflexive x \<and> transitive x"

abbreviation "coreflexives \<equiv> { x . coreflexive x }"

end

text \<open>
The first algebra is a very weak idempotent semiring, in which multiplication is not necessarily associative.
\<close>

class non_associative_left_semiring = bounded_semilattice_sup_bot + times + one +
  assumes mult_left_sub_dist_sup: "x * y \<squnion> x * z \<le> x * (y \<squnion> z)"
  assumes mult_right_dist_sup: "(x \<squnion> y) * z = x * z \<squnion> y * z"
  assumes mult_left_zero [simp]: "bot * x = bot"
  assumes mult_left_one [simp]: "1 * x = x"
  assumes mult_sub_right_one: "x \<le> x * 1"
begin

subclass times_one_ord .

text \<open>
We first show basic isotonicity and subdistributivity properties of multiplication.
\<close>

lemma mult_left_isotone:
  "x \<le> y \<Longrightarrow> x * z \<le> y * z"
  using mult_right_dist_sup sup_right_divisibility by auto

lemma mult_right_isotone:
  "x \<le> y \<Longrightarrow> z * x \<le> z * y"
  using mult_left_sub_dist_sup sup.bounded_iff sup_right_divisibility by auto

lemma mult_isotone:
  "w \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> w * x \<le> y * z"
  using order_trans mult_left_isotone mult_right_isotone by blast

lemma affine_isotone:
  "isotone (\<lambda>x . y * x \<squnion> z)"
  using isotone_def mult_right_isotone sup_left_isotone by auto

lemma mult_left_sub_dist_sup_left:
  "x * y \<le> x * (y \<squnion> z)"
  by (simp add: mult_right_isotone)

lemma mult_left_sub_dist_sup_right:
  "x * z \<le> x * (y \<squnion> z)"
  by (simp add: mult_right_isotone)

lemma mult_right_sub_dist_sup_left:
  "x * z \<le> (x \<squnion> y) * z"
  by (simp add: mult_left_isotone)

lemma mult_right_sub_dist_sup_right:
  "y * z \<le> (x \<squnion> y) * z"
  by (simp add: mult_left_isotone)

lemma case_split_left:
  assumes "1 \<le> w \<squnion> z"
      and "w * x \<le> y"
      and "z * x \<le> y"
    shows "x \<le> y"
proof -
  have "(w \<squnion> z) * x \<le> y"
    by (simp add: assms(2-3) mult_right_dist_sup)
  thus ?thesis
    by (metis assms(1) dual_order.trans mult_left_one mult_left_isotone)
qed

lemma case_split_left_equal:
  "w \<squnion> z = 1 \<Longrightarrow> w * x = w * y \<Longrightarrow> z * x = z * y \<Longrightarrow> x = y"
  by (metis mult_left_one mult_right_dist_sup)

text \<open>
Next we consider under which semiring operations the above properties are closed.
\<close>

lemma reflexive_one_closed:
  "reflexive 1"
  by simp

lemma reflexive_sup_closed:
  "reflexive x \<Longrightarrow> reflexive (x \<squnion> y)"
  by (simp add: le_supI1)

lemma reflexive_mult_closed:
  "reflexive x \<Longrightarrow> reflexive y \<Longrightarrow> reflexive (x * y)"
  using mult_isotone by fastforce

lemma coreflexive_bot_closed:
  "coreflexive bot"
  by simp

lemma coreflexive_one_closed:
  "coreflexive 1"
  by simp

lemma coreflexive_sup_closed:
  "coreflexive x \<Longrightarrow> coreflexive y \<Longrightarrow> coreflexive (x \<squnion> y)"
  by simp

lemma coreflexive_mult_closed:
  "coreflexive x \<Longrightarrow> coreflexive y \<Longrightarrow> coreflexive (x * y)"
  using mult_isotone by fastforce

lemma transitive_bot_closed:
  "transitive bot"
  by simp

lemma transitive_one_closed:
  "transitive 1"
  by simp

lemma dense_one_closed:
  "dense_rel 1"
  by simp

lemma dense_sup_closed:
  "dense_rel x \<Longrightarrow> dense_rel y \<Longrightarrow> dense_rel (x \<squnion> y)"
  by (metis mult_right_dist_sup order_lesseq_imp sup.mono mult_left_sub_dist_sup_left mult_left_sub_dist_sup_right)

lemma idempotent_bot_closed:
  "idempotent bot"
  by simp

lemma idempotent_one_closed:
  "idempotent 1"
  by simp

lemma preorder_one_closed:
  "preorder 1"
  by simp

lemma coreflexive_transitive:
  "coreflexive x \<Longrightarrow> transitive x"
  using mult_left_isotone by fastforce

lemma preorder_idempotent:
  "preorder x \<Longrightarrow> idempotent x"
  using order.antisym mult_isotone by fastforce

text \<open>
We study the following three ways of defining reflexive-transitive closures.
Each of them is given as a least prefixpoint, but the underlying functions are different.
They implement left recursion, right recursion and symmetric recursion, respectively.
\<close>

abbreviation Lf :: "'a \<Rightarrow> ('a \<Rightarrow> 'a)" where "Lf y \<equiv> (\<lambda>x . 1 \<squnion> x * y)"
abbreviation Rf :: "'a \<Rightarrow> ('a \<Rightarrow> 'a)" where "Rf y \<equiv> (\<lambda>x . 1 \<squnion> y * x)"
abbreviation Sf :: "'a \<Rightarrow> ('a \<Rightarrow> 'a)" where "Sf y \<equiv> (\<lambda>x . 1 \<squnion> y \<squnion> x * x)"

abbreviation lstar :: "'a \<Rightarrow> 'a" where "lstar y \<equiv> p\<mu> (Lf y)"
abbreviation rstar :: "'a \<Rightarrow> 'a" where "rstar y \<equiv> p\<mu> (Rf y)"
abbreviation sstar :: "'a \<Rightarrow> 'a" where "sstar y \<equiv> p\<mu> (Sf y)"

text \<open>
All functions are isotone and, therefore, if the prefixpoints exist they are also fixpoints.
\<close>

lemma lstar_rec_isotone:
  "isotone (Lf y)"
  using isotone_def sup_right_divisibility sup_right_isotone mult_right_sub_dist_sup_right by auto

lemma rstar_rec_isotone:
  "isotone (Rf y)"
  using isotone_def sup_right_divisibility sup_right_isotone mult_left_sub_dist_sup_right by auto

lemma sstar_rec_isotone:
  "isotone (Sf y)"
  using isotone_def sup_right_isotone mult_isotone by auto

lemma lstar_fixpoint:
  "has_least_prefixpoint (Lf y) \<Longrightarrow> lstar y = \<mu> (Lf y)"
  by (simp add: pmu_mu lstar_rec_isotone)

lemma rstar_fixpoint:
  "has_least_prefixpoint (Rf y) \<Longrightarrow> rstar y = \<mu> (Rf y)"
  by (simp add: pmu_mu rstar_rec_isotone)

lemma sstar_fixpoint:
  "has_least_prefixpoint (Sf y) \<Longrightarrow> sstar y = \<mu> (Sf y)"
  by (simp add: pmu_mu sstar_rec_isotone)

lemma sstar_increasing:
  "has_least_prefixpoint (Sf y) \<Longrightarrow> y \<le> sstar y"
  using order_trans pmu_unfold sup_ge1 sup_ge2 by blast

text \<open>
The fixpoint given by right recursion is always below the one given by symmetric recursion.
\<close>

lemma rstar_below_sstar:
  assumes "has_least_prefixpoint (Rf y)"
      and "has_least_prefixpoint (Sf y)"
    shows "rstar y \<le> sstar y"
proof -
  have "y \<le> sstar y"
    using assms(2) pmu_unfold by force
  hence "Rf y (sstar y) \<le> Sf y (sstar y)"
    by (meson sup.cobounded1 sup.mono mult_left_isotone)
  also have "... \<le> sstar y"
    using assms(2) pmu_unfold by blast
  finally show ?thesis
    using assms(1) is_least_prefixpoint_def least_prefixpoint by auto
qed

end

text \<open>
Our next structure adds one half of the associativity property.
This inequality holds, for example, for multirelations under the compositions defined by Parikh and Peleg \<^cite>\<open>"Parikh1983" and "Peleg1987"\<close>.
The converse inequality requires up-closed multirelations for Parikh's composition.
\<close>

class pre_left_semiring = non_associative_left_semiring +
  assumes mult_semi_associative: "(x * y) * z \<le> x * (y * z)"
begin

lemma mult_one_associative [simp]:
  "x * 1 * y = x * y"
  by (metis dual_order.antisym mult_left_isotone mult_left_one mult_semi_associative mult_sub_right_one)

lemma mult_sup_associative_one:
  "(x * (y * 1)) * z \<le> x * (y * z)"
  by (metis mult_semi_associative mult_one_associative)

lemma rstar_increasing:
  assumes "has_least_prefixpoint (Rf y)"
    shows "y \<le> rstar y"
proof -
  have "Rf y (rstar y) \<le> rstar y"
    using assms pmu_unfold by blast
  thus ?thesis
    by (metis le_supE mult_right_isotone mult_sub_right_one sup.absorb_iff2)
qed

end

text \<open>
For the next structure we add a left residual operation.
Such a residual is available, for example, for multirelations.

The operator notation for binary division is introduced in a class that requires a unary inverse.
This is appropriate for fields, but too strong in the present context of semirings.
We therefore reintroduce it without requiring a unary inverse.
\<close>

no_notation
  inverse_divide (infixl "'/" 70)

notation
  divide (infixl "'/" 70)

class residuated_pre_left_semiring = pre_left_semiring + divide +
  assumes lres_galois: "x * y \<le> z \<longleftrightarrow> x \<le> z / y"
begin

text \<open>
We first derive basic properties of left residuals from the Galois connection.
\<close>

lemma lres_left_isotone:
  "x \<le> y \<Longrightarrow> x / z \<le> y / z"
  using dual_order.trans lres_galois by blast

lemma lres_right_antitone:
  "x \<le> y \<Longrightarrow> z / y \<le> z / x"
  using dual_order.trans lres_galois mult_right_isotone by blast

lemma lres_inverse:
  "(x / y) * y \<le> x"
  by (simp add: lres_galois)

lemma lres_one:
  "x / 1 \<le> x"
  using mult_sub_right_one order_trans lres_inverse by blast

lemma lres_mult_sub_lres_lres:
  "x / (z * y) \<le> (x / y) / z"
  using lres_galois mult_semi_associative order.trans by blast

lemma mult_lres_sub_assoc:
  "x * (y / z) \<le> (x * y) / z"
  by (meson dual_order.trans lres_galois mult_right_isotone lres_inverse lres_mult_sub_lres_lres)

text \<open>
With the help of a left residual, it follows that left recursion is below right recursion.
\<close>

lemma lstar_below_rstar:
  assumes "has_least_prefixpoint (Lf y)"
      and "has_least_prefixpoint (Rf y)"
    shows "lstar y \<le> rstar y"
proof -
  have "y * (rstar y / y) * y \<le> y * rstar y"
    using lres_galois mult_lres_sub_assoc by auto
  also have "... \<le> rstar y"
    using assms(2) le_supE pmu_unfold by blast
  finally have "y * (rstar y / y) \<le> rstar y / y"
    by (simp add: lres_galois)
  hence "Rf y (rstar y / y) \<le> rstar y / y"
    using assms(2) lres_galois rstar_increasing by fastforce
  hence "rstar y \<le> rstar y / y"
    using assms(2) is_least_prefixpoint_def least_prefixpoint by auto
  hence "Lf y (rstar y) \<le> rstar y"
    using assms(2) lres_galois pmu_unfold by fastforce
  thus ?thesis
    using assms(1) is_least_prefixpoint_def least_prefixpoint by auto
qed

text \<open>
Moreover, right recursion gives the same result as symmetric recursion.
The next proof follows an argument of \<^cite>\<open>\<open>Satz 10.1.5\<close> in "Berghammer2012"\<close>.
\<close>

lemma rstar_sstar:
  assumes "has_least_prefixpoint (Rf y)"
      and "has_least_prefixpoint (Sf y)"
    shows "rstar y = sstar y"
proof -
  have "Rf y (rstar y / rstar y) * rstar y \<le> rstar y \<squnion> y * ((rstar y / rstar y) * rstar y)"
    using mult_right_dist_sup mult_semi_associative sup_right_isotone by auto
  also have "... \<le> rstar y \<squnion> y * rstar y"
    using mult_right_isotone sup_right_isotone lres_inverse by blast
  also have "... \<le> rstar y"
    using assms(1) pmu_unfold by fastforce
  finally have "Rf y (rstar y / rstar y) \<le> rstar y / rstar y"
    by (simp add: lres_galois)
  hence "rstar y * rstar y \<le> rstar y"
    using assms(1) is_least_prefixpoint_def least_prefixpoint lres_galois by auto
  hence "y \<squnion> rstar y * rstar y \<le> rstar y"
    by (simp add: assms(1) rstar_increasing)
  hence "Sf y (rstar y) \<le> rstar y"
    using assms(1) pmu_unfold by force
  hence "sstar y \<le> rstar y"
    using assms(2) is_least_prefixpoint_def least_prefixpoint by auto
  thus ?thesis
    by (simp add: assms order.antisym rstar_below_sstar)
qed

end

text \<open>
In the next structure we add full associativity of multiplication, as well as a right unit.
Still, multiplication does not need to have a right zero and does not need to distribute over addition from the left.
\<close>

class idempotent_left_semiring = non_associative_left_semiring + monoid_mult
begin

subclass pre_left_semiring
  by unfold_locales (simp add: mult_assoc)

lemma zero_right_mult_decreasing:
  "x * bot \<le> x"
  by (metis bot_least mult_1_right mult_right_isotone)

text \<open>
The following result shows that for dense coreflexives there are two equivalent ways to express that a property is preserved.
In the setting of Kleene algebras, this is well known for tests, which form a Boolean subalgebra.
The point here is that only very few properties of tests are needed to show the equivalence.
\<close>

end

text \<open>
The next structure has both distributivity properties of multiplication.
Only a right zero is missing from full semirings.
This is important as many computation models do not have a right zero of sequential composition.
\<close>

class idempotent_left_zero_semiring = idempotent_left_semiring +
  assumes mult_left_dist_sup: "x * (y \<squnion> z) = x * y \<squnion> x * z"
begin

lemma case_split_right:
  assumes "1 \<le> w \<squnion> z"
      and "x * w \<le> y"
      and "x * z \<le> y"
    shows "x \<le> y"
proof -
  have "x * (w \<squnion> z) \<le> y"
    by (simp add: assms(2-3) mult_left_dist_sup)
  thus ?thesis
    by (metis assms(1) dual_order.trans mult_1_right mult_right_isotone)
qed

lemma case_split_right_equal:
  "w \<squnion> z = 1 \<Longrightarrow> x * w = y * w \<Longrightarrow> x * z = y * z \<Longrightarrow> x = y"
  by (metis mult_1_right mult_left_dist_sup)

text \<open>
This is the first structure we can connect to the semirings provided by Isabelle/HOL.
\<close>

sublocale semiring: ordered_semiring sup bot less_eq less times
  apply unfold_locales
  using sup_right_isotone apply blast
  apply (simp add: mult_right_dist_sup)
  apply (simp add: mult_left_dist_sup)
  apply (simp add: mult_right_isotone)
  by (simp add: mult_left_isotone)

sublocale semiring: semiring_numeral 1 times sup ..

end

text \<open>
Completing this part of the hierarchy, we obtain idempotent semirings by adding a right zero of multiplication.
\<close>

class idempotent_semiring = idempotent_left_zero_semiring +
  assumes mult_right_zero [simp]: "x * bot = bot"
begin

sublocale semiring: semiring_0 sup bot times
  by unfold_locales simp_all

end

subsection \<open>Bounded Idempotent Semirings\<close>

text \<open>
All of the following semirings have a greatest element in the underlying semilattice order.
With this element, we can express further standard properties of relations.
We extend each class in the above hierarchy in turn.
\<close>

class times_top = times + top
begin

abbreviation vector     :: "'a \<Rightarrow> bool" where "vector x     \<equiv> x * top = x"
abbreviation covector   :: "'a \<Rightarrow> bool" where "covector x   \<equiv> top * x = x"
abbreviation total      :: "'a \<Rightarrow> bool" where "total x      \<equiv> x * top = top"
abbreviation surjective :: "'a \<Rightarrow> bool" where "surjective x \<equiv> top * x = top"

abbreviation "vectors   \<equiv> { x . vector x }"
abbreviation "covectors \<equiv> { x . covector x }"

end

class bounded_non_associative_left_semiring = non_associative_left_semiring + top +
  assumes sup_right_top [simp]: "x \<squnion> top = top"
begin

subclass times_top .

text \<open>
We first give basic properties of the greatest element.
\<close>

lemma sup_left_top [simp]:
  "top \<squnion> x = top"
  using sup_right_top sup.commute by fastforce

lemma top_greatest [simp]:
  "x \<le> top"
  by (simp add: le_iff_sup)

lemma top_left_mult_increasing:
  "x \<le> top * x"
  by (metis mult_left_isotone mult_left_one top_greatest)

lemma top_right_mult_increasing:
  "x \<le> x * top"
  using mult_right_isotone mult_sub_right_one order_trans top_greatest by blast

lemma top_mult_top [simp]:
  "top * top = top"
  by (simp add: order.antisym top_left_mult_increasing)

text \<open>
Closure of the above properties under the semiring operations is considered next.
\<close>

lemma vector_bot_closed:
  "vector bot"
  by simp

lemma vector_top_closed:
  "vector top"
  by simp

lemma vector_sup_closed:
  "vector x \<Longrightarrow> vector y \<Longrightarrow> vector (x \<squnion> y)"
  by (simp add: mult_right_dist_sup)

lemma covector_top_closed:
  "covector top"
  by simp

lemma total_one_closed:
  "total 1"
  by simp

lemma total_top_closed:
  "total top"
  by simp

lemma surjective_one_closed:
  "surjective 1"
  by (simp add: order.antisym mult_sub_right_one)

lemma surjective_top_closed:
  "surjective top"
  by simp

lemma surjective_sup_closed:
  "surjective x \<Longrightarrow> surjective (x \<squnion> y)"
  by (metis le_iff_sup mult_left_sub_dist_sup_left sup_left_top)

lemma reflexive_top_closed:
  "reflexive top"
  by simp

lemma transitive_top_closed:
  "transitive top"
  by simp

lemma dense_top_closed:
  "dense_rel top"
  by simp

lemma idempotent_top_closed:
  "idempotent top"
  by simp

lemma preorder_top_closed:
  "preorder top"
  by simp

end

text \<open>
Some closure properties require at least half of associativity.
\<close>

class bounded_pre_left_semiring = pre_left_semiring + bounded_non_associative_left_semiring
begin

lemma vector_mult_closed:
  "vector y \<Longrightarrow> vector (x * y)"
  by (metis order.antisym mult_semi_associative top_right_mult_increasing)

lemma surjective_mult_closed:
  "surjective x \<Longrightarrow> surjective y \<Longrightarrow> surjective (x * y)"
  by (metis order.antisym mult_semi_associative top_greatest)

end

text \<open>
We next consider residuals with the greatest element.
\<close>

class bounded_residuated_pre_left_semiring = residuated_pre_left_semiring + bounded_pre_left_semiring
begin

lemma lres_top_decreasing:
  "x / top \<le> x"
  using lres_inverse order.trans top_right_mult_increasing by blast

lemma top_lres_absorb [simp]:
  "top / x = top"
  using order.antisym lres_galois top_greatest by blast

lemma covector_lres_closed:
  "covector x \<Longrightarrow> covector (x / y)"
  by (metis order.antisym mult_lres_sub_assoc top_left_mult_increasing)

end

text \<open>
Some closure properties require full associativity.
\<close>

class bounded_idempotent_left_semiring = bounded_pre_left_semiring + idempotent_left_semiring
begin

lemma covector_mult_closed:
  "covector x \<Longrightarrow> covector (x * y)"
  by (metis mult_assoc)

lemma total_mult_closed:
  "total x \<Longrightarrow> total y \<Longrightarrow> total (x * y)"
  by (simp add: mult_assoc)

end

text \<open>
Some closure properties require distributivity from the left.
\<close>

class bounded_idempotent_left_zero_semiring = bounded_idempotent_left_semiring + idempotent_left_zero_semiring
begin

lemma covector_sup_closed:
  "covector x \<Longrightarrow> covector y \<Longrightarrow> covector (x \<squnion> y)"
  by (simp add: mult_left_dist_sup)

end

text \<open>
Our final structure is an idempotent semiring with a greatest element.
\<close>

class bounded_idempotent_semiring = bounded_idempotent_left_zero_semiring + idempotent_semiring
begin

lemma covector_bot_closed:
  "covector bot"
  by simp

end

end


(*  Title:      HOL/Number_Theory/Quadratic_Reciprocity.thy
    Author:     Jaime Mendizabal Roche
*)

theory Quadratic_Reciprocity
imports Gauss
begin

text \<open>
  The proof is based on Gauss's fifth proof, which can be found at
  \<^url>\<open>https://www.lehigh.edu/~shw2/q-recip/gauss5.pdf\<close>.
\<close>

locale QR =
  fixes p :: "nat"
  fixes q :: "nat"
  assumes p_prime: "prime p"
  assumes p_ge_2: "2 < p"
  assumes q_prime: "prime q"
  assumes q_ge_2: "2 < q"
  assumes pq_neq: "p \<noteq> q"
begin

lemma odd_p: "odd p"
  using p_ge_2 p_prime prime_odd_nat by blast

lemma p_ge_0: "0 < int p"
  by (simp add: p_prime prime_gt_0_nat)

lemma p_eq2: "int p = (2 * ((int p - 1) div 2)) + 1"
  using odd_p by simp

lemma odd_q: "odd q"
  using q_ge_2 q_prime prime_odd_nat by blast

lemma q_ge_0: "0 < int q"
  by (simp add: q_prime prime_gt_0_nat)

lemma q_eq2: "int q = (2 * ((int q - 1) div 2)) + 1"
  using odd_q by simp

lemma pq_eq2: "int p * int q = (2 * ((int p * int q - 1) div 2)) + 1"
  using odd_p odd_q by simp

lemma pq_coprime: "coprime p q"
  using pq_neq p_prime primes_coprime_nat q_prime by blast

lemma pq_coprime_int: "coprime (int p) (int q)"
  by (simp add: gcd_int_def pq_coprime)

lemma qp_ineq: "int p * k \<le> (int p * int q - 1) div 2 \<longleftrightarrow> k \<le> (int q - 1) div 2"
proof -
  have "2 * int p * k \<le> int p * int q - 1 \<longleftrightarrow> 2 * k \<le> int q - 1"
    using p_ge_0 by auto
  then show ?thesis by auto
qed

lemma QRqp: "QR q p"
  using QR_def QR_axioms by simp

lemma pq_commute: "int p * int q = int q * int p"
  by simp

lemma pq_ge_0: "int p * int q > 0"
  using p_ge_0 q_ge_0 mult_pos_pos by blast

definition "r = ((p - 1) div 2) * ((q - 1) div 2)"
definition "m = card (GAUSS.E p q)"
definition "n = card (GAUSS.E q p)"

abbreviation "Res k \<equiv> {0 .. k - 1}" for k :: int
abbreviation "Res_ge_0 k \<equiv> {0 <.. k - 1}" for k :: int
abbreviation "Res_0 k \<equiv> {0::int}" for k :: int
abbreviation "Res_l k \<equiv> {0 <.. (k - 1) div 2}" for k :: int
abbreviation "Res_h k \<equiv> {(k - 1) div 2 <.. k - 1}" for k :: int

abbreviation "Sets_pq r0 r1 r2 \<equiv>
  {(x::int). x \<in> r0 (int p * int q) \<and> x mod p \<in> r1 (int p) \<and> x mod q \<in> r2 (int q)}"

definition "A = Sets_pq Res_l Res_l Res_h"
definition "B = Sets_pq Res_l Res_h Res_l"
definition "C = Sets_pq Res_h Res_h Res_l"
definition "D = Sets_pq Res_l Res_h Res_h"
definition "E = Sets_pq Res_l Res_0 Res_h"
definition "F = Sets_pq Res_l Res_h Res_0"

definition "a = card A"
definition "b = card B"
definition "c = card C"
definition "d = card D"
definition "e = card E"
definition "f = card F"

lemma Gpq: "GAUSS p q"
  using p_prime pq_neq p_ge_2 q_prime
  by (auto simp: GAUSS_def cong_iff_dvd_diff dest: primes_dvd_imp_eq)

lemma Gqp: "GAUSS q p"
  by (simp add: QRqp QR.Gpq)

lemma QR_lemma_01: "(\<lambda>x. x mod q) ` E = GAUSS.E q p"
proof
  have "x \<in> E \<longrightarrow> x mod int q \<in> GAUSS.E q p" if "x \<in> E" for x
  proof -
    from that obtain k where k: "x = int p * k"
      unfolding E_def by blast
    from that E_def have "x \<in> Res_l (int p * int q)"
      by blast
    then have "k \<in> GAUSS.A q"
      using Gqp GAUSS.A_def k qp_ineq by (simp add: zero_less_mult_iff)
    then have "x mod q \<in> GAUSS.E q p"
      using GAUSS.C_def[of q p] Gqp k GAUSS.B_def[of q p] that GAUSS.E_def[of q p]
      by (force simp: E_def)
    then show ?thesis by auto
  qed
  then show "(\<lambda>x. x mod int q) ` E \<subseteq> GAUSS.E q p"
    by auto
  show "GAUSS.E q p \<subseteq> (\<lambda>x. x mod q) ` E"
  proof
    fix x
    assume x: "x \<in> GAUSS.E q p"
    then obtain ka where ka: "ka \<in> GAUSS.A q" "x = (ka * p) mod q"
      by (auto simp: Gqp GAUSS.B_def GAUSS.C_def GAUSS.E_def)
    then have "ka * p \<in> Res_l (int p * int q)"
      using Gqp p_ge_0 qp_ineq by (simp add: GAUSS.A_def Groups.mult_ac(2))
    then show "x \<in> (\<lambda>x. x mod q) ` E"
      using ka x Gqp q_ge_0 by (force simp: E_def GAUSS.E_def)
  qed
qed

lemma QR_lemma_02: "e = n"
proof -
  have "x = y" if x: "x \<in> E" and y: "y \<in> E" and mod: "x mod q = y mod q" for x y
  proof -
    obtain p_inv where p_inv: "[int p * p_inv = 1] (mod int q)"
      using pq_coprime_int cong_solve_coprime_int by blast
    from x y E_def obtain kx ky where k: "x = int p * kx" "y = int p * ky"
      using dvd_def[of p x] by blast
    with x y E_def have "0 < x" "int p * kx \<le> (int p * int q - 1) div 2"
        "0 < y" "int p * ky \<le> (int p * int q - 1) div 2"
      using greaterThanAtMost_iff mem_Collect_eq by blast+
    with k have "0 \<le> kx" "kx < q" "0 \<le> ky" "ky < q"
      using qp_ineq by (simp_all add: zero_less_mult_iff)
    moreover from mod k have "(p_inv * (p * kx)) mod q = (p_inv * (p * ky)) mod q"
      using mod_mult_cong by blast
    then have "(p * p_inv * kx) mod q = (p * p_inv * ky) mod q"
      by (simp add: algebra_simps)
    then have "kx mod q = ky mod q"
      using p_inv mod_mult_cong[of "p * p_inv" "q" "1"]
      by (auto simp: cong_def)
    then have "[kx = ky] (mod q)"
      unfolding cong_def by blast
    ultimately show ?thesis
      using cong_less_imp_eq_int k by blast
  qed
  then have "inj_on (\<lambda>x. x mod q) E"
    by (auto simp: inj_on_def)
  then show ?thesis
    using QR_lemma_01 card_image e_def n_def by fastforce
qed

lemma QR_lemma_03: "f = m"
proof -
  have "F = QR.E q p"
    unfolding F_def pq_commute using QRqp QR.E_def[of q p] by fastforce
  then have "f = QR.e q p"
    unfolding f_def using QRqp QR.e_def[of q p] by presburger
  then show ?thesis
    using QRqp QR.QR_lemma_02 m_def QRqp QR.n_def by presburger
qed

definition f_1 :: "int \<Rightarrow> int \<times> int"
  where "f_1 x = ((x mod p), (x mod q))"

definition P_1 :: "int \<times> int \<Rightarrow> int \<Rightarrow> bool"
  where "P_1 res x \<longleftrightarrow> x mod p = fst res \<and> x mod q = snd res \<and> x \<in> Res (int p * int q)"

definition g_1 :: "int \<times> int \<Rightarrow> int"
  where "g_1 res = (THE x. P_1 res x)"

lemma P_1_lemma:
  fixes res :: "int \<times> int"
  assumes "0 \<le> fst res" "fst res < p" "0 \<le> snd res" "snd res < q"
  shows "\<exists>!x. P_1 res x"
proof -
  obtain y k1 k2 where yk: "y = nat (fst res) + k1 * p" "y = nat (snd res) + k2 * q"
    using chinese_remainder[of p q] pq_coprime p_ge_0 q_ge_0 by fastforce
  have "fst res = int (y - k1 * p)"
    using \<open>0 \<le> fst res\<close> yk(1) by simp
  moreover have "snd res = int (y - k2 * q)"
    using \<open>0 \<le> snd res\<close> yk(2) by simp
  ultimately have res: "res = (int (y - k1 * p), int (y - k2 * q))"
    by (simp add: prod_eq_iff)
  have y: "k1 * p \<le> y" "k2 * q \<le> y"
    using yk by simp_all
  from y have *: "[y = nat (fst res)] (mod p)" "[y = nat (snd res)] (mod q)"
    by (auto simp add: res cong_le_nat intro: exI [of _ k1] exI [of _ k2])
  from * have "(y mod (int p * int q)) mod int p = fst res" "(y mod (int p * int q)) mod int q = snd res"
    using y apply (auto simp add: res of_nat_mult [symmetric] of_nat_mod [symmetric] mod_mod_cancel simp del: of_nat_mult)
     apply (metis \<open>fst res = int (y - k1 * p)\<close> assms(1) assms(2) cong_def mod_pos_pos_trivial nat_int of_nat_mod)
    apply (metis \<open>snd res = int (y - k2 * q)\<close> assms(3) assms(4) cong_def mod_pos_pos_trivial nat_int of_nat_mod)
    done
  then obtain x where "P_1 res x"
    unfolding P_1_def
    using Divides.pos_mod_bound Divides.pos_mod_sign pq_ge_0 by fastforce
  moreover have "a = b" if "P_1 res a" "P_1 res b" for a b
  proof -
    from that have "int p * int q dvd a - b"
      using divides_mult[of "int p" "a - b" "int q"] pq_coprime_int mod_eq_dvd_iff [of a _ b]
      unfolding P_1_def by force
    with that show ?thesis
      using dvd_imp_le_int[of "a - b"] unfolding P_1_def by fastforce
  qed
  ultimately show ?thesis by auto
qed

lemma g_1_lemma:
  fixes res :: "int \<times> int"
  assumes "0 \<le> fst res" "fst res < p" "0 \<le> snd res" "snd res < q"
  shows "P_1 res (g_1 res)"
  using assms P_1_lemma [of res] theI' [of "P_1 res"] g_1_def
  by auto

definition "BuC = Sets_pq Res_ge_0 Res_h Res_l"

lemma finite_BuC [simp]:
  "finite BuC"
proof -
  {
    fix p q :: nat
    have "finite {x. 0 < x \<and> x < int p * int q}"
      by simp
    then have "finite {x.
      0 < x \<and>
      x < int p * int q \<and>
      (int p - 1) div 2
      < x mod int p \<and>
      x mod int p < int p \<and>
      0 < x mod int q \<and>
      x mod int q \<le> (int q - 1) div 2}"
      by (auto intro: rev_finite_subset)
  }
  then show ?thesis
    by (simp add: BuC_def)
qed

lemma QR_lemma_04: "card BuC = card (Res_h p \<times> Res_l q)"
  using card_bij_eq[of f_1 "BuC" "Res_h p \<times> Res_l q" g_1]
proof
  show "inj_on f_1 BuC"
  proof
    fix x y
    assume *: "x \<in> BuC" "y \<in> BuC" "f_1 x = f_1 y"
    then have "int p * int q dvd x - y"
      using f_1_def pq_coprime_int divides_mult[of "int p" "x - y" "int q"]
        mod_eq_dvd_iff[of x _ y]
      by auto
    with * show "x = y"
      using dvd_imp_le_int[of "x - y" "int p * int q"] unfolding BuC_def by force
  qed
  show "inj_on g_1 (Res_h p \<times> Res_l q)"
  proof
    fix x y
    assume *: "x \<in> Res_h p \<times> Res_l q" "y \<in> Res_h p \<times> Res_l q" "g_1 x = g_1 y"
    then have "0 \<le> fst x" "fst x < p" "0 \<le> snd x" "snd x < q"
        "0 \<le> fst y" "fst y < p" "0 \<le> snd y" "snd y < q"
      using mem_Sigma_iff prod.collapse by fastforce+
    with * show "x = y"
      using g_1_lemma[of x] g_1_lemma[of y] P_1_def by fastforce
  qed
  show "g_1 ` (Res_h p \<times> Res_l q) \<subseteq> BuC"
  proof
    fix y
    assume "y \<in> g_1 ` (Res_h p \<times> Res_l q)"
    then obtain x where x: "y = g_1 x" "x \<in> Res_h p \<times> Res_l q"
      by blast
    then have "P_1 x y"
      using g_1_lemma by fastforce
    with x show "y \<in> BuC"
      unfolding P_1_def BuC_def mem_Collect_eq using SigmaE prod.sel by fastforce
  qed
qed (auto simp: finite_subset f_1_def, simp_all add: BuC_def)

lemma QR_lemma_05: "card (Res_h p \<times> Res_l q) = r"
proof -
  have "card (Res_l q) = (q - 1) div 2" "card (Res_h p) = (p - 1) div 2"
    using p_eq2 by force+
  then show ?thesis
    unfolding r_def using card_cartesian_product[of "Res_h p" "Res_l q"] by presburger
qed

lemma QR_lemma_06: "b + c = r"
proof -
  have "B \<inter> C = {}" "finite B" "finite C" "B \<union> C = BuC"
    unfolding B_def C_def BuC_def by fastforce+
  then show ?thesis
    unfolding b_def c_def using card.empty card_Un_Int QR_lemma_04 QR_lemma_05 by fastforce
qed

definition f_2:: "int \<Rightarrow> int"
  where "f_2 x = (int p * int q) - x"

lemma f_2_lemma_1: "f_2 (f_2 x) = x"
  by (simp add: f_2_def)

lemma f_2_lemma_2: "[f_2 x = int p - x] (mod p)"
  by (simp add: f_2_def cong_iff_dvd_diff)

lemma f_2_lemma_3: "f_2 x \<in> S \<Longrightarrow> x \<in> f_2 ` S"
  using f_2_lemma_1[of x] image_eqI[of x f_2 "f_2 x" S] by presburger

lemma QR_lemma_07:
  "f_2 ` Res_l (int p * int q) = Res_h (int p * int q)"
  "f_2 ` Res_h (int p * int q) = Res_l (int p * int q)"
proof -
  have 1: "f_2 ` Res_l (int p * int q) \<subseteq> Res_h (int p * int q)"
    by (force simp: f_2_def)
  have 2: "f_2 ` Res_h (int p * int q) \<subseteq> Res_l (int p * int q)"
    using pq_eq2 by (fastforce simp: f_2_def)
  from 2 have 3: "Res_h (int p * int q) \<subseteq> f_2 ` Res_l (int p * int q)"
    using f_2_lemma_3 by blast
  from 1 have 4: "Res_l (int p * int q) \<subseteq> f_2 ` Res_h (int p * int q)"
    using f_2_lemma_3 by blast
  from 1 3 show "f_2 ` Res_l (int p * int q) = Res_h (int p * int q)"
    by blast
  from 2 4 show "f_2 ` Res_h (int p * int q) = Res_l (int p * int q)"
    by blast
qed

lemma QR_lemma_08:
    "f_2 x mod p \<in> Res_l p \<longleftrightarrow> x mod p \<in> Res_h p"
    "f_2 x mod p \<in> Res_h p \<longleftrightarrow> x mod p \<in> Res_l p"
  using f_2_lemma_2[of x] cong_def[of "f_2 x" "p - x" p] minus_mod_self2[of x p]
    zmod_zminus1_eq_if[of x p] p_eq2
  by auto

lemma QR_lemma_09:
    "f_2 x mod q \<in> Res_l q \<longleftrightarrow> x mod q \<in> Res_h q"
    "f_2 x mod q \<in> Res_h q \<longleftrightarrow> x mod q \<in> Res_l q"
  using QRqp QR.QR_lemma_08 f_2_def QR.f_2_def pq_commute by auto

lemma QR_lemma_10: "a = c"
  unfolding a_def c_def
  apply (rule card_bij_eq[of f_2 A C f_2])
  unfolding A_def C_def
  using QR_lemma_07 QR_lemma_08 QR_lemma_09 apply ((simp add: inj_on_def f_2_def), blast)+
  apply fastforce+
  done

definition "BuD = Sets_pq Res_l Res_h Res_ge_0"
definition "BuDuF = Sets_pq Res_l Res_h Res"

definition f_3 :: "int \<Rightarrow> int \<times> int"
  where "f_3 x = (x mod p, x div p + 1)"

definition g_3 :: "int \<times> int \<Rightarrow> int"
  where "g_3 x = fst x + (snd x - 1) * p"

lemma QR_lemma_11: "card BuDuF = card (Res_h p \<times> Res_l q)"
  using card_bij_eq[of f_3 BuDuF "Res_h p \<times> Res_l q" g_3]
proof
  show "f_3 ` BuDuF \<subseteq> Res_h p \<times> Res_l q"
  proof
    fix y
    assume "y \<in> f_3 ` BuDuF"
    then obtain x where x: "y = f_3 x" "x \<in> BuDuF"
      by blast
    then have "x \<le> int p * (int q - 1) div 2 + (int p - 1) div 2"
      unfolding BuDuF_def using p_eq2 int_distrib(4) by auto
    moreover from x have "(int p - 1) div 2 \<le> - 1 + x mod p"
      by (auto simp: BuDuF_def)
    moreover have "int p * (int q - 1) div 2 = int p * ((int q - 1) div 2)"
      by (subst div_mult1_eq) (simp add: odd_q)
    then have "p * (int q - 1) div 2 = p * ((int q + 1) div 2 - 1)"
      by fastforce
    ultimately have "x \<le> p * ((int q + 1) div 2 - 1) - 1 + x mod p"
      by linarith
    then have "x div p < (int q + 1) div 2 - 1"
      using mult.commute[of "int p" "x div p"] p_ge_0 div_mult_mod_eq[of x p]
        and mult_less_cancel_left_pos[of p "x div p" "(int q + 1) div 2 - 1"]
      by linarith
    moreover from x have "0 < x div p + 1"
      using pos_imp_zdiv_neg_iff[of p x] p_ge_0 by (auto simp: BuDuF_def)
    ultimately show "y \<in> Res_h p \<times> Res_l q"
      using x by (auto simp: BuDuF_def f_3_def)
  qed
  show "inj_on g_3 (Res_h p \<times> Res_l q)"
  proof
    have *: "f_3 (g_3 x) = x" if "x \<in> Res_h p \<times> Res_l q" for x
    proof -
      from that have *: "(fst x + (snd x - 1) * int p) mod int p = fst x"
        by force
      from that have "(fst x + (snd x - 1) * int p) div int p + 1 = snd x"
        by auto
      with * show "f_3 (g_3 x) = x"
        by (simp add: f_3_def g_3_def)
    qed
    fix x y
    assume "x \<in> Res_h p \<times> Res_l q" "y \<in> Res_h p \<times> Res_l q" "g_3 x = g_3 y"
    from this *[of x] *[of y] show "x = y"
      by presburger
  qed
  show "g_3 ` (Res_h p \<times> Res_l q) \<subseteq> BuDuF"
  proof
    fix y
    assume "y \<in> g_3 ` (Res_h p \<times> Res_l q)"
    then obtain x where x: "x \<in> Res_h p \<times> Res_l q" and y: "y = g_3 x"
      by blast
    then have "snd x \<le> (int q - 1) div 2"
      by force
    moreover have "int p * ((int q - 1) div 2) = (int p * int q - int p) div 2"
      using int_distrib(4) div_mult1_eq[of "int p" "int q - 1" 2] odd_q by fastforce
    ultimately have "(snd x) * int p \<le> (int q * int p - int p) div 2"
      using mult_right_mono[of "snd x" "(int q - 1) div 2" p] mult.commute[of "(int q - 1) div 2" p]
        pq_commute
      by presburger
    then have "(snd x - 1) * int p \<le> (int q * int p - 1) div 2 - int p"
      using p_ge_0 int_distrib(3) by auto
    moreover from x have "fst x \<le> int p - 1" by force
    ultimately have "fst x + (snd x - 1) * int p \<le> (int p * int q - 1) div 2"
      using pq_commute by linarith
    moreover from x have "0 < fst x" "0 \<le> (snd x - 1) * p"
      by fastforce+
    ultimately show "y \<in> BuDuF"
      unfolding BuDuF_def using q_ge_0 x g_3_def y by auto
  qed
  show "finite BuDuF" unfolding BuDuF_def by fastforce
qed (simp add: inj_on_inverseI[of BuDuF g_3] f_3_def g_3_def QR_lemma_05)+

lemma QR_lemma_12: "b + d + m = r"
proof -
  have "B \<inter> D = {}" "finite B" "finite D" "B \<union> D = BuD"
    unfolding B_def D_def BuD_def by fastforce+
  then have "b + d = card BuD"
    unfolding b_def d_def using card_Un_Int by fastforce
  moreover have "BuD \<inter> F = {}" "finite BuD" "finite F"
    unfolding BuD_def F_def by fastforce+
  moreover have "BuD \<union> F = BuDuF"
    unfolding BuD_def F_def BuDuF_def
    using q_ge_0 ivl_disj_un_singleton(5)[of 0 "int q - 1"] by auto
  ultimately show ?thesis
    using QR_lemma_03 QR_lemma_05 QR_lemma_11 card_Un_disjoint[of BuD F]
    unfolding b_def d_def f_def
    by presburger
qed

lemma QR_lemma_13: "a + d + n = r"
proof -
  have "A = QR.B q p"
    unfolding A_def pq_commute using QRqp QR.B_def[of q p] by blast
  then have "a = QR.b q p"
    using a_def QRqp QR.b_def[of q p] by presburger
  moreover have "D = QR.D q p"
    unfolding D_def pq_commute using QRqp QR.D_def[of q p] by blast
  then have "d = QR.d q p"
    using d_def  QRqp QR.d_def[of q p] by presburger
  moreover have "n = QR.m q p"
    using n_def QRqp QR.m_def[of q p] by presburger
  moreover have "r = QR.r q p"
    unfolding r_def using QRqp QR.r_def[of q p] by auto
  ultimately show ?thesis
    using QRqp QR.QR_lemma_12 by presburger
qed

lemma QR_lemma_14: "(-1::int) ^ (m + n) = (-1) ^ r"
proof -
  have "m + n + 2 * d = r"
    using QR_lemma_06 QR_lemma_10 QR_lemma_12 QR_lemma_13 by auto
  then show ?thesis
    using power_add[of "-1::int" "m + n" "2 * d"] by fastforce
qed

lemma Quadratic_Reciprocity:
  "Legendre p q * Legendre q p = (-1::int) ^ ((p - 1) div 2 * ((q - 1) div 2))"
  using Gpq Gqp GAUSS.gauss_lemma power_add[of "-1::int" m n] QR_lemma_14
  unfolding r_def m_def n_def by auto

end

theorem Quadratic_Reciprocity:
  assumes "prime p" "2 < p" "prime q" "2 < q" "p \<noteq> q"
  shows "Legendre p q * Legendre q p = (-1::int) ^ ((p - 1) div 2 * ((q - 1) div 2))"
  using QR.Quadratic_Reciprocity QR_def assms by blast

theorem Quadratic_Reciprocity_int:
  assumes "prime (nat p)" "2 < p" "prime (nat q)" "2 < q" "p \<noteq> q"
  shows "Legendre p q * Legendre q p = (-1::int) ^ (nat ((p - 1) div 2 * ((q - 1) div 2)))"
proof -
  from assms have "0 \<le> (p - 1) div 2" by simp
  moreover have "(nat p - 1) div 2 = nat ((p - 1) div 2)" "(nat q - 1) div 2 = nat ((q - 1) div 2)"
    by fastforce+
  ultimately have "(nat p - 1) div 2 * ((nat q - 1) div 2) = nat ((p - 1) div 2 * ((q - 1) div 2))"
    using nat_mult_distrib by presburger
  moreover have "2 < nat p" "2 < nat q" "nat p \<noteq> nat q" "int (nat p) = p" "int (nat q) = q"
    using assms by linarith+
  ultimately show ?thesis
    using Quadratic_Reciprocity[of "nat p" "nat q"] assms by presburger
qed

end


theory Pappus_Desargues
  imports Main Projective_Plane_Axioms Pappus_Property Pascal_Property Desargues_Property
begin

(* Author: Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk .*)

text \<open>
Contents:
\<^item> We prove Hessenberg's theorem @{term "hessenberg_theorem"}: Pappus's property implies Desargues's
property in a projective plane.
\<close>

section \<open>Hessenberg's Theorem\<close>

context projective_plane
begin

lemma col_ABC_ABD_1:
  assumes "A \<noteq> B" and "col A B C" and "col A B D"
  shows "col B C D"
  by (metis assms ax_uniqueness col_def)

lemma col_ABC_ABD_2:
  assumes "A \<noteq> B" and "col A B C" and "col A B D"
  shows "col A C D"
  by (metis assms ax_uniqueness col_def)

lemma col_line_eq_1:
  assumes "A \<noteq> B" and "B \<noteq> C"and "col A B C"
  shows "line A B = line B C"
  by (metis assms ax_uniqueness col_def incidA_lAB incidB_lAB)

lemma col_line_eq_2:
  assumes "A \<noteq> B" and "A \<noteq> C" and "col A B C"
  shows "line A B = line A C"
  by (metis assms col_line_eq_1 col_rot_CW line_comm)

lemma desargues_config_not_col_1:
  assumes "desargues_config A B C A' B' C' M N P R"
  shows "\<not> col A A' B'"
proof
  assume a1:"col A A' B'"
  have f1:"A \<noteq> A'"
    using assms desargues_config_def distinct7_def
    by force
  have f2:"col A A' R"
    using assms desargues_config_def meet_3_col_1
    by blast
  from f1 and f2 and a1 have f3:"col A' B' R"
    using col_ABC_ABD_1
    by blast
  from a1 have f4:"line A A' = line A' B'"
    by (metis assms ax_uniqueness col_def desargues_config_def f1 incidA_lAB incidB_lAB)
  have f5:"A' \<noteq> B'"
    using assms desargues_config_def distinct7_def
    by force
  have f6:"B' \<noteq> R"
    using assms desargues_config_def distinct7_def
    by force
  from f3 and f5 and f6 have f7:"line A' B' = line B' R"
    using col_line_eq_1
    by blast
  have "line B' R = line B B'"
    by (metis a1 assms col_2cycle col_AAB col_line_eq_1 desargues_config_def f6 meet_3_col_2)
  have "line A A' = line B B'"
    by (simp add: \<open>line B' R = line B B'\<close> f4 f7)
  then have "False"
    using assms desargues_config_def distinct3_def
    by auto
  then show f8:"col A A' B' \<Longrightarrow> False"
    by simp
qed

lemma desargues_config_not_col_2:
  assumes "desargues_config A B C A' B' C' M N P R"
  shows "\<not> col B B' C'"
  using assms desargues_config_not_col_1 desargues_config_rot_CCW
  by blast

lemma desargues_config_not_col_3:
  assumes "desargues_config A B C A' B' C' M N P R"
  shows "\<not> col C C' B'"
  by (smt assms col_line_eq_1 col_rot_CW desargues_config_def desargues_config_not_col_2
      desargues_config_rot_CW distinct3_def meet_3_in_def meet_col_1 meet_col_2)

lemma desargues_config_not_col_4:
  assumes "desargues_config A B C A' B' C' M N P R"
  shows "\<not> col A A' C'"
  using assms desargues_config_not_col_3 desargues_config_rot_CCW
  by blast

lemma desargues_config_not_col_5:
  assumes "desargues_config A B C A' B' C' M N P R"
  shows "\<not> col B B' A'"
  using assms desargues_config_not_col_3 desargues_config_rot_CW
  by blast

lemma desargues_config_not_col_6:
  assumes "desargues_config A B C A' B' C' M N P R"
  shows "\<not> col C C' A'"
  using assms desargues_config_not_col_1 desargues_config_rot_CW
  by blast

lemma desargues_config_not_col_7:
  assumes "desargues_config A B C A' B' C' M N P R"
  shows "\<not> col A B B'"
proof
  assume a1:"col A B B'"
  have f1:"col A B R"
    by (metis a1 assms col_ABB col_ABC_ABD_2 col_rot_CW desargues_config_def desargues_config_not_col_5
        meet_3_col_2)
  have f2:"col A A' R"
    using assms desargues_config_def meet_3_col_1
    by blast
  have f3:"A \<noteq> A'"
    using assms col_AAB desargues_config_not_col_4
    by blast
  have f4:"A \<noteq> R" using assms desargues_config_def distinct7_def
    by auto
  from f2 and f3 and f4 have f5:"line A A' = line A R"
    using col_line_eq_2
    by blast
  from f1 have f6:"line A R = line B R"
    by (metis a1 assms col_2cycle col_ABC_ABD_2 desargues_config_not_col_1 f2 f4)
  have f7:"line B R = line B B'"
    by (metis \<open>line A R = line B R\<close> a1 assms col_AAB col_line_eq_1 desargues_config_def
        desargues_config_not_col_2 f1)
  from f5 and f6 and f7 have "line A A' = line B B'"
    by simp
  then have "False"
    using assms desargues_config_def distinct3_def
    by auto
  thus "col A B B' \<Longrightarrow> False"
    by simp
qed

lemma desargues_config_not_col_8:
  assumes "desargues_config A B C A' B' C' M N P R"
  shows "\<not> col A C C'"

  by (smt (z3) assms col_ABA col_line_eq_1 col_rot_CW desargues_config_def desargues_config_not_col_6 desargues_config_not_col_7 distinct3_def meet_3_col_1 meet_3_col_3 projective_plane.meet_all_3 projective_plane.meet_col_1 projective_plane_axioms)
  (*by (metis assms col_ABA col_line_eq_1 col_rot_CW desargues_config_def desargues_config_not_col_3
      desargues_config_not_col_7 distinct3_def meet_3_col_1 meet_3_col_2 meet_3_col_3)*)

lemma desargues_config_not_col_9:
  assumes "desargues_config A B C A' B' C' M N P R"
  shows "\<not> col B A A'"
  using assms desargues_config_not_col_8 desargues_config_rot_CCW
  by blast

lemma desargues_config_not_col_10:
  assumes "desargues_config A B C A' B' C' M N P R"
  shows "\<not> col B C C'"
  using assms desargues_config_not_col_7 desargues_config_rot_CCW
  by blast

lemma desargues_config_not_col_11:
  assumes "desargues_config A B C A' B' C' M N P R"
  shows "\<not> col C A A'"
  using assms desargues_config_not_col_7 desargues_config_rot_CW
  by blast

lemma desargues_config_not_col_12:
  assumes "desargues_config A B C A' B' C' M N P R"
  shows "\<not> col C B B'"
  using assms desargues_config_not_col_8 desargues_config_rot_CW
  by blast

lemma col_inter:
  assumes "A \<noteq> C" and "B \<noteq> C" and "col A B C"
  shows "inter l (line B C) = inter l (line A C)"
  by (metis assms col_line_eq_1 col_line_eq_2)

lemma lemma_1:
  assumes "desargues_config A B C A' B' C' M N P R" and "is_pappus"
  shows "col M N P \<or> incid A (line B' C') \<or> incid C' (line A B)"
proof-
  have "?thesis" if "incid A (line B' C') \<or> incid C' (line A B)"
    by (simp add: that)
(* The proof consists in three successive applications of Pappus property *)
  define Q E X F where "Q = inter (line A B) (line B' C')" and "E = inter (line A C) (line R Q)"
    and "X = inter (line A C') (line R B)" and "F = inter (line A' C') (line R Q)"
  have "col X E M" if "\<not> incid A (line B' C')" and "\<not> incid C' (line A B)"
  proof-
    have f1:"distinct [C,C',R,Q,B,A]"
      by (smt Q_def \<open>\<not> incid A (line B' C')\<close> \<open>\<not> incid C' (line A B)\<close> assms(1) col_ABB col_A_B_ABl
          col_A_B_lAB col_line_eq_2 col_rot_CW desargues_config_def desargues_config_not_col_12
          desargues_config_not_col_2 desargues_config_not_col_3 desargues_config_not_col_7
          desargues_config_not_col_9 distinct6_def incidA_lAB line_comm meet_3_col_1 meet_3_col_2)
    have f2: "col C C' R"
      using assms(1) desargues_config_def meet_3_col_3
      by blast
    have f3: "col Q B A"
      using Q_def col_2cycle col_A_B_ABl col_rot_CW
      by blast
    have f4: "is_a_intersec E C A Q R"
      using E_def col_2cycle inter_is_a_intersec is_a_intersec_def
      by auto
    have f5:"is_a_intersec M C B Q C'"
      by (metis Q_def assms(1) col_2cycle col_ABB col_ABC_ABD_1 col_A_B_lAB col_rot_CW
          desargues_config_def is_a_intersec_def meet_col_1 meet_col_2)
    have f6:"is_a_intersec X C' A B R"
      using X_def col_2cycle inter_is_a_intersec is_a_intersec_def
      by auto
    from f1 and f2 and f3 and f4 and f5 and f6 have "col M X E"
      using assms(2) is_pappus2_def is_pappus_def
      by blast
    then show "col X E M"
      using col_def
      by auto
  qed
  have "col P X F" if "\<not> incid A (line B' C')" and "\<not> incid C' (line A B)"
  proof-
    have f1:"distinct [A',A,R,Q,B',C']"
      by (smt Q_def \<open>\<not> incid A (line B' C')\<close> \<open>\<not> incid C' (line A B)\<close> assms(1) col_AAB col_A_B_ABl
          col_A_B_lAB col_line_eq_1 col_rot_CW desargues_config_def desargues_config_not_col_2
          desargues_config_not_col_3 desargues_config_not_col_4 desargues_config_not_col_6
          desargues_config_not_col_7 distinct6_def incidB_lAB meet_3_col_2 meet_3_col_3)
    have f2:"col A' A R"
      by (metis assms(1) col_ABA col_line_eq_1 desargues_config_def meet_3_col_1)
    have f3:"col Q B' C'"
      by (simp add: Q_def col_A_B_lAB col_rot_CW)
    have "is_a_intersec (inter (line A B) (line A' B')) A' B' Q A"
      by (metis Q_def col_def incidA_lAB incid_inter_left inter_is_a_intersec is_a_intersec_def)
    then have f4:"is_a_intersec P A' B' Q A"
      using assms(1) desargues_config_def meet_in_def uniq_inter
      by auto
    have f5:"is_a_intersec X A C' B' R"
      by (metis X_def assms(1) col_def col_line_eq_2 desargues_config_def desargues_config_not_col_9
          f2 inter_is_a_intersec is_a_intersec_def line_comm meet_3_col_2)
    have f6:"is_a_intersec F A' C' Q R"
      by (metis F_def inter_is_a_intersec inter_line_line_comm)
    from f1 and f2 and f3 and f4 and f5 and f6 and assms(2)
      show "col P X F"
        using is_pappus2_def is_pappus_def
        by blast
    qed
    have "col M N P" if "\<not> incid A (line B' C')" and "\<not> incid C' (line A B)"
    proof-
      have f1:"Q \<noteq> C' \<and> X \<noteq> E \<and> line Q C' \<noteq> line X E"
        by (smt E_def Q_def X_def \<open>\<not> incid A (line B' C')\<close> \<open>\<not> incid C' (line A B)\<close> assms(1) col_ABB
            col_A_B_ABl col_A_B_lAB col_line_eq_2 col_rot_CW desargues_config_def
            desargues_config_not_col_10 desargues_config_not_col_2 desargues_config_not_col_8
            incidB_lAB incid_C_AB line_comm meet_3_col_1 meet_3_col_2 meet_3_col_3)
      have f2:"E \<noteq> A \<and> C' \<noteq> F \<and> line E A \<noteq> line C' F"
        by (smt E_def F_def Q_def X_def \<open>\<lbrakk>\<not> incid A (line B' C'); \<not> incid C' (line A B)\<rbrakk> \<Longrightarrow> col X E M\<close>
            assms(1) ax_uniqueness col_def desargues_config_def desargues_config_not_col_10
            desargues_config_not_col_3 f1 incidA_lAB incidB_lAB incid_inter_left incid_inter_right
            meet_in_def that(1))
      have f3:"Q \<noteq> A \<and> X \<noteq> F \<and> line Q A \<noteq> line X F"
        by (smt F_def Q_def X_def \<open>\<not> incid A (line B' C')\<close> \<open>\<not> incid C' (line A B)\<close> assms(1)
            ax_uniqueness col_def desargues_config_def desargues_config_not_col_10
            desargues_config_not_col_2 desargues_config_not_col_7 incidA_lAB incidB_lAB incid_inter_left
            incid_inter_right meet_3_col_2 meet_3_col_3)
      have f4:"col Q E F"
        using E_def F_def col_def incidB_lAB incid_inter_right
        by blast
      have f5:"col X C' A"
        using X_def col_2cycle col_A_B_ABl col_rot_CW
        by blast
      have f6:"is_a_intersec M Q C' X E"
        by (metis Q_def \<open>\<lbrakk>\<not> incid A (line B' C'); \<not> incid C' (line A B)\<rbrakk> \<Longrightarrow> col X E M\<close> assms(1)
            col_ABB col_A_B_lAB col_def col_line_eq_1 desargues_config_def incidB_lAB is_a_intersec_def
            meet_in_def that(1) that(2))
      have f7:"is_a_intersec N E A C' F"
        by (metis E_def F_def assms(1) ax_uniqueness col_rot_CW desargues_config_def f2 incidA_lAB
            incidB_lAB incid_inter_left is_a_intersec_def meet_col_1 meet_col_2)
      have f8:"is_a_intersec P Q A X F"
        by (metis Q_def \<open>\<lbrakk>\<not> incid A (line B' C'); \<not> incid C' (line A B)\<rbrakk> \<Longrightarrow> col P X F\<close> assms(1) col_AAB col_A_B_ABl col_line_eq_2 col_rot_CW desargues_config_def is_a_intersec_def meet_col_1 that(1) that(2))
      from f1 and f2 and f3 and f4 and f5 and f6 and f7 and f8 and assms(2) show "col M N P"
        using is_pappus2_def is_pappus_def
        by blast
    qed
    show "col M N P \<or> incid A (line B' C') \<or> incid C' (line A B)"
      using \<open>\<lbrakk>\<not> incid A (line B' C'); \<not> incid C' (line A B)\<rbrakk> \<Longrightarrow> col M N P\<close>
      by auto
qed

corollary corollary_1:
  assumes "desargues_config A B C A' B' C' M N P R" and "is_pappus"
  shows "col M N P \<or> ((incid A (line B' C') \<or> incid C' (line A B)) \<and>
  (incid C (line A' B') \<or> incid B' (line A C)) \<and> (incid B (line A' C') \<or> incid A' (line B C)))"
  by (metis assms(1) assms(2) col_rot_CW desargues_config_rot_CCW lemma_1 line_comm)

definition triangle_circumscribes_triangle ::
  "['point, 'point, 'point, 'point, 'point, 'point] \<Rightarrow> bool" where
"triangle_circumscribes_triangle A' B' C' A B C \<equiv> incid A (line B' C') \<and> incid C (line A' B') \<and>
incid B (line A' C')"

lemma lemma_2:
  assumes "desargues_config A B C A' B' C' M N P R" and "incid A (line B' C') \<or> incid C' (line A B)"
    and "incid C (line A' B') \<or> incid B' (line A C)" and "incid B (line A' C') \<or> incid A' (line B C)"
  shows "col M N P \<or> triangle_circumscribes_triangle A B C A' B' C' \<or> triangle_circumscribes_triangle A' B' C' A B C"
  by (smt assms ax_uniqueness col_def desargues_config_not_col_1
      desargues_config_not_col_11 desargues_config_not_col_12 desargues_config_not_col_2
      desargues_config_not_col_3 desargues_config_not_col_9 incidA_lAB incidB_lAB
      triangle_circumscribes_triangle_def)

lemma lemma_3:
  assumes "is_pappus" and "desargues_config A B C A' B' C' M N P R" and
    "triangle_circumscribes_triangle A' B' C' A B C"
  shows "col M N P"
proof-
  define S T where "S = inter (line C' P) (line R A)" and "T = inter (line C' P) (line R B)"
(* The collinearity of M N P follows from three applications of Pappus property *)
  have "col N S B'"
  proof-
    have f1:"distinct [R,C,C',P,B,A]"
      by (smt assms(2) col_AAB col_line_eq_2 col_rot_CW desargues_config_def
          desargues_config_not_col_1 desargues_config_not_col_12 desargues_config_not_col_2
          desargues_config_not_col_5 desargues_config_not_col_7 desargues_config_not_col_8
          desargues_config_not_col_9 distinct6_def line_comm meet_3_col_1 meet_3_col_2 meet_col_1
          meet_col_2)
    have f2:"col R C C'"
      using assms(2) col_rot_CW desargues_config_def meet_3_col_3
      by blast
    have f3:"col P B A"
      by (metis assms(2) col_rot_CW desargues_config_def line_comm meet_col_1)
    have f4:"is_a_intersec B' R B P C"
      by (metis assms(2) assms(3) col_def desargues_config_def incidB_lAB is_a_intersec_def
          meet_3_col_2 meet_in_def triangle_circumscribes_triangle_def)
    have f5:"is_a_intersec S R A P C'"
      using S_def col_2cycle inter_is_a_intersec is_a_intersec_def
      by auto
    have "line B C' = line A' C'"
      by (metis \<open>distinct [R,C,C',P,B,A]\<close> assms(3) ax_uniqueness distinct6_def incidA_lAB incidB_lAB
          triangle_circumscribes_triangle_def)
    then have f6:"is_a_intersec N C A B C'"
      by (metis assms(2) desargues_config_def inter_is_a_intersec line_comm meet_in_def uniq_inter)
    from f1 and f2 and f3 and f4 and f5 and f6 and assms(1) have "col B' N S"
      using is_pappus2_def is_pappus_def
      by blast
    then show "col N S B'"
      by (simp add: col_rot_CW)
  qed
  have "col M T A'"
  proof-
    have f1:"distinct [R,C,C',P,A,B]"
      by (smt assms(2) col_ABA col_line_eq_2 col_rot_CW desargues_config_def desargues_config_not_col_1
          desargues_config_not_col_12 desargues_config_not_col_2 desargues_config_not_col_5
          desargues_config_not_col_7 desargues_config_not_col_8 desargues_config_not_col_9 distinct6_def
          line_comm meet_3_col_1 meet_3_col_2 meet_col_1 meet_col_2)
    have f2:"col R C C'"
      using assms(2) col_rot_CW desargues_config_def meet_3_col_3
      by blast
    have f3:"col P A B"
      using assms(2) col_rot_CW desargues_config_def meet_col_1
      by blast
    have f4:"line P C = line A' B'"
      by (metis \<open>distinct [R,C,C',P,A,B]\<close> assms(2) assms(3) ax_uniqueness desargues_config_def
          distinct6_def incidA_lAB incidB_lAB meet_in_def triangle_circumscribes_triangle_def)
    have f5:"line R A = line A A'"
      by (metis \<open>distinct [R,C,C',P,A,B]\<close> assms(2) col_AAB col_line_eq_2 desargues_config_def
          desargues_config_not_col_1 distinct6_def line_comm meet_3_col_1)
    from f4 and f5 have f6:"is_a_intersec A' R A P C"
      by (metis col_def incidA_lAB incidB_lAB is_a_intersec_def)
    have "line A C' = line B' C'"
      by (metis assms(3) ax_uniqueness distinct6_def f1 incidA_lAB incidB_lAB
          triangle_circumscribes_triangle_def)
    then have f7:"is_a_intersec M C B A C'"
      by (metis assms(2) col_rot_CW desargues_config_def is_a_intersec_def line_comm meet_col_1
          meet_col_2)
    have f8:"is_a_intersec T R B P C'"
      by (metis T_def distinct6_def f1 inter_comm_line_line_comm inter_is_a_intersec line_comm)
    from f1 and f2 and f3 and f6 and f7 and f8 and assms(1) have "col A' M T"
      using is_pappus2_def is_pappus_def
      by blast
    thus "col M T A'"
      by (simp add: col_rot_CW)
  qed
  then show "col M N P"
  proof-
    have f1:"S \<noteq> T \<and> B \<noteq> A \<and> line S T \<noteq> line B A"
      by (smt T_def \<open>col N S B'\<close> assms(2) assms(3) ax_uniqueness col_AAB col_line_eq_2 col_rot_CW
          desargues_config_def desargues_config_not_col_10 desargues_config_not_col_7
          desargues_config_not_col_9 incidB_lAB incid_inter_left incid_inter_right
          line_comm meet_3_col_2 meet_3_col_3 meet_col_1 meet_col_2 triangle_circumscribes_triangle_def)
    have f2:"A \<noteq> B' \<and> T \<noteq> A' \<and> line A B' \<noteq> line T A'"
      by (smt (verit) S_def T_def assms(2) assms(3) col_A_B_ABl col_line_eq_2 desargues_config_def desargues_config_not_col_1 desargues_config_not_col_9 f1 incidA_lAB inter_comm line_comm meet_3_col_1 meet_col_2 projective_plane.col_def projective_plane_axioms triangle_circumscribes_triangle_def)
    have f3:"S \<noteq> B' \<and> B \<noteq> A'"
      by (smt S_def assms(2) assms(3) ax_uniqueness col_A_B_ABl col_line_eq_2 col_rot_CW
          desargues_config_def desargues_config_not_col_2 desargues_config_not_col_5
          desargues_config_not_col_7 incidA_lAB incidB_lAB incid_inter_right inter_comm line_comm
          meet_3_col_2 meet_in_def triangle_circumscribes_triangle_def)
    then have f4:"line S B' \<noteq> line B A'"
      by (metis assms(2) col_def desargues_config_not_col_5 incidA_lAB incidB_lAB)
    have f5:"col S A A'"
      by (metis S_def assms(2) col_ABC_ABD_1 col_A_B_lAB col_rot_CW desargues_config_def
          desargues_config_not_col_8 meet_3_col_1 meet_3_col_3)
    have f6:"col B T B'"
      by (metis T_def assms(2) col_def col_line_eq_2 desargues_config_def desargues_config_not_col_10
          incidB_lAB incid_inter_right line_comm meet_3_col_2 meet_3_col_3)
    have f7:"is_a_intersec P S T B A"
      by (metis S_def T_def assms(2) col_ABC_ABD_1 col_A_B_ABl col_def desargues_config_def incidA_lAB
          incidB_lAB is_a_intersec_def meet_in_def)
    have f8:"is_a_intersec M A B' T A'"
      by (smt (verit, del_insts) \<open>col M T A'\<close> assms(2) assms(3) col_rot_CW desargues_config_def f2 incidA_lAB incidB_lAB is_a_intersec_def meet_col_2 projective_plane.ax_uniqueness projective_plane_axioms triangle_circumscribes_triangle_def)
    have f9:"is_a_intersec N S B' B A'"
      using \<open>col N S B'\<close> assms(2) assms(3) col_def desargues_config_def incidA_lAB is_a_intersec_def
        meet_in_def triangle_circumscribes_triangle_def
      by auto
    from f1 and f2 and f3 and f4 and f5 and f6 and f7 and f8 and f9 and assms(1) have "col P M N"
      using is_pappus2_def is_pappus_def
      by blast
    thus "col M N P"
      by (simp add: col_rot_CW)
  qed
qed

theorem pappus_desargues:
  assumes "is_pappus" and "desargues_config A B C A' B' C' M N P R"
  shows "col M N P"
proof-
  have f1:"col M N P \<or> ((incid A (line B' C') \<or> incid C' (line A B)) \<and>
  (incid C (line A' B') \<or> incid B' (line A C)) \<and> (incid B (line A' C') \<or> incid A' (line B C)))"
    using assms corollary_1
    by auto
  have f2:"col M N P \<or> triangle_circumscribes_triangle A B C A' B' C' \<or> triangle_circumscribes_triangle A' B' C' A B C"
    if "(incid A (line B' C') \<or> incid C' (line A B)) \<and> (incid C (line A' B') \<or> incid B' (line A C))
    \<and> (incid B (line A' C') \<or> incid A' (line B C))"
    using assms(2) lemma_2 that
    by auto
  have f3:"col M N P" if "triangle_circumscribes_triangle A' B' C' A B C"
    using assms lemma_3 that
    by auto
  have f4:"col M N P" if "triangle_circumscribes_triangle A B C A' B' C'"
  proof-
    have "desargues_config A' B' C' A B C M N P R"
    proof-
      have f1:"distinct [A',B',C',A,B,C,R]"
        using assms(2) desargues_config_def distinct7_def
        by auto
      have f2:"\<not> col A' B' C'"
        using assms(2) desargues_config_def
        by blast
      have f3:"\<not> col A B C"
        using assms(2) desargues_config_def
        by blast
      have f4:"distinct [(line A' A),(line B' B),(line C' C)]"
        by (metis assms(2) desargues_config_def line_comm)
      have f5:"meet_3_in (line A' A) (line B' B) (line C' C) R"
        by (metis assms(2) desargues_config_def line_comm)
      have f6:"(line A' B') \<noteq> (line A B) \<and> (line B' C') \<noteq> (line B C) \<and> (line A' C') \<noteq> (line A C)"
        using assms(2) desargues_config_def
        by auto
      have f7:"meet_in (line B' C') (line B C) M \<and> meet_in (line A' C') (line A C) N \<and>
      meet_in (line A' B') (line A B) P"
        using assms(2) desargues_config_def meet_comm
        by blast
      from f1 and f2 and f3 and f4 and f5 and f6 and f7 show "desargues_config A' B' C' A B C M N P R"
        by (simp add: desargues_config_def)
    qed
    then show "col M N P"
      using assms(1) lemma_3 that
      by blast
  qed
  from f1 and f2 and f3 and f4 show "col M N P"
    by blast
qed

theorem hessenberg_thereom:
  assumes "is_pappus"
  shows "desargues_prop"
  by (smt are_perspective_from_line_def assms col_def desargues_prop_def pappus_desargues
      perspective_from_point_desargues_config)

corollary pascal_desargues:
  assumes "pascal_prop"
  shows "desargues_prop"
  by (simp add: assms hessenberg_thereom pascal_pappus)

end

end