theory subminimal_logics
  imports "negation_conditions" "strict_implication"
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Subintuitionistic and subminimal logics\<close>

(**In this section we examine some special paracomplete logics. The idea is to illustrate an approach by
means of which we can obtain logics which are boldly paracomplete and (non-boldly) paraconsistent at the
same time, Johansson's 'minimal logic' @{cite JML} being the paradigmatic case we aim at modelling.*)

(**Drawing upon the literature on Johanson's minimal logic, we introduce an unconstrained propositional
constant Q, which we then employ to define a 'rigid' frontier operation @{text "\<F>'"}.*)
consts Q::"\<sigma>"
abbreviation "\<F>' \<equiv> \<lambda>X. Q"
abbreviation "\<I>' \<equiv> \<I>\<^sub>F \<F>'"
abbreviation "\<C>' \<equiv> \<C>\<^sub>F \<F>'"
abbreviation "\<B>' \<equiv> \<B>\<^sub>F \<F>'"

(**As defined, @{text "\<F>'"} (and its corresponding closure operation) satisfies several semantic conditions.*)
lemma "Fr_1 \<F>' \<and> Fr_2 \<F>' \<and> Fr_4 \<F>'" by (simp add: Fr_1_def Fr_2_def Fr_4_def conn)
lemma "Cl_1 \<C>' \<and> Cl_2 \<C>' \<and> Cl_4 \<C>'" using ADDI_def CF2 IDEMb_def Cl_fr_def PC4 unfolding conn by auto
(**However Fr-3 is not valid. In fact, adding it by hand would collapse into classical logic (making all sets clopen).*)
lemma "Fr_3 \<F>'" nitpick oops (*counterexample found*)
lemma "Cl_3 \<C>'" nitpick oops (*counterexample found*)
lemma "Fr_3 \<F>' \<Longrightarrow> \<forall>A. \<F>'(A) \<^bold>\<approx> \<^bold>\<bottom>"  by (simp add: NOR_def)

(**In order to obtain a paracomplete logic not validating ECQ, we define negation as follows,*)
abbreviation neg_IC::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>")  where  "\<^bold>\<not>A \<equiv> \<C>'(\<I>(\<^bold>\<midarrow>A))"

(**and observe that some plausible semantic properties obtain:*)
lemma Q_def1: "\<forall>A. Q \<^bold>\<approx> \<^bold>\<not>A \<^bold>\<and> \<^bold>\<not>(\<^bold>\<not>A)" using Cl_fr_def IF2 dEXP_def conn by auto
lemma Q_def2: "Fr_1b \<F> \<Longrightarrow> \<forall>A. Q \<^bold>\<approx> \<^bold>\<not>(A \<^bold>\<or> \<^bold>\<not>A)" by (smt Cl_fr_def IF2 dEXP_def MONO_def monI conn)
lemma neg_Idef: "\<forall>A. \<^bold>\<not>A \<^bold>\<approx> \<I>(\<^bold>\<midarrow>A) \<^bold>\<or> Q" by (simp add: Cl_fr_def)
lemma neg_Cdef: "Fr_2 \<F> \<Longrightarrow> \<forall>A. \<^bold>\<not>A \<^bold>\<approx> \<C>(A) \<^bold>\<rightarrow> Q" using Cl_fr_def Fr_2_def Int_fr_def conn by auto

(**The negation so defined validates some properties corresponding to a (rather weak) paracomplete logic:*)
lemma "\<FF> \<F> \<Longrightarrow> TND \<^bold>\<not>" nitpick oops (*counterexample found: negation is paracomplete*)
lemma "\<FF> \<F> \<Longrightarrow> TNDw \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> TNDm \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> ECQ \<^bold>\<not>" nitpick oops (*counterexample found: negation is paraconsistent...*)
lemma ECQw: "ECQw \<^bold>\<not>" using Cl_fr_def Disj_I ECQw_def unfolding conn by auto (*...but not 'boldly' paraconsistent*)
lemma ECQm: "ECQm \<^bold>\<not>" using Cl_fr_def Disj_I ECQm_def unfolding conn by auto
lemma "\<FF> \<F> \<Longrightarrow> LNC \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> DNI \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> DNE \<^bold>\<not>"  nitpick oops
lemma CoPw: "Fr_1b \<F> \<Longrightarrow> CoPw \<^bold>\<not>" using Cl_fr_def MONO_def monI unfolding Defs conn by smt
lemma "\<FF> \<F> \<Longrightarrow> CoP1 \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> CoP2 \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> CoP3 \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> XCoP \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> DM3 \<^bold>\<not>" nitpick oops

(**Moreover, we cannot have both DNI and DNE without validating ECQ (thus losing paraconsistency).*)
lemma "DNI \<^bold>\<not> \<and> DNE \<^bold>\<not> \<longrightarrow> ECQ \<^bold>\<not>" using DNE_def ECQ_def Int_fr_def neg_Idef unfolding conn by (metis (no_types, lifting))
(**However, we can have all of De Morgan laws while keeping (non-bold) paraconsistency.*)
lemma "\<sim>ECQ \<^bold>\<not> \<and> DM1 \<^bold>\<not> \<and> DM2 \<^bold>\<not> \<and> DM3 \<^bold>\<not> \<and> DM4 \<^bold>\<not> \<and> \<FF> \<F>" nitpick[satisfy,card w=3] oops (*(weakly paraconsistent) model found*)

(**Below we combine negation with strict implication and verify some interesting properties.
For instance, the following are not valid (and cannot become valid by adding semantic restrictions). *)
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (\<^bold>\<not>a \<^bold>\<Rightarrow> (a \<^bold>\<Rightarrow> b)) \<^bold>\<approx> \<^bold>\<top>" nitpick oops (*counterexample found*)
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (\<^bold>\<not>a \<^bold>\<rightarrow> (a \<^bold>\<rightarrow> b)) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<and> \<^bold>\<not>a \<^bold>\<Rightarrow> b) \<^bold>\<approx> \<^bold>\<top>"  nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<and> \<^bold>\<not>a \<^bold>\<rightarrow> b) \<^bold>\<approx> \<^bold>\<top>"  nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<Rightarrow> (b \<^bold>\<or> \<^bold>\<not>b)) \<^bold>\<approx> \<^bold>\<top>"  nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<rightarrow> (b \<^bold>\<or> \<^bold>\<not>b)) \<^bold>\<approx> \<^bold>\<top>"  nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. (a \<^bold>\<Rightarrow> \<^bold>\<not>a) \<^bold>\<Rightarrow> \<^bold>\<not>a \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. (a \<^bold>\<rightarrow> \<^bold>\<not>a) \<^bold>\<rightarrow> \<^bold>\<not>a \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<and> \<^bold>\<not>a) \<^bold>\<Rightarrow> b \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<and> \<^bold>\<not>a) \<^bold>\<rightarrow> b \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. a \<^bold>\<Rightarrow> (b \<^bold>\<or> \<^bold>\<not>b) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. a \<^bold>\<rightarrow> (b \<^bold>\<or> \<^bold>\<not>b) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<leftrightarrow> b) \<^bold>\<Rightarrow> (\<^bold>\<not>a \<^bold>\<leftrightarrow> \<^bold>\<not>b) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<leftrightarrow> b) \<^bold>\<rightarrow> (\<^bold>\<not>a \<^bold>\<leftrightarrow> \<^bold>\<not>b) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<Rightarrow> b) \<^bold>\<and> (a \<^bold>\<Rightarrow> \<^bold>\<not>b) \<^bold>\<Rightarrow> \<^bold>\<not>a \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<rightarrow> b) \<^bold>\<and> (a \<^bold>\<rightarrow> \<^bold>\<not>b) \<^bold>\<Rightarrow> \<^bold>\<not>a \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. (\<^bold>\<not>a  \<^bold>\<Rightarrow>  \<^bold>\<bottom>) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. (\<^bold>\<not>a  \<^bold>\<rightarrow>  \<^bold>\<bottom>) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. (\<^bold>\<not>a \<^bold>\<Rightarrow> \<^bold>\<not>(\<^bold>\<not>\<^bold>\<top>)) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. (\<^bold>\<not>a \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<not>\<^bold>\<top>)) \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. \<^bold>\<not>(\<^bold>\<not>(\<^bold>\<not>a)) \<^bold>\<Rightarrow> \<^bold>\<not>a \<^bold>\<approx> \<^bold>\<top>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> \<forall>a. \<^bold>\<not>(\<^bold>\<not>(\<^bold>\<not>a)) \<^bold>\<rightarrow> \<^bold>\<not>a \<^bold>\<approx> \<^bold>\<top>" nitpick oops

