theory Pascal_Property
  imports Main Projective_Plane_Axioms Pappus_Property
begin

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

text \<open>
Contents:
\<^item> A hexagon is pascal if its three opposite sides meet in collinear points @{term is_pascal}.
\<^item> A plane is pascal, or has Pascal's property, if for every hexagon of that plane
Pascal property is stable under any permutation of that hexagon.
\<close>

section \<open>Pascal's Property\<close>

context projective_plane
begin

definition inters :: "'line \<Rightarrow> 'line \<Rightarrow> 'point set" where
"inters l m \<equiv> {P. incid P l \<and> incid P m}"

lemma inters_is_singleton:
  assumes "l \<noteq> m" and "P \<in> inters l m" and "Q \<in> inters l m"
  shows "P = Q"
  using assms ax_uniqueness inters_def
  by blast

definition inter :: "'line \<Rightarrow> 'line \<Rightarrow> 'point" where
"inter l m \<equiv> @P. P \<in> inters l m"

lemma uniq_inter:
  assumes "l \<noteq> m" and "incid P l" and "incid P m"
  shows "inter l m = P"
proof -
  have "P \<in> inters l m"
    by (simp add: assms(2) assms(3) inters_def)
  have "\<forall>Q. Q \<in> inters l m \<longrightarrow> Q = P"
    using \<open>P \<in> inters l m\<close> assms(1) inters_is_singleton
    by blast
  show "inter l m = P"
    using \<open>P \<in> inters l m\<close> assms(1) inter_def inters_is_singleton
    by auto
qed

(* The configuration of a hexagon where the three pairs of opposite sides meet in
collinear points *)
definition is_pascal :: "['point, 'point, 'point, 'point, 'point, 'point] \<Rightarrow> bool" where
"is_pascal A B C D E F \<equiv> distinct [A,B,C,D,E,F] \<longrightarrow> line B C \<noteq> line E F \<longrightarrow> line C D \<noteq> line A F
\<longrightarrow> line A B \<noteq> line D E \<longrightarrow>
(let P = inter (line B C) (line E F) in
let Q = inter (line C D) (line A F) in
let R = inter (line A B) (line D E) in
col P Q R)"

lemma col_rot_CW:
  assumes "col P Q R"
  shows "col R P Q"
  using assms col_def
  by auto

lemma col_2cycle:
  assumes "col P Q R"
  shows "col P R Q"
  using assms col_def
  by auto

lemma distinct6_rot_CW:
  assumes "distinct [A,B,C,D,E,F]"
  shows "distinct [F,A,B,C,D,E]"
  using assms distinct6_def
  by auto

lemma lines_comm: "lines P Q = lines Q P"
  using lines_def
  by auto

lemma line_comm:
  assumes "P \<noteq> Q"
  shows "line P Q = line Q P"
  by (metis ax_uniqueness incidA_lAB incidB_lAB)

lemma inters_comm: "inters l m = inters m l"
  using inters_def
  by auto

lemma inter_comm: "inter l m = inter m l"
  by (simp add: inter_def inters_comm)

lemma inter_line_line_comm:
  assumes "C \<noteq> D"
  shows "inter (line A B) (line C D) = inter (line A B) (line D C)"
  using assms line_comm
  by auto

lemma inter_line_comm_line:
  assumes "A \<noteq> B"
  shows "inter (line A B) (line C D) = inter (line B A) (line C D)"
  using assms line_comm
  by auto

lemma inter_comm_line_line_comm:
  assumes "C \<noteq> D" and "line A B \<noteq> line C D"
  shows "inter (line A B) (line C D) = inter (line D C) (line A B)"
  by (metis inter_comm line_comm)

