theory negation_properties
  imports "../boolean_algebra/boolean_algebra"
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Negative semantic conditions for operations\<close>

(**We define and interrelate some conditions on operations (i.e. propositional functions of type
@{type "\<sigma>\<Rightarrow>\<sigma>"}), this time involving negative-like properties.*)

named_theorems Defs

subsection \<open>Definitions and interrelations (finitary case)\<close>

subsubsection \<open>Principles of excluded middle, contradiction and explosion\<close>

(**TND: tertium non datur, aka. law of excluded middle (resp. strong, weak, minimal).*)
abbreviation pTND  ("TND\<^sup>_  _") where "TND\<^sup>a  \<eta> \<equiv>       \<^bold>\<top>  \<^bold>\<approx> a \<^bold>\<or> (\<eta> a)"
abbreviation pTNDw ("TNDw\<^sup>_ _") where "TNDw\<^sup>a \<eta> \<equiv> \<forall>b. (\<eta> b) \<^bold>\<preceq> a \<^bold>\<or> (\<eta> a)"
abbreviation pTNDm ("TNDm\<^sup>_ _") where "TNDm\<^sup>a \<eta> \<equiv>     (\<eta> \<^bold>\<bottom>) \<^bold>\<preceq> a \<^bold>\<or> (\<eta> a)"
definition "TND  \<eta> \<equiv> \<forall>\<phi>. TND\<^sup>\<phi>  \<eta>"
definition "TNDw \<eta> \<equiv> \<forall>\<phi>. TNDw\<^sup>\<phi> \<eta>"
definition "TNDm \<eta> \<equiv> \<forall>\<phi>. TNDm\<^sup>\<phi> \<eta>"
declare TND_def[Defs] TNDw_def[Defs] TNDm_def[Defs]

(**Explore some (non)entailment relations:*)
lemma "TND  \<eta> \<Longrightarrow> TNDw \<eta>" unfolding Defs conn by simp
lemma "TNDw \<eta> \<Longrightarrow> TND  \<eta>" nitpick oops
lemma "TNDw \<eta> \<Longrightarrow> TNDm \<eta>" unfolding Defs by simp
lemma "TNDm \<eta> \<Longrightarrow> TNDw \<eta>" nitpick oops

(**ECQ: ex contradictione (sequitur) quodlibet (resp: strong, weak, minimal).*)
abbreviation pECQ  ("ECQ\<^sup>_ _")  where "ECQ\<^sup>a  \<eta> \<equiv>     a \<^bold>\<and> (\<eta> a) \<^bold>\<approx> \<^bold>\<bottom>"
abbreviation pECQw ("ECQw\<^sup>_ _") where "ECQw\<^sup>a \<eta> \<equiv> \<forall>b. a \<^bold>\<and> (\<eta> a) \<^bold>\<preceq> (\<eta> b)"
abbreviation pECQm ("ECQm\<^sup>_ _") where "ECQm\<^sup>a \<eta> \<equiv>     a \<^bold>\<and> (\<eta> a) \<^bold>\<preceq> (\<eta> \<^bold>\<top>)"
definition "ECQ  \<eta> \<equiv> \<forall>a. ECQ\<^sup>a  \<eta>"
definition "ECQw \<eta> \<equiv> \<forall>a. ECQw\<^sup>a \<eta>"
definition "ECQm \<eta> \<equiv> \<forall>a. ECQm\<^sup>a \<eta>"
declare ECQ_def[Defs] ECQw_def[Defs] ECQm_def[Defs]

(**Explore some (non)entailment relations:*)
lemma "ECQ  \<eta> \<Longrightarrow> ECQw \<eta>" unfolding Defs conn by blast
lemma "ECQw \<eta> \<Longrightarrow> ECQ  \<eta>" nitpick oops
lemma "ECQw \<eta> \<Longrightarrow> ECQm \<eta>" unfolding Defs conn by simp
lemma "ECQm \<eta> \<Longrightarrow> ECQw \<eta>" nitpick oops

(**LNC: law of non-contradiction.*)
abbreviation pLNC  ("LNC\<^sup>_ _")  where "LNC\<^sup>a \<eta> \<equiv> \<eta>(a \<^bold>\<and> \<eta> a) \<^bold>\<approx> \<^bold>\<top>"
definition "LNC \<eta> \<equiv> \<forall>a. LNC\<^sup>a \<eta>"
declare LNC_def[Defs]

(**ECQ and LNC are in general independent.*)
lemma "ECQ \<eta> \<Longrightarrow> LNC \<eta>" nitpick oops
lemma "LNC \<eta> \<Longrightarrow> ECQm \<eta>" nitpick oops

subsubsection \<open>Contraposition rules\<close>

(**CoP: contraposition (global/rule variants, resp. weak, strong var. 1, strong var. 2, strong var. 3).*)
abbreviation pCoPw ("CoPw\<^sup>_\<^sup>_ _") where "CoPw\<^sup>a\<^sup>b \<eta> \<equiv> a \<^bold>\<preceq> b \<longrightarrow> (\<eta> b) \<^bold>\<preceq> (\<eta> a)"
abbreviation pCoP1 ("CoP1\<^sup>_\<^sup>_ _") where "CoP1\<^sup>a\<^sup>b \<eta> \<equiv> a \<^bold>\<preceq> (\<eta> b) \<longrightarrow> b \<^bold>\<preceq> (\<eta> a)"
abbreviation pCoP2 ("CoP2\<^sup>_\<^sup>_ _") where "CoP2\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<^bold>\<preceq> b \<longrightarrow> (\<eta> b) \<^bold>\<preceq> a"
abbreviation pCoP3 ("CoP3\<^sup>_\<^sup>_ _") where "CoP3\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<^bold>\<preceq> (\<eta> b) \<longrightarrow> b \<^bold>\<preceq> a"
definition "CoPw  \<eta> \<equiv> \<forall>a b. CoPw\<^sup>a\<^sup>b \<eta>"
definition "CoP1  \<eta> \<equiv> \<forall>a b. CoP1\<^sup>a\<^sup>b \<eta>"
definition "CoP1' \<eta> \<equiv> \<forall>a b. a \<^bold>\<preceq> (\<eta> b) \<longleftrightarrow> b \<^bold>\<preceq> (\<eta> a)"
definition "CoP2  \<eta> \<equiv> \<forall>a b. CoP2\<^sup>a\<^sup>b \<eta>"
definition "CoP2' \<eta> \<equiv> \<forall>a b. (\<eta> a) \<^bold>\<preceq> b \<longleftrightarrow> (\<eta> b) \<^bold>\<preceq> a"
definition "CoP3  \<eta> \<equiv> \<forall>a b. CoP3\<^sup>a\<^sup>b \<eta>"
declare CoPw_def[Defs] CoP1_def[Defs] CoP1'_def[Defs]
        CoP2_def[Defs] CoP2'_def[Defs] CoP3_def[Defs]

lemma CoP1_defs_rel: "CoP1 \<eta> = CoP1' \<eta>" unfolding Defs by metis
lemma CoP2_defs_rel: "CoP2 \<eta> = CoP2' \<eta>" unfolding Defs by metis

(**Explore some (non)entailment relations:*)
lemma "CoP1 \<eta> \<Longrightarrow> CoPw \<eta>" unfolding Defs by metis
lemma "CoPw \<eta> \<Longrightarrow> CoP1 \<eta>" nitpick oops
lemma "CoP2 \<eta> \<Longrightarrow> CoPw \<eta>" unfolding Defs by metis
lemma "CoPw \<eta> \<Longrightarrow> CoP2 \<eta>" nitpick oops
lemma "CoP3 \<eta> \<Longrightarrow> CoPw \<eta>" (*nitpick*) oops (**no countermodel found so far*)
lemma "CoPw \<eta> \<Longrightarrow> CoP3 \<eta>" nitpick oops

(**All three strong variants are pairwise independent. However, CoP3 follows from CoP1 plus CoP2.*)
lemma CoP123: "CoP1 \<eta> \<Longrightarrow> CoP2 \<eta> \<Longrightarrow> CoP3 \<eta>" unfolding Defs by smt
(**Taking all CoP together still leaves room for a boldly paraconsistent resp. paracomplete logic.*)
lemma "CoP1 \<eta> \<Longrightarrow> CoP2 \<eta> \<Longrightarrow> ECQm \<eta>" nitpick oops
lemma "CoP1 \<eta> \<Longrightarrow> CoP2 \<eta> \<Longrightarrow> TNDm \<eta>" nitpick oops

subsubsection \<open>Modus tollens rules\<close>

(**MT: modus (tollendo) tollens (global/rule variants).*)
abbreviation pMT0 ("MT0\<^sup>_\<^sup>_ _") where "MT0\<^sup>a\<^sup>b \<eta> \<equiv> a \<^bold>\<preceq> b \<and> (\<eta> b) \<^bold>\<approx> \<^bold>\<top> \<longrightarrow> (\<eta> a) \<^bold>\<approx> \<^bold>\<top>"
abbreviation pMT1 ("MT1\<^sup>_\<^sup>_ _") where "MT1\<^sup>a\<^sup>b \<eta> \<equiv> a \<^bold>\<preceq> (\<eta> b) \<and> b \<^bold>\<approx> \<^bold>\<top> \<longrightarrow> (\<eta> a) \<^bold>\<approx> \<^bold>\<top>"
abbreviation pMT2 ("MT2\<^sup>_\<^sup>_ _") where "MT2\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<^bold>\<preceq> b \<and> (\<eta> b) \<^bold>\<approx> \<^bold>\<top> \<longrightarrow> a \<^bold>\<approx> \<^bold>\<top>"
abbreviation pMT3 ("MT3\<^sup>_\<^sup>_ _") where "MT3\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<^bold>\<preceq> (\<eta> b) \<and> b \<^bold>\<approx> \<^bold>\<top> \<longrightarrow> a \<^bold>\<approx> \<^bold>\<top>"
definition "MT0 \<eta> \<equiv> \<forall>a b. MT0\<^sup>a\<^sup>b \<eta>"
definition "MT1 \<eta> \<equiv> \<forall>a b. MT1\<^sup>a\<^sup>b \<eta>"
definition "MT2 \<eta> \<equiv> \<forall>a b. MT2\<^sup>a\<^sup>b \<eta>"
definition "MT3 \<eta> \<equiv> \<forall>a b. MT3\<^sup>a\<^sup>b \<eta>"
declare MT0_def[Defs] MT1_def[Defs] MT2_def[Defs] MT3_def[Defs]

(**Again, all MT variants are pairwise independent. We explore some (non)entailment relations:*)
lemma "CoPw \<eta> \<Longrightarrow> MT0 \<eta>" unfolding Defs by (metis top_def)
lemma "CoP1 \<eta> \<Longrightarrow> MT1 \<eta>" unfolding Defs by (metis top_def)
lemma "CoP2 \<eta> \<Longrightarrow> MT2 \<eta>" unfolding Defs by (metis top_def)
lemma "CoP3 \<eta> \<Longrightarrow> MT3 \<eta>" unfolding Defs by (metis top_def)
lemma "MT0 \<eta> \<Longrightarrow> MT1 \<eta> \<Longrightarrow> MT2 \<eta> \<Longrightarrow> MT3 \<eta> \<Longrightarrow> CoPw \<eta>" nitpick oops
lemma "MT0 \<eta> \<Longrightarrow> MT1 \<eta> \<Longrightarrow> MT2 \<eta> \<Longrightarrow> MT3 \<eta> \<Longrightarrow> ECQm \<eta>" nitpick oops
lemma "MT0 \<eta> \<Longrightarrow> MT1 \<eta> \<Longrightarrow> MT2 \<eta> \<Longrightarrow> MT3 \<eta> \<Longrightarrow> TNDm \<eta>" nitpick oops
lemma MT123: "MT1 \<eta> \<Longrightarrow> MT2 \<eta> \<Longrightarrow> MT3 \<eta>"  unfolding Defs by smt

subsubsection \<open>Double negation introduction and elimination\<close>

(**DNI/DNE: double negation introduction/elimination (as axioms).*)
abbreviation pDNI ("DNI\<^sup>_ _") where "DNI\<^sup>a \<eta> \<equiv> a \<^bold>\<preceq> \<eta> (\<eta> a)"
abbreviation pDNE ("DNE\<^sup>_ _") where "DNE\<^sup>a \<eta> \<equiv> \<eta> (\<eta> a) \<^bold>\<preceq> a"
definition "DNI \<eta> \<equiv> \<forall>a. DNI\<^sup>a \<eta>"
definition "DNE \<eta> \<equiv> \<forall>a. DNE\<^sup>a \<eta>"
declare DNI_def[Defs] DNE_def[Defs]

(**CoP1 (resp. CoP2) can alternatively be defined as CoPw plus DNI (resp. DNE).*)
lemma "DNI \<eta> \<Longrightarrow> CoP1 \<eta>" nitpick oops
lemma CoP1_def2: "CoP1 \<eta> = (CoPw \<eta> \<and> DNI \<eta>)" unfolding Defs by smt
lemma "DNE \<eta> \<Longrightarrow>  CoP2 \<eta>" nitpick oops
lemma CoP2_def2: "CoP2 \<eta> = (CoPw \<eta> \<and> DNE \<eta>)" unfolding Defs by smt

(**Explore some non-entailment relations:*)
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> CoPw \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> TNDm \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> ECQm \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> MT0 \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> MT1 \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> MT2 \<eta>" nitpick oops
lemma "DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> MT3 \<eta>" nitpick oops

(**DNI/DNE: double negation introduction/elimination (as rules).*)
abbreviation prDNI ("rDNI\<^sup>_ _") where "rDNI\<^sup>a \<eta> \<equiv> a \<^bold>\<approx> \<^bold>\<top> \<longrightarrow> \<eta> (\<eta> a) \<^bold>\<approx> \<^bold>\<top>"
abbreviation prDNE ("rDNE\<^sup>_ _") where "rDNE\<^sup>a \<eta> \<equiv> \<eta> (\<eta> a) \<^bold>\<approx> \<^bold>\<top> \<longrightarrow> a \<^bold>\<approx> \<^bold>\<top>"
definition "rDNI \<eta> \<equiv> \<forall>a. rDNI\<^sup>a \<eta>"
definition "rDNE \<eta> \<equiv> \<forall>a. rDNE\<^sup>a \<eta>"
declare rDNI_def[Defs] rDNE_def[Defs]

(**The rule variants are strictly weaker than the axiom variants,*)
lemma "DNI \<eta> \<Longrightarrow> rDNI \<eta>" by (simp add: DNI_def rDNI_def top_def)
lemma "rDNI \<eta> \<Longrightarrow> DNI \<eta>" nitpick oops
lemma "DNE \<eta> \<Longrightarrow> rDNE \<eta>" by (metis DNE_def rDNE_def top_def)
lemma "rDNE \<eta> \<Longrightarrow> DNE \<eta>" nitpick oops
(**and follow already from modus tollens.*)
lemma MT1_rDNI: "MT1 \<eta> \<Longrightarrow> rDNI \<eta>" unfolding Defs by blast
lemma MT2_rDNE: "MT2 \<eta> \<Longrightarrow> rDNE \<eta>" unfolding Defs by blast

subsubsection \<open>Normality and its dual\<close>

(**n(D)Nor: negative (dual) 'normality'.*)
definition "nNor \<eta> \<equiv> (\<eta> \<^bold>\<bottom>) \<^bold>\<approx> \<^bold>\<top>"
definition "nDNor \<eta> \<equiv> (\<eta> \<^bold>\<top>) \<^bold>\<approx> \<^bold>\<bottom>"
declare nNor_def[Defs] nDNor_def[Defs]