(**The (weak) local contraposition axiom is indeed valid under appropriate conditions.*)
lemma lCoPw: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> lCoPw(\<^bold>\<Rightarrow>) \<^bold>\<not>" proof -
  assume fr1: "Fr_1 \<F>" and fr2: "Fr_2 \<F>" and fr3: "Fr_3 \<F>" and fr4: "Fr_4 \<F>"
  { fix a b
    from fr2 have "\<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a \<^bold>\<approx> (\<C> a \<^bold>\<rightarrow> \<C> b) \<^bold>\<or> Q" using Cl_fr_def Fr_2_def Int_fr_def conn by auto
    moreover from fr1 fr2 fr3 have "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<preceq> \<C> a \<^bold>\<rightarrow> \<C> b" using IC_imp by simp
    ultimately have "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<preceq> \<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a" unfolding conn by simp
    moreover from fr1 fr2 fr4 have "let A=(a \<^bold>\<rightarrow> b); B=(\<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a) in \<I> A \<^bold>\<preceq> B \<longrightarrow> \<I> A \<^bold>\<preceq> \<I> B"
      using PF1 MONO_MULTa IF1a IF4 PI9 Int_9_def by smt
    ultimately have "\<I>(a \<^bold>\<rightarrow> b) \<^bold>\<preceq> \<I>(\<^bold>\<not>b \<^bold>\<rightarrow> \<^bold>\<not>a)" by simp
  } hence "lCoPw(\<^bold>\<Rightarrow>) \<^bold>\<not>" unfolding Defs conn by blast
  thus ?thesis by simp