(* Pascal's property is stable under the 6-cycle [A B C D E F] *)
lemma is_pascal_rot_CW:
  assumes "is_pascal A B C D E F"
  shows "is_pascal F A B C D E"
proof -
  define P Q R where "P = inter (line A B) (line D E)" and "Q = inter (line B C) (line E F)" and
    "R = inter (line F A) (line C D)"
  have "col P Q R" if "distinct [F,A,B,C,D,E]" and "line A B \<noteq> line D E" and "line B C \<noteq> line E F"
    and "line F A \<noteq> line C D"
    using P_def Q_def R_def assms col_rot_CW distinct6_def inter_comm is_pascal_def line_comm
      that(1) that(2) that(3) that(4)
    by auto
  then show "is_pascal F A B C D E"
    by (metis P_def Q_def R_def is_pascal_def line_comm)
qed

(* We recall that the group of permutations S_6 is generated by the 2-cycle [1 2]
and the 6-cycle [1 2 3 4 5 6] *)

(* Assuming Pappus's property, Pascal's property is stable under the 2-cycle [A B] *)

lemma incid_C_AB:
  assumes "A \<noteq> B" and "incid A l" and "incid B l" and "incid C l"
  shows "incid C (line A B)"
  using assms ax_uniqueness incidA_lAB incidB_lAB
  by blast

lemma incid_inters_left:
  assumes "P \<in> inters l m"
  shows "incid P l"
  using assms inters_def
  by auto

lemma incid_inters_right:
  assumes "P \<in> inters l m"
  shows "incid P m"
  using assms incid_inters_left inters_comm
  by blast

lemma inter_in_inters: "inter l m \<in> inters l m"
proof -
  have "\<exists>P. P \<in> inters l m"
    using inters_def ax2
    by auto
  show "inter l m \<in> inters l m"
    by (metis \<open>\<exists>P. P \<in> inters l m\<close> inter_def some_eq_ex)
qed

lemma incid_inter_left: "incid (inter l m) l"
  using incid_inters_left inter_in_inters
  by blast

lemma incid_inter_right: "incid (inter l m) m"
  using incid_inter_left inter_comm
  by fastforce

lemma col_A_B_ABl: "col A B (inter (line A B) l)"
  using col_def incidA_lAB incidB_lAB incid_inter_left
  by blast

lemma col_A_B_lAB: "col A B (inter l (line A B))"
  using col_A_B_ABl inter_comm
  by auto

lemma inter_is_a_intersec: "is_a_intersec (inter (line A B) (line C D)) A B C D"
  by (simp add: col_A_B_ABl col_A_B_lAB col_rot_CW is_a_intersec_def)

definition line_ext :: "'line \<Rightarrow> 'point set" where
"line_ext l \<equiv> {P. incid P l}"

lemma line_left_inter_1:
  assumes "P \<in> line_ext l" and "P \<notin> line_ext m"
  shows "line (inter l m) P = l"
  by (metis CollectD CollectI assms(1) assms(2) incidA_lAB incidB_lAB incid_inter_left
      incid_inter_right line_ext_def uniq_inter)

lemma line_left_inter_2:
  assumes "P \<in> line_ext m" and "P \<notin> line_ext l"
  shows "line (inter l m) P = m"
  using assms inter_comm line_left_inter_1
  by fastforce

lemma line_right_inter_1:
  assumes "P \<in> line_ext l" and "P \<notin> line_ext m"
  shows "line P (inter l m) = l"
  by (metis assms line_comm line_left_inter_1)

lemma line_right_inter_2:
  assumes "P \<in> line_ext m" and "P \<notin> line_ext l"
  shows "line P (inter l m) = m"
  by (metis assms inter_comm line_comm line_left_inter_1)

lemma inter_ABC_1:
  assumes "line A B \<noteq> line C A"
  shows "inter (line A B) (line C A) = A"
  using assms ax_uniqueness incidA_lAB incidB_lAB incid_inter_left incid_inter_right
  by blast

lemma line_inter_2:
  assumes "inter l m \<noteq> inter l' m"
  shows "line (inter l m) (inter l' m) = m"
  using assms ax_uniqueness incidA_lAB incidB_lAB incid_inter_right
  by blast

lemma col_line_ext_1:
  assumes "col A B C" and "A \<noteq> C"
  shows "B \<in> line_ext (line A C)"
  by (metis CollectI assms ax_uniqueness col_def incidA_lAB incidB_lAB line_ext_def)

lemma inter_line_ext_1:
  assumes "inter l m \<in> line_ext n" and "l \<noteq> m" and "l \<noteq> n"
  shows "inter l m = inter l n"
  using assms(1) assms(3) ax_uniqueness incid_inter_left incid_inter_right line_ext_def
  by blast

lemma inter_line_ext_2:
  assumes "inter l m \<in> line_ext n" and "l \<noteq> m" and "m \<noteq> n"
  shows "inter l m = inter m n"
  by (metis assms inter_comm inter_line_ext_1)

definition pascal_prop :: "bool" where
"pascal_prop \<equiv> \<forall>A B C D E F. is_pascal A B C D E F \<longrightarrow> is_pascal B A C D E F"

lemma pappus_pascal:
  assumes "is_pappus"
  shows "pascal_prop"
proof-
  have "is_pascal B A C D E F" if "is_pascal A B C D E F" for A B C D E F
  proof-
    define X Y Z where "X = inter (line A C) (line E F)" and "Y = inter (line C D) (line B F)"
      and "Z = inter (line B A) (line D E)"
    have "col X Y Z" if "distinct [B,A,C,D,E,F]" and "line A C \<noteq> line E F" and "line C D \<noteq> line B F"
      and "line B A \<noteq> line D E" and "line B C = line E F"
      by (smt X_def Y_def ax_uniqueness col_ABA col_rot_CW distinct6_def incidB_lAB incid_inter_left
          incid_inter_right line_comm that(1) that(2) that(3) that(5))
    have "col X Y Z" if "distinct [B,A,C,D,E,F]" and "line A C \<noteq> line E F" and "line C D \<noteq> line B F"
      and "line B A \<noteq> line D E" and "line C D = line A F"
      by (metis X_def Y_def col_ABA col_rot_CW distinct6_def inter_ABC_1 line_comm that(1) that(2)
          that(3) that(5))
    have "col X Y Z" if "distinct [B,A,C,D,E,F]" and "line A C \<noteq> line E F" and "line C D \<noteq> line B F"
      and "line B A \<noteq> line D E" and "line B C \<noteq> line E F" and "line C D \<noteq> line A F"
    proof-
      define W where "W = inter (line A C) (line E F)"
      have "col A C W"
        by (simp add: col_A_B_ABl W_def)
      define P Q R where "P = inter (line B C) (line E F)"
        and "Q = inter (line A B) (line D E)"
        and "R = inter (line C D) (line A F)"
      have "col P Q R"
        using P_def Q_def R_def \<open>is_pascal A B C D E F\<close> col_2cycle distinct6_def is_pascal_def
          line_comm that(1) that(4) that(5) that(6)
        by auto
          (* Below we take care of a few degenerate cases *)
      have "col X Y Z" if "P = Q"
        by (smt P_def Q_def X_def Y_def Z_def \<open>distinct [B,A,C,D,E,F]\<close> ax_uniqueness col_ABA col_def
            distinct6_def incidA_lAB incidB_lAB incid_inter_left inter_comm that)
      have "col X Y Z" if "P = R"
        by (smt P_def R_def X_def Y_def Z_def \<open>distinct [B,A,C,D,E,F]\<close> \<open>line A C \<noteq> line E F\<close>
            \<open>line C D \<noteq> line B F\<close> col_2cycle col_A_B_ABl col_rot_CW distinct6_def incidA_lAB
            incidB_lAB incid_inter_left incid_inter_right that uniq_inter)
      have "col X Y Z" if "P = A"
        by (smt P_def Q_def R_def X_def Y_def Z_def \<open>P = Q \<Longrightarrow> col X Y Z\<close> \<open>P = R \<Longrightarrow> col X Y Z\<close>
            \<open>col P Q R\<close> \<open>line B C \<noteq> line E F\<close> ax_uniqueness col_def incidA_lAB incid_inter_left
            incid_inter_right line_comm that)
      have "col X Y Z" if "P = C"
        by (smt P_def Q_def R_def X_def Y_def Z_def \<open>P = R \<Longrightarrow> col X Y Z\<close> \<open>col P Q R\<close>
            \<open>line A C \<noteq> line E F\<close> ax_uniqueness col_def incidA_lAB incid_inter_left
            incid_inter_right line_comm that)
      have "col X Y Z" if "P = W"
        by (smt P_def Q_def R_def W_def X_def Y_def Z_def \<open>P = C \<Longrightarrow> col X Y Z\<close> \<open>P = Q \<Longrightarrow> col X Y Z\<close>
            \<open>col P Q R\<close> \<open>distinct [B,A,C,D,E,F]\<close> ax_uniqueness col_def distinct6_def incidB_lAB
            incid_inter_left incid_inter_right line_comm that)
      have "col X Y Z" if "Q = R"
        by (smt Q_def R_def X_def Y_def Z_def \<open>distinct [B,A,C,D,E,F]\<close> ax_uniqueness col_A_B_lAB
            col_rot_CW distinct6_def incidB_lAB incid_inter_right inter_comm line_comm that)
      have "col X Y Z" if "Q = A"
        by (smt P_def Q_def R_def X_def Y_def Z_def \<open>col P Q R\<close> \<open>distinct [B,A,C,D,E,F]\<close>
            \<open>line C D \<noteq> line B F\<close> ax_uniqueness col_ABA col_def distinct6_def incidA_lAB incidB_lAB
            incid_inter_left incid_inter_right that)
      have "col X Y Z" if "Q = C"
        by (metis P_def Q_def W_def \<open>P = W \<Longrightarrow> col X Y Z\<close> \<open>distinct [B,A,C,D,E,F]\<close> ax_uniqueness
            distinct6_def incidA_lAB incid_inter_left line_comm that)
      have "col X Y Z" if "Q = W"
        by (metis Q_def W_def X_def Z_def col_ABA line_comm that)
      have "col X Y Z" if "R = A"
        by (smt P_def Q_def R_def W_def X_def Y_def \<open>P = W \<Longrightarrow> col X Y Z\<close> \<open>Q = A \<Longrightarrow> col X Y Z\<close>
            \<open>col P Q R\<close> \<open>distinct [B,A,C,D,E,F]\<close> ax_uniqueness col_ABA col_def col_rot_CW distinct6_def
            incidA_lAB incidB_lAB incid_inter_right inter_comm that)
      have "col X Y Z" if "R = C"
        by (smt P_def Q_def R_def X_def Y_def Z_def \<open>col P Q R\<close> \<open>distinct [B,A,C,D,E,F]\<close>
            \<open>line A C \<noteq> line E F\<close> ax_uniqueness col_def distinct6_def incidA_lAB incidB_lAB
            incid_inter_left inter_comm that)
      have "col X Y Z" if "R = W"
        by (metis R_def W_def \<open>R = A \<Longrightarrow> col X Y Z\<close> \<open>R = C \<Longrightarrow> col X Y Z\<close> \<open>line C D \<noteq> line A F\<close>
            ax_uniqueness incidA_lAB incidB_lAB incid_inter_left incid_inter_right that)
      have "col X Y Z" if "A = W"
        by (smt P_def Q_def R_def W_def X_def Y_def Z_def \<open>P = R \<Longrightarrow> col X Y Z\<close> \<open>Q = A \<Longrightarrow> col X Y Z\<close>
            \<open>col P Q R\<close> \<open>distinct [B,A,C,D,E,F]\<close> ax_uniqueness col_def distinct6_def incidA_lAB
            incidB_lAB incid_inter_left incid_inter_right that)
      have "col X Y Z" if "C = W"
        by (metis P_def W_def \<open>P = C \<Longrightarrow> col X Y Z\<close> \<open>line B C \<noteq> line E F\<close> ax_uniqueness incidB_lAB
            incid_inter_left incid_inter_right that)
      have f1:"col (inter (line P C) (line A Q)) (inter (line Q W) (line C R))
      (inter (line P W) (line A R))" if "distinct [P,Q,R,A,C,W]"
        using assms(1) is_pappus_def is_pappus2_def \<open>distinct [P,Q,R,A,C,W]\<close> \<open>col P Q R\<close>
          \<open>col A C W\<close> inter_is_a_intersec inter_line_line_comm
        by presburger
      have "col X Y Z" if "C \<in> line_ext (line E F)"
        using P_def \<open>P = C \<Longrightarrow> col X Y Z\<close> \<open>line B C \<noteq> line E F\<close> incidB_lAB line_ext_def that uniq_inter
        by auto
      have "col X Y Z" if "A \<in> line_ext (line D E)"
        by (metis Q_def \<open>Q = A \<Longrightarrow> col X Y Z\<close> \<open>line B A \<noteq> line D E\<close> ax_uniqueness incidA_lAB
            incid_inter_left incid_inter_right line_comm line_ext_def mem_Collect_eq that)
      have "col X Y Z" if "line B C = line A B"
        by (metis P_def W_def \<open>P = W \<Longrightarrow> col X Y Z\<close> \<open>distinct [B,A,C,D,E,F]\<close> ax_uniqueness
            distinct6_def incidA_lAB incidB_lAB that)
          (* We can resume our proof with the non-degenerate case *)
      have f2:"inter (line P C) (line A Q) = B" if
        "C \<notin> line_ext (line E F)" and "A \<notin> line_ext (line D E)" and "line B C \<noteq> line A B"
        by (smt CollectI P_def Q_def ax_uniqueness incidA_lAB incidB_lAB incid_inter_left
            incid_inter_right line_ext_def that(1) that(2) that(3))
          (* Again, we need to take care of a few particular cases *)
      have "col X Y Z" if "line E F = line A F"
        by (metis W_def \<open>A = W \<Longrightarrow> col X Y Z\<close> \<open>line A C \<noteq> line E F\<close> inter_ABC_1 inter_comm that)
      have "col X Y Z" if "A \<in> line_ext (line C D)"
        using R_def \<open>R = A \<Longrightarrow> col X Y Z\<close> \<open>line C D \<noteq> line A F\<close> ax_uniqueness incidA_lAB
          incid_inter_left incid_inter_right line_ext_def that
        by blast
      have "col X Y Z" if "inter (line B C) (line E F) = inter (line A C) (line E F)"
        by (simp add: P_def W_def \<open>P = W \<Longrightarrow> col X Y Z\<close> that)
          (* We resume the general case *)
      have f3:"inter (line P W) (line A R) = F" if "line E F \<noteq> line A F" and "A \<notin> line_ext (line C D)"
        and "inter (line B C) (line E F) \<noteq> inter (line A C) (line E F)"
        by (smt CollectI P_def R_def W_def ax_uniqueness incidA_lAB incidB_lAB incid_inter_left
            incid_inter_right line_ext_def that(1) that(2) that(3))
          (* Once again, first we need to handle a particular case, namely C \<in> AF, then
            we resume the general case *)
      have "col X Y Z" if "C \<in> line_ext (line A F)"
        using R_def \<open>R = C \<Longrightarrow> col X Y Z\<close> \<open>line C D \<noteq> line A F\<close> ax_uniqueness incidA_lAB
          incid_inter_left incid_inter_right line_ext_def that
        by blast
      have f4:"inter (line Q W) (line C R) = inter (line Q W) (line C D)" if "C \<notin> line_ext (line A F)"
        using R_def incidA_lAB line_ext_def line_right_inter_1 that
        by auto
      then have "inter (line Q W) (line C D) \<in> line_ext (line B F)" if "distinct [P,Q,R,A,C,W]"
        and  "C \<notin> line_ext (line E F)" and "A \<notin> line_ext (line D E)" and "line B C \<noteq> line A B"
        and "line E F \<noteq> line A F" and "A \<notin> line_ext (line C D)"
        and "inter (line B C) (line E F) \<noteq> inter (line A C) (line E F)"
        by (smt R_def \<open>distinct [B,A,C,D,E,F]\<close> ax_uniqueness col_line_ext_1 distinct6_def f1 f2 f3
            incidA_lAB incidB_lAB incid_inter_left that(1) that(2) that(3) that(5) that(6) that(7))
      then have "inter (line Q W) (line C D) = inter (line C D) (line B F)" if "distinct [P,Q,R,A,C,W]"
        and  "C \<notin> line_ext (line E F)" and "A \<notin> line_ext (line D E)" and "line B C \<noteq> line A B"
        and "line E F \<noteq> line A F" and "A \<notin> line_ext (line C D)"
        and "inter (line B C) (line E F) \<noteq> inter (line A C) (line E F)"
        by (smt W_def \<open>distinct [B,A,C,D,E,F]\<close> \<open>line C D \<noteq> line B F\<close> ax_uniqueness distinct6_def f2
            incidA_lAB incidB_lAB incid_inter_left incid_inter_right inter_line_ext_2 that(1) that(2)
            that(3) that(5) that(6) that(7))
      moreover have "inter (line C D) (line B F) \<in> line_ext (line Q W)" if "distinct [P,Q,R,A,C,W]"
        and  "C \<notin> line_ext (line E F)" and "A \<notin> line_ext (line D E)" and "line B C \<noteq> line A B"
        and "line E F \<noteq> line A F" and "A \<notin> line_ext (line C D)"
        and "inter (line B C) (line E F) \<noteq> inter (line A C) (line E F)"
        by (metis calculation col_2cycle col_A_B_ABl col_line_ext_1 distinct6_def that(1) that(2)
            that(3) that(4) that(5) that(6) that(7))
      ultimately have "col (inter (line A C) (line E F)) (inter (line C D) (line B F))
      (inter (line A B) (line D E))" if "distinct [P,Q,R,A,C,W]"
        and  "C \<notin> line_ext (line E F)" and "A \<notin> line_ext (line D E)" and "line B C \<noteq> line A B"
        and "line E F \<noteq> line A F" and "A \<notin> line_ext (line C D)"
        and "inter (line B C) (line E F) \<noteq> inter (line A C) (line E F)"
        by (metis Q_def W_def col_A_B_ABl col_rot_CW that(1) that(2) that(3) that(4) that(5) that(6)
            that(7))
      show "col X Y Z"
        by (metis P_def W_def X_def Y_def Z_def \<open>A = W \<Longrightarrow> col X Y Z\<close> \<open>A \<in> line_ext (line C D) \<Longrightarrow> col X Y Z\<close>
            \<open>A \<in> line_ext (line D E) \<Longrightarrow> col X Y Z\<close> \<open>C = W \<Longrightarrow> col X Y Z\<close> \<open>C \<in> line_ext (line E F) \<Longrightarrow> col X Y Z\<close>
            \<open>P = A \<Longrightarrow> col X Y Z\<close> \<open>P = C \<Longrightarrow> col X Y Z\<close> \<open>P = Q \<Longrightarrow> col X Y Z\<close> \<open>P = R \<Longrightarrow> col X Y Z\<close>
            \<open>inter (line B C) (line E F) = inter (line A C) (line E F) \<Longrightarrow> col X Y Z\<close>
            \<open>Q = A \<Longrightarrow> col X Y Z\<close> \<open>Q = C \<Longrightarrow> col X Y Z\<close> \<open>Q = R \<Longrightarrow> col X Y Z\<close> \<open>Q = W \<Longrightarrow> col X Y Z\<close> \<open>R = A \<Longrightarrow> col X Y Z\<close>
            \<open>R = C \<Longrightarrow> col X Y Z\<close> \<open>R = W \<Longrightarrow> col X Y Z\<close> \<open>\<lbrakk>distinct [P,Q,R,A,C,W]; C \<notin> line_ext (line E F); A \<notin> line_ext (line D E); line B C \<noteq> line A B; line E F \<noteq> line A F; A \<notin> line_ext (line C D); inter (line B C) (line E F) \<noteq> inter (line A C) (line E F)\<rbrakk> \<Longrightarrow> col (inter (line A C) (line E F)) (inter (line C D) (line B F)) (inter (line A B) (line D E))\<close>
            \<open>line B C = line A B \<Longrightarrow> col X Y Z\<close> \<open>line E F = line A F \<Longrightarrow> col X Y Z\<close> distinct6_def line_comm)
     qed
     show "is_pascal B A C D E F"
       using X_def Y_def Z_def \<open>\<lbrakk>distinct [B,A,C,D,E,F]; line A C \<noteq> line E F; line C D \<noteq> line B F; line B A \<noteq> line D E; line B C = line E F\<rbrakk> \<Longrightarrow> col X Y Z\<close>
         \<open>\<lbrakk>distinct [B,A,C,D,E,F]; line A C \<noteq> line E F; line C D \<noteq> line B F; line B A \<noteq> line D E; line B C \<noteq> line E F; line C D \<noteq> line A F\<rbrakk> \<Longrightarrow> col X Y Z\<close>
         \<open>\<lbrakk>distinct [B,A,C,D,E,F]; line A C \<noteq> line E F; line C D \<noteq> line B F; line B A \<noteq> line D E; line C D = line A F\<rbrakk> \<Longrightarrow> col X Y Z\<close>
         is_pascal_def
       by force
  qed
  thus "pascal_prop" using pascal_prop_def
    by auto
qed

lemma is_pascal_under_alternate_vertices:
  assumes "pascal_prop" and "is_pascal A B C A' B' C'"
  shows "is_pascal A B' C A' B C'"
  using assms pascal_prop_def is_pascal_rot_CW
  by presburger

lemma col_inter:
  assumes "distinct [A,B,C,D,E,F]" and "col A B C" and "col D E F"
  shows "inter (line B C) (line E F) = inter (line A B) (line D E)"
  by (smt assms ax_uniqueness col_def distinct6_def incidA_lAB incidB_lAB)

lemma pascal_pappus1:
  assumes "pascal_prop"
  shows "is_pappus1 A B C A' B' C' P Q R"
proof-
  define a1 a2 a3 a4 a5 a6 where "a1 = distinct [A,B,C,A',B',C']"  and "a2 = col A B C" and
"a3 = col A' B' C'" and "a4 = is_a_proper_intersec P A B' A' B" and "a5 = is_a_proper_intersec Q B C' B' C"
and "a6 = is_a_proper_intersec R A C' A' C"
  (* i.e. we have assumed a Pappus configuration *)
  have "inter (line B C) (line B' C') = inter (line A B) (line A' B')" if a1 a2 a3 a4 a5 a6
    using a1_def a2_def a3_def col_inter that(1) that(2) that(3)
    by blast
  then have "is_pascal A B C A' B' C'" if a1 a2 a3 a4 a5 a6
    using a1_def col_ABA is_pascal_def that(1) that(2) that(3) that(4) that(5) that(6)
    by auto
  then have "is_pascal A B' C A' B C'" if a1 a2 a3 a4 a5 a6
    using assms is_pascal_under_alternate_vertices that(1) that(2) that(3) that(4) that(5) that(6)
    by blast
  then have "col P Q R" if a1 a2 a3 a4 a5 a6
    by (smt a1_def a4_def a5_def a6_def ax_uniqueness col_def distinct6_def incidB_lAB incid_inter_left
        incid_inter_right is_a_proper_intersec_def is_pascal_def line_comm that(1) that(2) that(3)
        that(4) that(5) that(6))
  show "is_pappus1 A B C A' B' C' P Q R"
    by (simp add: \<open>\<lbrakk>a1; a2; a3; a4; a5; a6\<rbrakk> \<Longrightarrow> col P Q R\<close> a1_def a2_def a3_def a4_def a5_def a6_def
        is_pappus1_def)
qed

lemma pascal_pappus:
  assumes "pascal_prop"
  shows "is_pappus"
  by (simp add: assms is_pappus_def pappus12 pascal_pappus1)

theorem pappus_iff_pascal: "is_pappus = pascal_prop"
  using pappus_pascal pascal_pappus
  by blast

end

end


theory Chap1_Lemma1
  imports Main Chap1_Properties
begin

section "commutative monoid"

typedecl m

consts m_mult :: "m \<Rightarrow> m \<Rightarrow> m" (infixr "\<^bold>\<sqdot>\<^sub>m" 55)
consts m_one :: "m" ("\<^bold>1\<^sub>m")
consts m_ord :: "m \<Rightarrow> m \<Rightarrow> bool" (infixr "\<^bold>\<le>\<^sub>m" 50)

axiomatization where
m_assoc: "assoc (\<^bold>\<sqdot>\<^sub>m)" and
m_commu: "commu (\<^bold>\<sqdot>\<^sub>m)" and
m_idemp: "unitE (\<^bold>\<sqdot>\<^sub>m) \<^bold>1\<^sub>m"

(* definition even  \<equiv>\<forall>x. \<exists> y:: m. Prod (Suc Suc Zero) y = x \<longrightarrow>   *)

(* \<forall> x1 x2 x3. even x1 x2 x3 \<longrightarrow> assoc x1 x2 x3 *)

section "commutative residuated lattice"

subsection "Definitions"

type_synonym p = "m \<Rightarrow> bool"
type_synonym p_op = "p \<Rightarrow> p \<Rightarrow> p"

definition p_meet :: p_op (infixr "\<^bold>\<inter>\<^sub>p" 55) where
"X \<^bold>\<inter>\<^sub>p Y \<equiv> \<lambda> m. X m \<and> Y m"
definition p_join :: p_op (infixr "\<^bold>\<union>\<^sub>p" 55) where
"X \<^bold>\<union>\<^sub>p Y \<equiv> \<lambda> m. X m \<or> Y m"
definition p_mult :: p_op (infixr "\<^bold>\<star>\<^sub>p" 55) where
"X \<^bold>\<star>\<^sub>p Y \<equiv> \<lambda> m. \<exists> a b. X a \<and> Y b \<and> (a \<^bold>\<sqdot>\<^sub>m b) = m"
definition p_impl :: p_op (infixr "\<^bold>\<Rrightarrow>\<^sub>p" 55) where
"X \<^bold>\<Rrightarrow>\<^sub>p Y \<equiv> \<lambda> m. \<forall> c. X c \<longrightarrow> Y (m \<^bold>\<sqdot>\<^sub>m c)"
consts p_zero :: "p" ("\<^bold>0\<^sub>p")
definition p_one :: "p" ("\<^bold>1\<^sub>p") where
"\<^bold>1\<^sub>p \<equiv> \<lambda> m. m = (\<^bold>1\<^sub>m)"
definition p_bot :: "p" ("\<^bold>\<bottom>\<^sub>p") where
"\<^bold>\<bottom>\<^sub>p \<equiv> \<lambda> m. False"
definition p_top :: "p" ("\<^bold>\<top>\<^sub>p") where
"\<^bold>\<top>\<^sub>p \<equiv> \<lambda> m. True"
definition p_ord ::"p \<Rightarrow> p \<Rightarrow> bool" (infixr"\<^bold>\<le>\<^sub>p"51) where
(*"p1 \<^bold>\<le>\<^sub>p p2 \<equiv> \<forall> m. (p1 \<^bold>\<inter>\<^sub>p p2) m \<longleftrightarrow> p1 m"*)
(* this might be also contravariant *)
"p1 \<^bold>\<le>\<^sub>p p2 \<equiv> \<forall> m. (p1 m \<longrightarrow> p2 m)"

subsection "Properties Proof"

subsubsection "commutative monoid with the unit 1"
(*
definition "commu Op \<equiv> \<forall> a b. Op a b = Op b a"
definition "unitE Op One \<equiv> \<forall> a. Op a One = a"
definition "assoc Op \<equiv> \<forall> x y z. Op (Op x y) z = Op x (Op y z)"
*)

lemma p_commu_mult: "commu (\<^bold>\<star>\<^sub>p)"
  apply (unfold commu_def p_mult_def)
proof (rule, rule, rule)
  fix a b m
  show "(\<exists>aa ba. a aa \<and> b ba \<and> aa \<^bold>\<sqdot>\<^sub>m ba = m) = (\<exists>aa ba. b aa \<and> a ba \<and> aa \<^bold>\<sqdot>\<^sub>m ba = m)" proof
    show "\<exists>aa ba. a aa \<and> b ba \<and> aa \<^bold>\<sqdot>\<^sub>m ba = m \<Longrightarrow> \<exists>aa ba. b aa \<and> a ba \<and> aa \<^bold>\<sqdot>\<^sub>m ba = m" proof -
      assume 1: "\<exists>aa ba. a aa \<and> b ba \<and> aa \<^bold>\<sqdot>\<^sub>m ba = m"
      then obtain aa ba where "a aa \<and> b ba \<and> aa \<^bold>\<sqdot>\<^sub>m ba = m" by auto
      hence "a aa \<and> b ba \<and> ba \<^bold>\<sqdot>\<^sub>m aa = m" using commu_def m_commu by metis
      thus "\<exists>aa ba. b aa \<and> a ba \<and> aa \<^bold>\<sqdot>\<^sub>m ba = m" by auto
    qed
    show " \<exists>aa ba. b aa \<and> a ba \<and> aa \<^bold>\<sqdot>\<^sub>m ba = m \<Longrightarrow> \<exists>aa ba. a aa \<and> b ba \<and> aa \<^bold>\<sqdot>\<^sub>m ba = m"
      by (meson commu_def m_commu) qed qed
lemma p_unitE_mult: "unitE (\<^bold>\<star>\<^sub>p) (\<^bold>1\<^sub>p)"
  apply (unfold unitE_def p_one_def p_mult_def)
proof (rule, rule)
  fix a m
  show "(\<exists>aa b. a aa \<and> b = \<^bold>1\<^sub>m \<and> aa \<^bold>\<sqdot>\<^sub>m b = m) = a m" proof
    show "\<exists>aa b. a aa \<and> b = \<^bold>1\<^sub>m \<and> aa \<^bold>\<sqdot>\<^sub>m b = m \<Longrightarrow> a m" proof -
      assume 1: "\<exists>aa b. a aa \<and> b = \<^bold>1\<^sub>m \<and> aa \<^bold>\<sqdot>\<^sub>m b = m"
      then obtain aa b where 2: "a aa \<and> b = \<^bold>1\<^sub>m \<and> aa \<^bold>\<sqdot>\<^sub>m b = m" by auto
      then have "a aa \<and> (aa \<^bold>\<sqdot>\<^sub>m \<^bold>1\<^sub>m = m)" by auto
      then have "a aa \<and> (aa = m)" using m_idemp unitE_def by metis
      thus "a m" by auto qed
  next
    show "a m \<Longrightarrow> \<exists>aa b. a aa \<and> b = \<^bold>1\<^sub>m \<and> aa \<^bold>\<sqdot>\<^sub>m b = m" using m_idemp by (simp add: unitE_def)
  qed qed
lemma p_assoc_mult: "assoc (\<^bold>\<star>\<^sub>p)"
  apply (unfold assoc_def p_mult_def)
proof (rule, rule, rule, rule)
  fix x y z m
  show "(\<exists>a b. (\<exists>aa b. x aa \<and> y b \<and> aa \<^bold>\<sqdot>\<^sub>m b = a) \<and> z b \<and> a \<^bold>\<sqdot>\<^sub>m b = m) = (\<exists>a b. x a \<and> (\<exists>a ba. y a \<and> z ba \<and> a \<^bold>\<sqdot>\<^sub>m ba = b) \<and> a \<^bold>\<sqdot>\<^sub>m b = m)"
  proof
    show "\<exists>a b. (\<exists>aa b. x aa \<and> y b \<and> aa \<^bold>\<sqdot>\<^sub>m b = a) \<and> z b \<and> a \<^bold>\<sqdot>\<^sub>m b = m \<Longrightarrow> \<exists>a b. x a \<and> (\<exists>a ba. y a \<and> z ba \<and> a \<^bold>\<sqdot>\<^sub>m ba = b) \<and> a \<^bold>\<sqdot>\<^sub>m b = m"
    proof -
      assume 1: "\<exists>a b. (\<exists>aa bb. x aa \<and> y bb \<and> aa \<^bold>\<sqdot>\<^sub>m bb = a) \<and> z b \<and> a \<^bold>\<sqdot>\<^sub>m b = m"
      then obtain a b aa bb where 3: "x aa \<and> y bb \<and> aa \<^bold>\<sqdot>\<^sub>m bb = a \<and> z b \<and> a \<^bold>\<sqdot>\<^sub>m b = m" by auto
      hence "x aa \<and> y bb \<and> z b \<and> (aa \<^bold>\<sqdot>\<^sub>m bb) \<^bold>\<sqdot>\<^sub>m b = m" by auto
      hence "x aa \<and> y bb \<and> z b \<and> aa \<^bold>\<sqdot>\<^sub>m (bb \<^bold>\<sqdot>\<^sub>m b) = m" using m_assoc assoc_def by metis
      hence "\<exists> aa b' bb b. x aa \<and> y bb \<and> z b \<and> bb \<^bold>\<sqdot>\<^sub>m b = b' \<and> z b \<and> aa \<^bold>\<sqdot>\<^sub>m b' = m" by blast
      thus "\<exists>aa b'. x aa \<and> (\<exists>bb b. y bb \<and> z b \<and> bb \<^bold>\<sqdot>\<^sub>m b = b') \<and> aa \<^bold>\<sqdot>\<^sub>m b' = m" by auto qed
  next
    show "\<exists>a b. x a \<and> (\<exists>a ba. y a \<and> z ba \<and> a \<^bold>\<sqdot>\<^sub>m ba = b) \<and> a \<^bold>\<sqdot>\<^sub>m b = m \<Longrightarrow> \<exists>a b. (\<exists>aa b. x aa \<and> y b \<and> aa \<^bold>\<sqdot>\<^sub>m b = a) \<and> z b \<and> a \<^bold>\<sqdot>\<^sub>m b = m"
      by (metis assoc_def m_assoc) qed qed

subsubsection "bounded lattice for Meet"

(*
definition "commu Op \<equiv> \<forall> a b. Op a b = Op b a"
definition "assoc Op \<equiv> \<forall> x y z. Op (Op x y) z = Op x (Op y z)"
definition "idemp Op \<equiv> \<forall> a. Op a a = a"
definition "great Op Top \<equiv> extre Op Top"
*)

lemma p_commu_meet: "commu (\<^bold>\<inter>\<^sub>p)"
  apply (unfold commu_def p_meet_def)
proof (rule, rule, rule)
  fix a b :: p fix  m :: m
  show "(a m \<and> b m) = (b m \<and> a m)" by auto qed
lemma p_assoc_meet: "assoc (\<^bold>\<inter>\<^sub>p)"
  apply (unfold assoc_def p_meet_def)
proof (rule, rule, rule, rule)
  fix x y z :: p fix m :: m
  show "((x m \<and> y m) \<and> z m) = (x m \<and> y m \<and> z m)" by simp qed
lemma p_idemp_meet: "idemp (\<^bold>\<inter>\<^sub>p)"
  apply (unfold idemp_def p_meet_def) proof (rule, rule)
  fix a :: p fix m :: m
  show "(a m \<and> a m) = a m"  by simp qed
lemma p_great_meet: "great (\<^bold>\<inter>\<^sub>p) (\<^bold>\<top>\<^sub>p)"
  apply (unfold great_def extre_def p_meet_def p_top_def) proof (rule, rule)
  fix a :: p fix m :: m
  show "(a m \<and> True) = a m" by simp qed

subsubsection "bounded lattice for Join"

(*
definition "commu Op \<equiv> \<forall> a b. Op a b = Op b a"
definition "assoc Op \<equiv> \<forall> x y z. Op (Op x y) z = Op x (Op y z)"
definition "idemp Op \<equiv> \<forall> a. Op a a = a"
definition "least Op Top \<equiv> extre Op Top"
*)

lemma p_commu_join: "commu (\<^bold>\<union>\<^sub>p)"
  apply (unfold commu_def p_join_def)
proof (rule, rule, rule)
  fix a b :: p fix  m :: m
  show "(a m \<or> b m) = (b m \<or> a m)" by auto qed
lemma p_assoc_join: "assoc (\<^bold>\<union>\<^sub>p)"
  apply (unfold assoc_def p_join_def)
proof (rule, rule, rule, rule)
  fix x y z :: p fix m :: m
  show "((x m \<or> y m) \<or> z m) = (x m \<or> y m \<or> z m)" by simp qed
lemma p_idemp_join: "idemp (\<^bold>\<union>\<^sub>p)"
  apply (unfold idemp_def p_join_def) proof (rule, rule)
  fix a :: p fix m :: m
  show "(a m \<or> a m) = a m"  by simp qed
lemma p_least_join: "least (\<^bold>\<union>\<^sub>p) (\<^bold>\<bottom>\<^sub>p)"
  apply (unfold least_def extre_def p_join_def p_bot_def) proof (rule, rule)
  fix a :: p fix m :: m
  show "(a m \<or> False) = a m" by simp qed

subsubsection "bounded lattice for Join and Meet"

(*definition "absor Op1 Op2 \<equiv> \<forall> a b. Op1 a (Op2 a b) = a"*)

lemma p_absorb_meetjoin: "absorb (\<^bold>\<inter>\<^sub>p) (\<^bold>\<union>\<^sub>p)"
  apply (unfold absorb_def p_meet_def p_join_def) proof (rule, rule, rule)
  fix a b :: p fix m :: m
  show "(a m \<and> (a m \<or> b m)) = a m" by auto qed
lemma p_absorb_joinmeet: "absorb (\<^bold>\<union>\<^sub>p) (\<^bold>\<inter>\<^sub>p)"
  apply (unfold absorb_def p_meet_def p_join_def) proof (rule, rule, rule)
  fix a b :: p fix m :: m
  show "(a m \<or> a m \<and> b m) = a m" by auto qed

subsubsection "residuated lattice"

lemma p_resid_law: "resid (\<^bold>\<le>\<^sub>p) (\<^bold>\<star>\<^sub>p) (\<^bold>\<Rrightarrow>\<^sub>p)"
  apply (unfold resid_def p_mult_def p_impl_def p_ord_def)
(*  by (metis commu_def m_commu)*)
proof (rule, rule, rule)
  fix x y z :: p
  show "(\<forall>m. (\<exists>a b. x a \<and> y b \<and> a \<^bold>\<sqdot>\<^sub>m b = m) \<longrightarrow> z m) = (\<forall>a. x a \<longrightarrow> (\<forall>b. y b \<longrightarrow> z (a \<^bold>\<sqdot>\<^sub>m b)))" proof (rule)
    show " \<forall>m. (\<exists>a' b'. x a' \<and> y b' \<and> a' \<^bold>\<sqdot>\<^sub>m b' = m) \<longrightarrow> z m \<Longrightarrow> \<forall>a. x a \<longrightarrow> (\<forall>b. y b \<longrightarrow> z (a \<^bold>\<sqdot>\<^sub>m b))" proof (rule, rule, rule, rule)
      fix a b :: m
      assume 1: "\<forall>m. (\<exists>a' b'. x a' \<and> y b' \<and> a' \<^bold>\<sqdot>\<^sub>m b' = m) \<longrightarrow> z m"
      assume 2: "x a"
      assume 3: "y b"
      show "z (a \<^bold>\<sqdot>\<^sub>m b)" proof -
        let ?m' = "a \<^bold>\<sqdot>\<^sub>m b"
        from 2 3 have "x a \<and> y b \<and> a \<^bold>\<sqdot>\<^sub>m b = ?m'" by simp
        hence "\<exists>a' b'. x a' \<and> y b' \<and> a' \<^bold>\<sqdot>\<^sub>m b' = ?m'" by auto
        hence "z ?m'" using 1 by simp
        thus "z (a \<^bold>\<sqdot>\<^sub>m b)" by simp
      qed
    qed
  next
    show "\<forall>a. x a \<longrightarrow> (\<forall>b. y b \<longrightarrow> z (a \<^bold>\<sqdot>\<^sub>m b)) \<Longrightarrow> \<forall>m. (\<exists>a b. x a \<and> y b \<and> a \<^bold>\<sqdot>\<^sub>m b = m) \<longrightarrow> z m"
      by auto
  qed qed

  subsubsection "complete lattice"

(* how to state this ? *)

abbreviation "upper_bound U S \<equiv> \<forall>X. (S X) \<longrightarrow> X \<^bold>\<preceq> U"

abbreviation
"is_supremum U S \<equiv> upper_bound U S \<and> (\<forall>X. upper_bound X S \<longrightarrow> U \<^bold>\<preceq> X)"

lemma sup_char: "is_supremum \<^bold>\<Or>S S"

abbreviation "upper_bound U \<equiv> \<forall> X.  X \<^bold>\<preceq> U"

end


(*
  File: Graph.thy
  Author: Bohua Zhan

  Basics of graph of functions (as represented by a set of ordered pairs).
*)

theory Graph
  imports Set
begin

section \<open>Graphs\<close>

definition is_graph :: "i \<Rightarrow> o" where [rewrite]:
  "is_graph(G) \<longleftrightarrow> (\<forall>x\<in>G. x = \<langle>fst(x),snd(x)\<rangle>)"

lemma is_graphE [forward]: "is_graph(G) \<Longrightarrow> x \<in> G \<Longrightarrow> x = \<langle>fst(x),snd(x)\<rangle>" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_graph_def} *}

