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 ([\<open>hessenberg_theorem\<close>]): Pappus's property implies Desargues's
property in a projective plane.
\<close>

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

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 blast
  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 blast
  have f6:"B' \<noteq> R"
    using assms desargues_config_def distinct7_def
    by blast
  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 distinct3l_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 distinct3l_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 distinct3l_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 (metis assms col_ABA col_line_eq_1 col_rot_CW desargues_config_def desargues_config_not_col_3
      desargues_config_not_col_7 distinct3l_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:"distinct6 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:"distinct6 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)
            ax_uniqueness col_rot_CW desargues_config_def f3 incidA_lAB incidB_lAB incid_inter_left
            is_a_intersec_def meet_col_2 meet_comm 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 ::
  "[Points, Points, Points, Points, Points, Points] \<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:"distinct6 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>distinct6 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:"distinct6 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>distinct6 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>distinct6 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 T_def assms(2) col_def desargues_config_def desargues_config_not_col_1
          desargues_config_not_col_9 incidB_lAB incid_C_AB incid_inter_left line_comm meet_in_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 (metis \<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 triangle_circumscribes_triangle_def uniq_inter)
    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:"distinct7 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:"distinct3l (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


(*  Title:      HOL/Quickcheck_Examples/Quickcheck_Narrowing_Examples.thy
    Author:     Lukas Bulwahn
    Copyright   2011 TU Muenchen
*)

section \<open>Examples for narrowing-based testing\<close>

theory Quickcheck_Narrowing_Examples
imports Main
begin

declare [[quickcheck_timeout = 3600]]

subsection \<open>Minimalistic examples\<close>

lemma
  "x = y"
quickcheck[tester = narrowing, finite_types = false, default_type = int, expect = counterexample]
oops

lemma
  "x = y"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, expect = counterexample]
oops

subsection \<open>Simple examples with existentials\<close>

lemma
  "\<exists> y :: nat. \<forall> x. x = y"
quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops
(*
lemma
  "\<exists> y :: int. \<forall> x. x = y"
quickcheck[tester = narrowing, size = 2]
oops
*)
lemma
  "x > 1 --> (\<exists>y :: nat. x < y & y <= 1)"
quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

lemma
  "x > 2 \<longrightarrow> (\<exists>y :: nat. x < y \<and> y \<le> 2)"
quickcheck[tester = narrowing, finite_types = false, size = 10]
oops

lemma
  "\<forall>x. \<exists>y :: nat. x > 3 \<longrightarrow> (y < x \<and> y > 3)"
quickcheck[tester = narrowing, finite_types = false, size = 7]
oops

text \<open>A false conjecture derived from an partial copy-n-paste of @{thm not_distinct_decomp}\<close>
lemma
  "\<not> distinct ws \<Longrightarrow> \<exists>xs ys zs y. ws = xs @ [y] @ ys @ [y]"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, expect = counterexample]
oops

text \<open>A false conjecture derived from theorems @{thm split_list_first} and @{thm split_list_last}\<close>
lemma
  "x \<in> set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set zs \<and> x \<notin> set ys"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, expect = counterexample]
oops

text \<open>A false conjecture derived from @{thm map_eq_Cons_conv} with a typo\<close>
lemma
  "(map f xs = y # ys) = (\<exists>z zs. xs = z' # zs & f z = y \<and> map f zs = ys)"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, expect = counterexample]
oops

lemma "a # xs = ys @ [a] \<Longrightarrow> \<exists>zs. xs = zs @ [a] \<and> ys = a#zs"
quickcheck[narrowing, expect = counterexample]
quickcheck[exhaustive, random, expect = no_counterexample]
oops

subsection \<open>Simple list examples\<close>

lemma "rev xs = xs"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, expect = counterexample]
oops

lemma "rev xs = xs"
quickcheck[tester = narrowing, finite_types = false, default_type = int, expect = counterexample]
oops

lemma "rev xs = xs"
  quickcheck[tester = narrowing, finite_types = true, expect = counterexample]
oops

subsection \<open>Simple examples with functions\<close>

lemma "map f xs = map g xs"
  quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

lemma "map f xs = map f ys ==> xs = ys"
  quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

lemma
  "list_all2 P (rev xs) (rev ys) = list_all2 P xs (rev ys)"
  quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

lemma "map f xs = F f xs"
  quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

lemma "map f xs = F f xs"
  quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

(* requires some work...*)
(*
lemma "R O S = S O R"
  quickcheck[tester = narrowing, size = 2]
oops
*)

subsection \<open>Simple examples with inductive predicates\<close>

inductive even where
  "even 0" |
  "even n ==> even (Suc (Suc n))"

code_pred even .

lemma "even (n - 2) ==> even n"
quickcheck[narrowing, expect = counterexample]
oops

subsection \<open>AVL Trees\<close>

datatype 'a tree = ET |  MKT 'a "'a tree" "'a tree" nat

primrec set_of :: "'a tree \<Rightarrow> 'a set"
where
"set_of ET = {}" |
"set_of (MKT n l r h) = insert n (set_of l \<union> set_of r)"

primrec height :: "'a tree \<Rightarrow> nat"
where
"height ET = 0" |
"height (MKT x l r h) = max (height l) (height r) + 1"

primrec avl :: "'a tree \<Rightarrow> bool"
where
"avl ET = True" |
"avl (MKT x l r h) =
 ((height l = height r \<or> height l = 1+height r \<or> height r = 1+height l) \<and>
  h = max (height l) (height r) + 1 \<and> avl l \<and> avl r)"

primrec is_ord :: "('a::order) tree \<Rightarrow> bool"
where
"is_ord ET = True" |
"is_ord (MKT n l r h) =
 ((\<forall>n' \<in> set_of l. n' < n) \<and> (\<forall>n' \<in> set_of r. n < n') \<and> is_ord l \<and> is_ord r)"

primrec is_in :: "('a::order) \<Rightarrow> 'a tree \<Rightarrow> bool"
where
 "is_in k ET = False" |
 "is_in k (MKT n l r h) = (if k = n then True else
                           if k < n then (is_in k l)
                           else (is_in k r))"

primrec ht :: "'a tree \<Rightarrow> nat"
where
"ht ET = 0" |
"ht (MKT x l r h) = h"

definition
 mkt :: "'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"mkt x l r = MKT x l r (max (ht l) (ht r) + 1)"

(* replaced MKT lrn lrl lrr by MKT lrr lrl *)
fun l_bal where
"l_bal(n, MKT ln ll lr h, r) =
 (if ht ll < ht lr
  then case lr of ET \<Rightarrow> ET \<comment> \<open>impossible\<close>
                | MKT lrn lrr lrl lrh \<Rightarrow>
                  mkt lrn (mkt ln ll lrl) (mkt n lrr r)
  else mkt ln ll (mkt n lr r))"

fun r_bal where
"r_bal(n, l, MKT rn rl rr h) =
 (if ht rl > ht rr
  then case rl of ET \<Rightarrow> ET \<comment> \<open>impossible\<close>
                | MKT rln rll rlr h \<Rightarrow> mkt rln (mkt n l rll) (mkt rn rlr rr)
  else mkt rn (mkt n l rl) rr)"

primrec insrt :: "'a::order \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
where
"insrt x ET = MKT x ET ET 1" |
"insrt x (MKT n l r h) =
   (if x=n
    then MKT n l r h
    else if x<n
         then let l' = insrt x l; hl' = ht l'; hr = ht r
              in if hl' = 2+hr then l_bal(n,l',r)
                 else MKT n l' r (1 + max hl' hr)
         else let r' = insrt x r; hl = ht l; hr' = ht r'
              in if hr' = 2+hl then r_bal(n,l,r')
                 else MKT n l r' (1 + max hl hr'))"

subsubsection \<open>Necessary setup for code generation\<close>

primrec set_of'
where
  "set_of' ET = []"
| "set_of' (MKT n l r h) = n # (set_of' l @ set_of' r)"

lemma set_of':
  "set (set_of' t) = set_of t"
by (induct t) auto

lemma is_ord_mkt:
  "is_ord (MKT n l r h) = ((\<forall>n' \<in> set (set_of' l). n' < n) \<and> (\<forall>n' \<in> set (set_of' r). n < n') \<and> is_ord l \<and> is_ord r)"
by (simp add: set_of')

declare is_ord.simps(1)[code] is_ord_mkt[code]

subsubsection \<open>Invalid Lemma due to typo in \<^const>\<open>l_bal\<close>\<close>

lemma is_ord_l_bal:
 "\<lbrakk> is_ord(MKT (x :: nat) l r h); height l = height r + 2 \<rbrakk> \<Longrightarrow> is_ord(l_bal(x,l,r))"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, size = 6, expect = counterexample]
oops

subsection \<open>Examples with hd and last\<close>

lemma
  "hd (xs @ ys) = hd ys"
quickcheck[narrowing, expect = counterexample]
oops

lemma
  "last(xs @ ys) = last xs"
quickcheck[narrowing, expect = counterexample]
oops

subsection \<open>Examples with underspecified/partial functions\<close>

lemma
  "xs = [] ==> hd xs \<noteq> x"
quickcheck[narrowing, expect = no_counterexample]
oops

lemma
  "xs = [] ==> hd xs = x"
quickcheck[narrowing, expect = no_counterexample]
oops

lemma "xs = [] ==> hd xs = x ==> x = y"
quickcheck[narrowing, expect = no_counterexample]
oops

lemma
  "hd (xs @ ys) = (if xs = [] then hd ys else hd xs)"
quickcheck[narrowing, expect = no_counterexample]
oops

lemma
  "hd (map f xs) = f (hd xs)"
quickcheck[narrowing, expect = no_counterexample]
oops

end


subsection \<open>Defensive strategies\<close>

text \<open> A strategy is defensive if a player can avoid reaching winning positions.
       If the opponent is not already in a winning position, such defensive strategies exist.
       In closed games, a defensive strategy is winning for the closed player,
       so these strategies are a crucial step towards proving that such games are determined.
        \<close>
theory GaleStewartDefensiveStrategies
  imports GaleStewartGames
begin

context GSgame
begin

definition move_defensive_by_Even where
  "move_defensive_by_Even m p \<equiv> even (length p) \<longrightarrow> \<not> winning_position_Odd (p @ [m])"
definition move_defensive_by_Odd where
  "move_defensive_by_Odd m p  \<equiv> odd (length p) \<longrightarrow> \<not> winning_position_Even (p @ [m])"