(**nNor (resp. nDNor) is entailed by CoP1 (resp. CoP2). *)
lemma CoP1_Nor: "CoP1 \<eta> \<Longrightarrow> nNor \<eta>" unfolding Defs conn by simp
lemma CoP2_DNor: "CoP2 \<eta> \<Longrightarrow> nDNor \<eta>" unfolding Defs conn by fastforce
lemma "DNI \<eta> \<Longrightarrow> nNor \<eta>" nitpick oops
lemma "DNE \<eta> \<Longrightarrow> nDNor \<eta>" nitpick oops
(**nNor and nDNor together entail the rule variant of DNI (rDNI).*)
lemma nDNor_rDNI: "nNor \<eta> \<Longrightarrow> nDNor \<eta> \<Longrightarrow> rDNI \<eta>" unfolding Defs using nDNor_def nNor_def eq_ext by metis
lemma "nNor \<eta> \<Longrightarrow> nDNor \<eta> \<Longrightarrow> rDNE \<eta>" nitpick oops

subsubsection \<open>De Morgan laws\<close>

(**DM: De Morgan laws.*)
abbreviation pDM1 ("DM1\<^sup>_\<^sup>_ _") where "DM1\<^sup>a\<^sup>b \<eta> \<equiv> \<eta>(a \<^bold>\<or> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<and> (\<eta> b)"
abbreviation pDM2 ("DM2\<^sup>_\<^sup>_ _") where "DM2\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<^bold>\<or> (\<eta> b) \<^bold>\<preceq> \<eta>(a \<^bold>\<and> b)"
abbreviation pDM3 ("DM3\<^sup>_\<^sup>_ _") where "DM3\<^sup>a\<^sup>b \<eta> \<equiv> \<eta>(a \<^bold>\<and> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<or> (\<eta> b)"
abbreviation pDM4 ("DM4\<^sup>_\<^sup>_ _") where "DM4\<^sup>a\<^sup>b \<eta> \<equiv> (\<eta> a) \<^bold>\<and> (\<eta> b) \<^bold>\<preceq>  \<eta>(a \<^bold>\<or> b)"
definition "DM1 \<eta> \<equiv> \<forall>a b. DM1\<^sup>a\<^sup>b \<eta>"
definition "DM2 \<eta> \<equiv> \<forall>a b. DM2\<^sup>a\<^sup>b \<eta>"
definition "DM3 \<eta> \<equiv> \<forall>a b. DM3\<^sup>a\<^sup>b \<eta>"
definition "DM4 \<eta> \<equiv> \<forall>a b. DM4\<^sup>a\<^sup>b \<eta>"
declare DM1_def[Defs] DM2_def[Defs] DM3_def[Defs] DM4_def[Defs]

(**CoPw, DM1 and DM2 are indeed equivalent.*)
lemma DM1_CoPw: "DM1 \<eta> = CoPw \<eta>" proof -
  have LtoR: "DM1 \<eta> \<Longrightarrow> CoPw \<eta>" proof -
  assume dm1: "DM1 \<eta>"
  { fix a b
    { assume "a \<^bold>\<preceq> b"
      hence 1: "a \<^bold>\<or> b \<^bold>\<preceq> b" unfolding conn by simp
      have 2: "b \<^bold>\<preceq> a \<^bold>\<or> b" unfolding conn by simp
      from 1 2 have "b = a \<^bold>\<or> b" using eq_ext by blast
      hence 3: "\<eta> b \<^bold>\<approx> \<eta> (a \<^bold>\<or> b)" by auto
      from dm1 have "\<eta>(a \<^bold>\<or> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<and> (\<eta> b)" unfolding Defs by blast
      hence 4: "(\<eta> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<and> (\<eta> b)" using 3 by simp
      have 5: "(\<eta> a) \<^bold>\<and> (\<eta> b) \<^bold>\<preceq> (\<eta> a)" unfolding conn by simp
      from 4 5 have "(\<eta> b) \<^bold>\<preceq> (\<eta> a)" by simp
    } hence "a \<^bold>\<preceq> b \<longrightarrow> (\<eta> b) \<^bold>\<preceq> (\<eta> a)" by (rule impI)
  } thus ?thesis unfolding Defs by simp
  qed
  have RtoL: "CoPw \<eta> \<Longrightarrow> DM1 \<eta>" unfolding Defs conn by (metis (no_types, lifting))
  thus ?thesis using LtoR RtoL by blast
qed
lemma DM2_CoPw: "DM2 \<eta> = CoPw \<eta>" proof -
 have LtoR: "DM2 \<eta> \<Longrightarrow> CoPw \<eta>" proof -
   assume dm2: "DM2 \<eta>"
    { fix a b
      { assume "a \<^bold>\<preceq> b"
        hence 1: "a \<^bold>\<preceq> a \<^bold>\<and> b" unfolding conn by simp
        have 2: "a \<^bold>\<and> b \<^bold>\<preceq> a" unfolding conn by simp
        from 1 2 have "a = a \<^bold>\<and> b" using eq_ext by blast
        hence 3: "\<eta> a \<^bold>\<approx> \<eta> (a \<^bold>\<and> b)" by auto
        from dm2 have "(\<eta> a) \<^bold>\<or> (\<eta> b) \<^bold>\<preceq> \<eta>(a \<^bold>\<and> b)" unfolding Defs by blast
        hence 4: "(\<eta> a) \<^bold>\<or> (\<eta> b) \<^bold>\<preceq> (\<eta> a) " using 3 by simp
        have 5: "(\<eta> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<or> (\<eta> b)" unfolding conn by simp
        from 4 5 have "(\<eta> b) \<^bold>\<preceq> (\<eta> a)" by simp
      } hence "a \<^bold>\<preceq> b \<longrightarrow> (\<eta> b) \<^bold>\<preceq> (\<eta> a)" by (rule impI)
    } thus ?thesis unfolding Defs by simp
  qed
  have RtoL: "CoPw \<eta> \<Longrightarrow> DM2 \<eta>" unfolding Defs conn by (metis (no_types, lifting))
  thus ?thesis using LtoR RtoL by blast
qed
lemma DM12: "DM1 \<eta> = DM2 \<eta>" by (simp add: DM1_CoPw DM2_CoPw)

(**DM3 (resp. DM4) are entailed by CoPw together with DNE (resp. DNI).*)
lemma CoPw_DNE_DM3: "CoPw \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> DM3 \<eta>" proof -
  assume copw: "CoPw \<eta>" and dne: "DNE \<eta>"
  { fix a b
    have "\<eta>(a) \<^bold>\<preceq> (\<eta> a) \<^bold>\<or> (\<eta> b)" unfolding conn by simp
    hence "\<eta>(\<eta>(a) \<^bold>\<or> \<eta>(b)) \<^bold>\<preceq> \<eta>((\<eta> a))" using CoPw_def copw by (metis (no_types, lifting))
    hence 1: "\<eta>(\<eta>(a) \<^bold>\<or> \<eta>(b)) \<^bold>\<preceq> a" using DNE_def dne by metis
    have "\<eta>(b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<or> (\<eta> b)" unfolding conn by simp
    hence "\<eta>(\<eta>(a) \<^bold>\<or> \<eta>(b)) \<^bold>\<preceq> \<eta>((\<eta> b))" using CoPw_def copw by (metis (no_types, lifting))
    hence 2: "\<eta>(\<eta>(a) \<^bold>\<or> \<eta>(b)) \<^bold>\<preceq> b" using DNE_def dne by metis
    from 1 2 have "\<eta>(\<eta>(a) \<^bold>\<or> \<eta>(b)) \<^bold>\<preceq> a \<^bold>\<and> b" unfolding conn by simp
    hence "\<eta>(a \<^bold>\<and> b) \<^bold>\<preceq> \<eta>(\<eta>(\<eta>(a) \<^bold>\<or> \<eta>(b)))" using CoPw_def copw by smt
    hence "\<eta>(a \<^bold>\<and> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<or> (\<eta> b)" using DNE_def dne by metis
  } thus ?thesis by (simp add: DM3_def)
qed
lemma CoPw_DNI_DM4: "CoPw \<eta> \<Longrightarrow> DNI \<eta> \<Longrightarrow> DM4 \<eta>" proof -
  assume copw: "CoPw \<eta>" and dni: "DNI \<eta>"
  { fix a b
    have "(\<eta> a) \<^bold>\<and> (\<eta> b) \<^bold>\<preceq> \<eta>(a)" unfolding conn by simp
    hence "\<eta>((\<eta> a)) \<^bold>\<preceq> \<eta>(\<eta>(a) \<^bold>\<and> \<eta>(b))" using CoPw_def copw by (metis (no_types, lifting))
    hence 1: "a \<^bold>\<preceq> \<eta>(\<eta>(a) \<^bold>\<and> \<eta>(b))" using DNI_def dni by metis
    have "(\<eta> a) \<^bold>\<and> (\<eta> b) \<^bold>\<preceq> \<eta>(b)" unfolding conn by simp
    hence "\<eta>((\<eta> b)) \<^bold>\<preceq> \<eta>(\<eta>(a) \<^bold>\<and> \<eta>(b))" using CoPw_def copw by (metis (no_types, lifting))
    hence 2: "b \<^bold>\<preceq> \<eta>(\<eta>(a) \<^bold>\<and> \<eta>(b))" using DNI_def dni by metis
    from 1 2 have "a \<^bold>\<or> b \<^bold>\<preceq> \<eta>(\<eta>(a) \<^bold>\<and> \<eta>(b))" unfolding conn by simp
    hence "\<eta>(\<eta>(\<eta>(a) \<^bold>\<and> \<eta>(b))) \<^bold>\<preceq> \<eta>(a \<^bold>\<or> b)" using CoPw_def copw by auto
    hence "\<eta>(a) \<^bold>\<and> \<eta>(b) \<^bold>\<preceq> \<eta>(a \<^bold>\<or> b)" using DNI_def dni by simp
  } thus ?thesis by (simp add: DM4_def)
qed
(**From this follows that DM3 (resp. DM4) is entailed by CoP2 (resp. CoP1).*)
lemma CoP2_DM3: "CoP2 \<eta> \<Longrightarrow> DM3 \<eta>" by (simp add: CoP2_def2 CoPw_DNE_DM3)
lemma CoP1_DM4: "CoP1 \<eta> \<Longrightarrow> DM4 \<eta>" by (simp add: CoP1_def2 CoPw_DNI_DM4)
(**Explore some non-entailment relations:*)
lemma "CoPw \<eta> \<Longrightarrow> DM3 \<eta> \<Longrightarrow> DM4 \<eta> \<Longrightarrow> nNor \<eta> \<Longrightarrow> nDNor \<eta> \<Longrightarrow> DNI \<eta>" nitpick oops
lemma "CoPw \<eta> \<Longrightarrow> DM3 \<eta> \<Longrightarrow> DM4 \<eta> \<Longrightarrow> nNor \<eta> \<Longrightarrow> nDNor \<eta> \<Longrightarrow> DNE \<eta>" nitpick oops
lemma "CoPw \<eta> \<Longrightarrow> DM3 \<eta> \<Longrightarrow> DM4 \<eta> \<Longrightarrow> DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> ECQm \<eta>" nitpick oops
lemma "CoPw \<eta> \<Longrightarrow> DM3 \<eta> \<Longrightarrow> DM4 \<eta> \<Longrightarrow> DNI \<eta> \<Longrightarrow> DNE \<eta> \<Longrightarrow> TNDm \<eta>" nitpick oops

subsubsection \<open>Contextual (strong) contraposition rule\<close>

(**XCoP: contextual contraposition (global/rule variant).*)
abbreviation pXCoP ("XCoP\<^sup>_\<^sup>_ _") where "XCoP\<^sup>a\<^sup>b \<eta> \<equiv> \<forall>c. c \<^bold>\<and> a \<^bold>\<preceq> b \<longrightarrow> c \<^bold>\<and> (\<eta> b) \<^bold>\<preceq> (\<eta> a)"
definition "XCoP \<eta> \<equiv> \<forall>a b. XCoP\<^sup>a\<^sup>b \<eta>"
declare XCoP_def[Defs]

(**XCoP can alternatively be defined as ECQw plus TNDw.*)
lemma XCoP_def2: "XCoP \<eta> = (ECQw \<eta> \<and> TNDw \<eta>)" proof -
  have LtoR1: "XCoP \<eta> \<Longrightarrow> ECQw \<eta>" unfolding XCoP_def ECQw_def conn by auto
  have LtoR2: "XCoP \<eta> \<Longrightarrow> TNDw \<eta>" unfolding XCoP_def TNDw_def conn by (smt atom_def atomic2 conn)
  have RtoL: "ECQw \<eta> \<and> TNDw \<eta> \<Longrightarrow> XCoP \<eta>" using XCoP_def ECQw_def TNDw_def unfolding conn by metis
  from LtoR1 LtoR2 RtoL show ?thesis by blast
qed
(**Explore some (non)entailment relations:*)
lemma "XCoP \<eta> \<Longrightarrow> ECQ \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> TND \<eta>" nitpick oops
lemma XCoP_CoPw: "XCoP \<eta> \<Longrightarrow> CoPw \<eta>" unfolding Defs conn by metis
lemma "XCoP \<eta> \<Longrightarrow> CoP1 \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> CoP2 \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> CoP3 \<eta>" nitpick oops
lemma "CoP1 \<eta> \<and> CoP2 \<eta> \<Longrightarrow> XCoP \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> nNor \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> nDNor \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> rDNI \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> rDNE \<eta>" nitpick oops
lemma XCoP_DM3: "XCoP \<eta> \<Longrightarrow> DM3 \<eta>" unfolding DM3_def XCoP_def conn using ECQw_def TNDw_def atom_def atomic2 conn by smt
lemma XCoP_DM4: "XCoP \<eta> \<Longrightarrow> DM4 \<eta>" unfolding DM4_def XCoP_def conn using ECQw_def TNDw_def atom_def atomic2 conn by smt

subsubsection \<open>Local contraposition axioms\<close>
(**Observe that the definitions below take implication as an additional parameter: @{text "\<iota>"}.*)

(**lCoP: contraposition (local/axiom variants).*)
abbreviation plCoPw ("lCoPw\<^sup>_\<^sup>_ _ _") where "lCoPw\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> a b::\<sigma>) \<^bold>\<preceq> (\<iota> (\<eta> b) (\<eta> a))"
abbreviation plCoP1 ("lCoP1\<^sup>_\<^sup>_ _ _") where "lCoP1\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> a (\<eta> b::\<sigma>)) \<^bold>\<preceq> (\<iota> b (\<eta> a))"
abbreviation plCoP2 ("lCoP2\<^sup>_\<^sup>_ _ _") where "lCoP2\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> (\<eta> a) b::\<sigma>) \<^bold>\<preceq> (\<iota> (\<eta> b) a)"
abbreviation plCoP3 ("lCoP3\<^sup>_\<^sup>_ _ _") where "lCoP3\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> (\<eta> a) (\<eta> b::\<sigma>)) \<^bold>\<preceq> (\<iota> b a)"
definition "lCoPw  \<iota> \<eta> \<equiv> \<forall>a b. lCoPw\<^sup>a\<^sup>b \<iota> \<eta>"
definition "lCoP1  \<iota> \<eta> \<equiv> \<forall>a b. lCoP1\<^sup>a\<^sup>b \<iota> \<eta>"
definition "lCoP1' \<iota> \<eta> \<equiv> \<forall>a b. (\<iota> a (\<eta> b)) \<^bold>\<approx> (\<iota> b (\<eta> a))"
definition "lCoP2  \<iota> \<eta> \<equiv> \<forall>a b. lCoP2\<^sup>a\<^sup>b \<iota> \<eta>"
definition "lCoP2' \<iota> \<eta> \<equiv> \<forall>a b. (\<iota> (\<eta> a) b) \<^bold>\<approx> (\<iota> (\<eta> b) a)"
definition "lCoP3  \<iota> \<eta> \<equiv> \<forall>a b. lCoP3\<^sup>a\<^sup>b \<iota> \<eta>"
declare lCoPw_def[Defs] lCoP1_def[Defs] lCoP1'_def[Defs]
        lCoP2_def[Defs] lCoP2'_def[Defs] lCoP3_def[Defs]