definition gr_source :: "i \<Rightarrow> i" where [rewrite]:
  "gr_source(G) = {fst(p). p \<in> G}"
lemma gr_sourceI [typing2]: "\<langle>a,b\<rangle> \<in> G \<Longrightarrow> a \<in> gr_source(G)" by auto2
lemma gr_sourceE [backward]: "is_graph(G) \<Longrightarrow> a \<in> gr_source(G) \<Longrightarrow> \<exists>b. \<langle>a,b\<rangle>\<in>G" by auto2
setup {* del_prfstep_thm @{thm gr_source_def} *}

definition gr_target :: "i \<Rightarrow> i" where [rewrite]:
  "gr_target(G) = {snd(p). p \<in> G}"
lemma gr_targetI [typing2]: "\<langle>a,b\<rangle> \<in> G \<Longrightarrow> b \<in> gr_target(G)" by auto2
lemma gr_targetE [backward]: "is_graph(G) \<Longrightarrow> b \<in> gr_target(G) \<Longrightarrow> \<exists>a. \<langle>a,b\<rangle>\<in>G" by auto2
setup {* del_prfstep_thm @{thm gr_target_def} *}

definition gr_field :: "i \<Rightarrow> i" where [rewrite]:
  "gr_field(G) = gr_source(G) \<union> gr_target(G)"