(* This was a tricky part of the proof, it required explicit use of the choice theorem *)
lemma defensive_move_exists_for_Even:
assumes [intro]:"position p"
shows "winning_position_Odd p \<or> (\<exists> m. move_defensive_by_Even m p)" (is "?w \<or> ?d")
proof(cases "length p = 2*N \<or> odd (length p)")
  case False
  hence pl[intro]:"length p < 2*N"
    and ev[intro]:"even (length p)" using assms[unfolded position_def] by auto
  show ?thesis proof(rule impI[of "\<not> ?d \<longrightarrow> \<not> ?w \<longrightarrow> False", rule_format], force)
    assume not_def:"\<not> ?d"
    from not_def[unfolded move_defensive_by_Even_def]
    have "\<forall> m. \<exists>\<sigma>. strategy_winning_by_Odd \<sigma> (p @ [m])" by blast
    from choice[OF this] obtain \<sigma>\<^sub>o where
      str_Odd:"\<And> m. strategy_winning_by_Odd (\<sigma>\<^sub>o m) (p @ [m])" by blast
    define \<sigma> where "\<sigma> p' = \<sigma>\<^sub>o (p' ! length p) p'" for p'
    assume not_win:"\<not> ?w"
    from not_win[unfolded move_defensive_by_Even_def strategy_winning_by_Odd_def]
    obtain \<sigma>\<^sub>e where
      str_Even:"induced_play (joint_strategy \<sigma>\<^sub>e \<sigma>) p \<in> A"
      (is "?pe p \<in> A")
           by blast
    let ?pnext = "(p @ [joint_strategy \<sigma>\<^sub>e \<sigma> p])"
    { fix p' m
      assume "prefix (p @ [m]) p'"
      hence "(p' ! length p) = m"
        unfolding prefix_def by auto
    }
    hence eq_a:"\<forall> p'. prefix ?pnext p' \<longrightarrow> p' @ [joint_strategy \<sigma>\<^sub>e \<sigma> p'] =
                                    p' @ [joint_strategy \<sigma>\<^sub>e (\<sigma>\<^sub>o (joint_strategy \<sigma>\<^sub>e \<sigma> p)) p']"
      unfolding joint_strategy_def \<sigma>_def by auto
    have simps:"?pe p = ?pe (p @ [joint_strategy \<sigma>\<^sub>e \<sigma> p])"
      unfolding induced_play_def by auto
    from str_Even str_Odd[of "joint_strategy \<sigma>\<^sub>e \<sigma> p", unfolded strategy_winning_by_Odd_def, rule_format, of "\<sigma>\<^sub>e"]
         induced_play_eq[OF eq_a]
    show False unfolding simps by auto
  qed
qed (auto simp: move_defensive_by_Even_def strategy_winning_by_Even_def position_maxlength_cannotbe_augmented)

(* This is a repetition of the proof for defensive_move_exists_for_Even *)
lemma defensive_move_exists_for_Odd:
assumes [intro]:"position p"
shows "winning_position_Even p \<or> (\<exists> m. move_defensive_by_Odd m p)" (is "?w \<or> ?d")
proof(cases "length p = 2*N \<or> even (length p)")
  case False
  hence pl[intro]:"length p < 2*N"
    and ev[intro]:"odd (length p)" using assms[unfolded position_def] by auto
  show ?thesis proof(rule impI[of "\<not> ?d \<longrightarrow> \<not> ?w \<longrightarrow> False", rule_format], force)
    assume not_def:"\<not> ?d"
    from not_def[unfolded move_defensive_by_Odd_def]
    have "\<forall> m. \<exists>\<sigma>. strategy_winning_by_Even \<sigma> (p @ [m])" by blast
    from choice[OF this] obtain \<sigma>\<^sub>e where
      str_Even:"\<And> m. strategy_winning_by_Even (\<sigma>\<^sub>e m) (p @ [m])" by blast
    define \<sigma> where "\<sigma> p' = \<sigma>\<^sub>e (p' ! length p) p'" for p'
    assume not_win:"\<not> ?w"
    from not_win[unfolded move_defensive_by_Odd_def strategy_winning_by_Even_def]
    obtain \<sigma>\<^sub>o where
      str_Odd:"induced_play (joint_strategy \<sigma> \<sigma>\<^sub>o) p \<notin> A"
      (is "?pe p \<notin> A")
           by blast
    let ?strat = "joint_strategy \<sigma> \<sigma>\<^sub>o"
    let ?pnext = "(p @ [?strat p])"
    { fix p' m
      assume "prefix (p @ [m]) p'"
      hence "(p' ! length p) = m"
        unfolding prefix_def by auto
    }
    hence eq_a:"\<forall> p'. prefix ?pnext p' \<longrightarrow> p' @ [?strat p'] =
                                    p' @ [joint_strategy (\<sigma>\<^sub>e (?strat p)) \<sigma>\<^sub>o p']"
      unfolding joint_strategy_def \<sigma>_def by auto
    have simps:"?pe p = ?pe (p @ [?strat p])"
      unfolding induced_play_def by auto
    from str_Odd str_Even[of "?strat p", unfolded strategy_winning_by_Even_def, rule_format]
         induced_play_eq[OF eq_a]
    show False unfolding simps by auto
  qed
qed (auto simp: move_defensive_by_Odd_def strategy_winning_by_Odd_def position_maxlength_cannotbe_augmented)

definition defensive_strategy_Even where
"defensive_strategy_Even p \<equiv> SOME m. move_defensive_by_Even m p"
definition defensive_strategy_Odd where
"defensive_strategy_Odd p \<equiv> SOME m. move_defensive_by_Odd m p"

lemma position_augment:
  assumes "position ((augment_list f ^^ n) p)"
  shows "position p"
  using assms length_augment_list[of n f p] unfolding position_def
  by fastforce

lemma defensive_strategy_Odd:
  assumes "\<not> winning_position_Even p"
  shows "\<not> winning_position_Even (((augment_list (joint_strategy \<sigma>\<^sub>e defensive_strategy_Odd)) ^^ n) p)"
proof -
  show ?thesis using assms proof(induct n arbitrary:p)
    case (Suc n)
    show ?case proof(cases "position p")
      case True
      from Suc.prems defensive_move_exists_for_Odd[OF True] defensive_strategy_Odd_def someI
      have "move_defensive_by_Odd (defensive_strategy_Odd p) p" by metis
      from this[unfolded move_defensive_by_Odd_def] Suc.prems
           non_winning_moves_remains_non_winning_Even[of p]
      have "\<not> winning_position_Even (p @ [joint_strategy \<sigma>\<^sub>e defensive_strategy_Odd p])"
        by (simp add:  joint_strategy_def True)
      with Suc.hyps[of "p @ [joint_strategy \<sigma>\<^sub>e defensive_strategy_Odd p]"]
      show ?thesis unfolding funpow_Suc_right comp_def by fastforce
    qed (insert position_augment,blast)
  qed auto
qed

lemma defensive_strategy_Even:
  assumes "\<not> winning_position_Odd p"
  shows "\<not> winning_position_Odd (((augment_list (joint_strategy defensive_strategy_Even \<sigma>\<^sub>o)) ^^ n) p)"
proof -
  show ?thesis using assms proof(induct n arbitrary:p)
    case (Suc n)
    show ?case proof(cases "position p")
      case True
      from Suc.prems defensive_move_exists_for_Even[OF True] defensive_strategy_Even_def someI
      have "move_defensive_by_Even (defensive_strategy_Even p) p" by metis
      from this[unfolded move_defensive_by_Even_def] Suc.prems
           non_winning_moves_remains_non_winning_Odd[of p]
      have "\<not> winning_position_Odd (p @ [joint_strategy defensive_strategy_Even \<sigma>\<^sub>o p])"
        by (simp add: joint_strategy_def True)
      with Suc.hyps[of "p @ [joint_strategy defensive_strategy_Even \<sigma>\<^sub>o p]"]
      show ?thesis unfolding funpow_Suc_right comp_def by fastforce
    qed (insert position_augment,blast)
  qed auto
qed

end

locale closed_GSgame = GSgame +
  assumes closed:"e \<in> A \<Longrightarrow> \<exists> p. lprefix (llist_of p) e \<and> (\<forall> e'. lprefix (llist_of p) e' \<longrightarrow> llength e' = 2*N \<longrightarrow> e' \<in> A)"

(* Perhaps a misnomer, GSgames are supposed to be infinite ... *)
locale finite_GSgame = GSgame +
  assumes fin:"N \<noteq> \<infinity>"
begin

text \<open> Finite games are closed games. As a corollary to the GS theorem, this lets us conclude that finite games are determined. \<close>
sublocale closed_GSgame
proof
  fix e assume eA:"e \<in> A"
  let ?p = "list_of e"
  from eA have len:"llength e = 2*N" using length by blast
  with fin have p:"llist_of ?p = e"
    by (metis llist_of_list_of mult_2 not_lfinite_llength plus_eq_infty_iff_enat)
  hence pfx:"lprefix (llist_of ?p) e" by auto
  { fix e'
    assume "lprefix (llist_of ?p) e'" "llength e' = 2 * N"
    hence "e' = e" using len by (metis lprefix_llength_eq_imp_eq p)
    with eA have "e' \<in> A" by simp
  }
  with pfx show "\<exists>p. lprefix (llist_of p) e \<and> (\<forall>e'. lprefix (llist_of p) e' \<longrightarrow> llength e' = 2 * N \<longrightarrow> e' \<in> A)"
    by blast
qed
end

context closed_GSgame begin
lemma never_winning_is_losing_even:
  assumes "position p" "\<forall> n. \<not> winning_position_Even (((augment_list \<sigma>) ^^ n) p)"
  shows "induced_play \<sigma> p \<notin> A"