qed
lemma lCoPw_strict: "\<FF> \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<Rightarrow> b) \<^bold>\<Rightarrow> (\<^bold>\<not>b \<^bold>\<Rightarrow> \<^bold>\<not>a) \<^bold>\<approx> \<^bold>\<top>" by (metis (no_types, lifting) DTw2 lCoPw lCoPw_def)

(**However, other (local) contraposition axioms are not valid.*)
lemma "\<FF> \<F> \<Longrightarrow> lCoP1(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops (*counterexample found*)
lemma "\<FF> \<F> \<Longrightarrow> lCoP2(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> lCoP3(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
(**And this time no variant of disjunctive syllogism is valid.*)
lemma "\<FF> \<F> \<Longrightarrow> DS1(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> DS2(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> DS2(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "\<FF> \<F> \<Longrightarrow> DS4(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops

(**Interestingly, one of the local contraposition axioms (lCoP1) follows from DNI.*)
lemma DNI_lCoP1: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> Fr_4 \<F> \<Longrightarrow> DNI \<^bold>\<not> \<longrightarrow> lCoP1(\<^bold>\<Rightarrow>) \<^bold>\<not>" proof -
  assume fr1: "Fr_1 \<F>" and fr2: "Fr_2 \<F>" and fr3: "Fr_3 \<F>" and fr4: "Fr_4 \<F>"
  { assume dni: "DNI \<^bold>\<not>"
    { fix a b
      from fr1 fr2 fr3 fr4 have "lCoPw(\<^bold>\<Rightarrow>) \<^bold>\<not>"  using lCoPw by simp
      hence 1: "a \<^bold>\<Rightarrow> \<^bold>\<not>b \<^bold>\<preceq> \<^bold>\<not>(\<^bold>\<not>b) \<^bold>\<Rightarrow> \<^bold>\<not>a" unfolding lCoPw_def by simp
      from fr1 have 2: "let A=b; B=\<^bold>\<not>(\<^bold>\<not>b); C=\<^bold>\<not>a in A \<^bold>\<preceq> B \<longrightarrow>  \<I>(B \<^bold>\<rightarrow> C) \<^bold>\<preceq> \<I>(A \<^bold>\<rightarrow> C)" by (simp add: MONO_ant PF1 monI)
      from dni have dnib: "b \<^bold>\<preceq> \<^bold>\<not>(\<^bold>\<not>b)" unfolding DNI_def by simp
      from 1 2 dnib have "a \<^bold>\<Rightarrow> \<^bold>\<not>b \<^bold>\<preceq> b \<^bold>\<Rightarrow> \<^bold>\<not>a" unfolding conn by meson
    } hence "lCoP1(\<^bold>\<Rightarrow>) \<^bold>\<not>" unfolding Defs by blast
  } thus ?thesis by simp
qed
(**This entails some other interesting results.*)
lemma DNI_CoP1: "Fr_1b \<F> \<Longrightarrow> DNI \<^bold>\<not> \<Longrightarrow> CoP1 \<^bold>\<not>" using CoP1_def2 CoPw by blast
lemma CoP1_LNC: "CoP1 \<^bold>\<not> \<Longrightarrow> LNC \<^bold>\<not>" using CoP1_def ECQm_def LNC_def  Cl_fr_def Disj_I ECQm_def unfolding conn by smt
lemma DNI_LNC: "Fr_1b \<F> \<Longrightarrow> DNI \<^bold>\<not> \<Longrightarrow> LNC \<^bold>\<not>" by (simp add: CoP1_LNC DNI_CoP1)

(**The following variants of modus tollens also obtain.*)
lemma MT: "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>a b. (a \<^bold>\<Rightarrow> b) \<^bold>\<and> \<^bold>\<not>b \<^bold>\<preceq> \<^bold>\<not>a" using Cl_fr_def Fr_2_def IC_imp Int_fr_def unfolding conn by metis
lemma MT': "Fr_1 \<F> \<Longrightarrow> Fr_2 \<F> \<Longrightarrow> Fr_3 \<F> \<Longrightarrow> \<forall>a b. ((a \<^bold>\<Rightarrow> b) \<^bold>\<and> \<^bold>\<not>b) \<^bold>\<Rightarrow> \<^bold>\<not>a \<^bold>\<approx> \<^bold>\<top>" by (simp add: DTw2 MT)

(**We now semantically characterize (an approximation of) Johansson's Minimal Logic along with some
exemplary 'subminimal' logics (observing that many more are possible). We check some relevant properties.*)
abbreviation "JML \<equiv> \<FF> \<F> \<and> DNI \<^bold>\<not>"
abbreviation "SML1 \<equiv> \<FF> \<F>" (*Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_3 \<F> \<and> Fr_4 \<F>*)
abbreviation "SML2 \<equiv> Fr_1 \<F> \<and> Fr_2 \<F> \<and> Fr_3 \<F>"
abbreviation "SML3 \<equiv> Fr_1 \<F>"
abbreviation "SML4 \<equiv> Fr_1b \<F>"

(**TND:*)
lemma "JML \<Longrightarrow> TND \<^bold>\<not>" nitpick oops (*counterexample found*)
lemma "JML \<Longrightarrow> TNDw \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> TNDm \<^bold>\<not>" nitpick oops

(**ECQ:*)
lemma "JML \<Longrightarrow> ECQ \<^bold>\<not>" nitpick oops
lemma "ECQw \<^bold>\<not>" using Cl_fr_def Disj_I ECQw_def unfolding conn by auto
lemma "ECQm \<^bold>\<not>" using Cl_fr_def Disj_I ECQm_def unfolding conn by auto

(**LNC:*)
lemma "JML \<Longrightarrow> LNC \<^bold>\<not>" using DNI_LNC PF1 by blast
lemma "SML1 \<Longrightarrow> LNC \<^bold>\<not>" nitpick oops

(**(r)DNI/DNE:*)
lemma "JML \<Longrightarrow> DNI \<^bold>\<not>" using CoP1_def2 by blast
lemma "SML1 \<Longrightarrow> rDNI \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> rDNE \<^bold>\<not>"  nitpick oops

(**CoP/MT:*)
lemma "SML4 \<Longrightarrow> CoPw \<^bold>\<not>" unfolding Defs by (smt Cl_fr_def MONO_def monI conn)
lemma "JML \<Longrightarrow> CoP1 \<^bold>\<not>" using DNI_CoP1 PF1 by blast
lemma "SML1 \<Longrightarrow> MT1 \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> MT2 \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> MT3 \<^bold>\<not>" nitpick oops

(**XCoP:*)
lemma "JML \<Longrightarrow> XCoP \<^bold>\<not>" nitpick oops

(**DM3/4:*)
lemma "JML \<Longrightarrow> DM3 \<^bold>\<not>" nitpick oops
lemma "SML3 \<Longrightarrow> DM4 \<^bold>\<not>" by (simp add: DM4 PF1)
lemma "SML4 \<Longrightarrow> DM4 \<^bold>\<not>" nitpick oops

(**nNor/nDNor:*)
lemma "SML2 \<Longrightarrow> nNor \<^bold>\<not>" using Cl_fr_def nNor_I nNor_def unfolding conn by auto
lemma "SML3 \<Longrightarrow> nNor \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> nDNor \<^bold>\<not>" nitpick oops

(**lCoP classical:*)
lemma "JML \<Longrightarrow> lCoPw(\<^bold>\<rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lCoP1(\<^bold>\<rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lCoP2(\<^bold>\<rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lCoP3(\<^bold>\<rightarrow>) \<^bold>\<not>" nitpick oops

(**DS classical:*)
lemma "JML \<Longrightarrow> DS1(\<^bold>\<rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> DS2(\<^bold>\<rightarrow>) \<^bold>\<not>" nitpick oops

(**lCoP strict:*)
lemma "SML1 \<Longrightarrow> lCoPw(\<^bold>\<Rightarrow>) \<^bold>\<not>" using lCoPw by blast
lemma "SML2 \<Longrightarrow> lCoPw(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lCoP1(\<^bold>\<Rightarrow>) \<^bold>\<not>" using CoP1_def2 DNI_lCoP1 by blast
lemma "SML1 \<Longrightarrow> lCoP1(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lCoP2(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lCoP3(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops

(**lMT strict:*)
lemma "SML2 \<Longrightarrow> lMT0(\<^bold>\<Rightarrow>) \<^bold>\<not>" unfolding Defs using MT by auto
lemma "SML3 \<Longrightarrow> lMT0(\<^bold>\<Rightarrow>) \<^bold>\<not>"  (*nitpick*) oops (*no countermodel found*)
lemma "SML4 \<Longrightarrow> lMT0(\<^bold>\<Rightarrow>) \<^bold>\<not>"  nitpick oops
lemma "JML \<Longrightarrow> lMT1(\<^bold>\<Rightarrow>) \<^bold>\<not>"  by (smt DNI_lCoP1 DT1 lCoP1_def lMT1_def)
lemma "SML1 \<Longrightarrow> lMT1(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lMT2(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> lMT3(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops

(**DS strict:*)
lemma "JML \<Longrightarrow> DS1(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> DS2(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> DS3(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> DS4(\<^bold>\<Rightarrow>) \<^bold>\<not>" nitpick oops

end

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


theory No_Exception

imports
  "Sail.Sail2_state_lemmas"
  "HOL-Eisbach.Eisbach_Tools"
  "Bound_UntilM"

begin

text \<open>
Show that an action in the monad does not result in exceptions.

Comes with a gadget for proving lots of such theorems with little
supervision.
\<close>
definition
  monad_no_exception :: "('e set) \<Rightarrow> ('regv, 'a, 'e) monad \<Rightarrow> bool"
  where
  "monad_no_exception S m = (\<forall>t res. (m, t, res) \<in> Traces \<longrightarrow> (res \<notin> Exception ` (- S)))"

lemmas monad_no_exceptionD = monad_no_exception_def[THEN iffD1, rule_format]

lemma monad_no_exception_weaken:
  "monad_no_exception S f \<Longrightarrow> S \<subseteq> S' \<Longrightarrow>
    monad_no_exception S' f"
  by (auto simp: monad_no_exception_def)

lemma bind_exception_case:
  "(f \<bind> (\<lambda>x. g x), t, Exception e) \<in> Traces \<Longrightarrow>
    (f, t, Exception e) \<in> Traces \<or>
    (\<exists>t' x t''. Run f t' x \<and> (g x, t'', Exception e) \<in> Traces \<and> t = t' @ t'')"
  apply (erule bind_Traces_cases)
   apply (case_tac m''; simp)
   apply auto
  done

lemma monad_no_exception_bind:
  "monad_no_exception S f \<Longrightarrow>
    (\<forall>x t. Run f t x \<longrightarrow> monad_no_exception S' (g x)) \<Longrightarrow>
    monad_no_exception (S \<union> S') (bind f (\<lambda>x. g x))"
  apply (subst monad_no_exception_def, clarsimp)
  apply (drule bind_exception_case)
  apply (auto simp: monad_no_exception_def)
  apply fastforce
  done

lemma monad_no_exception_bind_simple:
  "monad_no_exception S f \<Longrightarrow>
    (\<And>x. monad_no_exception S (g x)) \<Longrightarrow>
    monad_no_exception S (bind f (\<lambda>x. g x))"
  by (drule monad_no_exception_bind, auto)

lemmas monad_no_exception_bind_backward =
  monad_no_exception_bind[where S=S and S'=S for S, simplified]

lemma try_catch_monad_no_exception:
  "monad_no_exception Q f \<Longrightarrow>
    (\<forall>x t. (f, t, Exception x) \<in> Traces \<and> x \<in> Q\<longrightarrow> monad_no_exception S (g x)) \<Longrightarrow>
    monad_no_exception S (try_catch f (\<lambda>x. g x))"
  apply (subst monad_no_exception_def, clarsimp)
  apply (erule try_catch_Traces_cases)
   apply (drule(1) monad_no_exceptionD)
   apply (case_tac m'; clarsimp)
   apply (drule spec, drule mp, rule conjI, erule exI)
    apply blast
   apply (clarsimp dest!: sym[where s="Exception _"])
   apply (simp add: monad_no_exception_def)
  apply (drule spec, drule mp, rule conjI, erule exI)
   apply (drule(1) monad_no_exceptionD)+
   apply auto[1]
  apply (drule(1) monad_no_exceptionD)+
  apply auto
  done

named_theorems monad_no_exception

lemma monad_no_exception_return[monad_no_exception]:
  "monad_no_exception {} (return x)"
  by (clarsimp simp add: monad_no_exception_def return_def)

lemma monad_no_exception_throw[monad_no_exception]:
  "monad_no_exception {x} (throw x)"
  by (clarsimp simp add: monad_no_exception_def throw_def)

definition
  sum_right_restrict :: "'b set \<Rightarrow> ('a + 'b) set"
  where
  "sum_right_restrict S = ((Inr ` S) \<union> range Inl)"

lemma sum_right_restrict_simps[simp]:
  "Inl x \<in> sum_right_restrict S"
  "(Inr x \<in> sum_right_restrict S) = (x \<in> S)"
  by (auto simp add: sum_right_restrict_def)

lemma catch_early_return_no_exception:
  "monad_no_exception (sum_right_restrict S) m \<Longrightarrow>
    monad_no_exception S (catch_early_return m)"
  apply (simp add: catch_early_return_def)
  apply (erule try_catch_monad_no_exception)
  apply (clarsimp split: sum.split)
  apply (intro conjI impI allI
    monad_no_exception_return[THEN monad_no_exception_weaken], simp_all)
  apply (rule monad_no_exception_weaken, rule monad_no_exception_throw)
  apply simp
  done

lemmas monad_no_exception_early_return[monad_no_exception] =
    monad_no_exception_throw[where x="Inl rv" for rv, folded early_return_def]

lemma liftR_no_exception:
  "monad_no_exception S f \<Longrightarrow>
    monad_no_exception (sum_right_restrict S) (liftR f)"
  apply (simp add: liftR_def)
  apply (erule try_catch_monad_no_exception)
  apply (clarsimp)
  apply (rule monad_no_exception_weaken, rule monad_no_exception_throw)
  apply simp
  done

lemma monad_no_exception_Fail[monad_no_exception]:
  "monad_no_exception {} (Fail s)"
  by (clarsimp simp add: monad_no_exception_def)

lemma monad_no_exception_Done[monad_no_exception]:
  "monad_no_exception {} (Done x)"
  by (clarsimp simp add: monad_no_exception_def)

lemma monad_no_exception_maybe_fail[monad_no_exception]:
  "monad_no_exception {} (maybe_fail s x)"
  by (simp add: maybe_fail_def monad_no_exception split: option.split)

lemma read_reg_traces[monad_no_exception]:
  "monad_no_exception {} (read_reg r)"
  apply (clarsimp simp add: monad_no_exception_def read_reg_def)
  apply (erule Traces.cases)
   apply clarsimp
  apply (erule T.cases; clarsimp split: option.split_asm)
  done

lemma write_reg_traces[monad_no_exception]:
  "monad_no_exception {} (write_reg r x)"
  apply (clarsimp simp add: monad_no_exception_def write_reg_def)
  apply (erule Traces.cases)
   apply clarsimp
  apply (erule T.cases; clarsimp split: option.split_asm)
  done

ML \<open>
structure Auto_Split_Tac = struct

fun add_consts i (Const c) xs = ((i, c) :: xs)
  | add_consts i (f $ x) xs = add_consts (i + 1) x (add_consts i f xs)
  | add_consts _ _ xs = xs

fun const_name_to_split thy nm = let
    val x = BNF_LFP_Compat.get_info thy [] (Long_Name.qualifier nm)
  in Option.map (#split) x end

fun tac ctxt = SUBGOAL (fn (t, i) => let
    val concl = Logic.strip_assums_concl t
    val cs = add_consts 0 concl [] |> map (apsnd fst)
        |> sort_distinct (prod_ord int_ord fast_string_ord)
    val thy = Proof_Context.theory_of ctxt
    val split = get_first (const_name_to_split thy) (map snd cs)
  in case split of NONE => no_tac
    | SOME t => Splitter.split_tac ctxt [t] i end)

fun meth ctxt = Method.SIMPLE_METHOD (tac ctxt 1)

end
\<close>

method_setup auto_split = \<open>Scan.succeed () >> K Auto_Split_Tac.meth\<close>

method monad_no_exceptionI uses rules = (determ \<open>
    intro allI conjI impI monad_no_exception_bind_simple
        monad_no_exception empty_subsetI
  | rule rules monad_no_exception
  | (rule monad_no_exception_weaken, rule rules monad_no_exception)
  | auto_split\<close>)+

lemma Read_mem_monad_no_exception:
  "(\<forall>x. monad_no_exception {} (f x)) \<Longrightarrow>
    monad_no_exception {} (Read_mem rk x sz f)"
  apply (clarsimp simp: monad_no_exception_def)
  apply (erule Traces.cases; clarsimp)
  apply (erule T.cases; clarsimp)
  apply fastforce
  done

lemma read_mem_monad_no_exception[monad_no_exception]:
  "monad_no_exception {}
    (read_mem dict_Sail2_values_Bitvector_a dict_Sail2_values_Bitvector_b rk addr_sz addr sz)"
  apply (simp add: read_mem_def read_mem_bytes_def maybe_fail_def[symmetric])
  apply (monad_no_exceptionI rules: Read_mem_monad_no_exception)
  done

lemma Write_mem_monad_no_exception:
  "(\<forall>x. monad_no_exception {} (f x)) \<Longrightarrow>
    monad_no_exception {} (Write_mem wk x sz v f)"
  apply (clarsimp simp: monad_no_exception_def)
  apply (erule Traces.cases; clarsimp)
  apply (erule T.cases; clarsimp)
  apply fastforce
  done

lemma write_mem_monad_no_exception[monad_no_exception]:
  "monad_no_exception {}
    (write_mem class_a class_b wk addr_sz addr sz v)"
  apply (simp add: write_mem_def read_mem_bytes_def maybe_fail_def split: option.split)
  apply (monad_no_exceptionI rules: Write_mem_monad_no_exception)
  done

lemma or_boolM_no_exception:
  "monad_no_exception S m \<Longrightarrow> monad_no_exception S m' \<Longrightarrow>
    monad_no_exception S (or_boolM m m')"
  apply (simp add: or_boolM_def)
  apply (monad_no_exceptionI | simp)+
  done

lemma and_boolM_no_exception:
  "monad_no_exception S m \<Longrightarrow> monad_no_exception S m' \<Longrightarrow>
    monad_no_exception S (and_boolM m m')"
  apply (simp add: and_boolM_def)
  apply (monad_no_exceptionI | simp)+
  done

lemma let_unfold_no_exception:
  "monad_no_exception S (f s) \<Longrightarrow>
    monad_no_exception S (Let s f)"
  by simp

lemma let_simple_no_exception:
  "(\<And>s. monad_no_exception S (f s)) \<Longrightarrow>
    monad_no_exception S (Let s f)"
  by simp

lemma bound_untilM_no_exception:
  "(\<forall>vars. monad_no_exception S (cond vars)) \<Longrightarrow>
    (\<forall>vars. monad_no_exception S (body vars)) \<Longrightarrow>
    monad_no_exception S (bound_untilM bound vars cond body)"
  apply (induct bound vars cond body rule: bound_untilM.induct)
  apply (subst bound_untilM.simps)
  apply (intro monad_no_exception_bind_backward allI impI)
    apply (monad_no_exceptionI | clarsimp)+
  done

lemma foreachM_monad_no_exception:
  "(\<And>x vs tr e. x \<in> set xs \<Longrightarrow> monad_no_exception S (body x vs)) \<Longrightarrow>
   monad_no_exception S (foreachM xs vs body)"
  by (induct xs arbitrary: vs, (monad_no_exceptionI | simp)+)

lemma genlistM_monad_no_exception:
  "(\<And>i. i < n \<Longrightarrow> monad_no_exception S (f i)) \<Longrightarrow> monad_no_exception S (genlistM f n)"
  apply (clarsimp simp add: genlistM_def genlist_def)
  apply (monad_no_exceptionI rules: foreachM_monad_no_exception | simp)+
  done

lemma monad_no_exception_Choose:
  "(\<forall>b. monad_no_exception S (cont b)) \<Longrightarrow>
    monad_no_exception S (Choose nm cont)"
  apply (clarsimp simp: monad_no_exception_def)
  apply (erule Traces.cases; clarsimp)
  apply (auto elim!: T.cases)
  done

named_theorems monad_no_exception_intro

lemmas monad_no_exception_intro_init[monad_no_exception_intro] =
    conjI impI allI Un_least monad_no_exception_bind_simple
    or_boolM_no_exception and_boolM_no_exception
    catch_early_return_no_exception let_simple_no_exception
    liftR_no_exception monad_no_exception_Choose
    foreachM_monad_no_exception genlistM_monad_no_exception
    bound_untilM_no_exception
    if_split[where P="monad_no_exception _", THEN iffD2]
    prod.split[where P="monad_no_exception _", THEN iffD2]
    option.split[where P="monad_no_exception _", THEN iffD2]

lemmas monad_no_exception_Choose_return =
    monad_no_exception_Choose[rule_format, OF monad_no_exception_return, simplified]

ML \<open>
structure Monad_No_Exception_Exploration = struct

val triv = Thm.trivial @{cprop "monad_no_exception S m"}
  |> Drule.generalize (["'a", "'b", "'c"], ["S", "m"])

fun dest_eq2 t = Logic.dest_equals t
  handle TERM _ => HOLogic.dest_eq (HOLogic.dest_Trueprop t)

fun is_monadT (Type (@{type_name monad}, _)) = true
  | is_monadT _ = false

val is_meta_monadT = is_monadT o snd o strip_type

fun is_monad_const t = let
    val (f, xs) = strip_comb t
  in is_Const f andalso is_monadT (fastype_of t)
    andalso not (exists (is_meta_monadT o fastype_of) xs) end

fun add_monad_consts [] xs = xs
  | add_monad_consts ((f $ x) :: ts) xs = add_monad_consts (f :: x :: ts)
    ((if is_monad_const (f $ x) then [f $ x] else []) @ xs)
  | add_monad_consts (Abs (nm, ty, t) :: ts) xs = let
    val t' = betapply (Abs (nm, ty, t), Var ((suffix "_bv" nm, 0), ty))
  in add_monad_consts (t' :: ts) xs end
  | add_monad_consts (_ :: ts) xs = add_monad_consts ts xs

fun fetch_by_term ctxt extras term = let
    val inst = Drule.infer_instantiate ctxt
        [(("m", 0), Thm.cterm_of ctxt term)] triv
    val thms = Named_Theorems.get ctxt @{named_theorems "monad_no_exception"}
    val resn = (extras @ thms) RL [inst]
  in case resn of [] => raise TERM ("fetch_by_term", [term])
    | (t :: _) => t
  end

fun dest (Const (@{const_name monad_no_exception}, _) $ S $ m) = (S, m)
  | dest t = raise TERM ("monad_no_exception dest", [t])

fun get_prop ctxt tm sub_thm_concls = let
    val _ = not (null sub_thm_concls) orelse raise TERM ("get_prop: no sub thms", [tm])
    val S_ty = dest (hd sub_thm_concls) |> fst |> fastype_of
    val S = Const (@{const_name bot}, S_ty)
    val inst = Drule.infer_instantiate ctxt
        [(("m", 0), Thm.cterm_of ctxt tm), (("S", 0), Thm.cterm_of ctxt S)] triv
  in Thm.concl_of inst end

fun prove ctxt extras defn = let
    val freeze_defn = Variable.import_vars ctxt defn
    val prop = Thm.concl_of freeze_defn
    val (term, expanded) = dest_eq2 prop
    val sub_fs = add_monad_consts [expanded] []
        |> sort_distinct Term_Ord.fast_term_ord
    val sub_thms = map (fetch_by_term ctxt extras) sub_fs
    val sub_thm_insts = sub_thms RL @{thms monad_no_exception_weaken}
    val prop = get_prop ctxt term (map (Thm.concl_of #> HOLogic.dest_Trueprop) sub_thms)
    val subset_ss = put_simpset HOL_ss ctxt addsimps @{thms subset_iff mem_simps}
    val intros = Named_Theorems.get ctxt @{named_theorems monad_no_exception_intro}
    val tac = simp_tac (put_simpset HOL_basic_ss ctxt addsimps [defn])
        THEN_ALL_NEW REPEAT_ALL_NEW (match_tac ctxt
            (intros @ sub_thm_insts))
        THEN_ALL_NEW simp_tac subset_ss
        THEN_ALL_NEW simp_tac ctxt
    val nms = Term.add_frees prop [] |> map fst
    fun tr ctxt = Syntax.pretty_term ctxt term
      |> (fn p => Pretty.block [Pretty.str "proving monad_no_exception for: ", p])
      |> Pretty.writeln
  in Goal.prove ctxt nms [] prop (fn r => (tr (#context r); tac 1))
  end

fun defn_name defn = Term.term_name (head_of (fst (dest_eq2 (Thm.concl_of defn))))

fun prove_rec thys ctxt extras nm defn = let
    val thm = prove ctxt extras defn
  in thm :: extras end
  handle TERM ("fetch_by_term", [tm]) => let
      val f = head_of tm
      val _ = is_Const f orelse raise TERM ("prove_rec: stuck", [tm])
      val f_nm = fst (dest_Const f)
      val q = Long_Name.qualifier f_nm
      val _ = member (op =) thys q orelse raise TERM ("prove_rec: not in thys", [tm])
      val def2 = Proof_Context.get_thm ctxt (suffix "_def" f_nm)
      val _ = tracing ("recursing " ^ nm ^ " --> "  ^ f_nm)
      val extras2 = prove_rec thys ctxt extras f_nm def2
    in prove_rec thys ctxt extras2 nm defn end

fun install_rec thys defn thy = let
    val ctxt = Proof_Context.init_global thy
    val thms = prove_rec thys ctxt [] "toplevel" defn
  in Context.theory_map
    (fold (Named_Theorems.add_thm @{named_theorems "monad_no_exception"}) thms)
    thy
  end

fun install_recs thys = fold (install_rec thys)

end
\<close>

lemma choose_bool_monad_no_exception[monad_no_exception]:
  "monad_no_exception {} (choose_bool s)"
  apply (simp add: choose_bool_def)
  apply (rule monad_no_exception_Choose_return)
  done

lemma bool_of_bitU_nondet_monad_no_exception[monad_no_exception]:
  "monad_no_exception {} (bool_of_bitU_nondet bitU)"
  by (cases bitU, simp_all add: bool_of_bitU_nondet_def, monad_no_exceptionI)

setup \<open>Monad_No_Exception_Exploration.install_recs
  ["Sail2_prompt_monad", "Sail2_prompt"]
  @{thms exit0_def assert_exp_def
    undefined_bool_def internal_pick_def
    of_bits_nondet_def}\<close>

end


theory IHT_Small_Examples
  imports
    "../SepLogicTime/SLTC_Main"
    "../Asymptotics/Asymptotics_1D"
begin

section \<open>f1 doubles\<close>

definition f1_impl :: "nat \<Rightarrow> nat Heap" where
  "f1_impl n = do { return (2*n) }"

definition f1_time :: nat where [rewrite]:
  "f1_time = 1"

lemma f1_time_bound [asym_bound]:
  "(\<lambda>n. f1_time) \<in> \<Theta>(\<lambda>(n::nat). 1)" unfolding f1_time_def by auto

lemma f1_rule [hoare_triple]:
  "<$(f1_time)> f1_impl n <\<lambda>r. \<up>(r=2*n)>\<^sub>t" by auto2

setup \<open>del_prfstep_thm @{thm f1_time_def}\<close>

section \<open>f2 builds two new Arrays\<close>

definition f2_impl :: "nat \<Rightarrow> ('a::heap array \<times> 'a array) Heap" where
  "f2_impl (n::nat) = do {
     r1 \<leftarrow> Array_Time.new n undefined;
     r2 \<leftarrow> Array_Time.new n undefined;
     return (r1,r2)
   }"

definition f2_time :: "nat \<Rightarrow> nat" where [rewrite]:
  "f2_time n = 2 * n + 3"

lemma f2_time_bound [asym_bound]:
  "(\<lambda>n. f2_time n) \<in> \<Theta>(\<lambda>n. n)" unfolding f2_time_def by auto

lemma f2_rule [hoare_triple]:
  "<$(f2_time (n))>
    f2_impl n
   <\<lambda>r. fst r \<mapsto>\<^sub>a replicate n undefined * snd r \<mapsto>\<^sub>a replicate n undefined>\<^sub>t" by auto2

setup \<open>del_prfstep_thm @{thm f2_time_def}\<close>

section \<open>f squares the length of a list and generates two arrays of that size\<close>

definition f_impl :: "'a::heap list \<Rightarrow> ('a array \<times> 'a array) Heap" where
  "f_impl xs = do {
     n \<leftarrow> f1_impl (length xs);
     f2_impl n
   }"

definition f_time :: "nat \<Rightarrow> nat" where [rewrite]:
  "f_time n = f1_time + f2_time (2 * n) + 1"

lemma f_rule [hoare_triple]:
  "<$(f_time (length xs))>
    f_impl xs
   <\<lambda>r. fst r \<mapsto>\<^sub>a replicate (2*length xs) undefined *
        snd r \<mapsto>\<^sub>a replicate (2*length xs) undefined>\<^sub>t" by auto2

lemma f_time_bound [asym_bound]: "(\<lambda>n. f_time n) \<in> \<Theta>(\<lambda>n. n)"
  unfolding f_time_def by auto2

setup \<open>del_prfstep_thm @{thm f_time_def}\<close>

end