lemma gr_fieldI1 [typing2]: "\<langle>a,b\<rangle> \<in> G \<Longrightarrow> a \<in> gr_field(G)" by auto2
lemma gr_fieldI2 [typing2]: "\<langle>a,b\<rangle> \<in> G \<Longrightarrow> b \<in> gr_field(G)" by auto2

definition gr_id :: "i \<Rightarrow> i" where [rewrite]:
  "gr_id(A) = {\<langle>a,a\<rangle>. a \<in> A}"
lemma gr_id_is_graph [forward]: "is_graph(gr_id(A))" by auto2
lemma gr_idI [typing2]: "a \<in> A \<Longrightarrow> \<langle>a,a\<rangle> \<in> gr_id(A)" by auto2
lemma gr_id_iff [rewrite]: "p \<in> gr_id(A) \<longleftrightarrow> (p\<in>A\<times>A \<and> fst(p) = snd(p))" by auto2
setup {* del_prfstep_thm @{thm gr_id_def} *}

definition gr_comp :: "i \<Rightarrow> i \<Rightarrow> i"  (infixr "\<circ>\<^sub>g" 60) where [rewrite]:
  "s \<circ>\<^sub>g r = {p\<in>gr_source(r)\<times>gr_target(s). \<exists>z. \<langle>fst(p),z\<rangle>\<in>r \<and> \<langle>z,snd(p)\<rangle>\<in>s}"

lemma gr_comp_is_graph [forward]: "is_graph(s \<circ>\<^sub>g r)" by auto2
lemma gr_compI [backward2]:
  "\<langle>x,y\<rangle> \<in> r \<Longrightarrow> \<langle>y,z\<rangle> \<in> s \<Longrightarrow> \<langle>x,z\<rangle> \<in> s \<circ>\<^sub>g r" by auto2
lemma gr_compE [forward]:
  "p \<in> s \<circ>\<^sub>g r \<Longrightarrow> \<exists>y. \<langle>fst(p),y\<rangle> \<in> r \<and> \<langle>y,snd(p)\<rangle> \<in> s" by auto2
setup {* del_prfstep_thm @{thm gr_comp_def} *}

section \<open>Evaluation on a graph\<close>

definition is_func_graph :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "is_func_graph(G,X) \<longleftrightarrow> is_graph(G) \<and> gr_source(G) = X \<and> (\<forall>a\<in>X. \<exists>!y. \<langle>a,y\<rangle> \<in> G)"

definition func_graphs :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "func_graphs(X,Y) = {G\<in>Pow(X\<times>Y). is_func_graph(G,X)}"

definition graph_eval :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "graph_eval(G,x) = (THE y. \<langle>x,y\<rangle> \<in> G)"

lemma is_func_graphD [forward]:
  "is_func_graph(G,X) \<Longrightarrow> is_graph(G) \<and> gr_source(G) = X" by auto2

lemma is_func_graphD2 [forward]:
  "is_func_graph(G,X) \<Longrightarrow> x \<in> X \<Longrightarrow> \<langle>x, graph_eval(G,x)\<rangle> \<in> G" by auto2

lemma is_func_graphD3 [forward]:
  "is_func_graph(G,X) \<Longrightarrow> \<langle>x,y\<rangle> \<in> G \<Longrightarrow> x \<in> X \<Longrightarrow> graph_eval(G,x) = y" by auto2

lemma graph_eq [backward1]:
  "is_func_graph(G,X) \<Longrightarrow> is_func_graph(H,X) \<Longrightarrow>
   \<forall>x\<in>X. graph_eval(G,x) = graph_eval(H,x) \<Longrightarrow> G = H" by auto2

lemma is_func_graph_cons:
  "is_func_graph(G,X) \<Longrightarrow> a \<notin> X \<Longrightarrow> is_func_graph(cons(\<langle>a,b\<rangle>,G),cons(a,X))"
@proof
  @let "H = cons(\<langle>a,b\<rangle>,G)"
  @have "is_graph(H)"
  @have "\<forall>x\<in>gr_source(H). x \<in> cons(a,X)" @with
    @obtain y where "\<langle>x,y\<rangle> \<in> H"
  @end
  @have "\<forall>c\<in>cons(a,X). \<exists>!y. \<langle>c,y\<rangle> \<in> H" @with
    @case "c = a"
  @end
@qed

lemma is_func_graph_empty: "is_func_graph(\<emptyset>,\<emptyset>)"
@proof
  @have "is_graph(\<emptyset>)"
  @have "\<forall>x\<in>gr_source(\<emptyset>). x \<in> \<emptyset>" @with
    @obtain y where "\<langle>x,y\<rangle> \<in> \<emptyset>"
  @end
@qed

setup {* del_prfstep_thm_eqforward @{thm is_func_graph_def} *}
setup {* del_prfstep_thm @{thm graph_eval_def} *}

section \<open>Graphs from a relation\<close>

definition rel_graph :: "i \<Rightarrow> (i \<Rightarrow> i \<Rightarrow> o) \<Rightarrow> i" where [rewrite]:
  "rel_graph(S,R) = {p\<in>S\<times>S. R(fst(p),snd(p))}"

lemma rel_graph_mem [typing]: "rel_graph(S,R) \<in> Pow(S\<times>S)" by auto2
lemma rel_graph_iff [rewrite]: "\<langle>x,y\<rangle> \<in> rel_graph(S,R) \<longleftrightarrow> (x \<in> S \<and> y \<in> S \<and> R(x,y))" by auto2

setup {* del_prfstep_thm @{thm rel_graph_def} *}

end


theory Design_Basics imports Main Multisets_Extras "HOL-Library.Disjoint_Sets"
begin

section \<open> Design Theory Basics\<close>
text \<open> All definitions in this section reference the handbook of combinatorial designs
 \cite{colbournHandbookCombinatorialDesigns2007}\<close>

subsection \<open> Initial setup \<close>

text \<open> Enable coercion of nats to ints to aid with reasoning on design properties \<close>
declare [[coercion_enabled]]
declare [[coercion "of_nat :: nat \<Rightarrow> int"]]

subsection \<open> Incidence System \<close>

text \<open>An incidence system is defined to be a wellformed set system. i.e. each block is a subset
of the base point set. Alternatively, an incidence system can be looked at as the point set
and an incidence relation which indicates if they are in the same block \<close>