proof
  assume "induced_play \<sigma> p \<in> A"
  from closed[OF this] obtain p' where
    p':"lprefix (llist_of p') (induced_play \<sigma> p)"
    "\<And> e. lprefix (llist_of p') e \<Longrightarrow> llength e = 2 * N \<Longrightarrow> e \<in> A" by blast
  from lprefix_llength_le[OF p'(1)] have lp':"llength (llist_of p') \<le> 2 * N" by auto
  show False proof (cases "length p' \<le> length p")
    case True
    hence "llength (llist_of p') \<le> llength (llist_of p)" by auto
    from lprefix_llength_lprefix[OF p'(1) _ this]
      induced_play_is_lprefix[OF assms(1)]
      lprefix_trans
    have pref:"lprefix (llist_of p') (induced_play strat p)" for strat by blast
    from assms(2)[rule_format,of 0] assms(1) have "\<not> strategy_winning_by_Even \<sigma> p" for \<sigma> by auto
    from this[unfolded strategy_winning_by_Even_def] obtain strat where
      strat:"induced_play strat p \<notin> A" by auto
    from strat p'(2)[OF pref] show False by simp
  next
    case False
    let ?n = "length p' - length p"
    let ?pos = "(augment_list \<sigma> ^^ ?n) p"
    from False have "length p' \<ge> length p" by auto
    hence [simp]:"length ?pos = length p'"
      by (auto simp:length_augment_list)
    hence pos[intro]:"position ?pos"
      using False lp'(1) unfolding position_def by auto
    have "llist_of p' = llist_of ?pos"
      using p'(1)
      by(intro lprefix_antisym[OF lprefix_llength_lprefix lprefix_llength_lprefix],auto)
    hence p'_pos:"p' = ?pos" by simp
    from assms(2)[rule_format,of ?n] assms(1) have "\<not> strategy_winning_by_Even \<sigma> ?pos" for \<sigma> by auto
    from this[unfolded strategy_winning_by_Even_def] obtain strat where
      strat:"induced_play strat ?pos \<notin> A" by auto
    from p'_pos induced_play_is_lprefix[OF pos, of strat]
    have pref:"lprefix (llist_of p') (induced_play strat ?pos)" by simp
    with p'(2)[OF pref] strat show False by simp
  qed
qed

lemma every_position_is_determined:
  assumes "position p"
  shows "winning_position_Even p \<or> winning_position_Odd p" (is "?we \<or> ?wo")
proof(rule impI[of "\<not> ?we \<longrightarrow> \<not> ?wo \<longrightarrow> False",rule_format],force)
  assume "\<not> ?we"
  from defensive_strategy_Odd[OF this] never_winning_is_losing_even[OF assms]
  have js_no:"induced_play
         (joint_strategy s defensive_strategy_Odd) p \<notin> A" for s
    by auto
  assume "\<not> ?wo"
  from this[unfolded strategy_winning_by_Odd_def] assms
  have "\<exists> s. induced_play
         (joint_strategy s defensive_strategy_Odd) p \<in> A" by simp
  thus False using js_no by simp
qed

end

end


(*  Title:      HOL/Nitpick_Examples/Manual_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2014

Examples from the Nitpick manual.
*)

section \<open>Examples from the Nitpick Manual\<close>

(* The "expect" arguments to Nitpick in this theory and the other example
   theories are there so that the example can also serve as a regression test
   suite. *)

theory Manual_Nits
imports HOL.Real "HOL-Library.Quotient_Product"
begin

section \<open>2. First Steps\<close>

nitpick_params [sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]

subsection \<open>2.1. Propositional Logic\<close>

lemma "P \<longleftrightarrow> Q"
nitpick [expect = genuine]
apply auto
nitpick [expect = genuine] 1
nitpick [expect = genuine] 2
oops

subsection \<open>2.2. Type Variables\<close>

lemma "x \<in> A \<Longrightarrow> (THE y. y \<in> A) \<in> A"
nitpick [verbose, expect = genuine]
oops

subsection \<open>2.3. Constants\<close>

lemma "x \<in> A \<Longrightarrow> (THE y. y \<in> A) \<in> A"
nitpick [show_consts, expect = genuine]
nitpick [dont_specialize, show_consts, expect = genuine]
oops

lemma "\<exists>!x. x \<in> A \<Longrightarrow> (THE y. y \<in> A) \<in> A"
nitpick [expect = none]
nitpick [card 'a = 1-50, expect = none]
(* sledgehammer *)
by (metis the_equality)

subsection \<open>2.4. Skolemization\<close>

lemma "\<exists>g. \<forall>x. g (f x) = x \<Longrightarrow> \<forall>y. \<exists>x. y = f x"
nitpick [expect = genuine]
oops

lemma "\<exists>x. \<forall>f. f x = x"
nitpick [expect = genuine]
oops

lemma "refl r \<Longrightarrow> sym r"
nitpick [expect = genuine]
oops

subsection \<open>2.5. Natural Numbers and Integers\<close>

lemma "\<lbrakk>i \<le> j; n \<le> (m::int)\<rbrakk> \<Longrightarrow> i * n + j * m \<le> i * m + j * n"
nitpick [expect = genuine]
nitpick [binary_ints, bits = 16, expect = genuine]
oops

lemma "\<forall>n. Suc n \<noteq> n \<Longrightarrow> P"
nitpick [card nat = 100, expect = potential]
oops

lemma "P Suc"
nitpick [expect = none]
oops

lemma "P ((+)::nat\<Rightarrow>nat\<Rightarrow>nat)"
nitpick [card nat = 1, expect = genuine]
nitpick [card nat = 2, expect = none]
oops

subsection \<open>2.6. Inductive Datatypes\<close>

lemma "hd (xs @ [y, y]) = hd xs"
nitpick [expect = genuine]
nitpick [show_consts, show_types, expect = genuine]
oops

lemma "\<lbrakk>length xs = 1; length ys = 1\<rbrakk> \<Longrightarrow> xs = ys"
nitpick [show_types, expect = genuine]
oops

subsection \<open>2.7. Typedefs, Records, Rationals, and Reals\<close>

definition "three = {0::nat, 1, 2}"
typedef three = three
  unfolding three_def by blast

definition A :: three where "A \<equiv> Abs_three 0"
definition B :: three where "B \<equiv> Abs_three 1"
definition C :: three where "C \<equiv> Abs_three 2"

lemma "\<lbrakk>A \<in> X; B \<in> X\<rbrakk> \<Longrightarrow> c \<in> X"
nitpick [show_types, expect = genuine]
oops

fun my_int_rel where
"my_int_rel (x, y) (u, v) = (x + v = u + y)"

quotient_type my_int = "nat \<times> nat" / my_int_rel
by (auto simp add: equivp_def fun_eq_iff)

definition add_raw where
"add_raw \<equiv> \<lambda>(x, y) (u, v). (x + (u::nat), y + (v::nat))"

quotient_definition "add::my_int \<Rightarrow> my_int \<Rightarrow> my_int" is add_raw
unfolding add_raw_def by auto

lemma "add x y = add x x"
nitpick [show_types, expect = genuine]
oops

ML \<open>
fun my_int_postproc _ _ _ T (Const _ $ (Const _ $ t1 $ t2)) =
    HOLogic.mk_number T (snd (HOLogic.dest_number t1)
                         - snd (HOLogic.dest_number t2))
  | my_int_postproc _ _ _ _ t = t
\<close>

declaration \<open>
Nitpick_Model.register_term_postprocessor \<^typ>\<open>my_int\<close> my_int_postproc
\<close>

lemma "add x y = add x x"
nitpick [show_types]
oops

record point =
  Xcoord :: int
  Ycoord :: int

lemma "Xcoord (p::point) = Xcoord (q::point)"
nitpick [show_types, expect = genuine]
oops

lemma "4 * x + 3 * (y::real) \<noteq> 1 / 2"
nitpick [show_types, expect = genuine]
oops

subsection \<open>2.8. Inductive and Coinductive Predicates\<close>

inductive even where
"even 0" |
"even n \<Longrightarrow> even (Suc (Suc n))"

lemma "\<exists>n. even n \<and> even (Suc n)"
nitpick [card nat = 50, unary_ints, verbose, expect = potential]
oops

lemma "\<exists>n \<le> 49. even n \<and> even (Suc n)"
nitpick [card nat = 50, unary_ints, expect = genuine]
oops

inductive even' where
"even' (0::nat)" |
"even' 2" |
"\<lbrakk>even' m; even' n\<rbrakk> \<Longrightarrow> even' (m + n)"

lemma "\<exists>n \<in> {0, 2, 4, 6, 8}. \<not> even' n"
nitpick [card nat = 10, unary_ints, verbose, show_consts, expect = genuine]
oops

lemma "even' (n - 2) \<Longrightarrow> even' n"
nitpick [card nat = 10, show_consts, expect = genuine]
oops

coinductive nats where
"nats (x::nat) \<Longrightarrow> nats x"

lemma "nats = (\<lambda>n. n \<in> {0, 1, 2, 3, 4})"
nitpick [card nat = 10, show_consts, expect = genuine]
oops

inductive odd where
"odd 1" |
"\<lbrakk>odd m; even n\<rbrakk> \<Longrightarrow> odd (m + n)"

lemma "odd n \<Longrightarrow> odd (n - 2)"
nitpick [card nat = 4, show_consts, expect = genuine]
oops

subsection \<open>2.9. Coinductive Datatypes\<close>

codatatype 'a llist = LNil | LCons 'a "'a llist"

primcorec iterates where
"iterates f a = LCons a (iterates f (f a))"

lemma "xs \<noteq> LCons a xs"
nitpick [expect = genuine]
oops

lemma "\<lbrakk>xs = LCons a xs; ys = iterates (\<lambda>b. a) b\<rbrakk> \<Longrightarrow> xs = ys"
nitpick [verbose, expect = genuine]
oops

lemma "\<lbrakk>xs = LCons a xs; ys = LCons a ys\<rbrakk> \<Longrightarrow> xs = ys"
nitpick [bisim_depth = -1, show_types, expect = quasi_genuine]
nitpick [card = 1-5, expect = none]
sorry

subsection \<open>2.10. Boxing\<close>

datatype tm = Var nat | Lam tm | App tm tm

primrec lift where
"lift (Var j) k = Var (if j < k then j else j + 1)" |
"lift (Lam t) k = Lam (lift t (k + 1))" |
"lift (App t u) k = App (lift t k) (lift u k)"

primrec loose where
"loose (Var j) k = (j \<ge> k)" |
"loose (Lam t) k = loose t (Suc k)" |
"loose (App t u) k = (loose t k \<or> loose u k)"

primrec subst\<^sub>1 where
"subst\<^sub>1 \<sigma> (Var j) = \<sigma> j" |
"subst\<^sub>1 \<sigma> (Lam t) =
 Lam (subst\<^sub>1 (\<lambda>n. case n of 0 \<Rightarrow> Var 0 | Suc m \<Rightarrow> lift (\<sigma> m) 1) t)" |
"subst\<^sub>1 \<sigma> (App t u) = App (subst\<^sub>1 \<sigma> t) (subst\<^sub>1 \<sigma> u)"

lemma "\<not> loose t 0 \<Longrightarrow> subst\<^sub>1 \<sigma> t = t"
nitpick [verbose, expect = genuine]
nitpick [eval = "subst\<^sub>1 \<sigma> t", expect = genuine]
(* nitpick [dont_box, expect = unknown] *)
oops

primrec subst\<^sub>2 where
"subst\<^sub>2 \<sigma> (Var j) = \<sigma> j" |
"subst\<^sub>2 \<sigma> (Lam t) =
 Lam (subst\<^sub>2 (\<lambda>n. case n of 0 \<Rightarrow> Var 0 | Suc m \<Rightarrow> lift (\<sigma> m) 0) t)" |
"subst\<^sub>2 \<sigma> (App t u) = App (subst\<^sub>2 \<sigma> t) (subst\<^sub>2 \<sigma> u)"

lemma "\<not> loose t 0 \<Longrightarrow> subst\<^sub>2 \<sigma> t = t"
nitpick [card = 1-5, expect = none]
sorry

subsection \<open>2.11. Scope Monotonicity\<close>

lemma "length xs = length ys \<Longrightarrow> rev (zip xs ys) = zip xs (rev ys)"
nitpick [verbose, expect = genuine]
oops

lemma "\<exists>g. \<forall>x::'b. g (f x) = x \<Longrightarrow> \<forall>y::'a. \<exists>x. y = f x"
nitpick [mono, expect = none]
nitpick [expect = genuine]
oops

subsection \<open>2.12. Inductive Properties\<close>

inductive_set reach where
"(4::nat) \<in> reach" |
"n \<in> reach \<Longrightarrow> n < 4 \<Longrightarrow> 3 * n + 1 \<in> reach" |
"n \<in> reach \<Longrightarrow> n + 2 \<in> reach"

lemma "n \<in> reach \<Longrightarrow> 2 dvd n"
(* nitpick *)
apply (induct set: reach)
  apply auto
 nitpick [card = 1-4, bits = 1-4, expect = none]
 apply (thin_tac "n \<in> reach")
 nitpick [expect = genuine]
oops

lemma "n \<in> reach \<Longrightarrow> 2 dvd n \<and> n \<noteq> 0"
(* nitpick *)
apply (induct set: reach)
  apply auto
 nitpick [card = 1-4, bits = 1-4, expect = none]
 apply (thin_tac "n \<in> reach")
 nitpick [expect = genuine]
oops

lemma "n \<in> reach \<Longrightarrow> 2 dvd n \<and> n \<ge> 4"
by (induct set: reach) arith+

section \<open>3. Case Studies\<close>

nitpick_params [max_potential = 0]

subsection \<open>3.1. A Context-Free Grammar\<close>

datatype alphabet = a | b

inductive_set S\<^sub>1 and A\<^sub>1 and B\<^sub>1 where
  "[] \<in> S\<^sub>1"
| "w \<in> A\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "w \<in> B\<^sub>1 \<Longrightarrow> a # w \<in> S\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> a # w \<in> A\<^sub>1"
| "w \<in> S\<^sub>1 \<Longrightarrow> b # w \<in> S\<^sub>1"
| "\<lbrakk>v \<in> B\<^sub>1; v \<in> B\<^sub>1\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>1"

theorem S\<^sub>1_sound:
"w \<in> S\<^sub>1 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
nitpick [expect = genuine]
oops

inductive_set S\<^sub>2 and A\<^sub>2 and B\<^sub>2 where
  "[] \<in> S\<^sub>2"
| "w \<in> A\<^sub>2 \<Longrightarrow> b # w \<in> S\<^sub>2"
| "w \<in> B\<^sub>2 \<Longrightarrow> a # w \<in> S\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> a # w \<in> A\<^sub>2"
| "w \<in> S\<^sub>2 \<Longrightarrow> b # w \<in> B\<^sub>2"
| "\<lbrakk>v \<in> B\<^sub>2; v \<in> B\<^sub>2\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>2"

theorem S\<^sub>2_sound:
"w \<in> S\<^sub>2 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
nitpick [expect = genuine]
oops

inductive_set S\<^sub>3 and A\<^sub>3 and B\<^sub>3 where
  "[] \<in> S\<^sub>3"
| "w \<in> A\<^sub>3 \<Longrightarrow> b # w \<in> S\<^sub>3"
| "w \<in> B\<^sub>3 \<Longrightarrow> a # w \<in> S\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> a # w \<in> A\<^sub>3"
| "w \<in> S\<^sub>3 \<Longrightarrow> b # w \<in> B\<^sub>3"
| "\<lbrakk>v \<in> B\<^sub>3; w \<in> B\<^sub>3\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>3"

theorem S\<^sub>3_sound:
"w \<in> S\<^sub>3 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
nitpick [card = 1-5, expect = none]
sorry

theorem S\<^sub>3_complete:
"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^sub>3"
nitpick [expect = genuine]
oops

inductive_set S\<^sub>4 and A\<^sub>4 and B\<^sub>4 where
  "[] \<in> S\<^sub>4"
| "w \<in> A\<^sub>4 \<Longrightarrow> b # w \<in> S\<^sub>4"
| "w \<in> B\<^sub>4 \<Longrightarrow> a # w \<in> S\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> a # w \<in> A\<^sub>4"
| "\<lbrakk>v \<in> A\<^sub>4; w \<in> A\<^sub>4\<rbrakk> \<Longrightarrow> b # v @ w \<in> A\<^sub>4"
| "w \<in> S\<^sub>4 \<Longrightarrow> b # w \<in> B\<^sub>4"
| "\<lbrakk>v \<in> B\<^sub>4; w \<in> B\<^sub>4\<rbrakk> \<Longrightarrow> a # v @ w \<in> B\<^sub>4"

theorem S\<^sub>4_sound:
"w \<in> S\<^sub>4 \<longrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
nitpick [card = 1-5, expect = none]
sorry

theorem S\<^sub>4_complete:
"length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] \<longrightarrow> w \<in> S\<^sub>4"
nitpick [card = 1-5, expect = none]
sorry

theorem S\<^sub>4_A\<^sub>4_B\<^sub>4_sound_and_complete:
"w \<in> S\<^sub>4 \<longleftrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b]"
"w \<in> A\<^sub>4 \<longleftrightarrow> length [x \<leftarrow> w. x = a] = length [x \<leftarrow> w. x = b] + 1"
"w \<in> B\<^sub>4 \<longleftrightarrow> length [x \<leftarrow> w. x = b] = length [x \<leftarrow> w. x = a] + 1"
nitpick [card = 1-5, expect = none]
sorry

subsection \<open>3.2. AA Trees\<close>

datatype 'a aa_tree = \<Lambda> | N "'a::linorder" nat "'a aa_tree" "'a aa_tree"

primrec data where
"data \<Lambda> = undefined" |
"data (N x _ _ _) = x"

primrec dataset where
"dataset \<Lambda> = {}" |
"dataset (N x _ t u) = {x} \<union> dataset t \<union> dataset u"

primrec level where
"level \<Lambda> = 0" |
"level (N _ k _ _) = k"

primrec left where
"left \<Lambda> = \<Lambda>" |
"left (N _ _ t\<^sub>1 _) = t\<^sub>1"

primrec right where
"right \<Lambda> = \<Lambda>" |
"right (N _ _ _ t\<^sub>2) = t\<^sub>2"

fun wf where
"wf \<Lambda> = True" |
"wf (N _ k t u) =
 (if t = \<Lambda> then
    k = 1 \<and> (u = \<Lambda> \<or> (level u = 1 \<and> left u = \<Lambda> \<and> right u = \<Lambda>))
  else
    wf t \<and> wf u \<and> u \<noteq> \<Lambda> \<and> level t < k \<and> level u \<le> k \<and> level (right u) < k)"

fun skew where
"skew \<Lambda> = \<Lambda>" |
"skew (N x k t u) =
 (if t \<noteq> \<Lambda> \<and> k = level t then
    N (data t) k (left t) (N x k (right t) u)
  else
    N x k t u)"

fun split where
"split \<Lambda> = \<Lambda>" |
"split (N x k t u) =
 (if u \<noteq> \<Lambda> \<and> k = level (right u) then
    N (data u) (Suc k) (N x k t (left u)) (right u)
  else
    N x k t u)"

theorem dataset_skew_split:
"dataset (skew t) = dataset t"
"dataset (split t) = dataset t"
nitpick [card = 1-5, expect = none]
sorry

theorem wf_skew_split:
"wf t \<Longrightarrow> skew t = t"
"wf t \<Longrightarrow> split t = t"
nitpick [card = 1-5, expect = none]
sorry

primrec insort\<^sub>1 where
"insort\<^sub>1 \<Lambda> x = N x 1 \<Lambda> \<Lambda>" |
"insort\<^sub>1 (N y k t u) x =
 \<^cancel>\<open>(split \<circ> skew)\<close> (N y k (if x < y then insort\<^sub>1 t x else t)
                             (if x > y then insort\<^sub>1 u x else u))"

theorem wf_insort\<^sub>1: "wf t \<Longrightarrow> wf (insort\<^sub>1 t x)"
nitpick [expect = genuine]
oops

theorem wf_insort\<^sub>1_nat: "wf t \<Longrightarrow> wf (insort\<^sub>1 t (x::nat))"
nitpick [eval = "insort\<^sub>1 t x", expect = genuine]
oops

primrec insort\<^sub>2 where
"insort\<^sub>2 \<Lambda> x = N x 1 \<Lambda> \<Lambda>" |
"insort\<^sub>2 (N y k t u) x =
 (split \<circ> skew) (N y k (if x < y then insort\<^sub>2 t x else t)
                       (if x > y then insort\<^sub>2 u x else u))"

theorem wf_insort\<^sub>2: "wf t \<Longrightarrow> wf (insort\<^sub>2 t x)"
nitpick [card = 1-5, expect = none]
sorry

theorem dataset_insort\<^sub>2: "dataset (insort\<^sub>2 t x) = {x} \<union> dataset t"
nitpick [card = 1-5, expect = none]
sorry

end


(*  Title:       Isabelle Collections Library
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
section {* \isaheader{Set Implementation by sorted Lists} *}
theory ListSetImpl_Sorted
imports
  "../spec/SetSpec"
  "../gen_algo/SetGA"
  "../../Lib/Sorted_List_Operations"
begin
text_raw {*\label{thy:ListSetImpl_Sorted}*}

(*@impl Set
  @type 'a::linorder lss
  @abbrv lss
  Sets implemented by sorted lists.
*)

type_synonym
  'a lss = "'a list"

subsection "Definitions"
definition lss_\<alpha> :: "'a lss \<Rightarrow> 'a set" where "lss_\<alpha> == set"
definition lss_invar :: "'a::{linorder} lss \<Rightarrow> bool" where "lss_invar l == distinct l \<and> sorted l"
definition lss_empty :: "unit \<Rightarrow> 'a lss" where "lss_empty == (\<lambda>_::unit. [])"
definition lss_memb :: "'a::{linorder} \<Rightarrow> 'a lss \<Rightarrow> bool" where "lss_memb x l == Sorted_List_Operations.memb_sorted l x"
definition lss_ins :: "'a::{linorder} \<Rightarrow> 'a lss \<Rightarrow> 'a lss" where "lss_ins x l == insertion_sort x l"
definition lss_ins_dj :: "'a::{linorder} \<Rightarrow> 'a lss \<Rightarrow> 'a lss" where "lss_ins_dj == lss_ins"

definition lss_delete :: "'a::{linorder} \<Rightarrow> 'a lss \<Rightarrow> 'a lss" where "lss_delete x l == delete_sorted x l"

definition lss_iterateoi :: "'a lss \<Rightarrow> ('a,'\<sigma>) set_iterator"
where "lss_iterateoi l = foldli l"

definition lss_reverse_iterateoi :: "'a lss \<Rightarrow> ('a,'\<sigma>) set_iterator"
where "lss_reverse_iterateoi l = foldli (rev l)"

definition lss_iteratei :: "'a lss \<Rightarrow> ('a,'\<sigma>) set_iterator"
where "lss_iteratei l = foldli l"

definition lss_isEmpty :: "'a lss \<Rightarrow> bool" where "lss_isEmpty s == s=[]"

definition lss_union :: "'a::{linorder} lss \<Rightarrow> 'a lss \<Rightarrow> 'a lss"
  where "lss_union s1 s2 == Misc.merge s1 s2"
definition lss_union_list :: "'a::{linorder} lss list \<Rightarrow> 'a lss"
  where "lss_union_list l == merge_list [] l"
definition lss_inter :: "'a::{linorder} lss \<Rightarrow> 'a lss \<Rightarrow> 'a lss"
  where "lss_inter == inter_sorted"
definition lss_union_dj :: "'a::{linorder} lss \<Rightarrow> 'a lss \<Rightarrow> 'a lss"
  where "lss_union_dj == lss_union" -- "Union of disjoint sets"

definition lss_image_filter
  where "lss_image_filter f l =
         mergesort_remdups (List.map_filter f l)"

definition lss_filter where [code_unfold]: "lss_filter = List.filter"

definition lss_inj_image_filter
  where "lss_inj_image_filter == lss_image_filter"

definition "lss_image == iflt_image lss_image_filter"
definition "lss_inj_image == iflt_inj_image lss_inj_image_filter"

definition lss_to_list :: "'a lss \<Rightarrow> 'a list" where "lss_to_list == id"
definition list_to_lss :: "'a::{linorder} list \<Rightarrow> 'a lss" where "list_to_lss == mergesort_remdups"

subsection "Correctness"
lemmas lss_defs =
  lss_\<alpha>_def
  lss_invar_def
  lss_empty_def
  lss_memb_def
  lss_ins_def
  lss_ins_dj_def
  lss_delete_def
  lss_iteratei_def
  lss_isEmpty_def
  lss_union_def
  lss_union_list_def
  lss_inter_def
  lss_union_dj_def
  lss_image_filter_def
  lss_inj_image_filter_def
  lss_image_def
  lss_inj_image_def
  lss_to_list_def
  list_to_lss_def

lemma lss_empty_impl: "set_empty lss_\<alpha> lss_invar lss_empty"
by (unfold_locales) (auto simp add: lss_defs)

lemma lss_memb_impl: "set_memb lss_\<alpha> lss_invar lss_memb"
by (unfold_locales) (auto simp add: lss_defs memb_sorted_correct)

lemma lss_ins_impl: "set_ins lss_\<alpha> lss_invar lss_ins"
by (unfold_locales) (auto simp add: lss_defs insertion_sort_correct)

lemma lss_ins_dj_impl: "set_ins_dj lss_\<alpha> lss_invar lss_ins_dj"
by (unfold_locales) (auto simp add: lss_defs insertion_sort_correct)

lemma lss_\<alpha>_finite[simp, intro!]: "finite (lss_\<alpha> l)"
  by (auto simp add: lss_defs)

lemma lss_is_finite_set: "finite_set lss_\<alpha> lss_invar"
by (unfold_locales) (auto simp add: lss_defs)

lemma lss_iterateoi_impl: "poly_set_iterateoi lss_\<alpha> lss_invar lss_iterateoi"
proof
  fix l :: "'a::{linorder} list"
  assume invar_l: "lss_invar l"
  show "finite (lss_\<alpha> l)"
    unfolding lss_\<alpha>_def by simp

  from invar_l
  show "set_iterator_linord (lss_iterateoi l) (lss_\<alpha> l)"
    apply (rule_tac set_iterator_linord_I [of "l"])
    apply (simp_all add: lss_\<alpha>_def lss_invar_def lss_iterateoi_def)
  done
qed

lemma lss_reverse_iterateoi_impl: "poly_set_rev_iterateoi lss_\<alpha> lss_invar lss_reverse_iterateoi"
proof
  fix l :: "'a list"
  assume invar_l: "lss_invar l"
  show "finite (lss_\<alpha> l)"
    unfolding lss_\<alpha>_def by simp

  from invar_l
  show "set_iterator_rev_linord (lss_reverse_iterateoi l) (lss_\<alpha> l)"
    apply (rule_tac set_iterator_rev_linord_I [of "rev l"])
    apply (simp_all add: lss_\<alpha>_def lss_invar_def lss_reverse_iterateoi_def)
  done
qed

lemma lss_iteratei_impl: "poly_set_iteratei lss_\<alpha> lss_invar lss_iteratei"
proof
  fix l :: "'a list"
  assume invar_l: "lss_invar l"
  show "finite (lss_\<alpha> l)"
    unfolding lss_\<alpha>_def by simp

  from invar_l
  show "set_iterator (lss_iteratei l) (lss_\<alpha> l)"
    apply (rule_tac set_iterator_I [of "l"])
    apply (simp_all add: lss_\<alpha>_def lss_invar_def lss_iteratei_def)
  done
qed

lemma lss_isEmpty_impl: "set_isEmpty lss_\<alpha> lss_invar lss_isEmpty"
by(unfold_locales)(auto simp add: lss_defs)

lemma lss_inter_impl: "set_inter lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_inter"
by (unfold_locales) (auto simp add: lss_defs inter_sorted_correct)

lemma lss_union_impl: "set_union lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_union"
by (unfold_locales) (auto simp add: lss_defs merge_correct)

lemma lss_union_list_impl: "set_union_list lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_union_list"
proof
  fix l :: "'a::{linorder} lss list"
  assume "\<forall>s1\<in>set l. lss_invar s1"

  with merge_list_correct [of l "[]"]
  show "lss_\<alpha> (lss_union_list l) = \<Union>{lss_\<alpha> s1 |s1. s1 \<in> set l}"
       "lss_invar (lss_union_list l)"
    by (auto simp add: lss_defs)
qed

lemma lss_union_dj_impl: "set_union_dj lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_union_dj"
by (unfold_locales) (auto simp add: lss_defs merge_correct)

lemma lss_image_filter_impl : "set_image_filter lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_image_filter"
apply (unfold_locales)
apply (simp_all add:
  lss_invar_def lss_image_filter_def lss_\<alpha>_def mergesort_remdups_correct
  set_map_filter Bex_def)
done

lemma lss_inj_image_filter_impl : "set_inj_image_filter lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_inj_image_filter"
apply (unfold_locales)
apply (simp_all add: lss_invar_def lss_inj_image_filter_def lss_image_filter_def
                     mergesort_remdups_correct lss_\<alpha>_def
                     set_map_filter Bex_def)
done

lemma lss_filter_impl : "set_filter lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_filter"
apply (unfold_locales)
apply (simp_all add: lss_invar_def lss_filter_def sorted_filter lss_\<alpha>_def
                     set_map_filter Bex_def sorted_filter')
done

lemmas lss_image_impl = iflt_image_correct[OF lss_image_filter_impl, folded lss_image_def]
lemmas lss_inj_image_impl = iflt_inj_image_correct[OF lss_inj_image_filter_impl, folded lss_inj_image_def]

lemma lss_to_list_impl: "set_to_list lss_\<alpha> lss_invar lss_to_list"
by(unfold_locales)(auto simp add: lss_defs)

lemma list_to_lss_impl: "list_to_set lss_\<alpha> lss_invar list_to_lss"
  by (unfold_locales) (auto simp add: lss_defs mergesort_remdups_correct)

definition lss_basic_ops :: "('x::linorder,'x lss) oset_basic_ops"
  where [icf_rec_def]: "lss_basic_ops \<equiv> \<lparr>
    bset_op_\<alpha> = lss_\<alpha>,
    bset_op_invar = lss_invar,
    bset_op_empty = lss_empty,
    bset_op_memb = lss_memb,
    bset_op_ins = lss_ins,
    bset_op_ins_dj = lss_ins_dj,
    bset_op_delete = lss_delete,
    bset_op_list_it = lss_iteratei,
    bset_op_ordered_list_it = lss_iterateoi,
    bset_op_rev_list_it = lss_reverse_iterateoi
  \<rparr>"

setup Locale_Code.open_block
interpretation lss_basic: StdBasicOSet lss_basic_ops
  apply (rule StdBasicOSet.intro)
  apply (rule StdBasicSet.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule lss_empty_impl lss_memb_impl lss_ins_impl lss_ins_dj_impl
    lss_delete_impl lss_iteratei_impl lss_iterateoi_impl
    lss_reverse_iterateoi_impl)+
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "lss_ops \<equiv> lss_basic.dflt_oops \<lparr>
  set_op_isEmpty := lss_isEmpty,
  set_op_union := lss_union,
  set_op_union_dj := lss_union_dj,
  set_op_filter := lss_filter,
  set_op_to_list := lss_to_list,
  set_op_from_list := list_to_lss
  \<rparr>"

setup Locale_Code.open_block
interpretation lss: StdOSetDefs lss_ops .
interpretation lss: StdOSet lss_ops
proof -
  interpret aux: StdOSet lss_basic.dflt_oops
    by (rule lss_basic.dflt_oops_impl)

  show "StdOSet lss_ops"
    unfolding lss_ops_def
    apply (rule StdOSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf
      lss_isEmpty_impl lss_union_impl lss_union_dj_impl lss_to_list_impl
      lss_filter_impl
      list_to_lss_impl
    )
    done
qed
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "lss"*}

lemma pi_lss[proper_it]:
  "proper_it' lss_iteratei lss_iteratei"
  apply (rule proper_it'I)
  unfolding lss_iteratei_def
  by (intro icf_proper_iteratorI)

interpretation pi_lss: proper_it_loc lss_iteratei lss_iteratei
  apply unfold_locales by (rule pi_lss)

definition test_codegen where "test_codegen \<equiv> (
  lss.empty,
  lss.memb,
  lss.ins,
  lss.delete,
  lss.list_it,
  lss.sng,
  lss.isEmpty,
  lss.isSng,
  lss.ball,
  lss.bex,
  lss.size,
  lss.size_abort,
  lss.union,
  lss.union_dj,
  lss.diff,
  lss.filter,
  lss.inter,
  lss.subset,
  lss.equal,
  lss.disjoint,
  lss.disjoint_witness,
  lss.sel,
  lss.to_list,
  lss.from_list
)"

export_code test_codegen in SML

end


(* Copyright 2021 (C) Mihails Milehins *)

section\<open>Equipollence\<close>
theory CZH_Sets_Equipollence
  imports CZH_Sets_IF
begin

subsection\<open>Background\<close>

text\<open>
The section presents an adaption of the existing framework \<open>Equipollence\<close>
in the main library of Isabelle/HOL to the type \<^typ>\<open>V\<close>.

Some of content of this theory was ported directly (with amendments) from the
theory \<open>HOL-Library.Equipollence\<close> in the main library of Isabelle/HOL.
\<close>

subsection\<open>\<open>veqpoll\<close>\<close>

abbreviation veqpoll :: "V \<Rightarrow> V \<Rightarrow> bool" (infixl "\<approx>\<^sub>\<circ>" 50)
  where "A \<approx>\<^sub>\<circ> B \<equiv> elts A \<approx> elts B"

text\<open>Rules\<close>

lemma (in v11) v11_veqpollI[intro]:
  assumes "\<D>\<^sub>\<circ> r = A" and "\<R>\<^sub>\<circ> r = B"
  shows "A \<approx>\<^sub>\<circ> B"
  unfolding eqpoll_def
proof(intro exI[of _ \<open>\<lambda>x. r\<lparr>x\<rparr>\<close>] bij_betw_imageI)
  from v11.v11_injective v11_axioms show "inj_on (app r) (elts A)"
    unfolding assms[symmetric] by (intro inj_onI) blast
  show "app r ` elts A = elts B" unfolding assms[symmetric] by force+
qed

lemmas v11_veqpollI[intro] = v11.v11_veqpollI

lemma v11_veqpollE[elim]:
  assumes "A \<approx>\<^sub>\<circ> B"
  obtains f where "v11 f" and "\<D>\<^sub>\<circ> f = A" and "\<R>\<^sub>\<circ> f = B"
proof-
  from assms obtain f where bij_f: "bij_betw f (elts A) (elts B)"
    unfolding eqpoll_def by auto
  then have "v11 (\<lambda>a\<in>\<^sub>\<circ>A. f a)"
    and "\<D>\<^sub>\<circ> (\<lambda>a\<in>\<^sub>\<circ>A. f a) = A"
    and "\<R>\<^sub>\<circ> (\<lambda>a\<in>\<^sub>\<circ>A. f a) = B"
    by (auto simp add: in_mono vrange_VLambda)
  then show ?thesis using that by simp
qed

text\<open>Set operations.\<close>

lemma veqpoll_vsingleton: "set {x} \<approx>\<^sub>\<circ> set {y}"
  by (simp add: singleton_eqpoll)

lemma veqpoll_vinsert:
  assumes "A \<approx>\<^sub>\<circ> B" and "a \<notin>\<^sub>\<circ> A" and "b \<notin>\<^sub>\<circ> B"
  shows "vinsert a A \<approx>\<^sub>\<circ> vinsert b B"
  using assms by (simp add: insert_eqpoll_insert_iff)

lemma veqpoll_pair:
  assumes "a \<noteq> b" and "c \<noteq> d"
  shows "set {a, b} \<approx>\<^sub>\<circ> set {c, d}"
  using assms by (simp add: insert_eqpoll_cong)

lemma veqpoll_vpair:
  assumes "a \<noteq> b" and "c \<noteq> d"
  shows "\<langle>a, b\<rangle> \<approx>\<^sub>\<circ> \<langle>c, d\<rangle>"
  using assms
  unfolding vpair_def
  by (metis doubleton_eq_iff insert_absorb2 veqpoll_pair)

subsection\<open>\<open>vlepoll\<close>\<close>

abbreviation vlepoll :: "V \<Rightarrow> V \<Rightarrow> bool" (infixl "\<lesssim>\<^sub>\<circ>" 50)
  where "A \<lesssim>\<^sub>\<circ> B \<equiv> elts A \<lesssim> elts B"

text\<open>Set operations.\<close>

lemma vlepoll_vsubset:
  assumes "A \<subseteq>\<^sub>\<circ> B"
  shows "A \<lesssim>\<^sub>\<circ> B"
  using assms by (simp add: less_eq_V_def subset_imp_lepoll)

text\<open>Special properties.\<close>

lemma vlepoll_singleton_vinsert: "set {x} \<lesssim>\<^sub>\<circ> vinsert y A"
  by (simp add: singleton_lepoll)

lemma vlepoll_vempty_iff[simp]: "A \<lesssim>\<^sub>\<circ> 0 \<longleftrightarrow> A = 0" by (rule iffI) fastforce+

subsection\<open>\<open>vlespoll\<close>\<close>

abbreviation vlesspoll :: "V \<Rightarrow> V \<Rightarrow> bool" (infixl \<open>\<prec>\<^sub>\<circ>\<close> 50)
  where "A \<prec>\<^sub>\<circ> B \<equiv> elts A \<prec> elts B"

lemma vlesspoll_def: "A \<prec>\<^sub>\<circ> B = (A \<lesssim>\<^sub>\<circ> B \<and> ~(A \<approx>\<^sub>\<circ> B))" by (simp add: lesspoll_def)

text\<open>Rules.\<close>

lemmas vlesspollI[intro] = vlesspoll_def[THEN iffD2]

lemmas vlesspollD[dest] = vlesspoll_def[THEN iffD1]

lemma vlesspollE[elim]:
  assumes "A \<prec>\<^sub>\<circ> B" and "A \<lesssim>\<^sub>\<circ> B \<Longrightarrow> ~(A \<approx>\<^sub>\<circ> B) \<Longrightarrow> P"
  shows P
  using assms by (simp add: vlesspoll_def)

lemma (in v11) v11_vlepollI[intro]:
  assumes "\<D>\<^sub>\<circ> r = A" and "\<R>\<^sub>\<circ> r \<subseteq>\<^sub>\<circ> B"
  shows "A \<lesssim>\<^sub>\<circ> B"
  unfolding lepoll_def
proof(intro exI[of _ \<open>\<lambda>x. r\<lparr>x\<rparr>\<close>] conjI)
  show "inj_on (app r) (elts A)"
    using assms(1) v11.v11_injective v11_axioms by (intro inj_onI) blast
  show "app r ` elts A \<subseteq> elts B"
    by (intro subsetI) (metis assms(1,2) imageE rev_vsubsetD vdomain_atD)
qed

lemmas v11_vlepollI[intro] = v11.v11_vlepollI

lemma v11_vlepollE[elim]:
  assumes "A \<lesssim>\<^sub>\<circ> B"
  obtains f where "v11 f" and "\<D>\<^sub>\<circ> f = A" and "\<R>\<^sub>\<circ> f \<subseteq>\<^sub>\<circ> B"
proof-
  from assms obtain f where "inj_on f (elts A)" and "f ` elts A \<subseteq> elts B"
    unfolding lepoll_def by auto
  then have "v11 (\<lambda>a\<in>\<^sub>\<circ>A. f a)"
    and "\<D>\<^sub>\<circ> (\<lambda>a\<in>\<^sub>\<circ>A. f a) = A"
    and "\<R>\<^sub>\<circ> (\<lambda>a\<in>\<^sub>\<circ>A. f a) \<subseteq>\<^sub>\<circ> B"
    by (auto simp: in_mono vrange_VLambda)
  then show ?thesis using that by simp
qed

text\<open>\newpage\<close>

end


(*  Title       : NSPrimes.thy
    Author      : Jacques D. Fleuriot
    Copyright   : 2002 University of Edinburgh
    Conversion to Isar and new proofs by Lawrence C Paulson, 2004
*)

section \<open>The Nonstandard Primes as an Extension of the Prime Numbers\<close>

theory NSPrimes
  imports "HOL-Computational_Algebra.Primes" "HOL-Nonstandard_Analysis.Hyperreal"
begin

text \<open>These can be used to derive an alternative proof of the infinitude of
primes by considering a property of nonstandard sets.\<close>

definition starprime :: "hypnat set"
  where [transfer_unfold]: "starprime = *s* {p. prime p}"

definition choicefun :: "'a set \<Rightarrow> 'a"
  where "choicefun E = (SOME x. \<exists>X \<in> Pow E - {{}}. x \<in> X)"

primrec injf_max :: "nat \<Rightarrow> 'a::order set \<Rightarrow> 'a"
where
  injf_max_zero: "injf_max 0 E = choicefun E"
| injf_max_Suc: "injf_max (Suc n) E = choicefun ({e. e \<in> E \<and> injf_max n E < e})"

lemma dvd_by_all2: "\<exists>N>0. \<forall>m. 0 < m \<and> m \<le> M \<longrightarrow> m dvd N"
  for M :: nat
  apply (induct M)
   apply auto
  apply (rule_tac x = "N * Suc M" in exI)
  apply auto
  apply (metis dvdI dvd_add_times_triv_left_iff dvd_add_triv_right_iff dvd_refl dvd_trans le_Suc_eq mult_Suc_right)
  done

lemma dvd_by_all: "\<forall>M::nat. \<exists>N>0. \<forall>m. 0 < m \<and> m \<le> M \<longrightarrow> m dvd N"
  using dvd_by_all2 by blast

lemma hypnat_of_nat_le_zero_iff [simp]: "hypnat_of_nat n \<le> 0 \<longleftrightarrow> n = 0"
  by transfer simp

text \<open>Goldblatt: Exercise 5.11(2) -- p. 57.\<close>
lemma hdvd_by_all: "\<forall>M. \<exists>N. 0 < N \<and> (\<forall>m::hypnat. 0 < m \<and> m \<le> M \<longrightarrow> m dvd N)"
  by transfer (rule dvd_by_all)

lemmas hdvd_by_all2 = hdvd_by_all [THEN spec]

text \<open>Goldblatt: Exercise 5.11(2) -- p. 57.\<close>
lemma hypnat_dvd_all_hypnat_of_nat:
  "\<exists>N::hypnat. 0 < N \<and> (\<forall>n \<in> - {0::nat}. hypnat_of_nat n dvd N)"
  apply (cut_tac hdvd_by_all)
  apply (drule_tac x = whn in spec)
  apply auto
  apply (rule exI)
  apply auto
  apply (drule_tac x = "hypnat_of_nat n" in spec)
  apply (auto simp add: linorder_not_less)
  done

text \<open>The nonstandard extension of the set prime numbers consists of precisely
  those hypernaturals exceeding 1 that have no nontrivial factors.\<close>

text \<open>Goldblatt: Exercise 5.11(3a) -- p 57.\<close>
lemma starprime: "starprime = {p. 1 < p \<and> (\<forall>m. m dvd p \<longrightarrow> m = 1 \<or> m = p)}"
  by transfer (auto simp add: prime_nat_iff)

text \<open>Goldblatt Exercise 5.11(3b) -- p 57.\<close>
lemma hyperprime_factor_exists: "\<And>n. 1 < n \<Longrightarrow> \<exists>k \<in> starprime. k dvd n"
  by transfer (simp add: prime_factor_nat)

text \<open>Goldblatt Exercise 3.10(1) -- p. 29.\<close>
lemma NatStar_hypnat_of_nat: "finite A \<Longrightarrow> *s* A = hypnat_of_nat ` A"
  by (rule starset_finite)

subsection \<open>Another characterization of infinite set of natural numbers\<close>

lemma finite_nat_set_bounded: "finite N \<Longrightarrow> \<exists>n::nat. \<forall>i \<in> N. i < n"
  apply (erule_tac F = N in finite_induct)
   apply auto
  apply (rule_tac x = "Suc n + x" in exI)
  apply auto
  done

lemma finite_nat_set_bounded_iff: "finite N \<longleftrightarrow> (\<exists>n::nat. \<forall>i \<in> N. i < n)"
  by (blast intro: finite_nat_set_bounded bounded_nat_set_is_finite)

lemma not_finite_nat_set_iff: "\<not> finite N \<longleftrightarrow> (\<forall>n::nat. \<exists>i \<in> N. n \<le> i)"
  by (auto simp add: finite_nat_set_bounded_iff not_less)

lemma bounded_nat_set_is_finite2: "\<forall>i::nat \<in> N. i \<le> n \<Longrightarrow> finite N"
  apply (rule finite_subset)
   apply (rule_tac [2] finite_atMost)
  apply auto
  done

lemma finite_nat_set_bounded2: "finite N \<Longrightarrow> \<exists>n::nat. \<forall>i \<in> N. i \<le> n"
  apply (erule_tac F = N in finite_induct)
   apply auto
  apply (rule_tac x = "n + x" in exI)
  apply auto
  done

lemma finite_nat_set_bounded_iff2: "finite N \<longleftrightarrow> (\<exists>n::nat. \<forall>i \<in> N. i \<le> n)"
  by (blast intro: finite_nat_set_bounded2 bounded_nat_set_is_finite2)

lemma not_finite_nat_set_iff2: "\<not> finite N \<longleftrightarrow> (\<forall>n::nat. \<exists>i \<in> N. n < i)"
  by (auto simp add: finite_nat_set_bounded_iff2 not_le)

subsection \<open>An injective function cannot define an embedded natural number\<close>

lemma lemma_infinite_set_singleton:
  "\<forall>m n. m \<noteq> n \<longrightarrow> f n \<noteq> f m \<Longrightarrow> {n. f n = N} = {} \<or> (\<exists>m. {n. f n = N} = {m})"
  apply auto
  apply (drule_tac x = x in spec, auto)
  apply (subgoal_tac "\<forall>n. f n = f x \<longleftrightarrow> x = n")
   apply auto
  done

lemma inj_fun_not_hypnat_in_SHNat:
  fixes f :: "nat \<Rightarrow> nat"
  assumes inj_f: "inj f"
  shows "starfun f whn \<notin> Nats"
proof
  from inj_f have inj_f': "inj (starfun f)"
    by (transfer inj_on_def Ball_def UNIV_def)
  assume "starfun f whn \<in> Nats"
  then obtain N where N: "starfun f whn = hypnat_of_nat N"
    by (auto simp: Nats_def)
  then have "\<exists>n. starfun f n = hypnat_of_nat N" ..
  then have "\<exists>n. f n = N" by transfer
  then obtain n where "f n = N" ..
  then have "starfun f (hypnat_of_nat n) = hypnat_of_nat N"
    by transfer
  with N have "starfun f whn = starfun f (hypnat_of_nat n)"
    by simp
  with inj_f' have "whn = hypnat_of_nat n"
    by (rule injD)
  then show False
    by (simp add: whn_neq_hypnat_of_nat)
qed

lemma range_subset_mem_starsetNat: "range f \<subseteq> A \<Longrightarrow> starfun f whn \<in> *s* A"
  apply (rule_tac x="whn" in spec)
  apply transfer
  apply auto
  done

text \<open>
  Gleason Proposition 11-5.5. pg 149, pg 155 (ex. 3) and pg. 360.

  Let \<open>E\<close> be a nonvoid ordered set with no maximal elements (note: effectively an
  infinite set if we take \<open>E = N\<close> (Nats)). Then there exists an order-preserving
  injection from \<open>N\<close> to \<open>E\<close>. Of course, (as some doofus will undoubtedly point out!
  :-)) can use notion of least element in proof (i.e. no need for choice) if
  dealing with nats as we have well-ordering property.
\<close>

lemma lemmaPow3: "E \<noteq> {} \<Longrightarrow> \<exists>x. \<exists>X \<in> Pow E - {{}}. x \<in> X"
  by auto

lemma choicefun_mem_set [simp]: "E \<noteq> {} \<Longrightarrow> choicefun E \<in> E"
  apply (unfold choicefun_def)
  apply (rule lemmaPow3 [THEN someI2_ex], auto)
  done

lemma injf_max_mem_set: "E \<noteq>{} \<Longrightarrow> \<forall>x. \<exists>y \<in> E. x < y \<Longrightarrow> injf_max n E \<in> E"
  apply (induct n)
   apply force
  apply (simp add: choicefun_def)
  apply (rule lemmaPow3 [THEN someI2_ex], auto)
  done

lemma injf_max_order_preserving: "\<forall>x. \<exists>y \<in> E. x < y \<Longrightarrow> injf_max n E < injf_max (Suc n) E"
  apply (simp add: choicefun_def)
  apply (rule lemmaPow3 [THEN someI2_ex])
   apply auto
  done

lemma injf_max_order_preserving2: "\<forall>x. \<exists>y \<in> E. x < y \<Longrightarrow> \<forall>n m. m < n \<longrightarrow> injf_max m E < injf_max n E"
  apply (rule allI)
  apply (induct_tac n)
   apply auto
  apply (simp add: choicefun_def)
  apply (rule lemmaPow3 [THEN someI2_ex])
   apply (auto simp add: less_Suc_eq)
  apply (drule_tac x = m in spec)
  apply (drule subsetD)
   apply auto
  apply (drule_tac x = "injf_max m E" in order_less_trans)
   apply auto
  done

lemma inj_injf_max: "\<forall>x. \<exists>y \<in> E. x < y \<Longrightarrow> inj (\<lambda>n. injf_max n E)"
  apply (rule inj_onI)
  apply (rule ccontr)
  apply auto
  apply (drule injf_max_order_preserving2)
  apply (metis antisym_conv3 order_less_le)
  done

lemma infinite_set_has_order_preserving_inj:
  "E \<noteq> {} \<Longrightarrow> \<forall>x. \<exists>y \<in> E. x < y \<Longrightarrow> \<exists>f. range f \<subseteq> E \<and> inj f \<and> (\<forall>m. f m < f (Suc m))"
  for E :: "'a::order set" and f :: "nat \<Rightarrow> 'a"
  apply (rule_tac x = "\<lambda>n. injf_max n E" in exI)
  apply safe
    apply (rule injf_max_mem_set)
     apply (rule_tac [3] inj_injf_max)
     apply (rule_tac [4] injf_max_order_preserving)
     apply auto
  done

text \<open>Only need the existence of an injective function from \<open>N\<close> to \<open>A\<close> for proof.\<close>

lemma hypnat_infinite_has_nonstandard: "\<not> finite A \<Longrightarrow> hypnat_of_nat ` A < ( *s* A)"
  apply auto
  apply (subgoal_tac "A \<noteq> {}")
   prefer 2 apply force
  apply (drule infinite_set_has_order_preserving_inj)
   apply (erule not_finite_nat_set_iff2 [THEN iffD1])
  apply auto
  apply (drule inj_fun_not_hypnat_in_SHNat)
  apply (drule range_subset_mem_starsetNat)
  apply (auto simp add: SHNat_eq)
  done

lemma starsetNat_eq_hypnat_of_nat_image_finite: "*s* A =  hypnat_of_nat ` A \<Longrightarrow> finite A"
  by (metis hypnat_infinite_has_nonstandard less_irrefl)

lemma finite_starsetNat_iff: "*s* A = hypnat_of_nat ` A \<longleftrightarrow> finite A"
  by (blast intro!: starsetNat_eq_hypnat_of_nat_image_finite NatStar_hypnat_of_nat)

lemma hypnat_infinite_has_nonstandard_iff: "\<not> finite A \<longleftrightarrow> hypnat_of_nat ` A < *s* A"
  apply (rule iffI)
   apply (blast intro!: hypnat_infinite_has_nonstandard)
  apply (auto simp add: finite_starsetNat_iff [symmetric])
  done

subsection \<open>Existence of Infinitely Many Primes: a Nonstandard Proof\<close>

lemma lemma_not_dvd_hypnat_one [simp]: "\<not> (\<forall>n \<in> - {0}. hypnat_of_nat n dvd 1)"
  apply auto
  apply (rule_tac x = 2 in bexI)
   apply transfer
   apply auto
  done

lemma lemma_not_dvd_hypnat_one2 [simp]: "\<exists>n \<in> - {0}. \<not> hypnat_of_nat n dvd 1"
  using lemma_not_dvd_hypnat_one by (auto simp del: lemma_not_dvd_hypnat_one)

lemma hypnat_add_one_gt_one: "\<And>N::hypnat. 0 < N \<Longrightarrow> 1 < N + 1"
  by transfer simp

lemma hypnat_of_nat_zero_not_prime [simp]: "hypnat_of_nat 0 \<notin> starprime"
  by transfer simp

lemma hypnat_zero_not_prime [simp]: "0 \<notin> starprime"
  using hypnat_of_nat_zero_not_prime by simp

lemma hypnat_of_nat_one_not_prime [simp]: "hypnat_of_nat 1 \<notin> starprime"
  by transfer simp

lemma hypnat_one_not_prime [simp]: "1 \<notin> starprime"
  using hypnat_of_nat_one_not_prime by simp

lemma hdvd_diff: "\<And>k m n :: hypnat. k dvd m \<Longrightarrow> k dvd n \<Longrightarrow> k dvd (m - n)"
  by transfer (rule dvd_diff_nat)

lemma hdvd_one_eq_one: "\<And>x::hypnat. is_unit x \<Longrightarrow> x = 1"
  by transfer simp

text \<open>Already proved as \<open>primes_infinite\<close>, but now using non-standard naturals.\<close>
theorem not_finite_prime: "\<not> finite {p::nat. prime p}"
  apply (rule hypnat_infinite_has_nonstandard_iff [THEN iffD2])
  using hypnat_dvd_all_hypnat_of_nat
  apply clarify
  apply (drule hypnat_add_one_gt_one)
  apply (drule hyperprime_factor_exists)
  apply clarify
  apply (subgoal_tac "k \<notin> hypnat_of_nat ` {p. prime p}")
   apply (force simp: starprime_def)
  apply (metis Compl_iff add.commute dvd_add_left_iff empty_iff hdvd_one_eq_one hypnat_one_not_prime
      imageE insert_iff mem_Collect_eq not_prime_0)
  done

end


(*  Title:      HOL/Quotient_Examples/Quotient_Message.thy
    Author:     Christian Urban

Message datatype, based on an older version by Larry Paulson.
*)

theory Quotient_Message
imports Main "~~/src/HOL/Library/Quotient_Syntax"
begin

subsection{*Defining the Free Algebra*}

datatype
  freemsg = NONCE  nat
        | MPAIR  freemsg freemsg
        | CRYPT  nat freemsg
        | DECRYPT  nat freemsg

inductive
  msgrel::"freemsg \<Rightarrow> freemsg \<Rightarrow> bool" (infixl "\<sim>" 50)
where
  CD:    "CRYPT K (DECRYPT K X) \<sim> X"
| DC:    "DECRYPT K (CRYPT K X) \<sim> X"
| NONCE: "NONCE N \<sim> NONCE N"
| MPAIR: "\<lbrakk>X \<sim> X'; Y \<sim> Y'\<rbrakk> \<Longrightarrow> MPAIR X Y \<sim> MPAIR X' Y'"
| CRYPT: "X \<sim> X' \<Longrightarrow> CRYPT K X \<sim> CRYPT K X'"
| DECRYPT: "X \<sim> X' \<Longrightarrow> DECRYPT K X \<sim> DECRYPT K X'"
| SYM:   "X \<sim> Y \<Longrightarrow> Y \<sim> X"
| TRANS: "\<lbrakk>X \<sim> Y; Y \<sim> Z\<rbrakk> \<Longrightarrow> X \<sim> Z"

lemmas msgrel.intros[intro]

text{*Proving that it is an equivalence relation*}

lemma msgrel_refl: "X \<sim> X"
by (induct X) (auto intro: msgrel.intros)

theorem equiv_msgrel: "equivp msgrel"
proof (rule equivpI)
  show "reflp msgrel" by (rule reflpI) (simp add: msgrel_refl)
  show "symp msgrel" by (rule sympI) (blast intro: msgrel.SYM)
  show "transp msgrel" by (rule transpI) (blast intro: msgrel.TRANS)
qed

subsection{*Some Functions on the Free Algebra*}

subsubsection{*The Set of Nonces*}

primrec
  freenonces :: "freemsg \<Rightarrow> nat set"
where
  "freenonces (NONCE N) = {N}"
| "freenonces (MPAIR X Y) = freenonces X \<union> freenonces Y"
| "freenonces (CRYPT K X) = freenonces X"
| "freenonces (DECRYPT K X) = freenonces X"

theorem msgrel_imp_eq_freenonces:
  assumes a: "U \<sim> V"
  shows "freenonces U = freenonces V"
  using a by (induct) (auto)

subsubsection{*The Left Projection*}

text{*A function to return the left part of the top pair in a message.  It will
be lifted to the initial algrebra, to serve as an example of that process.*}
primrec
  freeleft :: "freemsg \<Rightarrow> freemsg"
where
  "freeleft (NONCE N) = NONCE N"
| "freeleft (MPAIR X Y) = X"
| "freeleft (CRYPT K X) = freeleft X"
| "freeleft (DECRYPT K X) = freeleft X"

text{*This theorem lets us prove that the left function respects the
equivalence relation.  It also helps us prove that MPair
  (the abstract constructor) is injective*}
lemma msgrel_imp_eqv_freeleft_aux:
  shows "freeleft U \<sim> freeleft U"
  by (fact msgrel_refl)

theorem msgrel_imp_eqv_freeleft:
  assumes a: "U \<sim> V"
  shows "freeleft U \<sim> freeleft V"
  using a
  by (induct) (auto intro: msgrel_imp_eqv_freeleft_aux)

subsubsection{*The Right Projection*}

text{*A function to return the right part of the top pair in a message.*}
primrec
  freeright :: "freemsg \<Rightarrow> freemsg"
where
  "freeright (NONCE N) = NONCE N"
| "freeright (MPAIR X Y) = Y"
| "freeright (CRYPT K X) = freeright X"
| "freeright (DECRYPT K X) = freeright X"

text{*This theorem lets us prove that the right function respects the
equivalence relation.  It also helps us prove that MPair
  (the abstract constructor) is injective*}
lemma msgrel_imp_eqv_freeright_aux:
  shows "freeright U \<sim> freeright U"
  by (fact msgrel_refl)

theorem msgrel_imp_eqv_freeright:
  assumes a: "U \<sim> V"
  shows "freeright U \<sim> freeright V"
  using a
  by (induct) (auto intro: msgrel_imp_eqv_freeright_aux)

subsubsection{*The Discriminator for Constructors*}

text{*A function to distinguish nonces, mpairs and encryptions*}
primrec
  freediscrim :: "freemsg \<Rightarrow> int"
where
   "freediscrim (NONCE N) = 0"
 | "freediscrim (MPAIR X Y) = 1"
 | "freediscrim (CRYPT K X) = freediscrim X + 2"
 | "freediscrim (DECRYPT K X) = freediscrim X - 2"

text{*This theorem helps us prove @{term "Nonce N \<noteq> MPair X Y"}*}
theorem msgrel_imp_eq_freediscrim:
  assumes a: "U \<sim> V"
  shows "freediscrim U = freediscrim V"
  using a by (induct) (auto)

subsection{*The Initial Algebra: A Quotiented Message Type*}

quotient_type msg = freemsg / msgrel
  by (rule equiv_msgrel)

text{*The abstract message constructors*}

quotient_definition
  "Nonce :: nat \<Rightarrow> msg"
is
  "NONCE"
done

quotient_definition
  "MPair :: msg \<Rightarrow> msg \<Rightarrow> msg"
is
  "MPAIR"
by (rule MPAIR)

quotient_definition
  "Crypt :: nat \<Rightarrow> msg \<Rightarrow> msg"
is
  "CRYPT"
by (rule CRYPT)

quotient_definition
  "Decrypt :: nat \<Rightarrow> msg \<Rightarrow> msg"
is
  "DECRYPT"
by (rule DECRYPT)

text{*Establishing these two equations is the point of the whole exercise*}
theorem CD_eq [simp]:
  shows "Crypt K (Decrypt K X) = X"
  by (lifting CD)

theorem DC_eq [simp]:
  shows "Decrypt K (Crypt K X) = X"
  by (lifting DC)

subsection{*The Abstract Function to Return the Set of Nonces*}

quotient_definition
   "nonces:: msg \<Rightarrow> nat set"
is
  "freenonces"
by (rule msgrel_imp_eq_freenonces)

text{*Now prove the four equations for @{term nonces}*}

lemma nonces_Nonce [simp]:
  shows "nonces (Nonce N) = {N}"
  by (lifting freenonces.simps(1))

lemma nonces_MPair [simp]:
  shows "nonces (MPair X Y) = nonces X \<union> nonces Y"
  by (lifting freenonces.simps(2))

lemma nonces_Crypt [simp]:
  shows "nonces (Crypt K X) = nonces X"
  by (lifting freenonces.simps(3))

lemma nonces_Decrypt [simp]:
  shows "nonces (Decrypt K X) = nonces X"
  by (lifting freenonces.simps(4))

subsection{*The Abstract Function to Return the Left Part*}

quotient_definition
  "left:: msg \<Rightarrow> msg"
is
  "freeleft"
by (rule msgrel_imp_eqv_freeleft)

lemma left_Nonce [simp]:
  shows "left (Nonce N) = Nonce N"
  by (lifting freeleft.simps(1))

lemma left_MPair [simp]:
  shows "left (MPair X Y) = X"
  by (lifting freeleft.simps(2))

lemma left_Crypt [simp]:
  shows "left (Crypt K X) = left X"
  by (lifting freeleft.simps(3))

lemma left_Decrypt [simp]:
  shows "left (Decrypt K X) = left X"
  by (lifting freeleft.simps(4))

subsection{*The Abstract Function to Return the Right Part*}

quotient_definition
  "right:: msg \<Rightarrow> msg"
is
  "freeright"
by (rule msgrel_imp_eqv_freeright)

text{*Now prove the four equations for @{term right}*}

lemma right_Nonce [simp]:
  shows "right (Nonce N) = Nonce N"
  by (lifting freeright.simps(1))

lemma right_MPair [simp]:
  shows "right (MPair X Y) = Y"
  by (lifting freeright.simps(2))

lemma right_Crypt [simp]:
  shows "right (Crypt K X) = right X"
  by (lifting freeright.simps(3))

lemma right_Decrypt [simp]:
  shows "right (Decrypt K X) = right X"
  by (lifting freeright.simps(4))

subsection{*Injectivity Properties of Some Constructors*}

text{*Can also be proved using the function @{term nonces}*}
lemma Nonce_Nonce_eq [iff]:
  shows "(Nonce m = Nonce n) = (m = n)"
proof
  assume "Nonce m = Nonce n"
  then show "m = n"
    by (descending) (drule msgrel_imp_eq_freenonces, simp)
next
  assume "m = n"
  then show "Nonce m = Nonce n" by simp
qed

lemma MPair_imp_eq_left:
  assumes eq: "MPair X Y = MPair X' Y'"
  shows "X = X'"
  using eq
  by (descending) (drule msgrel_imp_eqv_freeleft, simp)

lemma MPair_imp_eq_right:
  shows "MPair X Y = MPair X' Y' \<Longrightarrow> Y = Y'"
  by (descending) (drule msgrel_imp_eqv_freeright, simp)

theorem MPair_MPair_eq [iff]:
  shows "(MPair X Y = MPair X' Y') = (X=X' & Y=Y')"
  by (blast dest: MPair_imp_eq_left MPair_imp_eq_right)

theorem Nonce_neq_MPair [iff]:
  shows "Nonce N \<noteq> MPair X Y"
  by (descending) (auto dest: msgrel_imp_eq_freediscrim)

text{*Example suggested by a referee*}

theorem Crypt_Nonce_neq_Nonce:
  shows "Crypt K (Nonce M) \<noteq> Nonce N"
  by (descending) (auto dest: msgrel_imp_eq_freediscrim)

text{*...and many similar results*}

theorem Crypt2_Nonce_neq_Nonce:
  shows "Crypt K (Crypt K' (Nonce M)) \<noteq> Nonce N"
  by (descending) (auto dest: msgrel_imp_eq_freediscrim)

theorem Crypt_Crypt_eq [iff]:
  shows "(Crypt K X = Crypt K X') = (X=X')"
proof
  assume "Crypt K X = Crypt K X'"
  hence "Decrypt K (Crypt K X) = Decrypt K (Crypt K X')" by simp
  thus "X = X'" by simp
next
  assume "X = X'"
  thus "Crypt K X = Crypt K X'" by simp
qed

theorem Decrypt_Decrypt_eq [iff]:
  shows "(Decrypt K X = Decrypt K X') = (X=X')"
proof
  assume "Decrypt K X = Decrypt K X'"
  hence "Crypt K (Decrypt K X) = Crypt K (Decrypt K X')" by simp
  thus "X = X'" by simp
next
  assume "X = X'"
  thus "Decrypt K X = Decrypt K X'" by simp
qed

lemma msg_induct [case_names Nonce MPair Crypt Decrypt, cases type: msg]:
  assumes N: "\<And>N. P (Nonce N)"
      and M: "\<And>X Y. \<lbrakk>P X; P Y\<rbrakk> \<Longrightarrow> P (MPair X Y)"
      and C: "\<And>K X. P X \<Longrightarrow> P (Crypt K X)"
      and D: "\<And>K X. P X \<Longrightarrow> P (Decrypt K X)"
  shows "P msg"
  using N M C D
  by (descending) (auto intro: freemsg.induct)

subsection{*The Abstract Discriminator*}

text{*However, as @{text Crypt_Nonce_neq_Nonce} above illustrates, we don't
need this function in order to prove discrimination theorems.*}

quotient_definition
  "discrim:: msg \<Rightarrow> int"
is
  "freediscrim"
by (rule msgrel_imp_eq_freediscrim)

text{*Now prove the four equations for @{term discrim}*}

lemma discrim_Nonce [simp]:
  shows "discrim (Nonce N) = 0"
  by (lifting freediscrim.simps(1))

lemma discrim_MPair [simp]:
  shows "discrim (MPair X Y) = 1"
  by (lifting freediscrim.simps(2))

lemma discrim_Crypt [simp]:
  shows "discrim (Crypt K X) = discrim X + 2"
  by (lifting freediscrim.simps(3))

lemma discrim_Decrypt [simp]:
  shows "discrim (Decrypt K X) = discrim X - 2"
  by (lifting freediscrim.simps(4))

end


header {* \isaheader{Fold-Combinator} *}
theory Refine_Fold
imports "../../Refine_Dflt_Only_ICF"
begin
  text {*
    In this theory, we explore the usage of the partial-function package, and
    define a function with a higher-order argument. As example, we choose a
    nondeterministic fold-operation on lists.
    *}

  text {*
    Note that the function @{const nfoldli}, which is included in the
    refinement framework by default, is similar to this function.
    Also, the parametricity based proof technique used there should
    be prefered to this example.
    *}

  partial_function (nrec) rfoldl where
    "rfoldl f s l = (case l of
        [] \<Rightarrow> RETURN s
      | x#ls \<Rightarrow> do { s\<leftarrow>f s x; rfoldl f s ls}
    )"

  text {* Currently, we have to manually state the standard simplification
    lemmas: *}
  lemma rfoldl_simps[simp]:
    "rfoldl f s [] = RETURN s"
    "rfoldl f s (x#ls) = do { s\<leftarrow>f s x; rfoldl f s ls}"
    apply (subst rfoldl.simps, simp)+
    done

  lemma rfoldl_refines[refine]:
    assumes SV: "single_valued Rs"
    assumes REFF: "\<And>x x' s s'. \<lbrakk> (s,s')\<in>Rs; (x,x')\<in>Rl \<rbrakk>
      \<Longrightarrow> f s x \<le> \<Down>Rs (f' s' x')"
    assumes REF0: "(s0,s0')\<in>Rs"
    assumes REFL: "(l,l')\<in>\<langle>Rl\<rangle>list_rel"
    shows "rfoldl f s0 l \<le> \<Down>Rs (rfoldl f' s0' l')"
    using REFL[unfolded list_rel_def, simplified] REF0
    apply (induct arbitrary: s0 s0' rule: list_all2_induct)
    apply (simp add: REF0 RETURN_refine_sv[OF SV])
    apply (simp only: rfoldl_simps)
    apply (refine_rcg)
    apply (rule REFF)
    apply simp_all
    done

  lemma transfer_rfoldl[refine_transfer]:
    assumes "\<And>s x. RETURN (f s x) \<le> F s x"
    shows "RETURN (foldl f s l) \<le> rfoldl F s l"
    using assms
    apply (induct l arbitrary: s)
    apply simp
    apply (simp only: foldl_Nil foldl_append rfoldl_simps)
    apply simp
    apply (rule order_trans[rotated])
    apply (rule refine_transfer)
    apply assumption
    apply assumption
    apply simp
    done

  subsection {* Example *}
  text {*
    As example application, we define a program that takes as input a list
    of non-empty sets of natural numbers, picks some number of each list,
    and adds up the picked numbers.
    *}
  definition "pick_sum (s0::nat) l \<equiv>
    rfoldl (\<lambda>s x. do {
      ASSERT (x\<noteq>{});
      y\<leftarrow>SPEC (\<lambda>y. y\<in>x);
      RETURN (s+y)
    }) s0 l
    "

  lemma foldl_mono:
    assumes "\<And>x. mono (\<lambda>s. f s x)"
    shows "mono (\<lambda>s. foldl f s l)"
    apply (rule monoI)
    using assms
    apply (induct l)
    apply (auto dest: monoD)
    done

  lemma pick_sum_correct:
    assumes NE: "{}\<notin>set l"
    assumes FIN: "\<forall>x\<in>set l. finite x"
    shows "pick_sum s0 l \<le> SPEC (\<lambda>s. s \<le> foldl (\<lambda>s x. s+Max x) s0 l)"
    using NE FIN
    apply (induction l arbitrary: s0)
    apply (simp)
    apply (simp)
    apply (intro refine_vcg)
    apply blast
    apply simp
    apply (rule order_trans)
    apply assumption
    apply (rule SPEC_rule)
    apply (erule order_trans)
    apply (rule monoD[OF foldl_mono])
    apply (auto intro: monoI)
    done

  definition "pick_sum_impl s0 l \<equiv>
    rfoldl (\<lambda>s x. do {
      y\<leftarrow>RETURN (the (ls.sel x (\<lambda>_. True)));
      RETURN (s+y)
    }) (s0::nat) l"

  lemma pick_sum_impl_refine:
    assumes A: "(l,l')\<in>\<langle>br ls.\<alpha> ls.invar\<rangle>list_rel"
    shows "pick_sum_impl s0 l \<le> \<Down>Id (pick_sum s0 l')"
    unfolding pick_sum_def pick_sum_impl_def
    using A
    apply (refine_rcg)
    apply (refine_dref_type)
    apply (simp_all add: refine_hsimp refine_rel_defs)
    done

  schematic_lemma pick_sum_code_aux: "RETURN ?f \<le> pick_sum_impl s0 l"
    unfolding pick_sum_impl_def
    apply refine_transfer
    done

  concrete_definition pick_sum_code for ?s0.0 l uses pick_sum_code_aux

  lemma pick_sum_code_refines:
    "RETURN (pick_sum_code s l) \<le> pick_sum_impl s l"
    by (rule pick_sum_code.refine)

  value
    "pick_sum_code 0 [list_to_ls [3,2,1], list_to_ls [1,2,3], list_to_ls[2,1]]"

end