lemma lCoP1_defs_rel: "lCoP1 \<iota> \<eta> = lCoP1' \<iota> \<eta>" by (metis (full_types) lCoP1'_def lCoP1_def)
lemma lCoP2_defs_rel: "lCoP2 \<iota> \<eta> = lCoP2' \<iota> \<eta>" by (metis (full_types) lCoP2'_def lCoP2_def)

(**All local contraposition variants are in general independent from each other. However if we take
classical implication we can verify some relationships.*)

lemma lCoP1_def2: "lCoP1(\<^bold>\<rightarrow>) \<eta> = (lCoPw(\<^bold>\<rightarrow>) \<eta> \<and> DNI \<eta>)" unfolding Defs conn by smt
lemma lCoP2_def2: "lCoP2(\<^bold>\<rightarrow>) \<eta> = (lCoPw(\<^bold>\<rightarrow>) \<eta> \<and> DNE \<eta>)" unfolding Defs conn by smt

lemma "lCoP1(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoPw(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis
lemma "lCoPw(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoP1(\<^bold>\<rightarrow>) \<eta>" nitpick oops
lemma "lCoP2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoPw(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis
lemma "lCoPw(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoP2(\<^bold>\<rightarrow>) \<eta>" nitpick oops
lemma "lCoP3(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoPw(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by blast
lemma "lCoPw(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoP3(\<^bold>\<rightarrow>) \<eta>" nitpick oops
lemma lCoP123: "lCoP1(\<^bold>\<rightarrow>) \<eta> \<and> lCoP2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> lCoP3(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis

(**Local variants imply global ones as expected.*)
lemma "lCoPw(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> CoPw \<eta>" unfolding Defs conn by metis
lemma "lCoP1(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> CoP1 \<eta>" unfolding Defs conn by metis
lemma "lCoP2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> CoP2 \<eta>" unfolding Defs conn by metis
lemma "lCoP3(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> CoP3 \<eta>" unfolding Defs conn by metis

(**Explore some (non)entailment relations.*)
lemma lCoPw_XCoP: "lCoPw(\<^bold>\<rightarrow>) \<eta> = XCoP \<eta>" unfolding Defs conn by (smt XCoP_def XCoP_def2 TNDw_def conn)
lemma lCoP1_TND: "lCoP1(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> TND \<eta>" by (smt XCoP_CoPw XCoP_def2 CoP1_Nor CoP1_def2 nNor_def TND_def TNDw_def lCoP1_def2 lCoPw_XCoP conn)
lemma "TND \<eta> \<Longrightarrow> lCoP1(\<^bold>\<rightarrow>) \<eta>" nitpick oops
lemma lCoP2_ECQ: "lCoP2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> ECQ \<eta>" by (smt XCoP_CoPw XCoP_def2 CoP2_DNor CoP2_def2 nDNor_def ECQ_def ECQw_def lCoP2_def2 lCoPw_XCoP conn)
lemma "ECQ \<eta> \<Longrightarrow> lCoP2(\<^bold>\<rightarrow>) \<eta>" nitpick oops

subsubsection \<open>Local modus tollens axioms\<close>

(**lMT: Modus tollens (local/axiom variants).*)
abbreviation plMT0 ("lMT0\<^sup>_\<^sup>_ _ _") where "lMT0\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> a b::\<sigma>) \<^bold>\<and> (\<eta> b) \<^bold>\<preceq> (\<eta> a)"
abbreviation plMT1 ("lMT1\<^sup>_\<^sup>_ _ _") where "lMT1\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> a (\<eta> b::\<sigma>)) \<^bold>\<and> b \<^bold>\<preceq> (\<eta> a)"
abbreviation plMT2 ("lMT2\<^sup>_\<^sup>_ _ _") where "lMT2\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> (\<eta> a) b::\<sigma>) \<^bold>\<and> (\<eta> b) \<^bold>\<preceq> a"
abbreviation plMT3 ("lMT3\<^sup>_\<^sup>_ _ _") where "lMT3\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> (\<eta> a) (\<eta> b::\<sigma>)) \<^bold>\<and> b \<^bold>\<preceq> a"
definition "lMT0 \<iota> \<eta> \<equiv> \<forall>a b. lMT0\<^sup>a\<^sup>b \<iota> \<eta>"
definition "lMT1 \<iota> \<eta> \<equiv> \<forall>a b. lMT1\<^sup>a\<^sup>b \<iota> \<eta>"
definition "lMT2 \<iota> \<eta> \<equiv> \<forall>a b. lMT2\<^sup>a\<^sup>b \<iota> \<eta>"
definition "lMT3 \<iota> \<eta> \<equiv> \<forall>a b. lMT3\<^sup>a\<^sup>b \<iota> \<eta>"
declare lMT0_def[Defs] lMT1_def[Defs] lMT2_def[Defs] lMT3_def[Defs]

(**All local MT variants are in general independent from each other and also from local CoP instances.
However if we take classical implication we can verify that local MT and CoP are indeed equivalent.*)
lemma "lMT0(\<^bold>\<rightarrow>) \<eta> = lCoPw(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis
lemma "lMT1(\<^bold>\<rightarrow>) \<eta> = lCoP1(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis
lemma "lMT2(\<^bold>\<rightarrow>) \<eta> = lCoP2(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis
lemma "lMT3(\<^bold>\<rightarrow>) \<eta> = lCoP3(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis

subsubsection \<open>Disjunctive syllogism\<close>

(**DS: disjunctive syllogism.*)
abbreviation pDS1 ("DS1\<^sup>_\<^sup>_ _ _") where "DS1\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (a \<^bold>\<or> b::\<sigma>) \<^bold>\<preceq> (\<iota> (\<eta> a) b)"
abbreviation pDS2 ("DS2\<^sup>_\<^sup>_ _ _") where "DS2\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> (\<eta> a) b::\<sigma>) \<^bold>\<preceq> (a \<^bold>\<or> b)"
abbreviation pDS3 ("DS3\<^sup>_\<^sup>_ _ _") where "DS3\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> ((\<eta> a) \<^bold>\<or> b::\<sigma>) \<^bold>\<preceq> (\<iota> a b)"
abbreviation pDS4 ("DS4\<^sup>_\<^sup>_ _ _") where "DS4\<^sup>a\<^sup>b \<iota> \<eta> \<equiv> (\<iota> a b::\<sigma>) \<^bold>\<preceq> ((\<eta> a) \<^bold>\<or> b)"
definition "DS1 \<iota> \<eta> \<equiv> \<forall>a b. DS1\<^sup>a\<^sup>b \<iota> \<eta>"
definition "DS2 \<iota> \<eta> \<equiv> \<forall>a b. DS2\<^sup>a\<^sup>b \<iota> \<eta>"
definition "DS3 \<iota> \<eta> \<equiv> \<forall>a b. DS3\<^sup>a\<^sup>b \<iota> \<eta>"
definition "DS4 \<iota> \<eta> \<equiv> \<forall>a b. DS4\<^sup>a\<^sup>b \<iota> \<eta>"
declare DS1_def[Defs] DS2_def[Defs] DS3_def[Defs] DS4_def[Defs]

(**All DS variants are in general independent from each other. However if we take classical implication
we can verify that the pairs DS1-DS3 and DS2-DS4 are indeed equivalent. *)
lemma "DS1(\<^bold>\<rightarrow>) \<eta> = DS3(\<^bold>\<rightarrow>) \<eta>" unfolding Defs by (metis impl_def join_def)
lemma "DS2(\<^bold>\<rightarrow>) \<eta> = DS4(\<^bold>\<rightarrow>) \<eta>" unfolding Defs by (metis impl_def join_def)

(**Explore some (non)entailment relations.*)
lemma DS1_nDNor: "DS1(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> nDNor \<eta>" unfolding Defs by (metis bottom_def impl_def join_def top_def)
lemma DS2_nNor:  "DS2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> nNor \<eta>" unfolding Defs by (metis bottom_def impl_def join_def top_def)
lemma lCoP2_DS1: "lCoP2(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> DS1(\<^bold>\<rightarrow>) \<eta>" unfolding Defs conn by metis
lemma lCoP1_DS2: "lCoP1(\<^bold>\<rightarrow>) \<eta> \<Longrightarrow> DS2(\<^bold>\<rightarrow>) \<eta>" unfolding Defs by (metis (no_types, lifting) conn)
lemma "CoP2 \<eta> \<Longrightarrow> DS1(\<^bold>\<rightarrow>) \<eta>" nitpick oops
lemma "CoP1 \<eta> \<Longrightarrow> DS2(\<^bold>\<rightarrow>) \<eta>" nitpick oops

end

github-repos/isabelle/davfuenmayor-topological-semantics/topological-semantics-770a84ffa2cf8498bd5f60853d11be4d77fc8cd3/old-stuff (to migrate from old version)/Example/negation_properties.thy


section \<open>Concrete setting\<close>

theory Concrete
imports Syntactic_Criteria
begin

(* We instatiate the parameters according to Examples 1 and 2 from the paper. *)

(* Security levels: *)
datatype level = Lo | Hi

lemma [dest]: "\<And> l A. \<lbrakk>l \<in> A; Lo \<notin> A\<rbrakk> \<Longrightarrow> l = Hi" and
      [dest]: "\<And> l A. \<lbrakk>l \<in> A; Hi \<notin> A\<rbrakk> \<Longrightarrow> l = Lo"
by (metis level.exhaust)+

declare level.split[split]

instantiation level :: complete_lattice
begin
  definition top_level: "top \<equiv> Hi"
  definition bot_level: "bot \<equiv> Lo"
  definition inf_level: "inf l1 l2 \<equiv> if Lo \<in> {l1,l2} then Lo else Hi"
  definition sup_level: "sup l1 l2 \<equiv> if Hi \<in> {l1,l2} then Hi else Lo"
  definition less_eq_level: "less_eq l1 l2 \<equiv> (l1 = Lo \<or> l2 = Hi)"
  definition less_level: "less l1 l2 \<equiv> l1 = Lo \<and> l2 = Hi"
  definition Inf_level: "Inf L \<equiv> if Lo \<in> L then Lo else Hi"
  definition Sup_level: "Sup L \<equiv> if Hi \<in> L then Hi else Lo"
instance
  proof qed (auto simp: top_level bot_level inf_level sup_level
                        less_eq_level less_level Inf_level Sup_level)
end

lemma sup_eq_Lo[simp]: "sup a b = Lo \<longleftrightarrow> a = Lo \<and> b = Lo"
  by (auto simp: sup_level)

datatype var = h | h' | l | l'
datatype exp = Ct nat | Var var | Plus exp exp | Minus exp exp
datatype test = Tr | Eq exp exp | Gt exp exp | Non test
datatype atom = Assign var exp
type_synonym choice = "real + test"
type_synonym state = "var \<Rightarrow> nat"

syntax
 "_assign" :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  ("_ ::= _" [1000, 61] 61)

translations
  "x ::= expr" == "CONST Atm (CONST Assign x expr)"

primrec sec where
  "sec h  = Hi"
| "sec h' = Hi"
| "sec l  = Lo"
| "sec l' = Lo"

fun eval where
 "eval (Ct n) s = n"
|"eval (Var x) s = s x"
|"eval (Plus e1 e2) s = eval e1 s + eval e2 s"
|"eval (Minus e1 e2) s = eval e1 s - eval e2 s"

fun tval where
 "tval Tr s = True"
|"tval (Eq e1 e2) s = (eval e1 s = eval e2 s)"
|"tval (Gt e1 e2) s = (eval e1 s > eval e2 s)"
|"tval (Non e) s = (\<not> tval e s)"

fun aval where
"aval (Assign x e) s = (s (x := eval e s))"

fun cval where
 "cval (Inl p) s = min 1 (max 0 p)"
|"cval (Inr tst) s = (if tval tst s then 1 else 0)"

definition indis :: "(state * state) set"where
"indis \<equiv> {(s,t). ALL x. sec x = Lo \<longrightarrow> s x = t x}"

interpretation Example_PL: PL_Indis aval tval cval indis
proof
  fix ch :: choice and  s show "0 \<le> cval ch s \<and> cval ch s \<le> 1"
    by (cases ch) auto
next
  show "equiv UNIV indis"
    unfolding refl_on_def sym_def trans_def equiv_def indis_def by auto
qed

(* The security level of expressions: *)
fun exprSec where
 "exprSec (Ct n) = Lo"
|"exprSec (Var x) = sec x"
|"exprSec (Plus e1 e2) = sup (exprSec e1) (exprSec e2)"
|"exprSec (Minus e1 e2) = sup (exprSec e1) (exprSec e2)"

(* The security level of tests: *)
fun tstSec where
 "tstSec Tr = Lo"
|"tstSec (Eq e1 e2) = sup (exprSec e1) (exprSec e2)"
|"tstSec (Gt e1 e2) = sup (exprSec e1) (exprSec e2)"
|"tstSec (Non e) = tstSec e"

lemma exprSec_Lo_eval_eq: "exprSec expr = Lo \<Longrightarrow> (s, t) \<in> indis \<Longrightarrow> eval expr s = eval expr t"
  by (induct expr) (auto simp: indis_def)

lemma compatAtmSyntactic[simp]: "exprSec expr = Lo \<or> sec v = Hi \<Longrightarrow> Example_PL.compatAtm (Assign v expr)"
  unfolding Example_PL.compatAtm_def
  by (induct expr)
     (auto simp: indis_def intro!: arg_cong2[where f="(+)"] arg_cong2[where f="(-)"] exprSec_Lo_eval_eq)

lemma presAtmSyntactic[simp]: "sec v = Hi \<Longrightarrow> Example_PL.presAtm (Assign v expr)"
  unfolding Example_PL.presAtm_def by (simp add: indis_def)

lemma compatTstSyntactic[simp]: "tstSec tst = Lo \<Longrightarrow> Example_PL.compatTst tst"
  unfolding Example_PL.compatTst_def
  by (induct tst)
     (simp_all, safe del: iffI
              intro!: arg_cong2[where f="(=)"] arg_cong2[where f="(<) :: nat \<Rightarrow> nat \<Rightarrow> bool"] exprSec_Lo_eval_eq)

(* Stateless choices are always compatible: *)
lemma compatPrchSyntactic[simp]: "Example_PL.compatCh (Inl p)"
  unfolding Example_PL.compatCh_def by auto

(* A test-choice is compatible iff its test is compatible: *)
lemma compatIfchSyntactic[simp]: "Example_PL.compatCh (Inr tst) \<longleftrightarrow> Example_PL.compatTst tst"
  unfolding Example_PL.compatCh_def Example_PL.compatTst_def by auto

abbreviation Ch_half ("Ch\<^sub>\<onehalf>") where "Ch\<^sub>\<onehalf> \<equiv> Ch (Inl (1/2))"
abbreviation If where "If tst \<equiv> Ch (Inr tst)"

abbreviation "siso c \<equiv> Example_PL.siso c"
abbreviation "discr c \<equiv> Example_PL.discr c"
abbreviation Sbis_abbrev (infix "\<approx>s" 55) where "c1 \<approx>s c2 \<equiv> (c1,c2) \<in> Example_PL.Sbis"
abbreviation ZObis_abbrev (infix "\<approx>01" 55) where "c1 \<approx>01 c2 \<equiv> (c1,c2) \<in> Example_PL.ZObis"

abbreviation "SC_siso c \<equiv> Example_PL.SC_siso c"
abbreviation "SC_discr c \<equiv> Example_PL.SC_discr c"
abbreviation "SC_Sbis c \<equiv> Example_PL.SC_Sbis c"
abbreviation "SC_ZObis c \<equiv> Example_PL.SC_ZObis c"

subsection \<open>The secure programs from the paper's Example 3\<close>

definition [simp]: "d0 =
  h' ::= Ct 0 ;;
  While (Gt (Var h) (Ct 0))
    (Ch\<^sub>\<onehalf> (h ::= Ct 0)
         (h' ::= Plus (Var h') (Ct 1)))"

definition [simp]: "d1 =
  While (Gt (Var h) (Ct 0))
    (Ch\<^sub>\<onehalf> (h ::= Minus (Var h) (Ct 1))
         (h ::= Plus (Var h) (Ct 1)))"

definition [simp]: "d2 =
  If (Eq (Var l) (Ct 0))
    (l' ::= Ct 1)
    d0"

definition [simp]: "d3 =
  h ::= Ct 5 ;;
  ParT [d0, (l ::= Ct 1)]"

(* The syntactic criteria are checked automatically: *)
theorem "SC_discr d0"
        "SC_discr d1"
        "SC_Sbis d2"
        "SC_ZObis d2"
  by (auto simp: Example_PL.SC_discr.simps Example_PL.SC_Sbis.simps Example_PL.SC_ZObis.simps)

(* Alternatively, the semantic notions follow directly from the compositionality facts
used as intro rules: *)
theorem "discr d0"
        "discr d1"
        "d2 \<approx>s d2"
        "d3 \<approx>01 d3"
  by (auto intro!: compatAtmSyntactic
                   Example_PL.ZObis Example_PL.proper_intros
                   Example_PL.Atm_Sbis)

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
                 Jose Divason
    License:     BSD
*)
section \<open>Missing Unsorted\<close>

text \<open>This theory contains several lemmas which might be of interest to the Isabelle distribution.
  For instance, we prove that $b^n \cdot n^k$ is bounded by a constant whenever $0 < b < 1$.\<close>

theory Missing_Unsorted
imports
  HOL.Complex "HOL-Computational_Algebra.Factorial_Ring"
begin

lemma bernoulli_inequality: assumes x: "-1 \<le> (x :: 'a :: linordered_field)"
  shows "1 + of_nat n * x \<le> (1 + x) ^ n"
proof (induct n)
  case (Suc n)
  have "1 + of_nat (Suc n) * x = 1 + x + of_nat n * x" by (simp add: field_simps)
  also have "\<dots> \<le> \<dots> + of_nat n * x ^ 2" by simp
  also have "\<dots> = (1 + of_nat n * x) * (1 + x)" by (simp add: field_simps power2_eq_square)
  also have "\<dots> \<le> (1 + x) ^ n * (1 + x)"
    by (rule mult_right_mono[OF Suc], insert x, auto)
  also have "\<dots> = (1 + x) ^ (Suc n)" by simp
  finally show ?case .
qed simp

context
  fixes b :: "'a :: archimedean_field"
  assumes b: "0 < b" "b < 1"
begin
private lemma pow_one: "b ^ x \<le> 1" using power_Suc_less_one[OF b, of "x - 1"] by (cases x, auto)

private lemma pow_zero: "0 < b ^ x" using b(1) by simp

lemma exp_tends_to_zero: assumes c: "c > 0"
  shows "\<exists> x. b ^ x \<le> c"
proof (rule ccontr)
  assume not: "\<not> ?thesis"
  define bb where "bb = inverse b"
  define cc where "cc = inverse c"
  from b have bb: "bb > 1" unfolding bb_def by (rule one_less_inverse)
  from c have cc: "cc > 0" unfolding cc_def by simp
  define bbb where "bbb = bb - 1"
  have id: "bb = 1 + bbb" and bbb: "bbb > 0" and bm1: "bbb \<ge> -1" unfolding bbb_def using bb by auto
  have "\<exists> n. cc / bbb < of_nat n" by (rule reals_Archimedean2)
  then obtain n where lt: "cc / bbb < of_nat n" by auto
  from not have "\<not> b ^ n \<le> c" by auto
  hence bnc: "b ^ n > c" by simp
  have "bb ^ n = inverse (b ^ n)" unfolding bb_def by (rule power_inverse)
  also have "\<dots> < cc" unfolding cc_def
    by (rule less_imp_inverse_less[OF bnc c])
  also have "\<dots> < bbb * of_nat n" using lt bbb by (metis mult.commute pos_divide_less_eq)
  also have "\<dots> \<le> bb ^ n"
    using bernoulli_inequality[OF bm1, folded id, of n] by (simp add: ac_simps)
  finally show False by simp
qed

lemma linear_exp_bound: "\<exists> p. \<forall> x. b ^ x * of_nat x \<le> p"
proof -
  from b have "1 - b > 0" by simp
  from exp_tends_to_zero[OF this]
  obtain x0 where x0: "b ^ x0 \<le> 1 - b" ..
  {
    fix x
    assume "x \<ge> x0"
    hence "\<exists> y. x = x0 + y" by arith
    then obtain y where x: "x = x0 + y" by auto
    have "b ^ x = b ^ x0 * b ^ y" unfolding x by (simp add: power_add)
    also have "\<dots> \<le> b ^ x0" using pow_one[of y] pow_zero[of x0] by auto
    also have "\<dots> \<le> 1 - b" by (rule x0)
    finally have "b ^ x \<le> 1 - b" .
  } note x0 = this
  define bs where "bs = insert 1 { b ^ Suc x * of_nat (Suc x) | x . x \<le> x0}"
  have bs: "finite bs" unfolding bs_def by auto
  define p where "p = Max bs"
  have bs: "\<And> b. b \<in> bs \<Longrightarrow> b \<le> p" unfolding p_def using bs by simp
  hence p1: "p \<ge> 1" unfolding bs_def by auto
  show ?thesis
  proof (rule exI[of _ p], intro allI)
    fix x
    show "b ^ x * of_nat x \<le> p"
    proof (induct x)
      case (Suc x)
      show ?case
      proof (cases "x \<le> x0")
        case True
        show ?thesis
          by (rule bs, unfold bs_def, insert True, auto)
      next
        case False
        let ?x = "of_nat x :: 'a"
        have "b ^ (Suc x) * of_nat (Suc x) = b * (b ^ x * ?x) + b ^ Suc x" by (simp add: field_simps)
        also have "\<dots> \<le> b * p + b ^ Suc x"
          by (rule add_right_mono[OF mult_left_mono[OF Suc]], insert b, auto)
        also have "\<dots> = p - ((1 - b) * p - b ^ (Suc x))" by (simp add: field_simps)
        also have "\<dots> \<le> p - 0"
        proof -
          have "b ^ Suc x \<le> 1 - b" using x0[of "Suc x"] False by auto
          also have "\<dots> \<le> (1 - b) * p" using b p1 by auto
          finally show ?thesis
            by (intro diff_left_mono, simp)
        qed
        finally show ?thesis by simp
      qed
    qed (insert p1, auto)
  qed
qed

lemma poly_exp_bound: "\<exists> p. \<forall> x. b ^ x * of_nat x ^ deg \<le> p"
proof -
  show ?thesis
  proof (induct deg)
    case 0
    show ?case
      by (rule exI[of _ 1], intro allI, insert pow_one, auto)
  next
    case (Suc deg)
    then obtain q where IH: "\<And> x. b ^ x * (of_nat x) ^ deg \<le> q" by auto
    define p where "p = max 0 q"
    from IH have IH: "\<And> x. b ^ x * (of_nat x) ^ deg \<le> p" unfolding p_def using le_max_iff_disj by blast
    have p: "p \<ge> 0" unfolding p_def by simp
    show ?case
    proof (cases "deg = 0")
      case True
      thus ?thesis using linear_exp_bound by simp
    next
      case False note deg = this
      define p' where "p' = p*p * 2 ^ Suc deg * inverse b"
      let ?f = "\<lambda> x. b ^ x * (of_nat x) ^ Suc deg"
      define f where "f = ?f"
      {
        fix x
        let ?x = "of_nat x :: 'a"
        have "f (2 * x) \<le> (2 ^ Suc deg) * (p * p)"
        proof (cases "x = 0")
          case False
          hence x1: "?x \<ge> 1" by (cases x, auto)
          from x1 have x: "?x ^ (deg - 1) \<ge> 1" by simp
          from x1 have xx: "?x ^ Suc deg \<ge> 1" by (rule one_le_power)
          define c where "c = b ^ x * b ^ x * (2 ^ Suc deg)"
          have c: "c > 0" unfolding c_def using b by auto
          have "f (2 * x) = ?f (2 * x)" unfolding f_def by simp
          also have "b ^ (2 * x) = (b ^ x) * (b ^ x)" by (simp add: power2_eq_square power_even_eq)
          also have "of_nat (2 * x) = 2 * ?x" by simp
          also have "(2 * ?x) ^ Suc deg = 2 ^ Suc deg * ?x ^ Suc deg" by simp
          finally have "f (2 * x) = c * ?x ^ Suc deg" unfolding c_def by (simp add: ac_simps)
          also have "\<dots> \<le> c * ?x ^ Suc deg * ?x ^ (deg - 1)"
          proof -
            have "c * ?x ^ Suc deg > 0" using c xx by simp
            thus ?thesis unfolding mult_le_cancel_left1 using x by simp
          qed
          also have "\<dots> = c * ?x ^ (Suc deg + (deg - 1))" by (simp add: power_add)
          also have "Suc deg + (deg - 1) = deg + deg" using deg by simp
          also have "?x ^ (deg + deg) = (?x ^ deg) * (?x ^ deg)" by (simp add: power_add)
          also have "c * \<dots> = (2 ^ Suc deg) * ((b ^ x * ?x ^ deg) * (b ^ x * ?x ^ deg))"
            unfolding c_def by (simp add: ac_simps)
          also have "\<dots> \<le> (2 ^ Suc deg) * (p * p)"
            by (rule mult_left_mono[OF mult_mono[OF IH IH p]], insert pow_zero[of x], auto)
          finally show "f (2 * x) \<le> (2 ^ Suc deg) * (p * p)" .
        qed (auto simp: f_def)
        hence "?f (2 * x) \<le> (2 ^ Suc deg) * (p * p)" unfolding f_def .
      } note even = this
      show ?thesis
      proof (rule exI[of _ p'], intro allI)
        fix y
        show "?f y \<le> p'"
        proof (cases "even y")
          case True
          define x where "x = y div 2"
          have "y = 2 * x" unfolding x_def using True by simp
          from even[of x, folded this] have "?f y \<le> 2 ^ Suc deg * (p * p)" .
          also have "\<dots> \<le> \<dots> * inverse b"
            unfolding mult_le_cancel_left1 using b p
            by (simp add: algebra_split_simps one_le_inverse)
          also have "\<dots> = p'" unfolding p'_def by (simp add: ac_simps)
          finally show "?f y \<le> p'" .
        next
          case False
          define x where "x = y div 2"
          have "y = 2 * x + 1" unfolding x_def using False by simp
          hence "?f y = ?f (2 * x + 1)" by simp
          also have "\<dots> \<le> b ^ (2 * x + 1) * of_nat (2 * x + 2) ^ Suc deg"
            by (rule mult_left_mono[OF power_mono], insert b, auto)
          also have "b ^ (2 * x + 1) = b ^ (2 * x + 2) * inverse b" using b by auto
          also have "b ^ (2 * x + 2) * inverse b * of_nat (2 * x + 2) ^ Suc deg =
            inverse b * ?f (2 * (x + 1))" by (simp add: ac_simps)
          also have "\<dots> \<le> inverse b * ((2 ^ Suc deg) * (p * p))"
            by (rule mult_left_mono[OF even], insert b, auto)
          also have "\<dots> = p'" unfolding p'_def by (simp add: ac_simps)
          finally show "?f y \<le> p'" .
        qed
      qed
    qed
  qed
qed
end

lemma prod_list_replicate[simp]: "prod_list (replicate n a) = a ^ n"
  by (induct n, auto)

lemma prod_list_power: fixes xs :: "'a :: comm_monoid_mult list"
  shows "prod_list xs ^ n = (\<Prod>x\<leftarrow>xs. x ^ n)"
  by (induct xs, auto simp: power_mult_distrib)

lemma set_upt_Suc: "{0 ..< Suc i} = insert i {0 ..< i}"
  by (fact atLeast0_lessThan_Suc)

lemma prod_pow[simp]: "(\<Prod>i = 0..<n. p) = (p :: 'a :: comm_monoid_mult) ^ n"
  by (induct n, auto simp: set_upt_Suc)

(* GCD and LCM part *)

lemma dvd_abs_mult_left_int [simp]:
  "\<bar>a\<bar> * y dvd x \<longleftrightarrow> a * y dvd x" for x y a :: int
  using abs_dvd_iff [of "a * y"] abs_dvd_iff [of "\<bar>a\<bar> * y"]
  by (simp add: abs_mult)

lemma gcd_abs_mult_right_int [simp]:
  "gcd x (\<bar>a\<bar> * y) = gcd x (a * y)" for x y a :: int
  using gcd_abs2_int [of _ "a * y"] gcd_abs2_int [of _ "\<bar>a\<bar> * y"]
  by (simp add: abs_mult)

lemma lcm_abs_mult_right_int [simp]:
  "lcm x (\<bar>a\<bar> * y) = lcm x (a * y)" for x y a :: int
  using lcm_abs2_int [of _ "a * y"] lcm_abs2_int [of _ "\<bar>a\<bar> * y"]
  by (simp add: abs_mult)

lemma gcd_abs_mult_left_int [simp]:
  "gcd x (a * \<bar>y\<bar>) = gcd x (a * y)" for x y a :: int
  using gcd_abs2_int [of _ "a * \<bar>y\<bar>"] gcd_abs2_int [of _ "a * y"]
  by (simp add: abs_mult)

lemma lcm_abs_mult_left_int [simp]:
  "lcm x (a * \<bar>y\<bar>) = lcm x (a * y)" for x y a :: int
  using lcm_abs2_int [of _ "a * \<bar>y\<bar>"] lcm_abs2_int [of _ "a * y"]
  by (simp add: abs_mult)

abbreviation (input) list_gcd :: "'a :: semiring_gcd list \<Rightarrow> 'a" where
  "list_gcd \<equiv> gcd_list"

abbreviation (input) list_lcm :: "'a :: semiring_gcd list \<Rightarrow> 'a" where
  "list_lcm \<equiv> lcm_list"

lemma list_gcd_simps: "list_gcd [] = 0" "list_gcd (x # xs) = gcd x (list_gcd xs)"
  by simp_all

lemma list_gcd: "x \<in> set xs \<Longrightarrow> list_gcd xs dvd x"
  by (fact Gcd_fin_dvd)

lemma list_gcd_greatest: "(\<And> x. x \<in> set xs \<Longrightarrow> y dvd x) \<Longrightarrow> y dvd (list_gcd xs)"
  by (fact gcd_list_greatest)

lemma list_gcd_mult_int [simp]:
  fixes xs :: "int list"
  shows "list_gcd (map (times a) xs) = \<bar>a\<bar> * list_gcd xs"
  by (simp add: Gcd_mult abs_mult)

lemma list_lcm_simps: "list_lcm [] = 1" "list_lcm (x # xs) = lcm x (list_lcm xs)"
  by simp_all

lemma list_lcm: "x \<in> set xs \<Longrightarrow> x dvd list_lcm xs"
  by (fact dvd_Lcm_fin)

lemma list_lcm_least: "(\<And> x. x \<in> set xs \<Longrightarrow> x dvd y) \<Longrightarrow> list_lcm xs dvd y"
  by (fact lcm_list_least)

lemma lcm_mult_distrib_nat: "(k :: nat) * lcm m n = lcm (k * m) (k * n)"
  by (simp add: lcm_mult_left)

lemma lcm_mult_distrib_int: "abs (k::int) * lcm m n = lcm (k * m) (k * n)"
  by (simp add: lcm_mult_left abs_mult)

lemma list_lcm_mult_int [simp]:
  fixes xs :: "int list"
  shows "list_lcm (map (times a) xs) = (if xs = [] then 1 else \<bar>a\<bar> * list_lcm xs)"
  by (simp add: Lcm_mult abs_mult)

lemma list_lcm_pos:
  "list_lcm xs \<ge> (0 :: int)"
  "0 \<notin> set xs \<Longrightarrow> list_lcm xs \<noteq> 0"
  "0 \<notin> set xs \<Longrightarrow> list_lcm xs > 0"
proof -
  have "0 \<le> \<bar>Lcm (set xs)\<bar>"
    by (simp only: abs_ge_zero)
  then have "0 \<le> Lcm (set xs)"
    by simp
  then show "list_lcm xs \<ge> 0"
    by simp
  assume "0 \<notin> set xs"
  then show "list_lcm xs \<noteq> 0"
    by (simp add: Lcm_0_iff)
  with \<open>list_lcm xs \<ge> 0\<close> show "list_lcm xs > 0"
    by (simp add: le_less)
qed

lemma quotient_of_nonzero: "snd (quotient_of r) > 0" "snd (quotient_of r) \<noteq> 0"
  using quotient_of_denom_pos' [of r] by simp_all

lemma quotient_of_int_div: assumes q: "quotient_of (of_int x / of_int y) = (a, b)"
  and y: "y \<noteq> 0"
  shows "\<exists> z. z \<noteq> 0 \<and> x = a * z \<and> y = b * z"
proof -
  let ?r = "rat_of_int"
  define z where "z = gcd x y"
  define x' where "x' = x div z"
  define y' where "y' = y div z"
  have id: "x = z * x'" "y = z * y'" unfolding x'_def y'_def z_def by auto
  from y have y': "y' \<noteq> 0" unfolding id by auto
  have z: "z \<noteq> 0" unfolding z_def using y by auto
  have cop: "coprime x' y'" unfolding x'_def y'_def z_def
    using div_gcd_coprime y by blast
  have "?r x / ?r y = ?r x' / ?r y'" unfolding id using z y y' by (auto simp: field_simps)
  from assms[unfolded this] have quot: "quotient_of (?r x' / ?r y') = (a, b)" by auto
  from quotient_of_coprime[OF quot] have cop': "coprime a b" .
  hence cop: "coprime b a"
    by (simp add: ac_simps)
  from quotient_of_denom_pos[OF quot] have b: "b > 0" "b \<noteq> 0" by auto
  from quotient_of_div[OF quot] quotient_of_denom_pos[OF quot] y'
  have "?r x' * ?r b = ?r a * ?r y'" by (auto simp: field_simps)
  hence id': "x' * b = a * y'" unfolding of_int_mult[symmetric] by linarith
  from id'[symmetric] have "b dvd y' * a" unfolding mult.commute[of y'] by auto
  with cop y' have "b dvd y'"
    by (simp add: coprime_dvd_mult_left_iff)
  then obtain z' where ybz: "y' = b * z'" unfolding dvd_def by auto
  from id[unfolded y' this] have y: "y = b * (z * z')" by auto
  with \<open>y \<noteq> 0\<close> have zz: "z * z' \<noteq> 0" by auto
  from quotient_of_div[OF q] \<open>y \<noteq> 0\<close> \<open>b \<noteq> 0\<close>
  have "?r x * ?r b = ?r y * ?r a" by (auto simp: field_simps)
  hence id': "x * b = y * a" unfolding of_int_mult[symmetric] by linarith
  from this[unfolded y] b have x: "x = a * (z * z')" by auto
  show ?thesis unfolding x y using zz by blast
qed

fun max_list_non_empty :: "('a :: linorder) list \<Rightarrow> 'a" where
  "max_list_non_empty [x] = x"
| "max_list_non_empty (x # xs) = max x (max_list_non_empty xs)"

lemma max_list_non_empty: "x \<in> set xs \<Longrightarrow> x \<le> max_list_non_empty xs"
proof (induct xs)
  case (Cons y ys) note oCons = this
  show ?case
  proof (cases ys)
    case (Cons z zs)
    hence id: "max_list_non_empty (y # ys) = max y (max_list_non_empty ys)" by simp
    from oCons show ?thesis unfolding id by (auto simp: max.coboundedI2)
  qed (insert oCons, auto)
qed simp

lemma cnj_reals[simp]: "(cnj c \<in> \<real>) = (c \<in> \<real>)"
  using Reals_cnj_iff by fastforce

lemma sgn_real_mono: "x \<le> y \<Longrightarrow> sgn x \<le> sgn (y :: real)"
  unfolding sgn_real_def
  by (auto split: if_splits)

lemma sgn_minus_rat: "sgn (- (x :: rat)) = - sgn x"
  by (fact Rings.sgn_minus)

lemma real_of_rat_sgn: "sgn (of_rat x) = real_of_rat (sgn x)"
  unfolding sgn_real_def sgn_rat_def by auto

lemma inverse_le_iff_sgn: assumes sgn: "sgn x = sgn y"
  shows "(inverse (x :: real) \<le> inverse y) = (y \<le> x)"
proof (cases "x = 0")
  case True
  with sgn have "sgn y = 0" by simp
  hence "y = 0" unfolding sgn_real_def by (cases "y = 0"; cases "y < 0"; auto)
  thus ?thesis using True by simp
next
  case False note x = this
  show ?thesis
  proof (cases "x < 0")
    case True
    with x sgn have "sgn y = -1" by simp
    hence "y < 0" unfolding sgn_real_def by (cases "y = 0"; cases "y < 0", auto)
    show ?thesis
      by (rule inverse_le_iff_le_neg[OF True \<open>y < 0\<close>])
  next
    case False
    with x have x: "x > 0" by auto
    with sgn have "sgn y = 1" by auto
    hence "y > 0" unfolding sgn_real_def by (cases "y = 0"; cases "y < 0", auto)
    show ?thesis
      by (rule inverse_le_iff_le[OF x \<open>y > 0\<close>])
  qed
qed

lemma inverse_le_sgn: assumes sgn: "sgn x = sgn y" and xy: "x \<le> (y :: real)"
  shows "inverse y \<le> inverse x"
  using xy inverse_le_iff_sgn[OF sgn] by auto

lemma set_list_update: "set (xs [i := k]) =
  (if i < length xs then insert k (set (take i xs) \<union> set (drop (Suc i) xs)) else set xs)"
proof (induct xs arbitrary: i)
  case (Cons x xs i)
  thus ?case
    by (cases i, auto)
qed simp

lemma prod_list_dvd: assumes "(x :: 'a :: comm_monoid_mult) \<in> set xs"
  shows "x dvd prod_list xs"
proof -
  from assms[unfolded in_set_conv_decomp] obtain ys zs where xs: "xs = ys @ x # zs" by auto
  show ?thesis unfolding xs dvd_def by (intro exI[of _ "prod_list (ys @ zs)"], simp add: ac_simps)
qed

lemma dvd_prod:
fixes A::"'b set"
assumes "\<exists>b\<in>A. a dvd f b" "finite A"
shows "a dvd prod f A"
using assms(2,1)
proof (induct A)
  case (insert x A)
  thus ?case
    using comm_monoid_mult_class.dvd_mult dvd_mult2 insert_iff prod.insert by auto
qed auto

context
  fixes xs :: "'a :: comm_monoid_mult list"
begin

lemma prod_list_partition: assumes "partition f xs = (ys, zs)"
  shows "prod_list xs = prod_list ys * prod_list zs"
  using assms by (subst prod_list_filter[symmetric, of f], auto simp: o_def)
end

lemma dvd_imp_mult_div_cancel_left[simp]:
  assumes "(a :: 'a :: semidom_divide) dvd b"
  shows "a * (b div a) = b"
proof(cases "b = 0")
  case True then show ?thesis by auto
next
  case False
  with dvdE[OF assms] obtain c where *: "b = a * c" by auto
  also with False have "a \<noteq> 0" by auto
  then have "a * c div a = c" by auto
  also note *[symmetric]
  finally show ?thesis.
qed

lemma (in semidom) prod_list_zero_iff[simp]:
  "prod_list xs = 0 \<longleftrightarrow> 0 \<in> set xs" by (induction xs, auto)

context comm_monoid_mult begin

lemma unit_prod [intro]:
  shows "a dvd 1 \<Longrightarrow> b dvd 1 \<Longrightarrow> (a * b) dvd 1"
  by (subst mult_1_left [of 1, symmetric]) (rule mult_dvd_mono)

lemma is_unit_mult_iff[simp]:
  shows "(a * b) dvd 1 \<longleftrightarrow> a dvd 1 \<and> b dvd 1"
  by (auto dest: dvd_mult_left dvd_mult_right)

end

context comm_semiring_1
begin
lemma irreducibleE[elim]:
  assumes "irreducible p"
      and "p \<noteq> 0 \<Longrightarrow> \<not> p dvd 1 \<Longrightarrow> (\<And>a b. p = a * b \<Longrightarrow> a dvd 1 \<or> b dvd 1) \<Longrightarrow> thesis"
  shows thesis using assms by (auto simp: irreducible_def)

lemma not_irreducibleE:
  assumes "\<not> irreducible x"
      and "x = 0 \<Longrightarrow> thesis"
      and "x dvd 1 \<Longrightarrow> thesis"
      and "\<And>a b. x = a * b \<Longrightarrow> \<not> a dvd 1 \<Longrightarrow> \<not> b dvd 1 \<Longrightarrow> thesis"
  shows thesis using assms unfolding irreducible_def by auto

lemma prime_elem_dvd_prod_list:
  assumes p: "prime_elem p" and pA: "p dvd prod_list A" shows "\<exists>a \<in> set A. p dvd a"
proof(insert pA, induct A)
  case Nil
  with p show ?case by (simp add: prime_elem_not_unit)
next
  case (Cons a A)
  then show ?case by (auto simp: prime_elem_dvd_mult_iff[OF p])
qed

lemma prime_elem_dvd_prod_mset:
  assumes p: "prime_elem p" and pA: "p dvd prod_mset A" shows "\<exists>a \<in># A. p dvd a"
proof(insert pA, induct A)
  case empty
  with p show ?case by (simp add: prime_elem_not_unit)
next
  case (add a A)
  then show ?case by (auto simp: prime_elem_dvd_mult_iff[OF p])
qed

lemma mult_unit_dvd_iff[simp]:
  assumes "b dvd 1"
  shows "a * b dvd c \<longleftrightarrow> a dvd c"
proof
  assume "a * b dvd c"
  with assms show "a dvd c" using dvd_mult_left[of a b c] by simp
next
  assume "a dvd c"
  with assms mult_dvd_mono show "a * b dvd c" by fastforce
qed

lemma mult_unit_dvd_iff'[simp]: "a dvd 1 \<Longrightarrow> (a * b) dvd c \<longleftrightarrow> b dvd c"
  using mult_unit_dvd_iff [of a b c] by (simp add: ac_simps)

lemma irreducibleD':
  assumes "irreducible a" "b dvd a"
  shows   "a dvd b \<or> b dvd 1"
proof -
  from assms obtain c where c: "a = b * c" by (elim dvdE)
  from irreducibleD[OF assms(1) this] have "b dvd 1 \<or> c dvd 1" .
  thus ?thesis by (auto simp: c)
qed

end

context idom
begin

text \<open>
  Following lemmas are adapted and generalized so that they don't use "algebraic" classes.
\<close>

lemma dvd_times_left_cancel_iff [simp]:
  assumes "a \<noteq> 0"
  shows "a * b dvd a * c \<longleftrightarrow> b dvd c"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then obtain d where "a * c = a * b * d" ..
  with assms have "c = b * d" by (auto simp add: ac_simps)
  then show ?rhs ..
next
  assume ?rhs
  then obtain d where "c = b * d" ..
  then have "a * c = a * b * d" by (simp add: ac_simps)
  then show ?lhs ..
qed

lemma dvd_times_right_cancel_iff [simp]:
  assumes "a \<noteq> 0"
  shows "b * a dvd c * a \<longleftrightarrow> b dvd c"
  using dvd_times_left_cancel_iff [of a b c] assms by (simp add: ac_simps)

lemma irreducibleI':
  assumes "a \<noteq> 0" "\<not> a dvd 1" "\<And>b. b dvd a \<Longrightarrow> a dvd b \<or> b dvd 1"
  shows   "irreducible a"
proof (rule irreducibleI)
  fix b c assume a_eq: "a = b * c"
  hence "a dvd b \<or> b dvd 1" by (intro assms) simp_all
  thus "b dvd 1 \<or> c dvd 1"
  proof
    assume "a dvd b"
    hence "b * c dvd b * 1" by (simp add: a_eq)
    moreover from \<open>a \<noteq> 0\<close> a_eq have "b \<noteq> 0" by auto
    ultimately show ?thesis using dvd_times_left_cancel_iff by fastforce
  qed blast
qed (simp_all add: assms(1,2))

lemma irreducible_altdef:
  shows "irreducible x \<longleftrightarrow> x \<noteq> 0 \<and> \<not> x dvd 1 \<and> (\<forall>b. b dvd x \<longrightarrow> x dvd b \<or> b dvd 1)"
  using irreducibleI'[of x] irreducibleD'[of x] irreducible_not_unit[of x] by auto

lemma dvd_mult_unit_iff:
  assumes b: "b dvd 1"
  shows "a dvd c * b \<longleftrightarrow> a dvd c"
proof-
  from b obtain b' where 1: "b * b' = 1" by (elim dvdE, auto)
  then have b0: "b \<noteq> 0" by auto
  from 1 have "a = (a * b') * b" by (simp add: ac_simps)
  also have "\<dots> dvd c * b \<longleftrightarrow> a * b' dvd c" using b0 by auto
  finally show ?thesis by (auto intro: dvd_mult_left)
qed

lemma dvd_mult_unit_iff': "b dvd 1 \<Longrightarrow> a dvd b * c \<longleftrightarrow> a dvd c"
  using dvd_mult_unit_iff [of b a c] by (simp add: ac_simps)

lemma irreducible_mult_unit_left:
  shows "a dvd 1 \<Longrightarrow> irreducible (a * p) \<longleftrightarrow> irreducible p"
  by (auto simp: irreducible_altdef mult.commute[of a] dvd_mult_unit_iff)

lemma irreducible_mult_unit_right:
  shows "a dvd 1 \<Longrightarrow> irreducible (p * a) \<longleftrightarrow> irreducible p"
  by (auto simp: irreducible_altdef mult.commute[of a] dvd_mult_unit_iff)

lemma prime_elem_imp_irreducible:
  assumes "prime_elem p"
  shows   "irreducible p"
proof (rule irreducibleI)
  fix a b
  assume p_eq: "p = a * b"
  with assms have nz: "a \<noteq> 0" "b \<noteq> 0" by auto
  from p_eq have "p dvd a * b" by simp
  with \<open>prime_elem p\<close> have "p dvd a \<or> p dvd b" by (rule prime_elem_dvd_multD)
  with \<open>p = a * b\<close> have "a * b dvd 1 * b \<or> a * b dvd a * 1" by auto
  thus "a dvd 1 \<or> b dvd 1"
    by (simp only: dvd_times_left_cancel_iff[OF nz(1)] dvd_times_right_cancel_iff[OF nz(2)])
qed (insert assms, simp_all add: prime_elem_def)

lemma unit_imp_dvd [dest]: "b dvd 1 \<Longrightarrow> b dvd a"
  by (rule dvd_trans [of _ 1]) simp_all

lemma unit_mult_left_cancel: "a dvd 1 \<Longrightarrow> a * b = a * c \<longleftrightarrow> b = c"
  using mult_cancel_left [of a b c] by auto

text \<open>New parts from here\<close>

lemma irreducible_multD:
  assumes l: "irreducible (a*b)"
  shows "a dvd 1 \<and> irreducible b \<or> b dvd 1 \<and> irreducible a"
proof-
  from l have "a dvd 1 \<or> b dvd 1" using irreducibleD by auto
  then show ?thesis
  proof(elim disjE)
    assume a: "a dvd 1"
    with l have "irreducible b"
      unfolding irreducible_def
      by (metis is_unit_mult_iff mult.left_commute mult_not_zero)
    with a show ?thesis by auto
  next
    assume a: "b dvd 1"
    with l have "irreducible a"
      unfolding irreducible_def
      by (meson is_unit_mult_iff mult_not_zero semiring_normalization_rules(16))
    with a show ?thesis by auto
  qed
qed

end

lemma (in field) irreducible_field[simp]:
  "irreducible x \<longleftrightarrow> False" by (auto simp: dvd_field_iff irreducible_def)

lemma (in idom) irreducible_mult:
  shows "irreducible (a*b) \<longleftrightarrow> a dvd 1 \<and> irreducible b \<or> b dvd 1 \<and> irreducible a"
  by (auto dest: irreducible_multD simp: irreducible_mult_unit_left irreducible_mult_unit_right)

end


theory Nejednacina
  imports HOL.Real Main
begin

lemma saberi_levo [simp]:
  fixes a b :: real
  assumes "a > 0"
  assumes "b > 0"
  shows "a + b > a"
  using assms
  by auto

lemma saberi_desno [simp]:
  fixes a b :: real
  assumes "a > 0"
  assumes "b > 0"
  shows "b + a > a"
  using assms
  by auto

lemma pomnozi_levo [simp]:
  fixes a b :: real
  assumes "a > 0"
  assumes "b > 0"
  assumes "a < 1"
  assumes "b < 1"
  shows "a * b < a"
  using assms
  by auto

lemma pomnozi_desno [simp]:
  fixes a b :: real
  assumes "a > 0"
  assumes "b > 0"
  assumes "a < 1"
  assumes "b < 1"
  shows " b * a < a"
  using assms
  by auto

lemma kroz_jedan [simp]:
  fixes a :: real
  shows "a/1=a"
  by auto

lemma poredjenje_u_imeniocu [simp]:
  fixes a b :: real
  assumes "b > 0"
  assumes "a > 0"
  assumes "b > a"
  shows "1/b < 1/a"
  by (simp add: assms(2) assms(3) frac_less2)

lemma stepenovan_pozitivan [simp]:
   fixes a :: real and n::nat
   assumes "a > 0"
   assumes "a < 1"
   shows "a ^ n > 0"
   using assms
   apply (induction n)
    apply auto
   done

lemma proizvod_pozitivan [simp]:
  fixes a b :: real
  assumes "b > 0"
  assumes "a > 0"
  shows "a*b > 0"
  using assms
  by auto

lemma zbir_pozitivan [simp]:
  fixes a b :: real
  assumes "b > 0"
  assumes "a > 0"
  shows "a+b > 0"
  using assms
  by auto

lemma pomocna [simp]:
fixes a b c:: real
  assumes "b < c"
  assumes "a > 0"
  assumes "b > 0"
  assumes "c > 0"
  shows "a*b < a*c"
  using assms
  by auto

lemma pomocna2 [simp]:
  fixes a:: real
  assumes "a > 0"
  shows "1 / a > 0"
  using assms
  by auto

lemma moj_seminarski:

  fixes a b c :: real
  assumes "a+b+c=1" : zbir
  assumes "a > 0"
  assumes "b > 0"
  assumes "c > 0"
  shows " a/(a^3 + b^2*c + c^2*b) + b/(b^3 + c^2*a + a^2*c) + c/(c^3 + a^2*b + b^2*a) ≤ 1 + 8/27*a*b*c "
  using assms
proof-
  from `c>0 `have "c^2 > 0" by auto
  from this and `b>0 ` have "c^2*b > 0" by auto
  from  `b>0 ` and  `c>0 ` have "b^2*c > 0" by auto
  from `c^2*b > 0` and `b^2*c > 0` have "b^2*c + c^2*b >0" by auto
  from `a>0 `have "a^3 > 0" by auto
  from this and `b^2*c + c^2*b >0` have "a^3 + (b^2*c + c^2*b) > a^3" by auto
  from `a^3 > 0` and `b^2*c + c^2*b >0` have "a^3 + (b^2*c + c^2*b) > 0" by auto
  from `a^3 > 0` and `a^3 + (b^2*c + c^2*b) > 0` and `a^3 + (b^2*c + c^2*b) > a^3`
  have "1/(a^3 + (b^2*c + c^2*b)) < 1/a^3" by auto
  from `a^3 + (b^2*c + c^2*b) > 0` have  "1/(a^3 + (b^2*c + c^2*b)) > 0" by auto
  from `a^3 > 0` have "1/a^3 > 0" by auto
  from `1/(a^3 + (b^2*c + c^2*b)) < 1/a^3` and `1/(a^3 + (b^2*c + c^2*b)) > 0` and `1/a^3 > 0` and `a>0`
  have "a * (1/(a^3 + (b^2*c + c^2*b))) < a * (1/a^3)" by auto
  sorry
qed

end


theory PreferenceLogicBasics imports Main         (*** Benzmüller & Fuenmayor, 2021 ***)
begin (*unimportant*) declare[[syntax_ambiguity_warning=false]]
      (*unimportant*) nitpick_params[user_axioms,expect=genuine,show_all,format=3]
(*** SSE of preference logic by van Benthem et al., JPL 2009 ***)
 (*preliminaries*)
typedecl \<iota>                  (*possible worlds*)
type_synonym \<sigma>="\<iota>\<Rightarrow>bool"    (*'world-lifted' propositions*)
type_synonym \<gamma>="\<iota>\<Rightarrow>\<iota>\<Rightarrow>bool"  (*preference relations*)
type_synonym \<mu>="\<sigma>\<Rightarrow>\<sigma>"       (*unary logical connectives*)
type_synonym \<nu>="\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>"    (*binary logical connectives*)
type_synonym \<pi>="\<sigma>\<Rightarrow>bool"    (*sets of world-lifted propositions*)
 (*betterness relation \<preceq> and strict betterness relation \<prec>*)
consts BR::\<gamma> ("_\<preceq>_")
definition SBR::\<gamma> ("_\<prec>_") where "v\<prec>w \<equiv> (v\<preceq>w) \<and> \<not>(w\<preceq>v)"
abbreviation "reflexive R \<equiv> \<forall>x. R x x"
abbreviation "transitive R \<equiv> \<forall>x y z. R x y \<and> R y z \<longrightarrow> R x z"
abbreviation "is_total R \<equiv> \<forall>x y. R x y \<or> R y x"
axiomatization where rBR: "reflexive BR" and tBR: "transitive BR"
lemma tSBR: "transitive SBR" using SBR_def tBR by blast (*derived from axioms*)
 (*modal logic connectives (operating on truth-sets)*)
abbreviation c1::\<sigma>  ("\<^bold>\<bottom>")   where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation c2::\<sigma>  ("\<^bold>\<top>")   where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation c3::\<mu>  ("\<^bold>\<not>_")  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w.\<not>(\<phi> w)"
abbreviation c4::\<nu>  (infixl"\<^bold>\<and>"85) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<and>(\<psi> w)"
abbreviation c5::\<nu>  (infixl"\<^bold>\<or>"83) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<or>(\<psi> w)"
abbreviation c6::\<nu>  (infixl"\<^bold>\<rightarrow>"84) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<longrightarrow>(\<psi> w)"
abbreviation c7::\<nu>  (infixl"\<^bold>\<leftrightarrow>"84) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w.(\<phi> w)\<longleftrightarrow>(\<psi> w)"
abbreviation c8::\<mu>  ("\<^bold>\<box>\<^sup>\<preceq>_") where "\<^bold>\<box>\<^sup>\<preceq>\<phi> \<equiv> \<lambda>w.\<forall>v.(w\<preceq>v)\<longrightarrow>(\<phi> v)"
abbreviation c9::\<mu>  ("\<^bold>\<diamond>\<^sup>\<preceq>_") where "\<^bold>\<diamond>\<^sup>\<preceq>\<phi> \<equiv> \<lambda>w.\<exists>v.(w\<preceq>v)\<and>(\<phi> v)"
abbreviation c10::\<mu> ("\<^bold>\<box>\<^sup>\<prec>_") where "\<^bold>\<box>\<^sup>\<prec>\<phi> \<equiv> \<lambda>w.\<forall>v.(w\<prec>v)\<longrightarrow>(\<phi> v)"
abbreviation c11::\<mu> ("\<^bold>\<diamond>\<^sup>\<prec>_") where "\<^bold>\<diamond>\<^sup>\<prec>\<phi> \<equiv> \<lambda>w.\<exists>v.(w\<prec>v)\<and>(\<phi> v)"
abbreviation c12::\<mu> ("\<^bold>E_")  where "\<^bold>E\<phi> \<equiv> \<lambda>w.\<exists>v.(\<phi> v)"
abbreviation c13::\<mu> ("\<^bold>A_")  where "\<^bold>A\<phi> \<equiv> \<lambda>w.\<forall>v.(\<phi> v)"
 (*meta-logical predicate for global and validity*)
abbreviation g1::\<pi> ("\<lfloor>_\<rfloor>")  where "\<lfloor>\<psi>\<rfloor> \<equiv>  \<forall>w. \<psi> w"
 (*some tests: dualities*)
lemma "\<lfloor>(\<^bold>\<diamond>\<^sup>\<preceq>\<phi>)\<^bold>\<leftrightarrow>(\<^bold>\<not>\<^bold>\<box>\<^sup>\<preceq>\<^bold>\<not>\<phi>)\<rfloor> \<and> \<lfloor>(\<^bold>\<diamond>\<^sup>\<prec>\<phi>)\<^bold>\<leftrightarrow>(\<^bold>\<not>\<^bold>\<box>\<^sup>\<prec>\<^bold>\<not>\<phi>)\<rfloor> \<and> \<lfloor>(\<^bold>A\<phi>)\<^bold>\<leftrightarrow>(\<^bold>\<not>\<^bold>E\<^bold>\<not>\<phi>)\<rfloor>" by simp (*proof*)
(**** Section 3: A basic modal preference language ****)
 (*Definition 5*)
abbreviation pEE::\<nu>  ("_\<preceq>\<^sub>E\<^sub>E_") where "(\<phi> \<preceq>\<^sub>E\<^sub>E \<psi>) u \<equiv> \<exists>s. \<phi> s \<and> (\<exists>t. \<psi> t \<and> s\<preceq>t)"
abbreviation pEEs::\<nu> ("_\<prec>\<^sub>E\<^sub>E_") where "(\<phi> \<prec>\<^sub>E\<^sub>E \<psi>) u \<equiv> \<exists>s. \<phi> s \<and> (\<exists>t. \<psi> t \<and> s\<prec>t)"
abbreviation pEA::\<nu>  ("_\<preceq>\<^sub>E\<^sub>A_") where "(\<phi> \<preceq>\<^sub>E\<^sub>A \<psi>) u \<equiv> \<exists>t. \<psi> t \<and> (\<forall>s. \<phi> s \<longrightarrow> s\<preceq>t)"
abbreviation pEAs::\<nu> ("_\<prec>\<^sub>E\<^sub>A_") where "(\<phi> \<prec>\<^sub>E\<^sub>A \<psi>) u \<equiv> \<exists>t. \<psi> t \<and> (\<forall>s. \<phi> s \<longrightarrow> s\<prec>t)"
abbreviation pAE::\<nu>  ("_\<preceq>\<^sub>A\<^sub>E_") where "(\<phi> \<preceq>\<^sub>A\<^sub>E \<psi>) u \<equiv> \<forall>s. \<phi> s\<longrightarrow>(\<exists>t. \<psi> t \<and> s\<preceq>t)"
abbreviation pAEs::\<nu> ("_\<prec>\<^sub>A\<^sub>E_") where "(\<phi> \<prec>\<^sub>A\<^sub>E \<psi>) u \<equiv> \<forall>s. \<phi> s\<longrightarrow>(\<exists>t. \<psi> t \<and> s\<prec>t)"
abbreviation pAA::\<nu>  ("_\<preceq>\<^sub>A\<^sub>A_") where "(\<phi> \<preceq>\<^sub>A\<^sub>A \<psi>) u \<equiv> \<forall>s. \<phi> s\<longrightarrow>(\<forall>t. \<psi> t\<longrightarrow>s\<preceq>t)"
abbreviation pAAs::\<nu> ("_\<prec>\<^sub>A\<^sub>A_") where "(\<phi> \<prec>\<^sub>A\<^sub>A \<psi>) u \<equiv> \<forall>s. \<phi> s\<longrightarrow>(\<forall>t. \<psi> t\<longrightarrow>s\<prec>t)"
abbreviation PEE::\<nu>   ("_\<^bold>\<preceq>\<^sub>E\<^sub>E_") where "\<phi> \<^bold>\<preceq>\<^sub>E\<^sub>E \<psi> \<equiv> \<^bold>E(\<phi> \<^bold>\<and> \<^bold>\<diamond>\<^sup>\<preceq>\<psi>)"
abbreviation PEEs::\<nu>  ("_\<^bold>\<prec>\<^sub>E\<^sub>E_") where "\<phi> \<^bold>\<prec>\<^sub>E\<^sub>E \<psi> \<equiv> \<^bold>E(\<phi> \<^bold>\<and> \<^bold>\<diamond>\<^sup>\<prec>\<psi>)"
abbreviation PEA::\<nu>   ("_\<^bold>\<preceq>\<^sub>E\<^sub>A_") where "\<phi> \<^bold>\<preceq>\<^sub>E\<^sub>A \<psi> \<equiv> \<^bold>E(\<psi> \<^bold>\<and> \<^bold>\<box>\<^sup>\<prec>\<^bold>\<not>\<phi>)"
abbreviation PEAs::\<nu>  ("_\<^bold>\<prec>\<^sub>E\<^sub>A_") where "\<phi> \<^bold>\<prec>\<^sub>E\<^sub>A \<psi> \<equiv> \<^bold>E(\<psi> \<^bold>\<and> \<^bold>\<box>\<^sup>\<preceq>\<^bold>\<not>\<phi>)"
abbreviation PAE::\<nu>   ("_\<^bold>\<preceq>\<^sub>A\<^sub>E_") where "\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>E \<psi> \<equiv> \<^bold>A(\<phi> \<^bold>\<rightarrow> \<^bold>\<diamond>\<^sup>\<preceq>\<psi>)"
abbreviation PAEs::\<nu>  ("_\<^bold>\<prec>\<^sub>A\<^sub>E_") where "\<phi> \<^bold>\<prec>\<^sub>A\<^sub>E \<psi> \<equiv> \<^bold>A(\<phi> \<^bold>\<rightarrow> \<^bold>\<diamond>\<^sup>\<prec>\<psi>)"
abbreviation PAA::\<nu>   ("_\<^bold>\<preceq>\<^sub>A\<^sub>A_") where "\<phi> \<^bold>\<preceq>\<^sub>A\<^sub>A \<psi> \<equiv> \<^bold>A(\<psi> \<^bold>\<rightarrow> \<^bold>\<box>\<^sup>\<prec>\<^bold>\<not>\<phi>)"
abbreviation PAAs::\<nu>  ("_\<^bold>\<prec>\<^sub>A\<^sub>A_") where "\<phi> \<^bold>\<prec>\<^sub>A\<^sub>A \<psi> \<equiv> \<^bold>A(\<psi> \<^bold>\<rightarrow> \<^bold>\<box>\<^sup>\<preceq>\<^bold>\<not>\<phi>)"
 (*quantification for objects of arbitrary type*)
abbreviation mforall ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
abbreviation mforallB (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation mexists ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
abbreviation mexistsB (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"
 (*polymorphic operators for sets of worlds/values*)
abbreviation subs   (infix "\<^bold>\<sqsubseteq>" 70)  where "A\<^bold>\<sqsubseteq>B \<equiv> \<forall>x. A x \<longrightarrow> B x"
abbreviation union  (infixr "\<^bold>\<squnion>" 70) where "A\<^bold>\<squnion>B \<equiv> \<lambda>x. A x \<or> B x"
abbreviation inters (infixr "\<^bold>\<sqinter>" 70) where "A\<^bold>\<sqinter>B \<equiv> \<lambda>x. A x \<and> B x"
 (*consistency confirmed (trivial: only abbreviations introduced)*)
lemma True nitpick[satisfy,user_axioms] oops (*satisfying model*)
end


theory Trace
  imports Aczel Mumble_Language Rely_Guarantee Algebra
  "~~/src/HOL/Library/Quotient_Set"
  "~~/src/HOL/Lifting_Set"
begin

no_notation shuffle (infixl "\<parallel>" 75)
no_notation l_prod (infixl "\<cdot>" 80)
no_notation Aczel ("\<pi>")

quotient_type 'a trace = "('a \<times> 'a) lan" / "\<lambda>X Y. X\<^sup>\<ddagger> = Y\<^sup>\<ddagger>"
  by (intro equivpI reflpI sympI transpI) auto

(* traces form a dioid *)

instantiation trace :: (type) dioid_one_zerol
begin

  lift_definition less_eq_trace :: "'a trace \<Rightarrow> 'a trace \<Rightarrow> bool" is "\<lambda>X Y. X\<^sup>\<ddagger> \<subseteq> Y\<^sup>\<ddagger>"
    by simp

  lift_definition less_trace :: "'a trace \<Rightarrow> 'a trace \<Rightarrow> bool" is "\<lambda>X Y. X\<^sup>\<ddagger> \<subset> Y\<^sup>\<ddagger>"
    by simp

  lift_definition zero_trace :: "'a trace" is "{}" done

  lift_definition one_trace :: "'a trace" is "{LNil}" done

  lift_definition times_trace :: "'a trace \<Rightarrow> 'a trace \<Rightarrow> 'a trace" is "\<lambda>X Y. l_prod X\<^sup>\<ddagger> Y\<^sup>\<ddagger>"
    by simp

  lift_definition plus_trace :: "'a trace \<Rightarrow> 'a trace \<Rightarrow> 'a trace" is "op \<union>"
    by simp

  instance
  proof
    fix x y z :: "'a trace"
    show "(x + y) + z = x + (y + z)"
      by transfer (simp only: Un_assoc)
    show "x + y = y + x"
      by transfer simp
    show "(x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
      by transfer (simp add: l_prod_assoc)
    show "(x + y) \<cdot> z = x \<cdot> z + y \<cdot> z"
      by transfer simp
    show "1 \<cdot> x = x"
      by transfer simp
    show "x \<cdot> 1 = x"
      by transfer simp
    show "0 + x = x"
      by transfer simp
    show "0 \<cdot> x = 0"
      by transfer simp
    show "(x \<le> y) = (x + y = y)"
      by transfer auto
    show "(x < y) = (x \<le> y \<and> x \<noteq> y)"
      by transfer (metis par.less_def)
    show "x + x = x"
      by transfer simp
    show "x \<cdot> (y + z) = x \<cdot> y + x \<cdot> z"
      by transfer simp
  qed
end

(* traces form a dioid w.r.t. parallel composition *)

instantiation trace :: (type) par_dioid
begin

  lift_definition par_trace :: "'a trace \<Rightarrow> 'a trace \<Rightarrow> 'a trace" is "\<lambda>X Y. (shuffle X\<^sup>\<ddagger> Y\<^sup>\<ddagger>)\<^sup>\<ddagger>"
    by simp

  instance proof
    fix x y z :: "'a trace"
    show "x \<parallel> (y \<parallel> z) = (x \<parallel> y) \<parallel> z"
      by transfer (simp add: shuffle_assoc)
    show "x \<parallel> y = y \<parallel> x"
      by transfer (metis shuffle_comm)
    show "x \<parallel> (y + z) = x \<parallel> y + x \<parallel> z"
      by transfer simp
    show "1 \<parallel> x = x"
      by transfer simp
    show "0 \<parallel> x = 0"
      by transfer simp
  qed
end

instance trace :: (type) weak_trioid by default

instantiation trace :: (type) lattice
begin

  lift_definition inf_trace :: "'a trace \<Rightarrow> 'a trace \<Rightarrow> 'a trace" is "\<lambda>X Y. X\<^sup>\<ddagger> \<inter> Y\<^sup>\<ddagger>"
    by simp

  lift_definition sup_trace :: "'a trace \<Rightarrow> 'a trace \<Rightarrow> 'a trace" is "op \<union>"
    by simp

  instance proof
    fix x y z :: "'a trace"
    show "x \<sqinter> y \<le> x"
      by transfer simp
    show "x \<sqinter> y \<le> y"
      by transfer simp
    show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
      by transfer simp
    show "x \<le> x \<squnion> y"
      by transfer simp
    show "y \<le> x \<squnion> y"
      by transfer simp
    show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
      by transfer simp
  qed
end

instance trace :: (type) distrib_lattice
  apply default
  apply transfer
  apply simp
  apply (simp add: fmumble_def)
  by (metis (hide_lams, no_types) distrib_lattice_class.sup_inf_distrib1 fmumble_def fmumble_meet fmumble_union inf_commute inf_left_idem)

no_notation Language.star ("_\<^sup>\<star>" [101] 100)

instantiation trace :: (type) left_kleene_algebra
begin

  lift_definition star_trace :: "'a trace \<Rightarrow> 'a trace" is "\<lambda>x. Language.star x\<^sup>\<ddagger>"
    by simp

  instance
  proof
    fix x y z :: "'a trace"
    show "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
      by transfer (metis fmumble_l_prod2 fmumble_union par.add_ub1 seq.add_idem' seq.star_unfoldl_eq)
    show "z + x \<cdot> y \<le> y \<longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
      by transfer (metis fmumble_l_prod1 fmumble_l_prod2 fmumble_star fmumble_star_inductl fmumble_union)
  qed
end

lemma [dest!]: "ys \<frown> LCons z (LCons z' zs) = LCons x LNil \<Longrightarrow> False"
  apply (cases "lfinite ys")
  apply (rotate_tac 1)
  apply (induct ys rule: lfinite.induct)
  by (simp_all add: lappend_inf)

lemma [dest!]: "xs \<in> mumble (LCons x LNil) \<Longrightarrow> xs = LCons x LNil"
  by (induct xs rule: mumble.induct) auto

lemma Mumble_atomic [simp]: "(atomic X)\<^sup>\<dagger> = atomic X"
  by (auto simp add: Mumble_def atomic_def image_def)

lemma join_is_plus [simp]:
  fixes x y :: "'a trace"
  shows "x \<squnion> y = x + y"
  by transfer simp

lemma [simp]: "pcr_trace op = x y \<longleftrightarrow> abs_trace x = y"
  by (simp add: pcr_trace_def OO_def cr_trace_def)

lemma [simp]: "abs_trace X = Abs_trace {Y. X\<^sup>\<ddagger> = Y\<^sup>\<ddagger>}"
  apply (auto simp add: abs_trace_def)
  apply (subst quot_type.abs_def[of _ _ Rep_trace])
  apply (auto simp add: quot_type_def)
  apply (metis equivp_implies_part_equivp trace_equivp)
  defer
  apply (metis Rep_trace_inverse)
  apply (erule rev_mp)+
  apply (subst Abs_trace_inverse)
  apply auto
  apply (erule rev_mp)+
  apply (subst Abs_trace_inverse)
  apply auto
  apply (subst Abs_trace_inverse)
  apply auto
  apply (metis Rep_trace_inject)
  apply (insert Rep_trace)
  by auto

(*

lemma [transfer_rule]: "(op = ===> pcr_trace op = ===> op =) (\<lambda>x y. x = Abs_trace {Y. y\<^sup>\<dagger> = Y\<^sup>\<dagger>}) op ="
  by (auto simp add: fun_rel_def)
*)

lemma atomic_star_lfinite: "xs \<in> star (atomic R) \<Longrightarrow> lfinite xs"
  apply (erule rev_mp)
  apply (subst star_power_fin)
  apply (auto simp add: powers_def)
  by (metis rely_power1)

lemma atomic_star_lset: "xs \<in> star (atomic R) \<Longrightarrow> lset xs \<subseteq> R"
  by (metis (lifting) mem_Collect_eq rely_def)

lemma atomic_star_elemI [intro]: "lfinite xs \<Longrightarrow> lset xs \<subseteq> R \<Longrightarrow> xs \<in> star (atomic R)"
proof (induct xs rule: lfinite.induct)
  case lfinite_LNil
  thus ?case
    by (metis (lifting) lfinite_LNil.prems lfinite_code(1) mem_Collect_eq rely_def)
next
  case (lfinite_LConsI xs x)
  thus ?case
    apply auto
    apply (erule rev_mp)+
    apply (subst star_power_fin, metis atom_finite)+
    apply (auto simp add: powers_def)
    apply (rule_tac x = "Language.power (atomic R) (Suc i)" in exI)
    apply auto
    apply (rule_tac x = "Suc i" in exI)
    apply (auto simp add: l_prod_def)
    apply (rule_tac x = "LCons x LNil" in exI)
    apply (rule_tac x = xs in exI)
    by (auto simp add: atomic_def)
qed

lemma mumble_star1: "ys \<in> mumble xs \<Longrightarrow> xs \<in> star (atomic R) \<Longrightarrow> ys \<in> star (atomic (trancl R))"
  apply (induct ys rule: mumble.induct)
  apply (erule set_rev_mp)
  apply (rule seq.star_iso[rule_format])
  apply simp
  apply (metis r_into_trancl' subsetI)
  apply auto
  apply (frule atomic_star_lfinite)
  apply simp
  apply (erule conjE)
  apply (drule atomic_star_lset)
  apply (rule atomic_star_elemI)
  by auto

lemma O_member: "x \<in> (R O S) \<Longrightarrow> (\<exists>\<sigma> \<sigma>' \<sigma>''. (\<sigma>, \<sigma>') \<in> R \<and> (\<sigma>', \<sigma>'') \<in> S)"
  by auto

lemma mumble_head [intro!]: "LCons (\<sigma>, \<sigma>'') xs \<in> mumble (LCons (\<sigma>, \<sigma>') (LCons (\<sigma>', \<sigma>'') xs))"
proof -
  have "LCons (\<sigma>, \<sigma>') (LCons (\<sigma>', \<sigma>'') xs) \<in> mumble (LCons (\<sigma>, \<sigma>') (LCons (\<sigma>', \<sigma>'') xs))"
    by (metis mumble.self)
  thus "LCons (\<sigma>, \<sigma>'') xs \<in> mumble (LCons (\<sigma>, \<sigma>') (LCons (\<sigma>', \<sigma>'') xs))"
    by (rule mumble[where ys = LNil, simplified])
qed

lemma trancl_to_llist: "x \<in> trancl R \<Longrightarrow> \<exists>xs. lfinite xs \<and> lset xs \<subseteq> R \<and> LCons x LNil \<in> mumble xs"
proof (auto simp add: trancl_power)
  fix n
  assume "x \<in> R ^^ n" and "0 < n"
  then obtain m where "n = Suc m"
    by (metis gr_implies_not0 list_decode.cases)
  hence "x \<in> R ^^ Suc m"
    by (metis `x \<in> R ^^ n`)
  thus "\<exists>xs. lfinite xs \<and> lset xs \<subseteq> R \<and> LCons x LNil \<in> mumble xs"
  proof (induct m arbitrary: x)
    case 0 thus ?case
      by (rule_tac x = "LCons x LNil" in exI) auto
  next
    case (Suc n) note ih = this[simplified]
    then obtain \<sigma> \<sigma>' \<sigma>'' where split1: "(\<sigma>, \<sigma>') \<in> R ^^ n O R" and split2: "(\<sigma>', \<sigma>'') \<in> R" and x_def [simp]: "x = (\<sigma>, \<sigma>'')"
      by auto
    show ?case using ih(1)[OF split1] and split2
      apply auto
      apply (rule_tac x = "xs \<frown> LCons (\<sigma>', \<sigma>'') LNil" in exI)
      apply auto
      apply (rule mumble_trans[of _ "LCons (\<sigma>, \<sigma>') LNil \<frown> LCons (\<sigma>', \<sigma>'') LNil"])
      defer
      apply (rule mumble_lappend)
      by auto
  qed
qed

lemma mumble_LNil [iff]: "xs \<in> mumble LNil \<longleftrightarrow> xs = LNil"
  apply auto
  apply (induct xs rule: mumble.induct)
  by auto

lemma mumble_star2: "lfinite xs \<Longrightarrow> lset xs \<subseteq> R\<^sup>+ \<Longrightarrow> \<exists>X. (\<exists>xs. X = mumble xs \<and> lfinite xs \<and> lset xs \<subseteq> R) \<and> xs \<in> X"
proof (induct xs rule: lfinite.induct)
  case lfinite_LNil
  thus ?case
    by (rule_tac x = "{LNil}" in exI) auto
next
  case (lfinite_LConsI xs x)
  thus ?case
    apply auto
    apply (drule trancl_to_llist)
    apply auto
    apply (rename_tac xs ys)
    apply (rule_tac x = "mumble (ys \<frown> xs)" in exI)
    apply (intro conjI)
    apply (rule_tac x = "ys \<frown> xs" in exI)
    apply auto
    by (metis LCons_lappend_LNil mumble_lappend)
qed

lemma Mumble_atomic_star: "(star (atomic R))\<^sup>\<dagger> = star (atomic (trancl R))"
  apply (auto simp add: Mumble_def)
  apply (metis mumble_star1)
  by (metis atomic_star_elemI atomic_star_lfinite atomic_star_lset mumble_star2)

lemma Mumble_Inter_Con [simp]: "x\<^sup>\<dagger> \<inter> Con = (x \<inter> Con)\<^sup>\<dagger>"
  by (auto simp add: Con_def Mumble_def)

instantiation trace :: (type) rely_guarantee_trioid
begin

  lift_definition RG_trace :: "'a trace set" is "{x. \<exists>R. x = Language.star (atomic R)}" done

  lift_definition C_trace :: "'a trace" is Aczel.Con done

  instance
  proof
    fix r s x y z :: "'a trace"
    show "(1::'a trace) \<in> RG"
      apply transfer
      by transfer (auto intro: exI[of _ "{LNil}"] exI[of _ "{}"] simp add: image_def)

    show "x \<cdot> y \<sqinter> C \<le> (x \<sqinter> C) \<cdot> (y \<sqinter> C) \<sqinter> C"
      apply transfer using Aczel_l_prod by (auto intro!: Mumble_iso simp add: Aczel_def)

    show "x\<^sup>\<star> \<sqinter> C \<le> (x \<sqinter> C)\<^sup>\<star> \<sqinter> C"
      apply transfer
      apply (auto intro!: Mumble_iso)
      by (metis Aczel_def Aczel_star Int_iff)

    show "x + y \<sqinter> z = (x + y) \<sqinter> (x + z)"
      apply transfer
      apply simp
      by (metis Mumble_meet Mumble_union Un_Int_distrib inf_sup_absorb)

    assume r_rg: "r \<in> RG"

    from r_rg show "r \<parallel> r \<le> r"
      apply transfer
      apply (simp add: image_def)
      apply (erule exE)
      apply (erule conjE)
      apply (erule exE)
      by (metis Mumble_shuffle_right Un_absorb order_refl rely_union shuffle_comm)

    from r_rg show "r \<parallel> x \<cdot> y = (r \<parallel> x) \<cdot> (r \<parallel> y)"
      apply transfer
      apply (simp add: image_def)
      apply (erule exE)
      apply (erule conjE)
      apply (erule exE)
      apply simp
      apply (subst Mumble_shuffle_left[symmetric])
      apply (subst Mumble_l_prod[symmetric])
      apply (subst Mumble_shuffle_left[symmetric]) back
      apply (subst Mumble_shuffle_left[symmetric]) back back
      apply (erule ssubst)
      by simp

    from r_rg show "r \<parallel> x\<^sup>\<star> \<cdot> x \<le> (r \<parallel> x)\<^sup>\<star> \<cdot> (r \<parallel> x)"
      apply transfer
      apply (simp add: image_def)
      apply (erule exE)
      apply (erule conjE)
      apply (erule exE)
      apply simp
      apply (subst Mumble_l_prod[symmetric])
      apply (subst Mumble_shuffle_left[symmetric])
      apply (subst Mumble_shuffle_left[symmetric]) back
      apply (subst Mumble_star[symmetric])
      apply (subst Mumble_shuffle_left[symmetric]) back
      apply (erule ssubst)
      apply simp
      apply (rule Mumble_iso)
      by (metis eq_iff rely_l_prod rely_star)

    from r_rg show "r \<parallel> x\<^sup>\<star>\<cdot>x \<le> (r \<parallel> x) \<cdot> (r \<parallel> x)\<^sup>\<star>"
      sorry

    assume s_rg: "s \<in> RG"

    from r_rg and s_rg show "r \<parallel> s \<in> RG"
      apply transfer
      apply (auto simp add: image_def)
      by (metis Mumble_shuffle_left rely_union shuffle_comm)

    from r_rg and s_rg show "r \<sqinter> s \<in> RG"
      apply transfer
      apply (auto simp add: image_def)
      apply (rename_tac r s R S)
      apply (rule_tac x = "star (atomic (R\<^sup>+ \<inter> S\<^sup>+))" in exI)
      apply (intro conjI)
      apply blast
      by (metis Mumble_meet Mumble_atomic_star rely_inter)

    from r_rg and s_rg show "r \<le> r \<parallel> s"
      apply transfer
      apply (auto simp add: image_def)
      by (metis (hide_lams, no_types) Mumble_shuffle_right Mumble_atomic_star in_mono rely_1 shuffle_mumble1)
  qed
end

no_notation atomic ("\<langle>_\<rangle>" [0] 1000)

lift_definition atomic_trace :: "'a rel \<Rightarrow> 'a trace" ("\<langle>_\<rangle>" [0] 1000) is "\<lambda>S. atomic S" by simp

definition test :: "'a set \<Rightarrow> 'a trace" where
  "test X = \<langle>Id_on X\<rangle>"

lemma atomic_test: "atomic (Id_on X) = {LCons (\<sigma>, \<sigma>') LNil |\<sigma> \<sigma>'. \<sigma> \<in> X \<and> \<sigma> = \<sigma>'}"
  by (auto simp add: atomic_def image_def Id_on_def)

lemma "\<pi> (test (X \<inter> Y)) \<le> \<pi> (test X \<cdot> test Y)"
  apply (simp only: test_def proj_def)
  apply transfer
  apply (simp add: atomic_test)
  apply (subst fin_l_prod)
  apply (force simp add: FIN_def)
  apply (auto simp add: Aczel_def Con_def Mumble_def)
  apply (rule_tac x = "mumble (LCons (\<sigma>, \<sigma>) (LCons (\<sigma>, \<sigma>) LNil))" in exI)
  apply (intro conjI)
  apply (rule_tac x = "LCons (\<sigma>, \<sigma>) (LCons (\<sigma>, \<sigma>) LNil)" in exI)
  apply (metis LCons_lappend_LNil inconsistent_mumble lappend_code(1) lfinite.simps)
  by (metis lappend_code(1) mumble.mumble mumble.self)

lemma "\<langle>X\<rangle> + \<langle>Y\<rangle> = \<langle>X \<union> Y\<rangle>"
  by transfer (metis Mumble_atomic atomic_def image_Un)

lift_definition stuttering :: "'a trace" is stutter done

instantiation trace :: (type) complete_lattice
begin

  lift_definition Sup_trace :: "'a trace set \<Rightarrow> 'a trace" is "Union"
    by (auto simp add: Mumble_continuous set_rel_def) metis+

  lift_definition Inf_trace :: "'a trace set \<Rightarrow> 'a trace" is "\<lambda>X. Inter (Mumble ` X)"
    apply (rule arg_cong) back
    apply (simp add: set_rel_def)
    apply safe
    by (metis INT_iff)+

  lift_definition bot_trace :: "'a trace" is "{}" done

  lift_definition top_trace :: "'a trace" is "UNIV" done

  instance
  proof
    fix x :: "'a trace" and A :: "'a trace set"
    assume "x \<in> A"
    thus "\<Sqinter>A \<le> x"
      by (transfer, simp only: Mumble_Inter, auto simp add: image_def Mumble_def)
  next
    fix x :: "'a trace" and A :: "'a trace set"
    assume "x \<in> A"
    thus "x \<le> \<Squnion>A"
      by transfer (auto simp add: Mumble_continuous)
  next
    fix z :: "'a trace" and A :: "'a trace set"
    assume "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
    thus "z \<le> \<Sqinter>A"
      by transfer (simp only: Mumble_Inter, auto)
  next
    fix z :: "'a trace" and A :: "'a trace set"
    assume "\<And>x. x \<in> A \<Longrightarrow> x \<le> z"
    thus "\<Squnion>A \<le> z"
      by transfer (auto simp add: Mumble_continuous)
  next
    show "\<Sqinter>({}::'a trace set) = \<top>"
      by transfer simp
  next
    show "\<Squnion>({}::'a trace set) = \<bottom>"
      by transfer simp
  qed
end

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

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

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

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

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

fun lt :: "Nat => Nat => bool" where
  "lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

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

fun ordered :: "Nat list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 z (nil2)) = True"
| "ordered (cons2 z (cons2 y2 xs)) =
     ((le z y2) & (ordered (cons2 y2 xs)))"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

(*fun did not finish the proof*)
function idiv :: "Nat => Nat => Nat" where
  "idiv y z = (if lt y z then Z else S (idiv (minus y z) z))"
  by pat_completeness auto

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function stooge1sort2 :: "Nat list => Nat list"
  and stoogesort :: "Nat list => Nat list"
  and stooge1sort1 :: "Nat list => Nat list" where
  "stooge1sort2 y =
   (case splitAt (idiv (length y) (S (S (S Z)))) (reverse y) of
      pair2 ys2 zs2 => x (stoogesort zs2) (reverse ys2))"
| "stoogesort (nil2) = nil2"
| "stoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge1sort2
       (stooge1sort1 (stooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge1sort1 y =
     (case splitAt (idiv (length y) (S (S (S Z)))) y of
        pair2 ys2 zs1 => x ys2 (stoogesort zs1))"
  by pat_completeness auto

theorem property0 :
  "ordered (stoogesort xs)"
  oops

end


theory Exercises
  imports Spec "~~/src/HOL/Library/Infinite_Set"
begin

section {* Some Fun Facts *}

fun
 zeroable :: "rexp \<Rightarrow> bool"
where
  "zeroable (ZERO) \<longleftrightarrow> True"
| "zeroable (ONE) \<longleftrightarrow> False"
| "zeroable (CHAR c) \<longleftrightarrow> False"
| "zeroable (ALT r1 r2) \<longleftrightarrow> zeroable r1 \<and> zeroable r2"
| "zeroable (SEQ r1 r2) \<longleftrightarrow> zeroable r1 \<or> zeroable r2"
| "zeroable (STAR r) \<longleftrightarrow> False"

lemma zeroable_correctness:
  shows "zeroable r \<longleftrightarrow> L r = {}"
by(induct r)(auto simp add: Sequ_def)

fun
 atmostempty :: "rexp \<Rightarrow> bool"
where
  "atmostempty (ZERO) \<longleftrightarrow> True"
| "atmostempty (ONE) \<longleftrightarrow> True"
| "atmostempty (CHAR c) \<longleftrightarrow> False"
| "atmostempty (ALT r1 r2) \<longleftrightarrow> atmostempty r1 \<and> atmostempty r2"
| "atmostempty (SEQ r1 r2) \<longleftrightarrow>
     zeroable r1 \<or> zeroable r2 \<or> (atmostempty r1 \<and> atmostempty r2)"
| "atmostempty (STAR r) = atmostempty r"

fun
 somechars :: "rexp \<Rightarrow> bool"
where
  "somechars (ZERO) \<longleftrightarrow> False"
| "somechars (ONE) \<longleftrightarrow> False"
| "somechars (CHAR c) \<longleftrightarrow> True"
| "somechars (ALT r1 r2) \<longleftrightarrow> somechars r1 \<or> somechars r2"
| "somechars (SEQ r1 r2) \<longleftrightarrow>
      (\<not> zeroable r1 \<and> somechars r2) \<or> (\<not> zeroable r2 \<and> somechars r1) \<or>
      (somechars r1 \<and> nullable r2) \<or> (somechars r2 \<and> nullable r1)"
| "somechars (STAR r) \<longleftrightarrow> somechars r"

lemma somechars_correctness:
  shows "somechars r \<longleftrightarrow> (\<exists>s. s \<noteq> [] \<and> s \<in> L r)"
apply(induct r)
apply(simp_all add: zeroable_correctness nullable_correctness Sequ_def)
using Nil_is_append_conv apply blast
apply blast
apply(auto)
using Star_cstring
  by (metis concat_eq_Nil_conv)

lemma atmostempty_correctness_aux:
  shows "atmostempty r \<longleftrightarrow> \<not> somechars r"
apply(induct r)
apply(simp_all)
apply(auto simp add: zeroable_correctness nullable_correctness somechars_correctness)
done

lemma atmostempty_correctness:
  shows "atmostempty r \<longleftrightarrow> L r \<subseteq> {[]}"
by(auto simp add: atmostempty_correctness_aux somechars_correctness)

fun
 leastsinglechar :: "rexp \<Rightarrow> bool"
where
  "leastsinglechar (ZERO) \<longleftrightarrow> False"
| "leastsinglechar (ONE) \<longleftrightarrow> False"
| "leastsinglechar (CHAR c) \<longleftrightarrow> True"
| "leastsinglechar (ALT r1 r2) \<longleftrightarrow> leastsinglechar r1 \<or> leastsinglechar r2"
| "leastsinglechar (SEQ r1 r2) \<longleftrightarrow>
      (if (zeroable r1 \<or> zeroable r2) then False
       else ((nullable r1 \<and> leastsinglechar r2) \<or> (nullable r2 \<and> leastsinglechar r1)))"
| "leastsinglechar (STAR r) \<longleftrightarrow> leastsinglechar r"

lemma leastsinglechar_correctness:
  "leastsinglechar r \<longleftrightarrow> (\<exists>c. [c] \<in> L r)"
  apply(induct r)
  apply(simp)
  apply(simp)
  apply(simp)
  prefer 2
  apply(simp)
  apply(blast)
  prefer 2
  apply(simp)
  using Star.step Star_decomp apply fastforce
  apply(simp add: Sequ_def zeroable_correctness nullable_correctness)
  by (metis append_Nil append_is_Nil_conv butlast_append butlast_snoc)

fun
 infinitestrings :: "rexp \<Rightarrow> bool"
where
  "infinitestrings (ZERO) = False"
| "infinitestrings (ONE) = False"
| "infinitestrings (CHAR c) = False"
| "infinitestrings (ALT r1 r2) = (infinitestrings r1 \<or> infinitestrings r2)"
| "infinitestrings (SEQ r1 r2) \<longleftrightarrow>
      (\<not> zeroable r1 \<and> infinitestrings r2) \<or> (\<not> zeroable r2 \<and> infinitestrings r1)"
| "infinitestrings (STAR r) = (\<not> atmostempty r)"

lemma Star_atmostempty:
  assumes "A \<subseteq> {[]}"
  shows "A\<star> \<subseteq> {[]}"
using assms
using Star_cstring concat_eq_Nil_conv empty_iff insert_iff subsetI subset_singletonD by fastforce

lemma Star_empty_string_finite:
  shows "finite ({[]}\<star>)"
using Star_atmostempty infinite_super by auto

lemma Star_empty_finite:
  shows "finite ({}\<star>)"
using Star_atmostempty infinite_super by auto

lemma Star_concat_replicate:
  assumes "s \<in> A"
  shows "concat (replicate n s) \<in> A\<star>"
using assms
by (induct n) (auto)

lemma concat_replicate_inj:
  assumes "concat (replicate n s) = concat (replicate m s)" "s \<noteq> []"
  shows "n = m"
using assms
apply(induct n arbitrary: m)
apply(auto)[1]
apply(auto)
apply(case_tac m)
apply(clarify)
apply(simp only: replicate.simps concat.simps)
apply blast
by simp

lemma A0:
  assumes "finite (A ;; B)" "B \<noteq> {}"
  shows "finite A"
apply(subgoal_tac "\<exists>s. s \<in> B")
apply(erule exE)
apply(subgoal_tac "finite {s1 @ s |s1. s1 \<in> A}")
apply(rule_tac f="\<lambda>s1. s1 @ s" in finite_imageD)
apply(simp add: image_def)
apply(smt Collect_cong)
apply(simp add: inj_on_def)
apply(rule_tac B="A ;; B" in finite_subset)
apply(auto simp add: Sequ_def)[1]
apply(rule assms(1))
using assms(2) by auto

lemma Sequ_Prod_finite:
  assumes "A \<noteq> {}" "B \<noteq> {}"
  shows "finite (A ;; B) \<longleftrightarrow> (finite (A \<times> B))"
apply(rule iffI)
apply(rule finite_cartesian_product)
apply(erule A0)
apply(rule assms(2))
apply(erule A1)
apply(rule assms(1))
apply(simp add: Sequ_def)
apply(rule finite_image_set2)
apply(drule finite_cartesian_productD1)
apply(rule assms(2))
apply(simp)
apply(drule finite_cartesian_productD2)
apply(rule assms(1))
apply(simp)
done

lemma Star_non_empty_string_infinite:
  assumes "s \<in> A" " s \<noteq> []"
  shows "infinite (A\<star>)"
proof -
  have "inj (\<lambda>n. concat (replicate n s))"
  using assms(2) concat_replicate_inj
    by(auto simp add: inj_on_def)
  moreover
  have "infinite (UNIV::nat set)" by simp
  ultimately
  have "infinite ((\<lambda>n. concat (replicate n s)) ` UNIV)"
   by (simp add: range_inj_infinite)
  moreover
  have "((\<lambda>n. concat (replicate n s)) ` UNIV) \<subseteq> (A\<star>)"
    using Star_concat_replicate assms(1) by auto
  ultimately show "infinite (A\<star>)"
  using infinite_super by auto
qed

lemma infinitestrings_correctness:
  shows "infinitestrings r \<longleftrightarrow> infinite (L r)"
apply(induct r)
apply(simp_all)
apply(simp add: zeroable_correctness)
apply(rule iffI)
apply(erule disjE)
apply(subst Sequ_Prod_finite)
apply(auto)[2]
using finite_cartesian_productD2 apply blast
apply(subst Sequ_Prod_finite)
apply(auto)[2]
using finite_cartesian_productD1 apply blast
apply(subgoal_tac "L r1 \<noteq> {} \<and> L r2 \<noteq> {}")
prefer 2
apply(auto simp add: Sequ_def)[1]
apply(subst (asm) Sequ_Prod_finite)
apply(auto)[2]
apply(auto)[1]
apply(simp add: atmostempty_correctness)
apply(rule iffI)
apply (metis Star_empty_finite Star_empty_string_finite subset_singletonD)
using Star_non_empty_string_infinite apply blast
done

unused_thms

end