locale incidence_system =
  fixes point_set :: "'a set" ("\<V>")
  fixes block_collection :: "'a set multiset" ("\<B>")
  assumes wellformed: "b \<in># \<B> \<Longrightarrow> b \<subseteq> \<V>"
begin

definition "\<I> \<equiv> { (x, b) . b \<in># \<B> \<and> x \<in> b}" (* incidence relation *)

definition incident :: "'a \<Rightarrow> 'a set \<Rightarrow> bool" where
"incident p b \<equiv> (p, b) \<in> \<I>"

text \<open>Defines common notation used to indicate number of points ($v$) and number of blocks ($b$) \<close>
abbreviation "\<v> \<equiv> card \<V>"

abbreviation "\<b> \<equiv> size \<B>"

text \<open>Basic incidence lemmas \<close>

lemma incidence_alt_def:
  assumes "p \<in> \<V>"
  assumes "b \<in># \<B>"
  shows "incident p b \<longleftrightarrow> p \<in> b"
  by (auto simp add: incident_def \<I>_def assms)

lemma wf_invalid_point: "x \<notin> \<V> \<Longrightarrow> b \<in># \<B> \<Longrightarrow> x \<notin> b"
  using wellformed by auto

lemma block_set_nempty_imp_block_ex: "\<B> \<noteq> {#} \<Longrightarrow> \<exists> bl . bl \<in># \<B>"
  by auto

text \<open>Abbreviations for all incidence systems \<close>
abbreviation multiplicity :: "'a set \<Rightarrow> nat" where
"multiplicity b \<equiv> count \<B> b"

abbreviation incomplete_block :: "'a set \<Rightarrow> bool" where
"incomplete_block bl \<equiv> card bl < card \<V> \<and> bl \<in># \<B>"

lemma incomplete_alt_size: "incomplete_block bl \<Longrightarrow> card bl < \<v>"
  by simp

lemma incomplete_alt_in: "incomplete_block bl \<Longrightarrow> bl \<in># \<B>"
  by simp

lemma incomplete_alt_imp[intro]: "card bl < \<v> \<Longrightarrow> bl \<in># \<B> \<Longrightarrow> incomplete_block bl"
  by simp

definition design_support :: "'a set set" where
"design_support \<equiv> set_mset \<B>"

end

subsection \<open> Finite Incidence Systems \<close>

text \<open> These simply require the point set to be finite.
As multisets are only defined to be finite, it is implied that the block set must be finite already \<close>

locale finite_incidence_system = incidence_system +
  assumes finite_sets: "finite \<V>"
begin

lemma finite_blocks: "b \<in># \<B> \<Longrightarrow> finite b"
  using wellformed finite_sets finite_subset by blast

lemma mset_points_distinct: "distinct_mset (mset_set \<V>)"
  using finite_sets by (simp add: distinct_mset_def)

lemma mset_points_distinct_diff_one: "distinct_mset (mset_set (\<V> - {x}))"
  by (meson count_mset_set_le_one distinct_mset_count_less_1)

lemma finite_design_support: "finite (design_support)"
  using design_support_def by auto

lemma block_size_lt_order: "bl \<in># \<B> \<Longrightarrow> card bl \<le> card \<V>"
  using wellformed by (simp add: card_mono finite_sets)

end

subsection \<open> Designs \<close>

text \<open> There are many varied definitions of a design in literature. However, the most
commonly accepted definition is a finite point set, $V$ and collection of blocks $B$, where
no block in $B$ can be empty \<close>
locale design = finite_incidence_system +
  assumes blocks_nempty: "bl \<in># \<B> \<Longrightarrow> bl \<noteq> {}"
begin

lemma wf_design: "design \<V> \<B>"  by intro_locales

lemma wf_design_iff: "bl \<in># \<B> \<Longrightarrow> design \<V> \<B> \<longleftrightarrow> (bl \<subseteq> \<V> \<and> finite \<V> \<and> bl \<noteq> {})"
  using blocks_nempty wellformed finite_sets
  by (simp add: wf_design)

text \<open>Reasoning on non empty properties and non zero parameters\<close>
lemma blocks_nempty_alt: "\<forall> bl \<in># \<B>. bl \<noteq> {}"
  using blocks_nempty by auto

lemma block_set_nempty_imp_points: "\<B> \<noteq> {#} \<Longrightarrow> \<V> \<noteq> {}"
  using wf_design wf_design_iff by auto

lemma b_non_zero_imp_v_non_zero: "\<b> > 0 \<Longrightarrow> \<v> > 0"
  using block_set_nempty_imp_points finite_sets by fastforce

lemma v_eq0_imp_b_eq_0: "\<v> = 0 \<Longrightarrow> \<b> = 0"
  using b_non_zero_imp_v_non_zero by auto

text \<open> Size lemmas \<close>
lemma block_size_lt_v: "bl \<in># \<B> \<Longrightarrow> card bl \<le> \<v>"
  by (simp add: card_mono finite_sets wellformed)

lemma block_size_gt_0: "bl \<in># \<B> \<Longrightarrow> card bl > 0"
  using finite_sets blocks_nempty finite_blocks by fastforce

lemma design_cart_product_size: "size ((mset_set \<V>) \<times># \<B>) = \<v> * \<b>"
  by (simp add: size_cartesian_product)

end

text \<open>Intro rules for design locale \<close>

lemma wf_design_implies:
  assumes "(\<And> b . b \<in># \<B> \<Longrightarrow> b \<subseteq> V)"
  assumes "\<And> b . b \<in># \<B> \<Longrightarrow> b \<noteq> {}"
  assumes "finite V"
  assumes "\<B> \<noteq> {#}"
  assumes "V \<noteq> {}"
  shows "design V \<B>"
  using assms by (unfold_locales) simp_all

lemma (in incidence_system) finite_sysI[intro]: "finite \<V> \<Longrightarrow> finite_incidence_system \<V> \<B>"
  by (unfold_locales) simp_all

lemma (in finite_incidence_system) designI[intro]: "(\<And> b. b \<in># \<B> \<Longrightarrow> b \<noteq> {}) \<Longrightarrow> \<B> \<noteq> {#}
     \<Longrightarrow> \<V> \<noteq> {} \<Longrightarrow> design \<V> \<B>"
  by (unfold_locales) simp_all

subsection \<open> Core Property Definitions \<close>

subsubsection \<open> Replication Number\<close>

text \<open> The replication number for a point is the number of blocks that point is incident with \<close>

definition point_replication_number :: "'a set multiset \<Rightarrow> 'a \<Rightarrow> nat" (infix "rep" 75) where
"B rep x \<equiv> size {#b \<in># B . x \<in> b#}"

lemma max_point_rep: "B rep x \<le> size B"
  using size_filter_mset_lesseq by (simp add: point_replication_number_def)

lemma rep_number_g0_exists:
  assumes "B rep x > 0"
  obtains b where "b \<in># B" and "x \<in> b"
proof -
  have "size {#b \<in># B . x \<in> b#} > 0" using assms point_replication_number_def
    by metis
  thus ?thesis
    by (metis filter_mset_empty_conv nonempty_has_size that)
qed

lemma rep_number_on_set_def: "finite B \<Longrightarrow> (mset_set B) rep x = card {b \<in> B . x \<in> b}"
  by (simp add: point_replication_number_def)

lemma point_rep_number_split[simp]: "(A + B) rep x = A rep x + B rep x"
  by (simp add: point_replication_number_def)

lemma point_rep_singleton_val [simp]: "x \<in> b \<Longrightarrow> {#b#} rep x = 1"
  by (simp add: point_replication_number_def)

lemma point_rep_singleton_inval [simp]: "x \<notin> b \<Longrightarrow> {#b#} rep x = 0"
  by (simp add: point_replication_number_def)

context incidence_system
begin

lemma point_rep_number_alt_def: "\<B> rep x = size {# b \<in># \<B> . x \<in> b#}"
  by (simp add: point_replication_number_def)

lemma rep_number_non_zero_system_point: " \<B> rep x > 0 \<Longrightarrow> x \<in> \<V>"
  using rep_number_g0_exists wellformed
  by (metis wf_invalid_point)

lemma point_rep_non_existance [simp]: "x \<notin> \<V> \<Longrightarrow> \<B> rep x = 0"
  using wf_invalid_point by (simp add:  point_replication_number_def filter_mset_empty_conv)

lemma point_rep_number_inv: "size {# b \<in># \<B> . x \<notin> b #} = \<b> - (\<B> rep x)"
proof -
  have "\<b> = size {# b \<in># \<B> . x \<notin> b #} + size {# b \<in># \<B> . x \<in> b #}"
    using multiset_partition by (metis add.commute size_union)
  thus ?thesis by (simp add: point_replication_number_def)
qed

lemma point_rep_num_inv_non_empty: "(\<B> rep x) < \<b> \<Longrightarrow> \<B> \<noteq> {#} \<Longrightarrow> {# b \<in># \<B> . x \<notin> b #} \<noteq> {#}"
  by (metis diff_zero point_replication_number_def size_empty size_filter_neg verit_comp_simplify1(1))

end

subsubsection \<open>Point Index \<close>

text \<open>The point index of a subset of points in a design, is the number of times those points
occur together in a block of the design\<close>
definition points_index :: "'a set multiset \<Rightarrow> 'a set \<Rightarrow> nat" (infix "index" 75) where
"B index ps \<equiv> size {#b \<in># B . ps \<subseteq> b#}"

lemma points_index_empty [simp]: "{#} index ps = 0"
  by (simp add: points_index_def)

lemma point_index_distrib: "(B1 + B2) index ps =  B1 index ps + B2 index ps"
  by (simp add: points_index_def)

lemma point_index_diff: "B1 index ps = (B1 + B2) index ps - B2 index ps"
  by (simp add: points_index_def)

lemma points_index_singleton: "{#b#} index ps = 1 \<longleftrightarrow> ps \<subseteq> b"
  by (simp add: points_index_def)

lemma points_index_singleton_zero: "\<not> (ps \<subseteq> b) \<Longrightarrow> {#b#} index ps = 0"
  by (simp add: points_index_def)

lemma points_index_sum: "(\<Sum>\<^sub># B ) index ps = (\<Sum>b \<in># B . (b index ps))"
  using points_index_empty by (induction B) (auto simp add: point_index_distrib)

lemma points_index_block_image_add_eq:
  assumes "x \<notin> ps"
  assumes "B index ps = l"
  shows "{# insert x b . b \<in># B#} index ps = l"
  using points_index_def by (metis (no_types, lifting) assms filter_mset_cong
      image_mset_filter_swap2 points_index_def size_image_mset subset_insert)

lemma points_index_on_set_def [simp]:
  assumes "finite B"
  shows "(mset_set B) index ps = card {b \<in> B. ps \<subseteq> b}"
  by (simp add: points_index_def assms)

lemma points_index_single_rep_num: "B index {x} = B rep x"
  by (simp add: points_index_def point_replication_number_def)

lemma points_index_pair_rep_num:
  assumes "\<And> b. b \<in># B \<Longrightarrow> x \<in> b"
  shows "B index {x, y} = B rep y"
  using point_replication_number_def points_index_def
  by (metis assms empty_subsetI filter_mset_cong insert_subset)

lemma points_index_0_left_imp:
  assumes "B index ps = 0"
  assumes "b \<in># B"
  shows "\<not> (ps \<subseteq> b)"
proof (rule ccontr)
  assume "\<not> \<not> ps \<subseteq> b"
  then have a: "ps \<subseteq> b" by auto
  then have "b \<in># {#bl \<in># B . ps \<subseteq> bl#}" by (simp add: assms(2))
  thus False by (metis assms(1) count_greater_eq_Suc_zero_iff count_size_set_repr not_less_eq_eq
        points_index_def size_filter_mset_lesseq)
qed

lemma points_index_0_right_imp:
  assumes "\<And> b . b \<in># B \<Longrightarrow> (\<not> ps \<subseteq> b)"
  shows "B index ps = 0"
  using assms by (simp add: filter_mset_empty_conv points_index_def)

lemma points_index_0_iff: "B index ps = 0 \<longleftrightarrow> (\<forall> b. b \<in># B \<longrightarrow> (\<not> ps \<subseteq> b))"
  using points_index_0_left_imp points_index_0_right_imp by metis

lemma points_index_gt0_impl_existance:
  assumes "B index ps > 0"
  shows "(\<exists> bl . (bl \<in># B \<and> ps \<subseteq> bl))"
proof -
  have "size {#bl \<in># B . ps \<subseteq> bl#} > 0"
    by (metis assms points_index_def)
  then obtain bl where "bl \<in># B" and "ps \<subseteq> bl"
    by (metis filter_mset_empty_conv nonempty_has_size)
  thus ?thesis by auto
qed

lemma points_index_one_unique:
  assumes "B index ps = 1"
  assumes "bl \<in># B" and "ps \<subseteq> bl" and "bl' \<in># B" and "ps \<subseteq> bl'"
  shows "bl = bl'"
proof (rule ccontr)
  assume assm: "bl \<noteq> bl'"
  then have bl1: "bl \<in># {#bl \<in># B . ps \<subseteq> bl#}" using assms by simp
  then have bl2: "bl'\<in># {#bl \<in># B . ps \<subseteq> bl#}" using assms by simp
  then have "{#bl, bl'#} \<subseteq># {#bl \<in># B . ps \<subseteq> bl#}" using assms by (metis bl1 bl2 points_index_def
        add_mset_subseteq_single_iff assm mset_subset_eq_single size_single subseteq_mset_size_eql)
  then have "size {#bl \<in># B . ps \<subseteq> bl#} \<ge> 2" using size_mset_mono by fastforce
  thus False using assms by (metis numeral_le_one_iff points_index_def semiring_norm(69))
qed

lemma points_index_one_unique_block:
  assumes "B index ps = 1"
  shows "\<exists>! bl . (bl \<in># B \<and> ps \<subseteq> bl)"
  using assms points_index_gt0_impl_existance points_index_one_unique
  by (metis zero_less_one)

lemma points_index_one_not_unique_block:
  assumes "B index ps = 1"
  assumes "ps \<subseteq> bl"
  assumes "bl \<in># B"
  assumes "bl' \<in># B - {#bl#}"
  shows "\<not> ps \<subseteq> bl'"
proof -
  have "B = (B - {#bl#}) + {#bl#}" by (simp add: assms(3))
  then have "(B - {#bl#}) index ps = B index ps - {#bl#} index ps"
    by (metis point_index_diff)
  then have "(B - {#bl#}) index ps = 0" using assms points_index_singleton
    by (metis diff_self_eq_0)
  thus ?thesis using assms(4) points_index_0_left_imp by auto
qed

lemma (in incidence_system) points_index_alt_def: "\<B> index ps = size {#b \<in># \<B> . ps \<subseteq> b#}"
  by (simp add: points_index_def)

lemma (in incidence_system) points_index_ps_nin: "\<not> (ps \<subseteq> \<V>) \<Longrightarrow> \<B> index ps = 0"
  using points_index_alt_def filter_mset_empty_conv in_mono size_empty subsetI wf_invalid_point
  by metis

lemma (in incidence_system) points_index_count_bl:
    "multiplicity bl \<ge> n \<Longrightarrow> ps \<subseteq> bl \<Longrightarrow> count {#bl \<in># \<B> . ps \<subseteq> bl#} bl \<ge> n"
  by simp

lemma (in finite_incidence_system) points_index_zero:
  assumes "card ps > card \<V>"
  shows "\<B> index ps = 0"
proof -
  have "\<And> b. b \<in># \<B> \<Longrightarrow> card ps > card b"
    using block_size_lt_order card_subset_not_gt_card finite_sets assms by fastforce
  then have "{#b \<in># \<B> . ps \<subseteq> b#} = {#}"
    by (simp add: card_subset_not_gt_card filter_mset_empty_conv finite_blocks)
  thus ?thesis using points_index_alt_def by simp
qed

lemma (in design) points_index_subset:
    "x \<subseteq># {#bl \<in># \<B> . ps \<subseteq> bl#} \<Longrightarrow> ps \<subseteq> \<V> \<Longrightarrow> (\<B> index ps) \<ge> (size x)"
  by (simp add: points_index_def size_mset_mono)

lemma (in design) points_index_count_min: "multiplicity bl \<ge> n \<Longrightarrow> ps \<subseteq> bl \<Longrightarrow> \<B> index ps \<ge> n"
  using points_index_alt_def set_count_size_min by (metis filter_mset.rep_eq)

subsubsection \<open>Intersection Number\<close>

text \<open> The intersection number of two blocks is the size of the intersection of those blocks. i.e.
the number of points which occur in both blocks \<close>
definition intersection_number :: "'a set \<Rightarrow> 'a set \<Rightarrow> nat" (infix "|\<inter>|" 70) where
"b1 |\<inter>| b2 \<equiv> card (b1 \<inter> b2)"

lemma intersection_num_non_neg: "b1 |\<inter>| b2 \<ge> 0"
  by (simp add: intersection_number_def)

lemma intersection_number_empty_iff:
  assumes "finite b1"
  shows "b1 \<inter> b2 = {} \<longleftrightarrow> b1 |\<inter>| b2 = 0"
  by (simp add: intersection_number_def assms)

lemma intersect_num_commute: "b1 |\<inter>| b2 = b2 |\<inter>| b1"
  by (simp add: inf_commute intersection_number_def)

definition n_intersect_number :: "'a set \<Rightarrow> nat\<Rightarrow> 'a set \<Rightarrow> nat" where
"n_intersect_number b1 n b2 \<equiv> card { x \<in> Pow (b1 \<inter> b2) . card x = n}"

notation n_intersect_number ("(_ |\<inter>|\<^sub>_ _)" [52, 51, 52] 50)

lemma n_intersect_num_subset_def: "b1 |\<inter>|\<^sub>n b2 = card {x . x \<subseteq> b1 \<inter> b2 \<and> card x = n}"
  using n_intersect_number_def by auto

lemma n_inter_num_one: "finite b1 \<Longrightarrow> finite b2 \<Longrightarrow> b1 |\<inter>|\<^sub>1 b2 = b1 |\<inter>| b2"
  using n_intersect_number_def intersection_number_def card_Pow_filter_one
  by (metis (full_types) finite_Int)

lemma n_inter_num_choose: "finite b1 \<Longrightarrow> finite b2 \<Longrightarrow> b1 |\<inter>|\<^sub>n b2 = (card (b1 \<inter> b2) choose n)"
  using n_subsets n_intersect_num_subset_def
  by (metis (full_types) finite_Int)

lemma set_filter_single: "x \<in> A \<Longrightarrow> {a \<in> A . a = x} = {x}"
  by auto

lemma (in design) n_inter_num_zero:
  assumes "b1 \<in># \<B>" and "b2 \<in># \<B>"
  shows "b1 |\<inter>|\<^sub>0 b2 = 1"
proof -
  have empty: "\<And>x . finite x \<Longrightarrow> card x = 0 \<Longrightarrow> x = {}"
    by simp
  have empt_in: "{} \<in> Pow (b1 \<inter> b2)" by simp
  have "finite (b1 \<inter> b2)" using finite_blocks assms by simp
  then have "\<And> x . x \<in> Pow (b1 \<inter> b2) \<Longrightarrow> finite x" by (meson PowD finite_subset)
  then have "{x \<in> Pow (b1 \<inter> b2) . card x = 0} = {x \<in> Pow (b1 \<inter> b2) . x = {}}"
    using empty by (metis card.empty)
  then have "{x \<in> Pow (b1 \<inter> b2) . card x = 0} = {{}}"
    by (simp add: empt_in set_filter_single Collect_conv_if)
  thus ?thesis by (simp add: n_intersect_number_def)
qed

lemma (in design) n_inter_num_choose_design: "b1 \<in># \<B> \<Longrightarrow> b2 \<in># \<B>
    \<Longrightarrow> b1 |\<inter>|\<^sub>n b2 = (card (b1 \<inter> b2) choose n) "
  using finite_blocks by (simp add: n_inter_num_choose)

lemma (in design) n_inter_num_choose_design_inter: "b1 \<in># \<B> \<Longrightarrow> b2 \<in># \<B>
    \<Longrightarrow> b1 |\<inter>|\<^sub>n b2 = (nat (b1 |\<inter>| b2) choose n) "
  using finite_blocks by (simp add: n_inter_num_choose intersection_number_def)

subsection \<open> Incidence System Set Property Definitions \<close>
context incidence_system
begin

text \<open>The set of replication numbers for all points of design\<close>
definition replication_numbers :: "int set" where
"replication_numbers \<equiv> {\<B> rep x | x . x \<in> \<V>}"

lemma replication_numbers_non_empty:
  assumes "\<V> \<noteq> {}"
  shows "replication_numbers \<noteq> {}"
  by (simp add: assms replication_numbers_def)

lemma obtain_point_with_rep: "r \<in> replication_numbers \<Longrightarrow> \<exists> x. x \<in> \<V> \<and> \<B> rep x = r"
  using replication_numbers_def by auto

lemma point_rep_number_in_set: "x \<in> \<V> \<Longrightarrow> (\<B> rep x) \<in> replication_numbers"
  by (auto simp add: replication_numbers_def)

lemma (in finite_incidence_system) replication_numbers_finite: "finite replication_numbers"
  using finite_sets by (simp add: replication_numbers_def)

text \<open>The set of all block sizes in a system\<close>

definition sys_block_sizes :: "nat set" where
"sys_block_sizes \<equiv> { (int (card bl)) | bl. bl \<in># \<B>}"

lemma block_sizes_non_empty_set:
  assumes "\<B> \<noteq> {#}"
  shows "sys_block_sizes \<noteq> {}"
by (simp add: sys_block_sizes_def assms)

lemma finite_block_sizes: "finite (sys_block_sizes)"
  by (simp add: sys_block_sizes_def)

lemma block_sizes_non_empty:
  assumes "\<B> \<noteq> {#}"
  shows "card (sys_block_sizes) > 0"
  using finite_block_sizes block_sizes_non_empty_set
  by (simp add: assms card_gt_0_iff)

lemma sys_block_sizes_in: "bl \<in># \<B> \<Longrightarrow> card bl \<in> sys_block_sizes"
  unfolding sys_block_sizes_def by auto

lemma sys_block_sizes_obtain_bl: "x \<in> sys_block_sizes  \<Longrightarrow> (\<exists> bl \<in># \<B>. card bl = x)"
  by (auto simp add: sys_block_sizes_def)

text \<open>The set of all possible intersection numbers in a system.\<close>

definition intersection_numbers :: "nat set" where
"intersection_numbers \<equiv> { b1 |\<inter>| b2 | b1 b2 . b1 \<in># \<B> \<and> b2 \<in># (\<B> - {#b1#})}"

lemma obtain_blocks_intersect_num: "n \<in> intersection_numbers \<Longrightarrow>
  \<exists> b1 b2. b1 \<in># \<B> \<and> b2 \<in># (\<B> - {#b1#}) \<and>  b1 |\<inter>| b2 = n"
  by (auto simp add: intersection_numbers_def)

lemma intersect_num_in_set: "b1 \<in># \<B> \<Longrightarrow> b2 \<in># (\<B> - {#b1#}) \<Longrightarrow> b1 |\<inter>| b2 \<in> intersection_numbers"
  by (auto simp add: intersection_numbers_def)

text \<open>The set of all possible point indices \<close>
definition point_indices :: "nat \<Rightarrow> nat set" where
"point_indices t \<equiv> {\<B> index ps | ps. card ps = t \<and> ps \<subseteq> \<V>}"

lemma point_indices_elem_in: "ps \<subseteq> \<V> \<Longrightarrow> card ps = t \<Longrightarrow> \<B> index ps \<in> point_indices t"
  by (auto simp add: point_indices_def)

lemma point_indices_alt_def: "point_indices t = { \<B> index ps | ps. card ps = t \<and> ps \<subseteq> \<V>}"
  by (simp add: point_indices_def)

end

subsection \<open>Basic Constructions on designs\<close>

text \<open>This section defines some of the most common universal constructions found in design theory
involving only a single design \<close>

subsubsection \<open>Design Complements \<close>

context incidence_system
begin

text \<open> The complement of a block are all the points in the design not in that block.
The complement of a design is therefore the original point sets, and set of all block complements \<close>
definition block_complement:: "'a set \<Rightarrow> 'a set" ("_\<^sup>c" [56] 55) where
"block_complement b \<equiv> \<V> - b"

definition complement_blocks :: "'a set multiset" ("(\<B>\<^sup>C)")where
"complement_blocks \<equiv> {# bl\<^sup>c . bl \<in># \<B> #}"

lemma block_complement_elem_iff:
  assumes "ps \<subseteq> \<V>"
  shows "ps \<subseteq> bl\<^sup>c \<longleftrightarrow> (\<forall> x \<in> ps. x \<notin> bl)"
  using assms block_complement_def by (auto)

lemma block_complement_inter_empty: "bl1\<^sup>c = bl2 \<Longrightarrow> bl1 \<inter> bl2 = {}"
  using block_complement_def by auto

lemma block_complement_inv:
  assumes "bl \<in># \<B>"
  assumes "bl\<^sup>c = bl2"
  shows "bl2\<^sup>c = bl"
  by (metis Diff_Diff_Int assms(1) assms(2) block_complement_def inf.absorb_iff2 wellformed)

lemma block_complement_subset_points: "ps \<subseteq> (bl\<^sup>c) \<Longrightarrow> ps \<subseteq> \<V>"
  using block_complement_def by blast

lemma obtain_comp_block_orig:
  assumes "bl1 \<in># \<B>\<^sup>C"
  obtains bl2 where "bl2 \<in># \<B>" and "bl1 = bl2\<^sup>c"
  using wellformed assms by (auto simp add: complement_blocks_def)

lemma complement_same_b [simp]: "size \<B>\<^sup>C = size \<B>"
  by (simp add: complement_blocks_def)

lemma block_comp_elem_alt_left: "x \<in> bl \<Longrightarrow> ps \<subseteq> bl\<^sup>c \<Longrightarrow> x \<notin> ps"
  by (auto simp add: block_complement_def block_complement_elem_iff)

lemma block_comp_elem_alt_right: "ps \<subseteq> \<V> \<Longrightarrow> (\<And> x . x \<in> ps \<Longrightarrow> x \<notin> bl) \<Longrightarrow> ps \<subseteq> bl\<^sup>c"
  by (auto simp add: block_complement_elem_iff)

lemma complement_index:
  assumes "ps \<subseteq> \<V>"
  shows "\<B>\<^sup>C index ps = size {# b \<in># \<B> . (\<forall> x \<in> ps . x \<notin> b) #}"
proof -
  have "\<B>\<^sup>C index ps =  size {# b \<in># {# bl\<^sup>c . bl \<in># \<B>#}. ps \<subseteq> b #}"
    by (simp add: complement_blocks_def points_index_def)
  then have "\<B>\<^sup>C index ps = size {# bl\<^sup>c | bl \<in># \<B> . ps \<subseteq> bl\<^sup>c #}"
    by (metis image_mset_filter_swap)
  thus ?thesis using assms by (simp add: block_complement_elem_iff)
qed

lemma complement_index_2:
  assumes "{x, y} \<subseteq> \<V>"
  shows "\<B>\<^sup>C index {x, y} = size {# b \<in># \<B> . x \<notin> b \<and> y \<notin> b #}"
proof -
  have a: "\<And> b. b \<in># \<B> \<Longrightarrow> \<forall> x' \<in> {x, y} . x' \<notin> b \<Longrightarrow> x \<notin> b \<and> y \<notin> b"
    by simp
  have "\<And> b. b \<in># \<B> \<Longrightarrow> x \<notin> b \<and> y \<notin> b \<Longrightarrow> \<forall> x' \<in> {x, y} . x' \<notin> b "
    by simp
  thus ?thesis using assms a complement_index
    by (smt (verit) filter_mset_cong)
qed

lemma complement_rep_number:
  assumes "x \<in> \<V>" and "\<B> rep x = r"
  shows  "\<B>\<^sup>C rep x = \<b> - r"
proof -
  have r: "size {#b \<in># \<B> . x \<in> b#} = r" using assms by (simp add: point_replication_number_def)
  then have a: "\<And> b . b \<in># \<B> \<Longrightarrow> x \<in> b \<Longrightarrow> x \<notin> b\<^sup>c"
    by (simp add: block_complement_def)
  have "\<And> b . b \<in># \<B> \<Longrightarrow> x \<notin> b \<Longrightarrow> x \<in> b\<^sup>c"
    by (simp add: assms(1) block_complement_def)
  then have alt: "(image_mset block_complement \<B>) rep x = size {#b \<in># \<B> . x \<notin> b#}"
    using a filter_mset_cong image_mset_filter_swap2 point_replication_number_def
    by (smt (verit, ccfv_SIG) size_image_mset)
  have "\<b> = size {#b \<in># \<B> . x \<in> b#} + size {#b \<in># \<B> . x \<notin> b#}"
    by (metis multiset_partition size_union)
  thus ?thesis using alt
    by (simp add: r complement_blocks_def)
qed

lemma complement_blocks_wf: "bl \<in># \<B>\<^sup>C \<Longrightarrow> bl \<subseteq> \<V>"
  by (auto simp add: complement_blocks_def block_complement_def)

lemma complement_wf [intro]: "incidence_system \<V> \<B>\<^sup>C"
  using complement_blocks_wf by (unfold_locales)

interpretation sys_complement: incidence_system "\<V>" "\<B>\<^sup>C"
  using complement_wf by simp
end

context finite_incidence_system
begin
lemma block_complement_size: "b \<subseteq> \<V> \<Longrightarrow> card (b\<^sup>c) = card \<V> - card b"
  by (simp add: block_complement_def card_Diff_subset finite_subset card_mono of_nat_diff finite_sets)

lemma block_comp_incomplete: "incomplete_block bl \<Longrightarrow> card (bl\<^sup>c) > 0"
  using block_complement_size by (simp add: wellformed)

lemma  block_comp_incomplete_nempty: "incomplete_block bl \<Longrightarrow> bl\<^sup>c \<noteq> {}"
  using wellformed block_complement_def finite_blocks
  by (auto simp add: block_complement_size block_comp_incomplete card_subset_not_gt_card)

lemma incomplete_block_proper_subset: "incomplete_block bl \<Longrightarrow> bl \<subset> \<V>"
  using wellformed by fastforce

lemma complement_finite: "finite_incidence_system \<V> \<B>\<^sup>C"
  using complement_wf finite_sets by (simp add: incidence_system.finite_sysI)

interpretation comp_fin: finite_incidence_system \<V> "\<B>\<^sup>C"
  using complement_finite by simp

end

context design
begin
lemma (in design) complement_design:
  assumes "\<And> bl . bl \<in># \<B> \<Longrightarrow> incomplete_block bl"
  shows "design \<V> (\<B>\<^sup>C)"
proof -
  interpret fin: finite_incidence_system \<V> "\<B>\<^sup>C" using complement_finite by simp
  show ?thesis using assms block_comp_incomplete_nempty wellformed
    by (unfold_locales) (auto simp add: complement_blocks_def)
qed

end
subsubsection \<open>Multiples\<close>
text \<open>An easy way to construct new set systems is to simply multiply the block collection by some
constant \<close>

context incidence_system
begin

abbreviation multiple_blocks :: "nat \<Rightarrow> 'a set multiset" where
"multiple_blocks n \<equiv> repeat_mset n \<B>"

lemma multiple_block_in_original: "b \<in># multiple_blocks n \<Longrightarrow> b \<in># \<B>"
  by (simp add: elem_in_repeat_in_original)

lemma multiple_block_in: "n > 0 \<Longrightarrow> b \<in># \<B> \<Longrightarrow>  b \<in># multiple_blocks n"
  by (simp add: elem_in_original_in_repeat)

lemma multiple_blocks_gt: "n > 0 \<Longrightarrow> size (multiple_blocks n) \<ge> size \<B>"
  by (simp)

lemma block_original_count_le: "n > 0 \<Longrightarrow> count \<B> b \<le> count (multiple_blocks n) b"
  using count_repeat_mset by simp

lemma multiple_blocks_sub: "n > 0 \<Longrightarrow> \<B> \<subseteq># (multiple_blocks n)"
  by (simp add: mset_subset_eqI block_original_count_le)

lemma multiple_1_same: "multiple_blocks 1 = \<B>"
  by simp

lemma multiple_unfold_1: "multiple_blocks (Suc n) = (multiple_blocks n) + \<B>"
  by simp

lemma multiple_point_rep_num: "(multiple_blocks n) rep x = (\<B> rep x) * n"
proof (induction n)
  case 0
  then show ?case by (simp add: point_replication_number_def)
next
  case (Suc n)
  then have "multiple_blocks (Suc n) rep x = \<B> rep x * n + (\<B> rep x)"
    using Suc.IH Suc.prems by (simp add: union_commute point_replication_number_def)
  then show ?case by simp
qed

lemma multiple_point_index: "(multiple_blocks n) index ps = (\<B> index ps) * n"
  by (induction n) (auto simp add: points_index_def)

lemma repeat_mset_block_point_rel: "\<And>b x. b \<in># multiple_blocks  n \<Longrightarrow> x \<in> b \<Longrightarrow> x \<in> \<V>"
  by (induction n) (auto, meson subset_iff wellformed)

lemma multiple_is_wellformed: "incidence_system \<V> (multiple_blocks n)"
  using repeat_mset_subset_in wellformed repeat_mset_block_point_rel by (unfold_locales) (auto)

lemma  multiple_blocks_num [simp]: "size (multiple_blocks n) = n*\<b>"
  by simp

interpretation mult_sys: incidence_system \<V> "(multiple_blocks n)"
  by (simp add: multiple_is_wellformed)

lemma multiple_block_multiplicity [simp]: "mult_sys.multiplicity n bl = (multiplicity bl) * n"
  by (simp)

lemma multiple_block_sizes_same:
  assumes "n > 0"
  shows "sys_block_sizes = mult_sys.sys_block_sizes n"
proof -
  have def: "mult_sys.sys_block_sizes n = {card bl | bl. bl \<in># (multiple_blocks n)}"
    by (simp add: mult_sys.sys_block_sizes_def)
  then have eq: "\<And> bl. bl \<in># (multiple_blocks n) \<longleftrightarrow> bl \<in># \<B>"
    using assms multiple_block_in multiple_block_in_original by blast
  thus ?thesis using def by (simp add: sys_block_sizes_def eq)
qed

end

context finite_incidence_system
begin

lemma multiple_is_finite: "finite_incidence_system \<V> (multiple_blocks n)"
  using multiple_is_wellformed finite_sets by (unfold_locales) (auto simp add: incidence_system_def)

end

context design
begin

lemma multiple_is_design: "design \<V> (multiple_blocks n)"
proof -
  interpret fis: finite_incidence_system \<V> "multiple_blocks n" using multiple_is_finite by simp
  show ?thesis using blocks_nempty
    by (unfold_locales) (auto simp add: elem_in_repeat_in_original repeat_mset_not_empty)
qed

end

subsection \<open> Simple Designs \<close>

text \<open> Simple designs are those in which the multiplicity of each block is at most one.
In other words, the block collection is a set. This can significantly ease reasoning. \<close>

locale simple_incidence_system = incidence_system +
  assumes simple [simp]: "bl \<in># \<B> \<Longrightarrow> multiplicity bl = 1"

begin

lemma simple_alt_def_all: "\<forall> bl \<in># \<B> . multiplicity bl = 1"
  using simple by auto

lemma simple_blocks_eq_sup: "mset_set (design_support) = \<B>"
  using distinct_mset_def simple design_support_def by (metis distinct_mset_set_mset_ident)

lemma simple_block_size_eq_card: "\<b> = card (design_support)"
  by (metis simple_blocks_eq_sup size_mset_set)

lemma points_index_simple_def: "\<B> index ps = card {b \<in> design_support . ps \<subseteq> b}"
  using design_support_def points_index_def card_size_filter_eq simple_blocks_eq_sup
  by (metis finite_set_mset)

lemma replication_num_simple_def: "\<B> rep x = card {b \<in> design_support . x \<in> b}"
  using design_support_def point_replication_number_def card_size_filter_eq simple_blocks_eq_sup
  by (metis finite_set_mset)

end

locale simple_design = design + simple_incidence_system

text \<open>Additional reasoning about when something is not simple \<close>
context incidence_system
begin
lemma simple_not_multiplicity: "b \<in># \<B> \<Longrightarrow> multiplicity  b > 1 \<Longrightarrow> \<not> simple_incidence_system \<V> \<B>"
  using simple_incidence_system_def simple_incidence_system_axioms_def by (metis nat_neq_iff)

lemma multiple_not_simple:
  assumes "n > 1"
  assumes "\<B> \<noteq> {#}"
  shows "\<not> simple_incidence_system \<V> (multiple_blocks n)"
proof (rule ccontr, simp)
  assume "simple_incidence_system \<V> (multiple_blocks n)"
  then have "\<And> bl. bl \<in># \<B> \<Longrightarrow> count (multiple_blocks n) bl = 1"
    using assms(1) elem_in_original_in_repeat
    by (metis not_gr_zero not_less_zero simple_incidence_system.simple)
  thus False using assms by auto
qed

end

subsection \<open>Proper Designs\<close>
text \<open>Many types of designs rely on parameter conditions that only make sense for non-empty designs.
i.e. designs with at least one block, and therefore given well-formed condition, at least one point.
To this end we define the notion of a "proper" design \<close>

locale proper_design = design +
  assumes b_non_zero: "\<b> \<noteq> 0"
begin

lemma is_proper: "proper_design \<V> \<B>" by intro_locales

lemma v_non_zero: "\<v> > 0"
  using b_non_zero v_eq0_imp_b_eq_0 by auto

lemma b_positive: "\<b> > 0" using b_non_zero
  by (simp add: nonempty_has_size)

lemma design_points_nempty: "\<V> \<noteq> {}"
  using v_non_zero by auto

lemma design_blocks_nempty: "\<B> \<noteq> {#}"
  using b_non_zero by auto

end

text \<open> Intro rules for a proper design \<close>
lemma (in design) proper_designI[intro]: "\<b> \<noteq> 0 \<Longrightarrow> proper_design \<V> \<B>"
  by (unfold_locales) simp

lemma proper_designII[intro]:
  assumes "design V B" and "B \<noteq> {#}"
  shows "proper_design V B"
proof -
  interpret des: design V B using assms by simp
  show ?thesis using assms by unfold_locales simp
qed

text \<open>Reasoning on construction closure for proper designs\<close>
context proper_design
begin

lemma multiple_proper_design:
  assumes "n > 0"
  shows "proper_design \<V> (multiple_blocks n)"
  using multiple_is_design assms design_blocks_nempty multiple_block_in
  by (metis block_set_nempty_imp_block_ex empty_iff proper_designII set_mset_empty)

lemma complement_proper_design:
  assumes "\<And> bl . bl \<in># \<B> \<Longrightarrow> incomplete_block bl"
  shows "proper_design \<V> \<B>\<^sup>C"
proof -
  interpret des: design \<V> "\<B>\<^sup>C"
    by (simp add: assms complement_design)
  show ?thesis using b_non_zero by (unfold_locales) auto
qed

end
end


(*
  File:    Eulerian_Polynomials.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Eulerian polynomials\<close>
theory Eulerian_Polynomials
imports
  Complex_Main
  "HOL-Computational_Algebra.Computational_Algebra"
  "HOL-Library.Stirling"
begin

text \<open>
  The Eulerian polynomials are a sequence of polynomials that is related to
  the closed forms of the power series
  \[\sum_{n=0}^\infty n^k X^n\]
  for a fixed $k$.
\<close>
primrec eulerian_poly :: "nat \<Rightarrow> 'a :: idom poly" where
  "eulerian_poly 0 = 1"
| "eulerian_poly (Suc n) = (let p = eulerian_poly n in
     [:0,1,-1:] * pderiv p + p * [:1, of_nat n:])"

lemmas eulerian_poly_Suc [simp del] = eulerian_poly.simps(2)

lemma eulerian_poly:
  "fps_of_poly (eulerian_poly k :: 'a :: field poly) =
     Abs_fps (\<lambda>n. of_nat (n+1) ^ k) * (1 - fps_X) ^ (k + 1)"
proof (induction k)
  case 0
  have "Abs_fps (\<lambda>_. 1 :: 'a) = inverse (1 - fps_X)"
    by (rule fps_inverse_unique [symmetric])
       (simp add: inverse_mult_eq_1 fps_inverse_gp' [symmetric])
  thus ?case by (simp add: inverse_mult_eq_1)
next
  case (Suc k)
  define p :: "'a fps" where "p = fps_of_poly (eulerian_poly k)"
  define F :: "'a fps" where "F = Abs_fps (\<lambda>n. of_nat (n+1) ^ k)"

  have p: "p = F * (1 - fps_X) ^ (k+1)" by (simp add: p_def Suc F_def)
  have p': "fps_deriv p = fps_deriv F * (1 - fps_X) ^ (k + 1) - F * (1 - fps_X) ^ k * of_nat (k + 1)"
    by (simp add: p fps_deriv_power algebra_simps fps_const_neg [symmetric] fps_of_nat
             del: power_Suc of_nat_Suc fps_const_neg)

  have "fps_of_poly (eulerian_poly (Suc k)) = (fps_X * fps_deriv F + F) * (1 - fps_X) ^ (Suc k + 1)"
    apply (simp add: Let_def p_def [symmetric] fps_of_poly_simps eulerian_poly_Suc del: power_Suc)
    apply (simp add: p p' fps_deriv_power fps_const_neg [symmetric] fps_of_nat
                del: power_Suc of_nat_Suc fps_const_neg)
    apply (simp add: algebra_simps)
    done
  also have "fps_X * fps_deriv F + F = Abs_fps (\<lambda>n. of_nat (n + 1) ^ Suc k)"
    unfolding F_def by (intro fps_ext) (auto simp: algebra_simps)
  finally show ?case .
qed

lemma eulerian_poly':
  "Abs_fps (\<lambda>n. of_nat (n+1) ^ k) =
     fps_of_poly (eulerian_poly k :: 'a :: field poly) / (1 - fps_X) ^ (k + 1)"
  by (subst eulerian_poly) simp

lemma eulerian_poly'':
  assumes k: "k > 0"
  shows "Abs_fps (\<lambda>n. of_nat n ^ k) =
           fps_of_poly (pCons 0 (eulerian_poly k :: 'a :: field poly)) / (1 - fps_X) ^ (k + 1)"
proof -
  from assms have "Abs_fps (\<lambda>n. of_nat n ^ k :: 'a) = fps_X * Abs_fps (\<lambda>n. of_nat (n + 1) ^ k)"
    by (intro fps_ext) (auto simp: of_nat_diff)
  also have "Abs_fps (\<lambda>n. of_nat (n + 1) ^ k :: 'a) =
               fps_of_poly (eulerian_poly k) / (1 - fps_X) ^ (k + 1)" by (rule eulerian_poly')
  also have "fps_X * \<dots> = fps_of_poly (pCons 0 (eulerian_poly k)) / (1 - fps_X) ^ (k + 1)"
    by (simp add: fps_of_poly_pCons fps_divide_unit)
  finally show ?thesis .
qed

definition fps_monom_poly :: "'a :: field \<Rightarrow> nat \<Rightarrow> 'a poly"
  where "fps_monom_poly c k = (if k = 0 then 1 else pcompose (pCons 0 (eulerian_poly k)) [:0,c:])"

primrec fps_monom_poly_aux :: "'a :: field \<Rightarrow> nat \<Rightarrow> 'a poly" where
  "fps_monom_poly_aux c 0 = [:c:]"
| "fps_monom_poly_aux c (Suc k) =
      (let p = fps_monom_poly_aux c k
       in  [:0,1,-c:] * pderiv p + [:1, of_nat k * c:] * p)"

lemma fps_monom_poly_aux:
  "fps_monom_poly_aux c k = smult c (pcompose (eulerian_poly k) [:0,c:])"
  by (induction k)
     (simp_all add: eulerian_poly_Suc Let_def pderiv_pcompose pcompose_pCons
                    pcompose_add pcompose_smult pcompose_uminus smult_add_right pderiv_pCons
                    pderiv_smult algebra_simps one_pCons)

lemma fps_monom_poly_code [code]:
  "fps_monom_poly c k = (if k = 0 then 1 else pCons 0 (fps_monom_poly_aux c k))"
  by (simp add: fps_monom_poly_def fps_monom_poly_aux pcompose_pCons)

lemma fps_monom_aux:
  "Abs_fps (\<lambda>n. of_nat n ^ k) = fps_of_poly (fps_monom_poly 1 k) / (1 - fps_X) ^ (k+1)"
proof (cases "k = 0")
  assume [simp]: "k = 0"
  hence "Abs_fps (\<lambda>n. of_nat n ^ k :: 'a) = Abs_fps (\<lambda>_. 1)" by simp
  also have "\<dots> = 1 / (1 - fps_X)" by (subst gp [symmetric]) simp_all
  finally show ?thesis by (simp add: fps_monom_poly_def)
qed (insert eulerian_poly''[of k, where ?'a = 'a], simp add: fps_monom_poly_def)

lemma fps_monom:
  "Abs_fps (\<lambda>n. of_nat n ^ k * c ^ n) =
      fps_of_poly (fps_monom_poly c k) / (1 - fps_const c * fps_X) ^ (k+1)"
proof -
  have "Abs_fps (\<lambda>n. of_nat n ^ k * c ^ n) =
          fps_compose (Abs_fps (\<lambda>n. of_nat n ^ k)) (fps_const c * fps_X)"
    by (subst fps_compose_linear) (simp add: mult_ac)
  also have "Abs_fps (\<lambda>n. of_nat n ^ k) = fps_of_poly (fps_monom_poly 1 k) / (1 - fps_X) ^ (k+1)"
    by (rule fps_monom_aux)
  also have "fps_compose \<dots> (fps_const c * fps_X) =
                 (fps_of_poly (fps_monom_poly 1 k) oo fps_const c * fps_X) /
                 ((1 - fps_X) ^ (k + 1) oo fps_const c * fps_X)"
    by (intro fps_compose_divide_distrib)
       (simp_all add: fps_compose_power [symmetric] fps_compose_sub_distrib del: power_Suc)
  also have "fps_of_poly (fps_monom_poly 1 k) oo (fps_const c * fps_X) =
                fps_of_poly (fps_monom_poly c k)"
    by (simp add: fps_monom_poly_def fps_of_poly_pcompose fps_of_poly_simps
                  fps_of_poly_pCons mult_ac)
  also have "((1 - fps_X) ^ (k + 1) oo fps_const c * fps_X) = (1 - fps_const c * fps_X) ^ (k + 1)"
    by (simp add: fps_compose_power [symmetric] fps_compose_sub_distrib del: power_Suc)
  finally show ?thesis .
qed

end


section {* Alternative list lexicographic order *}

theory List_lexord_alt
  imports "~~/src/HOL/Library/Char_ord"
begin

text {* Since we can't instantiate the order class twice for lists, and we want prefix as
  the default order for the UTP we here add syntax for the lexicographic order relation. *}

definition list_lex_less :: "'a::linorder list \<Rightarrow> 'a list \<Rightarrow> bool" (infix "<\<^sub>l" 50)
where "xs <\<^sub>l ys \<longleftrightarrow> (xs, ys) \<in> lexord {(u, v). u < v}"

lemma list_lex_less_neq [simp]: "x <\<^sub>l y \<Longrightarrow> x \<noteq> y"
  apply (simp add: list_lex_less_def)
  apply (meson case_prodD less_irrefl lexord_irreflexive mem_Collect_eq)
done

lemma not_less_Nil [simp]: "\<not> x <\<^sub>l []"
  by (simp add: list_lex_less_def)

lemma Nil_less_Cons [simp]: "[] <\<^sub>l a # x"
  by (simp add: list_lex_less_def)

lemma Cons_less_Cons [simp]: "a # x <\<^sub>l b # y \<longleftrightarrow> a < b \<or> a = b \<and> x <\<^sub>l y"
  by (simp add: list_lex_less_def)
end


theory Chapter16_1_Type
imports DeBruijnEnvironment
begin

datatype type =
  Tyvar var
| Arrow type type
| Unit
| Prod type type
| Void
| Sum type type
| Rec type

primrec type_insert :: "var => type => type"
where "type_insert n (Tyvar v) = Tyvar (incr n v)"
    | "type_insert n (Arrow t1 t2) = Arrow (type_insert n t1) (type_insert n t2)"
    | "type_insert n Unit = Unit"
    | "type_insert n (Prod t1 t2) = Prod (type_insert n t1) (type_insert n t2)"
    | "type_insert n Void = Void"
    | "type_insert n (Sum t1 t2) = Sum (type_insert n t1) (type_insert n t2)"
    | "type_insert n (Rec t) = Rec (type_insert (next n) t)"

primrec type_subst :: "type => var => type => type"
where "type_subst e' n (Tyvar v) = (if v = n then e' else Tyvar (subr n v))"
    | "type_subst e' n (Arrow t1 t2) = Arrow (type_subst e' n t1) (type_subst e' n t2)"
    | "type_subst e' n Unit = Unit"
    | "type_subst e' n (Prod t1 t2) = Prod (type_subst e' n t1) (type_subst e' n t2)"
    | "type_subst e' n Void = Void"
    | "type_subst e' n (Sum t1 t2) = Sum (type_subst e' n t1) (type_subst e' n t2)"
    | "type_subst e' n (Rec t) = Rec (type_subst (type_insert first e') (next n) t)"

end


theory AExp
imports Main
begin

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

datatype aexp =
  N int |
  V vname |
  Plus aexp aexp |
  Times aexp aexp

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"

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"

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 rule: plus.induct )
  apply ( auto )
done

fun times :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "times ( N n1 ) ( N n2 ) = N ( n1 * n2 )" |
  "times ( N n ) a =
    ( if
        n = 0 then N 0 else ( if
        n = 1 then a
        else Times ( N n ) a ) )" |
  "times a ( N n ) =
    ( if
        n = 0 then N 0 else ( if
        n = 1 then a
        else Times a ( N n ) ) )" |
  "times a1 a2 = Times a1 a2"

lemma "aval_times" : "aval ( times a1 a2 ) s = aval a1 s * aval a2 s"
  apply ( induction 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 )"

value "asimp ( Times ( Times (N 3) (V x) ) (Plus (N (-1)) (N 21)) )"

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

fun optimal :: "aexp \<Rightarrow> bool" where
  "optimal ( N n ) = True" |
  "optimal ( V x ) = True" |
  "optimal ( Plus ( N i ) ( N j ) ) = False" |
  "optimal ( Plus a1 a2 ) = ( optimal a1 \<and> optimal a2 )" |
  "optimal ( Times ( N i ) ( N j ) ) = False" |
  "optimal ( Times ( N n ) _ ) = ( n \<noteq> 0 \<and> n \<noteq> 1 )" |
  "optimal ( Times _ ( N n ) ) = ( n \<noteq> 0 \<and> n \<noteq> 1 )" |
  "optimal ( Times a1 a2 ) = ( optimal a1 \<and> optimal a2 )"

lemma "optimal_plus" : "optimal a1 \<Longrightarrow> optimal a2 \<Longrightarrow> optimal (plus a1 a2)"
  apply ( induction a1 a2 rule: plus.induct )
  apply ( auto )
done

lemma "optimal_times" : "optimal a1 \<Longrightarrow> optimal a2 \<Longrightarrow> optimal (times a1 a2)"
  apply ( induction a1 a2 rule: times.induct )
  apply ( auto )
done

lemma "optimal ( asimp a )"
  apply ( induction a )
  apply ( auto simp add: optimal_plus optimal_times )
done

end


theory Exercise5p3
imports Main
begin

inductive ev :: "nat \<Rightarrow> bool" where
    ev0:  "ev 0"
  | evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

(* Exercise 5.3 *)
lemma
  assumes a: "ev (Suc (Suc n))"
  shows "ev n"
proof -
  show ?thesis using a
  proof cases
    case evSS
    thus ?thesis by auto
  qed
qed

end