theory ex_subminimal_logics
  imports topo_negation_conditions topo_strict_implication
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Example application: Subintuitionistic and subminimal logics\<close>

text\<open>\noindent{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.}\<close>

text\<open>\noindent{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>'"}.}\<close>
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>'"

text\<open>\noindent{As defined, @{text "\<F>'"} (and its corresponding closure operation) satisfies several semantic conditions.}\<close>
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
text\<open>\noindent{However Fr-3 is not valid. In fact, adding it by hand would collapse into classical logic (making all sets clopen).}\<close>
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)

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

text\<open>\noindent{and observe that some plausible semantic properties obtain:}\<close>
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

text\<open>\noindent{The negation so defined validates some properties corresponding to a (rather weak) paracomplete logic:}\<close>
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

text\<open>\noindent{Moreover, we cannot have both DNI and DNE without validating ECQ (thus losing paraconsistency).}\<close>
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))
text\<open>\noindent{However, we can have all of De Morgan laws while keeping (non-bold) paraconsistency.}\<close>
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*)

text\<open>\noindent{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). }\<close>
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

text\<open>\noindent{The (weak) local contraposition axiom is indeed valid under appropriate conditions.}\<close>
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)

text\<open>\noindent{However, other (local) contraposition axioms are not valid.}\<close>
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
text\<open>\noindent{And this time no variant of disjunctive syllogism is valid.}\<close>
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

text\<open>\noindent{Interestingly, one of the local contraposition axioms (lCoP1) follows from DNI.}\<close>
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
text\<open>\noindent{This entails some other interesting results.}\<close>
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)

text\<open>\noindent{The following variants of modus tollens also obtain.}\<close>
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)

text\<open>\noindent{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.}\<close>
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>"

text\<open>\noindent{TND:}\<close>
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

text\<open>\noindent{ECQ:}\<close>
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

text\<open>\noindent{LNC:}\<close>
lemma "JML \<Longrightarrow> LNC \<^bold>\<not>" using DNI_LNC PF1 by blast
lemma "SML1 \<Longrightarrow> LNC \<^bold>\<not>" nitpick oops

text\<open>\noindent{(r)DNI/DNE:}\<close>
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

text\<open>\noindent{CoP/MT:}\<close>
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

text\<open>\noindent{XCoP:}\<close>
lemma "JML \<Longrightarrow> XCoP \<^bold>\<not>" nitpick oops

text\<open>\noindent{DM3/4:}\<close>
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

text\<open>\noindent{nNor/nDNor:}\<close>
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

text\<open>\noindent{lCoP classical:}\<close>
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

text\<open>\noindent{DS classical:}\<close>
lemma "JML \<Longrightarrow> DS1(\<^bold>\<rightarrow>) \<^bold>\<not>" nitpick oops
lemma "JML \<Longrightarrow> DS2(\<^bold>\<rightarrow>) \<^bold>\<not>" nitpick oops

text\<open>\noindent{lCoP strict:}\<close>
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

text\<open>\noindent{lMT strict:}\<close>
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

text\<open>\noindent{DS strict:}\<close>
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


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory ListRev
imports "AutoCorres.AutoCorres"
begin

external_file "list_rev.c"
install_C_file "list_rev.c"

autocorres [heap_abs_syntax] "list_rev.c"

primrec
  list :: "lifted_globals \<Rightarrow> node_C ptr \<Rightarrow> node_C ptr list \<Rightarrow> bool"
where
  "list s p [] = (p = NULL)"
| "list s p (x#xs) = (
       p = x \<and> p \<noteq> NULL \<and> is_valid_node_C s p \<and> list s (s[p]\<rightarrow>next) xs)"

lemma list_empty [simp]:
  "list s NULL xs = (xs = [])"
  by (induct xs) auto

lemma list_in [simp]:
  "\<lbrakk> list s p xs; p \<noteq> NULL \<rbrakk> \<Longrightarrow> p \<in> set xs"
  by (induct xs) auto

lemma list_non_NULL:
  "\<lbrakk> p \<noteq> NULL \<rbrakk> \<Longrightarrow>
    list s p xs = (\<exists>ys. xs = p # ys \<and> is_valid_node_C s p \<and> list s (s[p]\<rightarrow>next) ys)"
  by (cases xs) auto

lemma list_unique:
  "list s p xs \<Longrightarrow> list s p ys \<Longrightarrow> xs = ys"
  by (induct xs arbitrary: p ys) (auto simp add: list_non_NULL)

lemma list_append_Ex:
  "list s p (xs @ ys) \<Longrightarrow> (\<exists>q. list s q ys)"
  by (induct xs arbitrary: p) auto

lemma list_distinct [simp]:
  "list s p xs \<Longrightarrow> distinct xs"
  apply (induct xs arbitrary: p)
   apply simp
  apply (clarsimp dest!: split_list)
  apply (frule list_append_Ex)
  apply (auto dest: list_unique)
  done

lemma list_heap_update_ignore [simp]:
  "q \<notin> set xs \<Longrightarrow> list (s[q\<rightarrow>next := v]) p xs = list s p xs"
  apply (induct xs arbitrary: p)
   apply clarsimp
  apply (clarsimp simp: fun_upd_def)
  done

definition
  the_list :: "lifted_globals \<Rightarrow> node_C ptr \<Rightarrow> node_C ptr list"
where
  "the_list s p = (THE xs. list s p xs)"

lemma the_list_val [simp]: "list s p xs \<Longrightarrow> the_list s p = xs"
  apply (clarsimp simp: the_list_def)
  apply (metis (lifting) list_unique the_equality)
  done

definition "reverse_inv xs list' rev' s =
                 (\<exists>ys zs. list s list' ys
                    \<and> list s rev' zs
                    \<and> rev xs = rev ys @ zs
                    \<and> distinct (rev xs))"

lemma (in list_rev) reverse_correct:
  "\<lbrace> \<lambda>s. list s p xs \<rbrace>
     reverse' p
   \<lbrace> \<lambda>rv s. list s rv (rev xs) \<rbrace>!"
  apply (clarsimp simp: reverse'_def)
  apply (subst whileLoop_add_inv [where
        I="\<lambda>(list', rev') s. reverse_inv xs list' rev' s"
        and M="\<lambda>((list', rev'), s). length (the_list s list')",
        unfolded reverse_inv_def])
  apply wp
    apply (clarsimp simp del: distinct_rev)
    apply (case_tac ys, fastforce)
    apply (clarsimp simp del: distinct_rev)
    apply (rule_tac x=lista in exI)
    apply (simp add: fun_upd_def)
   apply (clarsimp simp del: distinct_rev)
  apply simp
  done

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      Closure.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2006-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section "Experiments with Closures"

theory Closure
imports "../Hoare"
begin

definition
"callClosure upd cl = Seq (Basic (upd (fst cl))) (Call (snd cl))"

definition
"dynCallClosure init upd cl return c =
  DynCom (\<lambda>s. call (upd (fst (cl s)) \<circ> init) (snd (cl s)) return c)"

lemma dynCallClosure_sound:
assumes adapt:
  "P \<subseteq> {s. \<exists>P' Q' A'. \<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub> P' (callClosure upd (cl s)) Q',A' \<and>
                  init s \<in> P' \<and>
                  (\<forall>t \<in> Q'. return s t \<in> R s t) \<and>
                  (\<forall>t \<in> A'. return s t \<in> A)}"
assumes res: "\<forall>s t n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
shows
"\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub>P (dynCallClosure init upd cl return c) Q,A"
proof (rule cnvalidI)
  fix s t
  assume ctxt: "\<forall>(P, p, Q, A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P Call p Q,A"
  assume exec: "\<Gamma>\<turnstile> \<langle>dynCallClosure init upd cl return c,Normal s\<rangle> =n\<Rightarrow> t"
  from execn.Basic [where f="(upd (fst (cl s)))" and s="(init s)"]
  have exec_upd: "\<Gamma>\<turnstile>\<langle>Basic (upd (fst (cl s))),Normal (init s)\<rangle> =n\<Rightarrow>
             Normal (((upd (fst (cl s))) \<circ> init) s)"
      by auto
  assume P: "s \<in> P"
  from P adapt obtain P' Q' A'
      where
      valid: "\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub> P' (callClosure upd (cl s)) Q',A'" and
      init_P': "init s \<in> P'"  and
      R: "(\<forall>t \<in> Q'. return s t \<in> R s t)" and
      A: "(\<forall>t \<in> A'. return s t \<in> A)"
      by auto
  assume t_notin_F: "t \<notin> Fault ` F"
  from exec [simplified dynCallClosure_def]
  have exec_call:
      "\<Gamma>\<turnstile>\<langle>call (upd (fst (cl s)) \<circ> init) (snd (cl s)) return c,Normal s\<rangle> =n\<Rightarrow> t"
    by cases
  then
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
  proof (cases rule: execn_call_Normal_elim)
    fix bdy m t'
    assume bdy: "\<Gamma> (snd (cl s)) = Some bdy"
    assume exec_body: "\<Gamma>\<turnstile>\<langle>bdy,Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =m\<Rightarrow> Normal t'"
    assume exec_c: "\<Gamma>\<turnstile>\<langle>c s t',Normal (return s t')\<rangle> =Suc m\<Rightarrow> t"
    assume n: "n = Suc m"
    have "\<Gamma>\<turnstile>\<langle>Basic init,Normal s\<rangle> =m\<Rightarrow> Normal (init s)"
      by (rule execn.Basic)
    from bdy exec_body
    have exec_callC:
      "\<Gamma>\<turnstile>\<langle>Call (snd (cl s)),Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =Suc m\<Rightarrow> Normal t'"
      by (rule execn.Call)
    from execn.Seq [OF exec_upd [simplified n]exec_callC]
    have exec_closure: "\<Gamma>\<turnstile> \<langle>callClosure upd (cl s),Normal (init s)\<rangle> =n\<Rightarrow> Normal t'"
      by (simp add: callClosure_def n)
    from cnvalidD [OF valid [rule_format] ctxt exec_closure init_P']
    have "t' \<in> Q'"
      by auto
    with R have "return s t' \<in> R s t'"
      by auto
    from cnvalidD [OF res [rule_format] ctxt exec_c [simplified n[symmetric]] this
         t_notin_F]
    show ?thesis
      by auto
  next
    fix bdy m t'
    assume bdy: "\<Gamma> (snd (cl s)) = Some bdy"
    assume exec_body: "\<Gamma>\<turnstile>\<langle>bdy,Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =m\<Rightarrow> Abrupt t'"
    assume t: "t=Abrupt (return s t')"
    assume n: "n = Suc m"
    from bdy exec_body
    have exec_callC:
      "\<Gamma>\<turnstile>\<langle>Call (snd (cl s)),Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =Suc m\<Rightarrow> Abrupt t'"
      by (rule execn.Call)
    from execn.Seq [OF exec_upd [simplified n] exec_callC]
    have exec_closure: "\<Gamma>\<turnstile> \<langle>callClosure upd (cl s),Normal (init s)\<rangle> =n\<Rightarrow> Abrupt t'"
      by (simp add: callClosure_def n)

    from cnvalidD [OF valid [rule_format] ctxt exec_closure init_P']
    have "t' \<in> A'"
      by auto
    with A have "return s t' \<in> A"
      by auto
    with t show ?thesis
      by auto
  next
    fix bdy m f
    assume bdy: "\<Gamma> (snd (cl s)) = Some bdy"
    assume exec_body: "\<Gamma>\<turnstile>\<langle>bdy,Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =m\<Rightarrow> Fault f"
    assume t: "t=Fault f"
    assume n: "n = Suc m"
    from bdy exec_body
    have exec_callC:
      "\<Gamma>\<turnstile>\<langle>Call (snd (cl s)),Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =Suc m\<Rightarrow> Fault f"
      by (rule execn.Call)
    from execn.Seq [OF exec_upd [simplified n] exec_callC]
    have exec_closure: "\<Gamma>\<turnstile> \<langle>callClosure upd (cl s),Normal (init s)\<rangle> =n\<Rightarrow> Fault f"
      by (simp add: callClosure_def n)
    from cnvalidD [OF valid [rule_format] ctxt exec_closure init_P'] t_notin_F t
    have False
      by auto
    thus ?thesis ..
  next
    fix bdy m
    assume bdy: "\<Gamma> (snd (cl s)) = Some bdy"
    assume exec_body: "\<Gamma>\<turnstile>\<langle>bdy,Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =m\<Rightarrow> Stuck"
    assume t: "t=Stuck"
    assume n: "n = Suc m"
    from execn.Basic [where f="(upd (fst (cl s)))" and s="(init s)"]
    have exec_upd: "\<Gamma>\<turnstile>\<langle>Basic (upd (fst (cl s))),Normal (init s)\<rangle> =Suc m\<Rightarrow>
             Normal (((upd (fst (cl s))) \<circ> init) s)"
      by auto
    from bdy exec_body
    have exec_callC:
      "\<Gamma>\<turnstile>\<langle>Call (snd (cl s)),Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =Suc m\<Rightarrow> Stuck"
      by (rule execn.Call)
    from execn.Seq [OF exec_upd [simplified n] exec_callC]
    have exec_closure: "\<Gamma>\<turnstile> \<langle>callClosure upd (cl s),Normal (init s)\<rangle> =n\<Rightarrow> Stuck"
      by (simp add: callClosure_def n)
    from cnvalidD [OF valid [rule_format] ctxt exec_closure init_P'] t_notin_F t
    have False
      by auto
    thus ?thesis ..
  next
    fix m
    assume no_bdy: "\<Gamma> (snd (cl s)) = None"
    assume t: "t=Stuck"
    assume n: "n = Suc m"
    from no_bdy
    have exec_callC:
      "\<Gamma>\<turnstile>\<langle>Call (snd (cl s)),Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =Suc m\<Rightarrow> Stuck"
      by (rule execn.CallUndefined)
    from execn.Seq [OF exec_upd [simplified n]exec_callC]
    have exec_closure: "\<Gamma>\<turnstile> \<langle>callClosure upd (cl s),Normal (init s)\<rangle> =n\<Rightarrow> Stuck"
      by (simp add: callClosure_def n)
    from cnvalidD [OF valid [rule_format] ctxt exec_closure init_P'] t_notin_F t
    have False
      by auto
    thus ?thesis ..
  qed
qed

lemma dynCallClosure:
assumes adapt: "P \<subseteq> {s. \<exists>P' Q' A'. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub> P' (callClosure upd (cl s)) Q',A' \<and>
                  init s \<in> P' \<and>
                  (\<forall>t \<in> Q'. return s t \<in> R s t) \<and>
                  (\<forall>t \<in> A'. return s t \<in> A)}"
assumes res: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
shows
"\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P (dynCallClosure init upd cl return c) Q,A"
  apply (rule hoare_complete')
  apply (rule allI)
  apply (rule dynCallClosure_sound [where R=R])
  using adapt
  apply (blast intro: hoare_cnvalid)
  using res
  apply (blast intro: hoare_cnvalid)
  done

lemma dynCallClosureFix:
assumes adapt: "P \<subseteq> {s. \<exists>Z. cl'=cl s \<and>
                  init s \<in> P' Z \<and>
                  (\<forall>t \<in> Q' Z. return s t \<in> R s t) \<and>
                  (\<forall>t \<in> A' Z. return s t \<in> A)}"
assumes res: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub> (P' Z) (callClosure upd cl') (Q' Z),(A' Z)"
shows
"\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P (dynCallClosure init upd cl return c) Q,A"
  apply (rule dynCallClosure [OF _ res])
  using adapt spec
  apply clarsimp
  apply (drule (1) in_subsetD)
  apply clarsimp
  apply (rule_tac x="P' Z" in exI)
  apply (rule_tac x="Q' Z" in exI)
  apply (rule_tac x="A' Z" in exI)
  apply blast
  done

lemma conseq_extract_pre:
             "\<lbrakk>\<forall>s \<in> P. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s}) c Q,A\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  apply (rule hoarep.Conseq)
  apply clarify
  apply (rule_tac x="{s}" in exI)
  apply (rule_tac x="Q" in exI)
  apply (rule_tac x="A" in exI)
  by simp

lemma app_closure_sound:
  assumes adapt: "P \<subseteq> {s. \<exists>P' Q' A'. \<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P' (callClosure upd (e',p)) Q',A' \<and>
                           upd x s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A}"
  assumes ap: "upd e = upd e' \<circ> upd x"
  shows "\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P (callClosure upd (e,p)) Q,A"
proof (rule cnvalidI)
  fix s t
  assume ctxt: "\<forall>(P, p, Q, A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P Call p Q,A"
  assume exec_e: "\<Gamma>\<turnstile> \<langle>callClosure upd (e, p),Normal s\<rangle> =n\<Rightarrow> t"
  assume P: "s \<in> P"
  assume t: "t \<notin> Fault ` F"
  from P adapt obtain P' Q' A'
    where
    valid: "\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub> P' (callClosure upd (e',p)) Q',A'" and
    init_P': "upd x s \<in> P'"  and
    Q: "Q' \<subseteq> Q" and
    A: "A' \<subseteq> A"
    by auto
  from exec_e [simplified callClosure_def] obtain s'
    where
    exec_e: "\<Gamma>\<turnstile> \<langle>Basic (upd (fst (e, p))),Normal s\<rangle> =n\<Rightarrow> s'"and
    exec_p: "\<Gamma>\<turnstile> \<langle>Call (snd (e, p)),s'\<rangle> =n\<Rightarrow> t"
    by cases
  from exec_e [simplified]
  have s': "s'=Normal (upd e s)"
    by cases simp
  from ap obtain s'' where
   s'': "upd x s = s''" and upd_e': "upd e' s''=upd e s"
    by auto
  from ap s' execn.Basic [where f="(upd (fst (e', p)))" and s="upd x s" and \<Gamma>=\<Gamma>]
  have exec_e': "\<Gamma>\<turnstile> \<langle>Basic (upd (fst (e', p))),Normal (upd x s)\<rangle> =n\<Rightarrow> s'"
    by simp
  with exec_p
  have "\<Gamma>\<turnstile> \<langle>callClosure upd (e', p),Normal (upd x s)\<rangle> =n\<Rightarrow> t"
    by (auto simp add: callClosure_def intro: execn.Seq)
  from cnvalidD [OF valid [rule_format] ctxt this init_P'] t Q A
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
    by auto
qed

lemma app_closure:
  assumes adapt: "P \<subseteq> {s. \<exists>P' Q' A'. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' (callClosure upd (e',p)) Q',A' \<and>
                           upd x s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A}"
  assumes ap: "upd e = upd e' \<circ> upd x"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (callClosure upd (e,p)) Q,A"
  apply (rule hoare_complete')
  apply (rule allI)
  apply (rule app_closure_sound [where x=x and e'=e', OF _ ap])
  using adapt
  apply (blast intro: hoare_cnvalid)
  done

lemma app_closure_spec:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. upd x s \<in> P' Z \<and> Q' Z \<subseteq> Q \<and> A' Z \<subseteq> A}"
  assumes ap: "upd e = upd e' \<circ> upd x"
  assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) (callClosure upd (e',p)) (Q' Z),(A' Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (callClosure upd (e,p)) Q,A"
  apply (rule app_closure [OF _ ap])
  apply clarsimp
  using adapt spec
  apply -
  apply (drule (1) in_subsetD)
  apply clarsimp
  apply (rule_tac x="P' Z" in exI)
  apply (rule_tac x="Q' Z" in exI)
  apply (rule_tac x="A' Z" in exI)
  apply blast
  done

text \<open>Implementation of closures as association lists.\<close>

definition "gen_upd var es s = foldl (\<lambda>s (x,i). the (var x) i s) s es"
definition "ap es c \<equiv> (es@fst c,snd c)"

lemma gen_upd_app: "\<And>es'. gen_upd var (es@es') = gen_upd var es' \<circ> gen_upd var es"
  apply (induct es)
  apply  (rule ext)
  apply  (simp add: gen_upd_def)
  apply (rule ext)
  apply (simp add: gen_upd_def)
  done

lemma gen_upd_ap:
  "gen_upd var (fst (ap es (es',p))) = gen_upd var es' \<circ> gen_upd var es"
  by (simp add: gen_upd_app ap_def)

lemma ap_closure:
  assumes adapt: "P \<subseteq> {s. \<exists>P' Q' A'. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' (callClosure (gen_upd var) c) Q',A' \<and>
                           gen_upd var es s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (callClosure (gen_upd var) (ap es c)) Q,A"
proof -
  obtain es' p where c: "c=(es',p)"
    by (cases c)
  have "gen_upd var (fst (ap es (es',p))) = gen_upd var es' \<circ> gen_upd var es"
    by (simp add: gen_upd_ap)
  from app_closure [OF adapt [simplified c] this]
  show ?thesis
    by (simp add: c ap_def)
qed

lemma ap_closure_spec:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. gen_upd var es s \<in> P' Z \<and> Q' Z \<subseteq> Q \<and> A' Z \<subseteq> A}"
  assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) (callClosure (gen_upd var) c) (Q' Z),(A' Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (callClosure (gen_upd var) (ap es c)) Q,A"
proof -
  obtain es' p where c: "c=(es',p)"
    by (cases c)
  have "gen_upd var (fst (ap es (es',p))) = gen_upd var es' \<circ> gen_upd var es"
    by (simp add: gen_upd_ap)
  from app_closure_spec [OF adapt [simplified c] this spec [simplified c]]
  show ?thesis
    by (simp add: c ap_def)
qed

end


theory Insert_Opt
  imports
    "../Insert"
    Balance_Opt
begin

context rbt_impl
begin
interpretation rbt_impl_deps .

definition "balance_black n_p c \<equiv> do { if c = 1 then balance_opt n_p else return n_p }"

lemmas [llvm_inline] = balance_black_def

partial_function (M) insert'_opt ::
  "'ki \<Rightarrow> 'vi \<Rightarrow> ('ki, 'vi) rbti \<Rightarrow> ('ki, 'vi) rbti llM" where
  "insert'_opt k\<^sub>n v\<^sub>n n_p =
  do {
    if n_p = null
    then new (RBT_NODE 0 null k\<^sub>n v\<^sub>n null)
    else
    do {
      n \<leftarrow> ll_load n_p;
      case n of (RBT_NODE c l_p k v r_p) \<Rightarrow>
      do {
          if! lt_impl k\<^sub>n k
          then! do {l_p\<^sub>n \<leftarrow> insert'_opt k\<^sub>n v\<^sub>n l_p; set_left_p l_p\<^sub>n n_p; balance_black n_p c}
          else! if! lt_impl k k\<^sub>n
          then! do {r_p\<^sub>n \<leftarrow> insert'_opt k\<^sub>n v\<^sub>n r_p; set_right_p r_p\<^sub>n n_p; balance_black n_p c}
          else! do {key_free k; value_free v;
                    set_key_p k\<^sub>n n_p; set_value_p v\<^sub>n n_p;
                    return n_p}
      }
    }
  }"

lemmas [llvm_code] = insert'_opt.simps

lemma insert'_opt_correct:
  "
    llvm_htriple
    (rbt_assn tree treei ** \<upharpoonleft>key_assn k ki ** \<upharpoonleft>value_assn v vi)
    (insert'_opt ki vi treei)
    (\<lambda>r. rbt_assn ((rbt_ins (\<lambda>_ _ v. v)) k v tree) r)
  "
proof (induction k v tree arbitrary: treei ki v rule: rbt_insert_ad'.induct)
  case (1 k\<^sub>n v\<^sub>n)
  then show ?case
    apply (subst insert'_opt.simps)
    apply vcg
    done
next
  case (2 k\<^sub>n v\<^sub>n l k v r)

  note [vcg_rules] = 2

  show ?case
    apply (subst insert'_opt.simps)
    unfolding balance_black_def
    apply vcg
    done
next
  case (3 k\<^sub>n v\<^sub>n l k v r)

  note [vcg_rules] = 3

  show ?case
    apply (subst insert'_opt.simps)
    unfolding balance_black_def
    apply vcg
    done
qed

lemma rbt_ins_non_empty:
  "rbt_ins f k v t \<noteq> rbt.Empty"
  apply (induction f k v t rule: rbt_ins.induct)
  subgoal by simp
  subgoal using rbt_balance_non_empty by (simp, fast)
  subgoal by simp
  done

definition insert_opt where
  "insert_opt k v n_p \<equiv>
  do {
    r_p \<leftarrow> insert'_opt k v n_p;
    set_color_p 1 r_p;
    return r_p
  }"

lemmas [llvm_code] = insert_opt_def

lemma insert_opt_correct [vcg_rules]:
  "
    llvm_htriple
    (rbt_assn tree treei ** \<upharpoonleft>key_assn k ki ** \<upharpoonleft>value_assn v vi)
    (insert_opt ki vi treei)
    (\<lambda>r. rbt_assn (rbt_insert k v tree) r)
  "
  unfolding insert_opt_def rbt_insert_def rbt_insert_with_key_def paint_def
  supply insert'_opt_correct[vcg_rules]
  apply vcg
  apply (cases "rbt_ins (\<lambda>_ _ v. v) k v tree")
  using rbt_ins_non_empty apply fast
  apply vcg
  done

end

end


theory Context_RR2
  imports Context_Extensions
    Ground_MCtxt
    Regular_Tree_Relations.RRn_Automata
begin

subsection \<open>Auxiliary lemmas\<close>
(* TODO Move *)
lemma gpair_gctxt:
  assumes "gpair s t = u"
  shows "(map_gctxt (\<lambda> f .(Some f, Some f)) C)\<langle>u\<rangle>\<^sub>G = gpair C\<langle>s\<rangle>\<^sub>G C\<langle>t\<rangle>\<^sub>G" using assms
  by (induct C arbitrary: s t u) (auto simp add: gpair_context1 comp_def map_funs_term_some_gpair intro!: nth_equalityI)

lemma gpair_gctxt':
  assumes "gpair C\<langle>v\<rangle>\<^sub>G C\<langle>w\<rangle>\<^sub>G = u"
  shows "u = (map_gctxt (\<lambda> f .(Some f, Some f)) C)\<langle>gpair v w\<rangle>\<^sub>G"
  using assms by (simp add: gpair_gctxt)

lemma gpair_gmctxt:
  assumes "\<forall> i < length us. gpair (ss ! i) (ts ! i) = us ! i"
    and "num_gholes C = length ss" "length ss = length ts" "length ts = length us"
  shows "fill_gholes (map_gmctxt (\<lambda>f . (Some f, Some f)) C) us = gpair (fill_gholes C ss) (fill_gholes C ts)"
  using assms
proof (induct C arbitrary: ss ts us)
  case GMHole
  then show ?case by (cases ss; cases ts; cases us) auto
next
  case (GMFun f Cs)
  show ?case using GMFun(2-)
    using GMFun(1)[OF nth_mem, of i "partition_gholes us Cs ! i" "partition_gholes ss Cs ! i" "partition_gholes ts Cs ! i" for i]
    using length_partition_gholes_nth[of Cs] partition_by_nth_nth[of "map num_gholes Cs" us]
    using partition_by_nth_nth[of "map num_gholes Cs" ss] partition_by_nth_nth[of "map num_gholes Cs" ts]
    by (auto simp: partition_holes_fill_gholes_conv' gpair_context1 simp del: fill_gholes.simps intro!: nth_equalityI)
      (simp add: length_partition_gholes_nth)
qed
(*Finished Move section*)

lemma gctxtex_onp_gpair_set_conv:
  "{gpair t u |t u. (t, u) \<in> gctxtex_onp P \<R>} =
    {(map_gctxt (\<lambda> f .(Some f, Some f)) C)\<langle>s\<rangle>\<^sub>G | C s. P C \<and> s \<in> {gpair t u |t u. (t, u) \<in> \<R>}}" (is "?Ls = ?Rs")
proof
  show "?Ls \<subseteq> ?Rs" using gpair_gctxt'
    by (auto elim!: gctxtex_onpE) blast
next
  show "?Rs \<subseteq> ?Ls"
    by (auto simp add: gctxtex_onpI gpair_gctxt)
qed

lemma gmctxtex_onp_gpair_set_conv:
  "{gpair t u |t u. (t, u) \<in> gmctxtex_onp P \<R>} =
    {fill_gholes (map_gmctxt (\<lambda> f .(Some f, Some f)) C) ss | C ss. num_gholes C = length ss \<and> P C \<and>
     (\<forall> i < length ss. ss ! i \<in> {gpair t u |t u. (t, u) \<in> \<R>})}" (is "?Ls = ?Rs")
proof
  {fix u assume "u \<in> ?Ls" then obtain s t
      where *: "u = gpair s t" "(s, t) \<in> gmctxtex_onp P \<R>"
      by auto
    from gmctxtex_onpE[OF *(2)] obtain C us vs where
      **: "s = fill_gholes C us" "t = fill_gholes C vs" and
      inv: "num_gholes C = length us" "length us = length vs" "P C"
       "\<forall> i < length vs. (us ! i, vs ! i) \<in> \<R>"
      by blast
    define ws where "ws \<equiv> map2 gpair us vs"
    from inv(1, 2) have "\<forall> i < length ws. gpair (us ! i) (vs ! i) =  ws ! i"
      by(auto simp: ws_def)
    from gpair_gmctxt[OF this inv(1, 2)] inv
    have "u \<in> ?Rs" unfolding * **
      by (auto simp: ws_def intro!: exI[of _ ws] exI[of _ C])}
  then show "?Ls \<subseteq> ?Rs" by blast
next
  {fix u assume "u \<in> ?Rs" then obtain C ss where
    *: "u = fill_gholes (map_gmctxt (\<lambda>f. (Some f, Some f)) C) ss" and
    inv: "P C" "num_gholes C = length ss" "\<forall> i < length ss. \<exists> t u. ss ! i = gpair t u \<and> (t, u) \<in> \<R>"
      by auto
    define us where "us \<equiv> map gfst ss" define vs where "vs \<equiv> map gsnd ss"
    then have len: "length ss = length us" "length us = length vs" and
      rec: "\<forall> i < length ss. gpair (us ! i) (vs ! i) = ss ! i"
        "\<forall> i < length vs. (us ! i, vs ! i) \<in> \<R>"
      by (auto simp: us_def vs_def) (metis gfst_gpair gsnd_gpair inv(3))+
    from len have l: "length vs = length ss" by auto
    have "u \<in> ?Ls" unfolding * using inv(2) len
      using gmctxtex_onpI[of P C us vs \<R>, OF inv(1) _ len(2) rec(2)]
      using gpair_gmctxt[OF rec(1) _ len(2) l, of C]
      by simp}
  then show "?Rs \<subseteq> ?Ls" by blast
qed

(* Results about lifting signature to RR2
  TODO rework, as this is not the RR2 signature more like
  the context signature, so closing a RR2 term under this signature
  leads a RR2 term
*)

abbreviation "lift_sig_RR2 \<equiv> \<lambda> (f, n). ((Some f, Some f), n)"
abbreviation "lift_fun \<equiv> (\<lambda> f. (Some f, Some f))"
abbreviation "unlift_fst \<equiv> (\<lambda> f. the (fst f))"
abbreviation "unlift_snd \<equiv> (\<lambda> f. the (snd f))"

lemma RR2_gterm_unlift_lift_id [simp]:
  "funas_gterm t \<subseteq> lift_sig_RR2 ` \<F> \<Longrightarrow> map_gterm (lift_fun \<circ> unlift_fst) t = t"
  by (induct t) (auto simp add: SUP_le_iff map_idI)

lemma RR2_gterm_unlift_funas [simp]:
  "funas_gterm t \<subseteq> lift_sig_RR2 ` \<F> \<Longrightarrow> funas_gterm (map_gterm unlift_fst t) \<subseteq> \<F>"
  by (induct t) (auto simp add: SUP_le_iff map_idI)

lemma gterm_funas_lift_RR2_funas [simp]:
  "funas_gterm t \<subseteq> \<F> \<Longrightarrow> funas_gterm (map_gterm lift_fun t) \<subseteq> lift_sig_RR2 ` \<F>"
  by (induct t) (auto simp add: SUP_le_iff map_idI)

lemma RR2_gctxt_unlift_lift_id [simp, intro]:
  "funas_gctxt C \<subseteq> lift_sig_RR2 ` \<F> \<Longrightarrow> (map_gctxt (lift_fun \<circ> unlift_fst) C) = C"
  by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)

lemma RR2_gctxt_unlift_funas [simp, intro]:
  "funas_gctxt C \<subseteq> lift_sig_RR2 ` \<F> \<Longrightarrow> funas_gctxt (map_gctxt unlift_fst C) \<subseteq> \<F>"
  by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)

lemma gctxt_funas_lift_RR2_funas [simp, intro]:
  "funas_gctxt C \<subseteq> \<F> \<Longrightarrow> funas_gctxt (map_gctxt lift_fun C) \<subseteq> lift_sig_RR2 ` \<F>"
  by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)

lemma RR2_gmctxt_unlift_lift_id [simp, intro]:
  "funas_gmctxt C \<subseteq> lift_sig_RR2 ` \<F> \<Longrightarrow> (map_gmctxt (lift_fun \<circ> unlift_fst) C) = C"
  by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)

lemma RR2_gmctxt_unlift_funas [simp, intro]:
  "funas_gmctxt C \<subseteq> lift_sig_RR2 ` \<F> \<Longrightarrow> funas_gmctxt (map_gmctxt unlift_fst C) \<subseteq> \<F>"
  by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)

lemma gmctxt_funas_lift_RR2_funas [simp, intro]:
  "funas_gmctxt C \<subseteq> \<F> \<Longrightarrow> funas_gmctxt (map_gmctxt lift_fun C) \<subseteq> lift_sig_RR2 ` \<F>"
  by (induct C) (auto simp add: all_set_conv_all_nth SUP_le_iff map_idI intro!: nth_equalityI)

lemma RR2_gctxt_cl_to_gctxt:
  assumes "\<And> C. P C \<Longrightarrow> funas_gctxt C \<subseteq> lift_sig_RR2 ` \<F>"
    and "\<And> C. P C \<Longrightarrow> R (map_gctxt unlift_fst C)"
    and "\<And> C. R C \<Longrightarrow> P (map_gctxt lift_fun C)"
  shows "{C\<langle>s\<rangle>\<^sub>G |C s. P C \<and> Q s} = {(map_gctxt lift_fun C)\<langle>s\<rangle>\<^sub>G |C s. R C \<and> Q s}" (is "?Ls = ?Rs")
proof
  {fix u assume "u \<in> ?Ls" then obtain C s where
    *:"u = C\<langle>s\<rangle>\<^sub>G" and inv: "P C" "Q s" by blast
    then have "funas_gctxt C \<subseteq> lift_sig_RR2 ` \<F>" using assms by auto
    from RR2_gctxt_unlift_lift_id[OF this] have "u \<in> ?Rs" using inv assms unfolding *
      by (auto intro!: exI[of _ "map_gctxt unlift_fst C"] exI[of _ s])}
  then show "?Ls \<subseteq> ?Rs" by blast
next
  {fix u assume "u \<in> ?Rs" then obtain C s where
    *:"u = (map_gctxt lift_fun C)\<langle>s\<rangle>\<^sub>G" and inv: "R C" "Q s"
      by blast
    have "u \<in> ?Ls" unfolding * using inv assms
      by (auto intro!: exI[of _ "map_gctxt lift_fun C"])}
  then show "?Rs \<subseteq> ?Ls" by blast
qed

lemma RR2_gmctxt_cl_to_gmctxt:
  assumes "\<And> C. P C \<Longrightarrow> funas_gmctxt C \<subseteq> lift_sig_RR2 ` \<F>"
    and "\<And> C. P C \<Longrightarrow> R (map_gmctxt (\<lambda> f. the (fst f)) C)"
    and "\<And> C. R C \<Longrightarrow> P (map_gmctxt (\<lambda> f. (Some f, Some f)) C)"
  shows "{fill_gholes C ss |C ss. num_gholes C = length ss \<and> P C \<and> (\<forall> i < length ss. Q (ss ! i))} =
    {fill_gholes (map_gmctxt (\<lambda>f. (Some f, Some f)) C) ss |C ss. num_gholes C = length ss \<and>
     R C \<and> (\<forall> i < length ss. Q (ss ! i))}" (is "?Ls = ?Rs")
proof
  {fix u assume "u \<in> ?Ls" then obtain C ss where
    *:"u = fill_gholes C ss" and inv: "num_gholes C = length ss" "P C" "\<forall> i < length ss. Q (ss ! i)"
      by blast
    then have "funas_gmctxt C \<subseteq> lift_sig_RR2 ` \<F>" using assms by auto
    from RR2_gmctxt_unlift_lift_id[OF this] have "u \<in> ?Rs" using inv assms unfolding *
      by (auto intro!: exI[of _ "map_gmctxt unlift_fst C"] exI[of _ ss])}
  then show "?Ls \<subseteq> ?Rs" by blast
next
  {fix u assume "u \<in> ?Rs" then obtain C ss where
    *:"u = fill_gholes (map_gmctxt lift_fun C) ss" and inv: "num_gholes C = length ss" "R C"
      "\<forall> i < length ss. Q (ss ! i)"
      by blast
    have "u \<in> ?Ls" unfolding * using inv assms
      by (auto intro!: exI[of _ "map_gmctxt lift_fun C"])}
  then show "?Rs \<subseteq> ?Ls" by blast
qed

lemma RR2_id_terms_gpair_set [simp]:
 "\<T>\<^sub>G (lift_sig_RR2 ` \<F>) = {gpair t u |t u. (t, u) \<in> Restr Id (\<T>\<^sub>G \<F>)}"
 apply (auto simp: map_funs_term_some_gpair \<T>\<^sub>G_equivalent_def)
 apply (smt RR2_gterm_unlift_funas RR2_gterm_unlift_lift_id gterm.map_comp)
 using funas_gterm_map_gterm by blast

end


(* Author: Andreas Lochbihler, ETH Zurich
   Author: Joshua Schneider, ETH Zurich *)

section \<open>Least and greatest fixpoints\<close>

theory Fixpoints imports
  Axiomatised_BNF_CC
begin

subsection \<open>Least fixpoint\<close>

subsubsection \<open>\BNFCC{} structure\<close>

context notes [[typedef_overloaded, bnf_internals]]
begin

datatype (set_T: 'l1, 'co1, 'co2, 'contra1, 'contra2, 'f) T =
  C_T (D_T: "(('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) T, 'l1, 'co1, 'co2, 'contra1, 'contra2, 'f) G")
  for
    map: mapl_T
    rel: rell_T

end

inductive rel_T :: "('l1 \<Rightarrow> 'l1' \<Rightarrow> bool) \<Rightarrow>
    ('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow>
    ('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) T \<Rightarrow>
    ('l1', 'co1', 'co2', 'contra1', 'contra2', 'f) T \<Rightarrow> bool"
  for L1 Co1 Co2 Contra1 Contra2 where
  "rel_T L1 Co1 Co2 Contra1 Contra2 (C_T x) (C_T y)"
    if "rel_G (rel_T L1 Co1 Co2 Contra1 Contra2) L1 Co1 Co2 Contra1 Contra2 x y"

primrec map_T :: "('l1 \<Rightarrow> 'l1') \<Rightarrow> ('co1 \<Rightarrow> 'co1') \<Rightarrow> ('co2 \<Rightarrow> 'co2') \<Rightarrow>
    ('contra1' \<Rightarrow> 'contra1) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2) \<Rightarrow>
    ('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) T \<Rightarrow>
    ('l1', 'co1', 'co2', 'contra1', 'contra2', 'f) T" where
  "map_T l1 co1 co2 contra1 contra2 (C_T x) =
    C_T (map_G id id co1 co2 contra1 contra2 (mapl_G (map_T l1 co1 co2 contra1 contra2) l1 x))"

text \<open>
  The mapper and relator generated by the datatype package coincide with our generalised definitions
  restricted to live arguments.
\<close>

lemma rell_T_alt_def: "rell_T L1 = rel_T L1 (=) (=) (=) (=)"
  apply (intro ext iffI)
   apply (erule T.rel_induct)
   apply (unfold rell_G_def)
   apply (erule rel_T.intros)
  apply (erule rel_T.induct)
  apply (rule T.rel_intros)
  apply (unfold rell_G_def)
  apply (erule rel_G_mono')
       apply (auto)
  done

lemma mapl_T_alt_def: "mapl_T l1 = map_T l1 id id id id"
  supply id_apply[simp del]
  apply (rule ext)
  subgoal for x
    apply (induction x)
    apply (simp add: mapl_G_def map_G_comp[THEN fun_cong, simplified])
    apply (fold mapl_G_def)
    apply (erule mapl_G_cong)
    apply (rule refl)
    done
  done

lemma rel_T_mono [mono]:
  "\<lbrakk> L1 \<le> L1'; Co1 \<le> Co1'; Co2 \<le> Co2'; Contra1' \<le> Contra1; Contra2' \<le> Contra2 \<rbrakk> \<Longrightarrow>
  rel_T L1 Co1 Co2 Contra1 Contra2 \<le> rel_T L1' Co1' Co2' Contra1' Contra2'"
  apply (rule predicate2I)
  apply (erule rel_T.induct)
  apply (rule rel_T.intros)
  apply (erule rel_G_mono')
       apply (auto)
  done

lemma rel_T_eq: "rel_T (=) (=) (=) (=) (=) = (=)"
  unfolding rell_T_alt_def[symmetric] T.rel_eq ..

lemma rel_T_conversep:
  "rel_T L1\<inverse>\<inverse> Co1\<inverse>\<inverse> Co2\<inverse>\<inverse> Contra1\<inverse>\<inverse> Contra2\<inverse>\<inverse> = (rel_T L1 Co1 Co2 Contra1 Contra2)\<inverse>\<inverse>"
  apply (intro ext iffI)
   apply (simp)
   apply (erule rel_T.induct)
   apply (rule rel_T.intros)
   apply (rewrite conversep_iff[symmetric])
   apply (fold rel_G_conversep)
   apply (erule rel_G_mono'; blast)
  apply (simp)
  apply (erule rel_T.induct)
  apply (rule rel_T.intros)
  apply (rewrite conversep_iff[symmetric])
  apply (unfold rel_G_conversep[symmetric] conversep_conversep)
  apply (erule rel_G_mono'; blast)
  done

lemma map_T_id0: "map_T id id id id id = id"
  unfolding mapl_T_alt_def[symmetric] T.map_id0 ..

lemma map_T_id: "map_T id id id id id x = x"
  by (simp add: map_T_id0)

lemma map_T_comp: "map_T l1 co1 co2 contra1 contra2 \<circ> map_T l1' co1' co2' contra1' contra2' =
  map_T (l1 \<circ> l1') (co1 \<circ> co1') (co2 \<circ> co2') (contra1' \<circ> contra1) (contra2' \<circ> contra2)"
  apply (rule ext)
  subgoal for x
    apply (induction x)
    apply (simp add: mapl_G_def map_G_comp[THEN fun_cong, simplified])
    apply (fold comp_def)
    apply (subst (1 2) map_G_mapl_G)
    apply (rule arg_cong[where f="map_G _ _ _ _ _ _"])
    apply (rule mapl_G_cong)
     apply (simp_all)
    done
  done

lemma map_T_parametric: "rel_fun (rel_fun L1 L1')
  (rel_fun (rel_fun Co1 Co1') (rel_fun (rel_fun Co2 Co2')
  (rel_fun (rel_fun Contra1' Contra1) (rel_fun (rel_fun Contra2' Contra2)
  (rel_fun (rel_T L1 Co1 Co2 Contra1 Contra2) (rel_T L1' Co1' Co2' Contra1' Contra2'))))))
  map_T map_T"
  apply (intro rel_funI)
  apply (erule rel_T.induct)
  apply (simp)
  apply (rule rel_T.intros)
  apply (fold map_G_mapl_G)
  apply (erule map_G_rel_cong)
       apply (blast elim: rel_funE)+
  done

definition rel_T_pos_distr_cond :: "('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('l1 \<times> 'l1' \<times> 'l1'' \<times> 'f) itself \<Rightarrow> bool" where
  "rel_T_pos_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' _ \<longleftrightarrow>
  (\<forall>(L1 :: 'l1 \<Rightarrow> 'l1' \<Rightarrow> bool) (L1' :: 'l1' \<Rightarrow> 'l1'' \<Rightarrow> bool).
    (rel_T L1 Co1 Co2 Contra1 Contra2 :: (_, _, _, _, _, 'f) T \<Rightarrow> _) OO
      rel_T L1' Co1' Co2' Contra1' Contra2' \<le>
    rel_T (L1 OO L1') (Co1 OO Co1') (Co2 OO Co2') (Contra1 OO Contra1') (Contra2 OO Contra2'))"

definition rel_T_neg_distr_cond :: "('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('l1 \<times> 'l1' \<times> 'l1'' \<times> 'f) itself \<Rightarrow> bool" where
  "rel_T_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' _ \<longleftrightarrow>
  (\<forall>(L1 :: 'l1 \<Rightarrow> 'l1' \<Rightarrow> bool) (L1' :: 'l1' \<Rightarrow> 'l1'' \<Rightarrow> bool).
    rel_T (L1 OO L1') (Co1 OO Co1') (Co2 OO Co2') (Contra1 OO Contra1') (Contra2 OO Contra2') \<le>
    (rel_T L1 Co1 Co2 Contra1 Contra2 :: (_, _, _, _, _, 'f) T \<Rightarrow> _) OO
      rel_T L1' Co1' Co2' Contra1' Contra2')"

text \<open>
  We inherit the conditions for subdistributivity over relation composition via
  a composition witness, which is derived from a witness for the underlying functor @{type G}.
\<close>

primrec rel_T_witness :: "('l1 \<Rightarrow> 'l1'' \<Rightarrow> bool) \<Rightarrow>
    ('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) T \<Rightarrow>
    ('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) T \<Rightarrow>
    ('l1 \<times> 'l1'', 'co1', 'co2', 'contra1', 'contra2', 'f) T" where
  "rel_T_witness L1 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' (C_T x) Cy = C_T
  (mapl_G (\<lambda>((x, f), y). f y) id
    (rel_G_witness (\<lambda>(x, f) y. rel_T (\<lambda>x (x', y). x' = x \<and> L1 x y) Co1 Co2 Contra1 Contra2 x (f y) \<and>
      rel_T (\<lambda>(x, y') y. y' = y \<and> L1 x y) Co1' Co2' Contra1' Contra2' (f y) y)
    L1 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2'
    (mapl_G (\<lambda>x. (x, rel_T_witness L1 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' x)) id x,
      D_T Cy)))"

lemma rel_T_pos_distr_imp:
  fixes Co1 :: "'co1 \<Rightarrow> 'co1' \<Rightarrow> bool" and Co1' :: "'co1' \<Rightarrow> 'co1'' \<Rightarrow> bool"
    and Co2 :: "'co2 \<Rightarrow> 'co2' \<Rightarrow> bool" and Co2' :: "'co2' \<Rightarrow> 'co2'' \<Rightarrow> bool"
    and Contra1 :: "'contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool" and Contra1' :: "'contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool"
    and Contra2 :: "'contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool" and Contra2' :: "'contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool"
    and tytok_G :: "(('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) T \<times>
      ('l1', 'co1', 'co2', 'contra1', 'contra2', 'f) T \<times>
      ('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) T \<times> 'l1 \<times> 'l1' \<times> 'l1'' \<times> 'f) itself"
    and tytok_T :: "('l1 \<times> 'l1' \<times> 'l1'' \<times> 'f) itself"
  assumes "rel_G_pos_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok_G"
  shows "rel_T_pos_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok_T"
  unfolding rel_T_pos_distr_cond_def
  apply (intro allI predicate2I)
  apply (erule relcomppE)
  subgoal premises prems for L1 L1' x z y
    using prems apply (induction arbitrary: z)
    apply (erule rel_T.cases)
    apply (simp)
    apply (rule rel_T.intros)
    apply (drule (1) rel_G_pos_distr[THEN predicate2D, OF assms relcomppI])
    apply (erule rel_G_mono'; blast)
    done
  done

lemma
  fixes L1 :: "'l1 \<Rightarrow> 'l1'' \<Rightarrow> bool"
    and Co1 :: "'co1 \<Rightarrow> 'co1' \<Rightarrow> bool" and Co1' :: "'co1' \<Rightarrow> 'co1'' \<Rightarrow> bool"
    and Co2 :: "'co2 \<Rightarrow> 'co2' \<Rightarrow> bool" and Co2' :: "'co2' \<Rightarrow> 'co2'' \<Rightarrow> bool"
    and Contra1 :: "'contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool" and Contra1' :: "'contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool"
    and Contra2 :: "'contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool" and Contra2' :: "'contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool"
    and tytok_G :: "((('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) T \<times>
         (('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) T
          \<Rightarrow> ('l1 \<times> 'l1'', 'co1', 'co2', 'contra1', 'contra2', 'f) T)) \<times>
        ((('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) T \<times>
          (('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) T
           \<Rightarrow> ('l1 \<times> 'l1'', 'co1', 'co2', 'contra1', 'contra2', 'f) T)) \<times>
         ('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) T) \<times>
        ('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) T \<times>
        'l1 \<times> ('l1 \<times> 'l1'') \<times> 'l1'' \<times> 'f) itself"
    and x :: "(_, _, _, _, _, 'f) T"
  assumes cond: "rel_G_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok_G"
    and rel_OO: "rel_T L1 (Co1 OO Co1') (Co2 OO Co2') (Contra1 OO Contra1') (Contra2 OO Contra2') x y"
  shows rel_T_witness1: "rel_T (\<lambda>x (x', y). x' = x \<and> L1 x y) Co1 Co2 Contra1 Contra2 x
      (rel_T_witness L1 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' x y)"
    and rel_T_witness2: "rel_T (\<lambda>(x, y') y. y' = y \<and> L1 x y) Co1' Co2' Contra1' Contra2'
      (rel_T_witness L1 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' x y) y"
  using rel_OO apply (induction)
  subgoal premises prems for x y
  proof-
    have x_expansion: "x = mapl_G fst id (mapl_G (\<lambda>x.
      (x, rel_T_witness L1 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' x)) id x)"
      by (simp add: mapl_G_def map_G_comp[THEN fun_cong, simplified] map_G_id[unfolded id_def] comp_def)
    show ?thesis
      apply (simp)
      apply (rule rel_T.intros)
      apply (rewrite in "rel_G _ _ _ _ _ _ \<hole> _" x_expansion)
      apply (rewrite in "rel_G _ _ _ _ _ _ _ \<hole>" mapl_G_def)
      apply (subst mapl_G_def)
      apply (rule map_G_rel_cong)
            apply (rule rel_G_witness1[OF cond])
            apply (rewrite in "rel_G _ _ _ _ _ _ \<hole> _" mapl_G_def)
            apply (rewrite in "rel_G _ _ _ _ _ _ _ \<hole>" map_G_id[symmetric])
            apply (rule map_G_rel_cong[OF prems])
                 apply (clarsimp)+
      done
  qed
  subgoal for x y
    apply (simp)
    apply (rule rel_T.intros)
    apply (rewrite in "rel_G _ _ _ _ _ _ \<hole> _" mapl_G_def)
    apply (rewrite in "rel_G _ _ _ _ _ _ _ \<hole>" map_G_id[symmetric])
    apply (rule map_G_rel_cong)
          apply (rule rel_G_witness2[OF cond[unfolded rel_T_neg_distr_cond_def]])
          apply (rewrite in "rel_G _ _ _ _ _ _ \<hole> _" mapl_G_def)
          apply (rewrite in "rel_G _ _ _ _ _ _ _ \<hole>" map_G_id[symmetric])
          apply (erule map_G_rel_cong)
               apply (clarsimp)+
    done
  done

lemma rel_T_neg_distr_imp:
  fixes Co1 :: "'co1 \<Rightarrow> 'co1' \<Rightarrow> bool" and Co1' :: "'co1' \<Rightarrow> 'co1'' \<Rightarrow> bool"
    and Co2 :: "'co2 \<Rightarrow> 'co2' \<Rightarrow> bool" and Co2' :: "'co2' \<Rightarrow> 'co2'' \<Rightarrow> bool"
    and Contra1 :: "'contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool" and Contra1' :: "'contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool"
    and Contra2 :: "'contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool" and Contra2' :: "'contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool"
    and tytok_G :: "((('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) T \<times>
         (('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) T
          \<Rightarrow> ('l1 \<times> 'l1'', 'co1', 'co2', 'contra1', 'contra2', 'f) T)) \<times>
        ((('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) T \<times>
          (('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) T
           \<Rightarrow> ('l1 \<times> 'l1'', 'co1', 'co2', 'contra1', 'contra2', 'f) T)) \<times>
         ('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) T) \<times>
        ('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) T \<times>
        'l1 \<times> ('l1 \<times> 'l1'') \<times> 'l1'' \<times> 'f) itself"
    and tytok_T :: "('l1 \<times> 'l1' \<times> 'l1'' \<times> 'f) itself"
  assumes "rel_G_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok_G"
  shows "rel_T_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok_T"
  unfolding rel_T_neg_distr_cond_def
proof (intro allI predicate2I relcomppI)
  fix L1 :: "'l1 \<Rightarrow> 'l1' \<Rightarrow> bool" and L1' :: "'l1' \<Rightarrow> 'l1'' \<Rightarrow> bool"
    and x :: "(_, _, _, _, _, 'f) T" and y :: "(_, _, _, _, _, 'f) T"
  assume *: "rel_T (L1 OO L1') (Co1 OO Co1') (Co2 OO Co2')
    (Contra1 OO Contra1') (Contra2 OO Contra2') x y"
  let ?z = "map_T (relcompp_witness L1 L1') id id id id
    (rel_T_witness (L1 OO L1') Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' x y)"
  show "rel_T L1 Co1 Co2 Contra1 Contra2 x ?z"
    apply(subst map_T_id[symmetric])
    apply(rule map_T_parametric[unfolded rel_fun_def, rule_format, rotated -1])
         apply(rule rel_T_witness1[OF assms *])
        apply(auto simp add: vimage2p_def del: relcomppE elim!: relcompp_witness)
    done
  show "rel_T L1' Co1' Co2' Contra1' Contra2' ?z y"
    apply(rewrite in "rel_T _ _ _ _ _ _ \<hole>" map_T_id[symmetric])
    apply(rule map_T_parametric[unfolded rel_fun_def, rule_format, rotated -1])
         apply(rule rel_T_witness2[OF assms *])
        apply(auto simp add: vimage2p_def del: relcomppE elim!: relcompp_witness)
    done
qed

lemma rel_T_pos_distr_cond_eq:
  "\<And>tytok. rel_T_pos_distr_cond (=) (=) (=) (=) (=) (=) (=) (=) tytok"
  by (intro rel_T_pos_distr_imp rel_G_pos_distr_cond_eq)

lemma rel_T_neg_distr_cond_eq:
  "\<And>tytok. rel_T_neg_distr_cond (=) (=) (=) (=) (=) (=) (=) (=) tytok"
  by (intro rel_T_neg_distr_imp rel_G_neg_distr_cond_eq)

text \<open>The BNF axioms are proved by the datatype package.\<close>

thm T.set_map T.bd_card_order T.bd_cinfinite T.set_bd T.map_cong[OF refl]
  T.rel_mono_strong T.wit

subsubsection \<open>Parametricity laws\<close>

context includes lifting_syntax begin

lemma C_T_parametric: "(rel_G (rel_T L1 Co1 Co2 Contra1 Contra2) L1 Co1 Co2 Contra1 Contra2 ===>
  rel_T L1 Co1 Co2 Contra1 Contra2) C_T C_T"
  by (fast elim: rel_T.intros)

lemma D_T_parametric: "(rel_T L1 Co1 Co2 Contra1 Contra2 ===>
  rel_G (rel_T L1 Co1 Co2 Contra1 Contra2) L1 Co1 Co2 Contra1 Contra2) D_T D_T"
  by (fastforce elim: rel_T.cases)

end

subsection \<open>Greatest fixpoints\<close>

subsubsection \<open>\BNFCC{} structure\<close>

context notes [[typedef_overloaded, bnf_internals]]
begin

codatatype (set_U: 'l1, 'co1, 'co2, 'contra1, 'contra2, 'f) U =
  C_U (D_U: "(('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) U, 'l1, 'co1, 'co2, 'contra1, 'contra2, 'f) G")
  for
    map: mapl_U
    rel: rell_U

end

coinductive rel_U :: "('l1 \<Rightarrow> 'l1' \<Rightarrow> bool) \<Rightarrow>
    ('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow>
    ('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) U \<Rightarrow>
    ('l1', 'co1', 'co2', 'contra1', 'contra2', 'f) U \<Rightarrow> bool"
  for L1 Co1 Co2 Contra1 Contra2 where
  "rel_U L1 Co1 Co2 Contra1 Contra2 x y"
    if "rel_G (rel_U L1 Co1 Co2 Contra1 Contra2) L1 Co1 Co2 Contra1 Contra2 (D_U x) (D_U y)"

primcorec map_U :: "('l1 \<Rightarrow> 'l1') \<Rightarrow> ('co1 \<Rightarrow> 'co1') \<Rightarrow> ('co2 \<Rightarrow> 'co2') \<Rightarrow>
    ('contra1' \<Rightarrow> 'contra1) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2) \<Rightarrow>
    ('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) U \<Rightarrow>
    ('l1', 'co1', 'co2', 'contra1', 'contra2', 'f) U" where
  "D_U (map_U l1 co1 co2 contra1 contra2 x) =
    mapl_G (map_U l1 co1 co2 contra1 contra2) l1 (map_G id id co1 co2 contra1 contra2 (D_U x))"

lemma rell_U_alt_def: "rell_U L1 = rel_U L1 (=) (=) (=) (=)"
  apply (intro ext iffI)
   apply (erule rel_U.coinduct)
   apply (erule U.rel_cases)
   apply (simp add: rell_G_def)
   apply (erule rel_G_mono'; blast)
  apply (erule U.rel_coinduct)
  apply (erule rel_U.cases)
  apply (simp add: rell_G_def)
  done

lemma mapl_U_alt_def: "mapl_U l1 = map_U l1 id id id id"
  supply id_apply[simp del]
  apply (rule ext)
  subgoal for x
    apply (coinduction arbitrary: x)
    apply (simp add: mapl_G_def map_G_comp[THEN fun_cong, simplified] U.map_sel)
    apply (unfold rell_G_def)
    apply (rule map_G_rel_cong[OF rel_G_eq_refl])
         apply (auto)
    done
  done

lemma rel_U_mono [mono]:
  "\<lbrakk> L1 \<le> L1'; Co1 \<le> Co1'; Co2 \<le> Co2'; Contra1' \<le> Contra1; Contra2' \<le> Contra2 \<rbrakk> \<Longrightarrow>
  rel_U L1 Co1 Co2 Contra1 Contra2 \<le> rel_U L1' Co1' Co2' Contra1' Contra2'"
  apply (rule predicate2I)
  apply (erule rel_U.coinduct[of "rel_U L1 Co1 Co2 Contra1 Contra2"])
  apply (erule rel_U.cases)
  apply (simp)
  apply (erule rel_G_mono')
       apply (blast)+
  done

lemma rel_U_eq: "rel_U (=) (=) (=) (=) (=) = (=)"
  unfolding rell_U_alt_def[symmetric] U.rel_eq ..

lemma rel_U_conversep:
  "rel_U L1\<inverse>\<inverse> Co1\<inverse>\<inverse> Co2\<inverse>\<inverse> Contra1\<inverse>\<inverse> Contra2\<inverse>\<inverse> = (rel_U L1 Co1 Co2 Contra1 Contra2)\<inverse>\<inverse>"
  apply (intro ext iffI)
   apply (simp)
   apply (erule rel_U.coinduct)
   apply (erule rel_U.cases)
   apply (simp del: conversep_iff)
   apply (rewrite conversep_iff[symmetric])
   apply (fold rel_G_conversep)
   apply (erule rel_G_mono'; blast)
  apply (erule rel_U.coinduct)
  apply (subst (asm) conversep_iff)
  apply (erule rel_U.cases)
  apply (simp del: conversep_iff)
  apply (rewrite conversep_iff[symmetric])
  apply (unfold rel_G_conversep[symmetric] conversep_conversep)
  apply (erule rel_G_mono'; blast)
  done

lemma map_U_id0: "map_U id id id id id = id"
  unfolding mapl_U_alt_def[symmetric] U.map_id0 ..

lemma map_U_id: "map_U id id id id id x = x"
  by (simp add: map_U_id0)

lemma map_U_comp: "map_U l1 co1 co2 contra1 contra2 \<circ> map_U l1' co1' co2' contra1' contra2' =
  map_U (l1 \<circ> l1') (co1 \<circ> co1') (co2 \<circ> co2') (contra1' \<circ> contra1) (contra2' \<circ> contra2)"
  apply (rule ext)
  subgoal for x
    apply (coinduction arbitrary: x)
    apply (simp add: mapl_G_def map_G_comp[THEN fun_cong, simplified])
    apply (unfold rell_G_def)
    apply (rule map_G_rel_cong[OF rel_G_eq_refl])
         apply (auto)
    done
  done

lemma map_U_parametric: "rel_fun (rel_fun L1 L1')
  (rel_fun (rel_fun Co1 Co1') (rel_fun (rel_fun Co2 Co2')
  (rel_fun (rel_fun Contra1' Contra1) (rel_fun (rel_fun Contra2' Contra2)
  (rel_fun (rel_U L1 Co1 Co2 Contra1 Contra2) (rel_U L1' Co1' Co2' Contra1' Contra2'))))))
  map_U map_U"
  apply (intro rel_funI)
  apply (coinduction)
  apply (simp add: mapl_G_def map_G_comp[THEN fun_cong, simplified])
  apply (erule rel_U.cases)
  apply (hypsubst)
  apply (erule map_G_rel_cong)
       apply (blast elim: rel_funE)+
  done

definition rel_U_pos_distr_cond :: "('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('l1 \<times> 'l1' \<times> 'l1'' \<times> 'f) itself \<Rightarrow> bool" where
  "rel_U_pos_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' _ \<longleftrightarrow>
  (\<forall>(L1 :: 'l1 \<Rightarrow> 'l1' \<Rightarrow> bool) (L1' :: 'l1' \<Rightarrow> 'l1'' \<Rightarrow> bool).
    (rel_U L1 Co1 Co2 Contra1 Contra2 :: (_, _, _, _, _, 'f) U \<Rightarrow> _) OO
      rel_U L1' Co1' Co2' Contra1' Contra2' \<le>
    rel_U (L1 OO L1') (Co1 OO Co1') (Co2 OO Co2') (Contra1 OO Contra1') (Contra2 OO Contra2'))"

definition rel_U_neg_distr_cond :: "('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('l1 \<times> 'l1' \<times> 'l1'' \<times> 'f) itself \<Rightarrow> bool" where
  "rel_U_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' _ \<longleftrightarrow>
  (\<forall>(L1 :: 'l1 \<Rightarrow> 'l1' \<Rightarrow> bool) (L1' :: 'l1' \<Rightarrow> 'l1'' \<Rightarrow> bool).
    rel_U (L1 OO L1') (Co1 OO Co1') (Co2 OO Co2') (Contra1 OO Contra1') (Contra2 OO Contra2') \<le>
    (rel_U L1 Co1 Co2 Contra1 Contra2 :: (_, _, _, _, _, 'f) U \<Rightarrow> _) OO
      rel_U L1' Co1' Co2' Contra1' Contra2')"

primcorec rel_U_witness :: "('l1 \<Rightarrow> 'l1'' \<Rightarrow> bool) \<Rightarrow>
    ('co1 \<Rightarrow> 'co1' \<Rightarrow> bool) \<Rightarrow> ('co1' \<Rightarrow> 'co1'' \<Rightarrow> bool) \<Rightarrow>
    ('co2 \<Rightarrow> 'co2' \<Rightarrow> bool) \<Rightarrow> ('co2' \<Rightarrow> 'co2'' \<Rightarrow> bool) \<Rightarrow>
    ('contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool) \<Rightarrow> ('contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool) \<Rightarrow>
    ('contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool) \<Rightarrow> ('contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool) \<Rightarrow>
    ('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) U \<times>
    ('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) U \<Rightarrow>
    ('l1 \<times> 'l1'', 'co1', 'co2', 'contra1', 'contra2', 'f) U" where
  "D_U (rel_U_witness L1 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' xy) =
  mapl_G (rel_U_witness L1 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2') id
    (rel_G_witness (rel_U L1 (Co1 OO Co1') (Co2 OO Co2') (Contra1 OO Contra1') (Contra2 OO Contra2'))
    L1 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' (D_U (fst xy), D_U (snd xy)))"

lemma rel_U_pos_distr_imp:
  fixes Co1 :: "'co1 \<Rightarrow> 'co1' \<Rightarrow> bool" and Co1' :: "'co1' \<Rightarrow> 'co1'' \<Rightarrow> bool"
    and Co2 :: "'co2 \<Rightarrow> 'co2' \<Rightarrow> bool" and Co2' :: "'co2' \<Rightarrow> 'co2'' \<Rightarrow> bool"
    and Contra1 :: "'contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool" and Contra1' :: "'contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool"
    and Contra2 :: "'contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool" and Contra2' :: "'contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool"
    and tytok_G :: "(('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) U \<times>
      ('l1', 'co1', 'co2', 'contra1', 'contra2', 'f) U \<times>
      ('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) U \<times> 'l1 \<times> 'l1' \<times> 'l1'' \<times> 'f) itself"
    and tytok_T :: "('l1 \<times> 'l1' \<times> 'l1'' \<times> 'f) itself"
  assumes "rel_G_pos_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok_G"
  shows "rel_U_pos_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok_T"
  unfolding rel_U_pos_distr_cond_def
  apply (intro allI predicate2I)
  apply (erule relcomppE)
  subgoal premises prems for L1 L1' x z y
    using prems apply (coinduction arbitrary: x y z)
    apply (simp)
    apply (rule rel_G_pos_distr[THEN predicate2D,
          OF assms relcomppI, THEN rel_G_mono'])
           apply (auto elim: rel_U.cases)
    done
  done

lemma rel_U_witness1:
  fixes L1 :: "'l1 \<Rightarrow> 'l1'' \<Rightarrow> bool"
    and Co1 :: "'co1 \<Rightarrow> 'co1' \<Rightarrow> bool" and Co1' :: "'co1' \<Rightarrow> 'co1'' \<Rightarrow> bool"
    and Co2 :: "'co2 \<Rightarrow> 'co2' \<Rightarrow> bool" and Co2' :: "'co2' \<Rightarrow> 'co2'' \<Rightarrow> bool"
    and Contra1 :: "'contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool" and Contra1' :: "'contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool"
    and Contra2 :: "'contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool" and Contra2' :: "'contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool"
    and tytok_G :: "(('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) U \<times>
             (('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) U \<times>
              ('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) U) \<times>
             ('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) U \<times>
             'l1 \<times> ('l1 \<times> 'l1'') \<times> 'l1'' \<times> 'f) itself"
    and x :: "(_, _, _, _, _, 'f) U"
  assumes cond: "rel_G_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok_G"
    and rel_OO: "rel_U L1 (Co1 OO Co1') (Co2 OO Co2') (Contra1 OO Contra1') (Contra2 OO Contra2') x y"
  shows "rel_U (\<lambda>x (x', y). x' = x \<and> L1 x y) Co1 Co2 Contra1 Contra2 x
      (rel_U_witness L1 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' (x, y))"
  using rel_OO apply (coinduction arbitrary: x y)
  apply (erule rel_U.cases)
  apply (clarsimp)
  apply (rewrite in "rel_G _ _ _ _ _ _ \<hole> _" map_G_id[symmetric])
  apply (subst mapl_G_def)
  apply (rule map_G_rel_cong)
        apply (erule rel_G_witness1[OF cond])
       apply (auto)
  done

lemma rel_U_witness2:
  fixes L1 :: "'l1 \<Rightarrow> 'l1'' \<Rightarrow> bool"
    and Co1 :: "'co1 \<Rightarrow> 'co1' \<Rightarrow> bool" and Co1' :: "'co1' \<Rightarrow> 'co1'' \<Rightarrow> bool"
    and Co2 :: "'co2 \<Rightarrow> 'co2' \<Rightarrow> bool" and Co2' :: "'co2' \<Rightarrow> 'co2'' \<Rightarrow> bool"
    and Contra1 :: "'contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool" and Contra1' :: "'contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool"
    and Contra2 :: "'contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool" and Contra2' :: "'contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool"
    and tytok_G :: "(('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) U \<times>
             (('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) U \<times>
              ('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) U) \<times>
             ('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) U \<times>
             'l1 \<times> ('l1 \<times> 'l1'') \<times> 'l1'' \<times> 'f) itself"
    and x :: "(_, _, _, _, _, 'f) U"
  assumes cond: "rel_G_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok_G"
    and rel_OO: "rel_U L1 (Co1 OO Co1') (Co2 OO Co2') (Contra1 OO Contra1') (Contra2 OO Contra2') x y"
  shows "rel_U (\<lambda>(x, y') y. y' = y \<and> L1 x y) Co1' Co2' Contra1' Contra2'
      (rel_U_witness L1 Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' (x, y)) y"
  using rel_OO apply (coinduction arbitrary: x y)
  apply (erule rel_U.cases)
  apply (clarsimp)
  apply (rewrite in "rel_G _ _ _ _ _ _ _ \<hole>" map_G_id[symmetric])
  apply (subst mapl_G_def)
  apply (rule map_G_rel_cong)
        apply (erule rel_G_witness2[OF cond])
       apply (auto)
  done

lemma rel_U_neg_distr_imp:
  fixes Co1 :: "'co1 \<Rightarrow> 'co1' \<Rightarrow> bool" and Co1' :: "'co1' \<Rightarrow> 'co1'' \<Rightarrow> bool"
    and Co2 :: "'co2 \<Rightarrow> 'co2' \<Rightarrow> bool" and Co2' :: "'co2' \<Rightarrow> 'co2'' \<Rightarrow> bool"
    and Contra1 :: "'contra1 \<Rightarrow> 'contra1' \<Rightarrow> bool" and Contra1' :: "'contra1' \<Rightarrow> 'contra1'' \<Rightarrow> bool"
    and Contra2 :: "'contra2 \<Rightarrow> 'contra2' \<Rightarrow> bool" and Contra2' :: "'contra2' \<Rightarrow> 'contra2'' \<Rightarrow> bool"
    and tytok_G :: "(('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) U \<times>
          (('l1, 'co1, 'co2, 'contra1, 'contra2, 'f) U \<times>
           ('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) U) \<times>
          ('l1'', 'co1'', 'co2'', 'contra1'', 'contra2'', 'f) U \<times>
          'l1 \<times> ('l1 \<times> 'l1'') \<times> 'l1'' \<times> 'f) itself"
    and tytok_T :: "('l1 \<times> 'l1' \<times> 'l1'' \<times> 'f) itself"
  assumes "rel_G_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok_G"
  shows "rel_U_neg_distr_cond Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' tytok_T"
  unfolding rel_U_neg_distr_cond_def
proof (intro allI predicate2I relcomppI)
  fix L1 :: "'l1 \<Rightarrow> 'l1' \<Rightarrow> bool" and L1' :: "'l1' \<Rightarrow> 'l1'' \<Rightarrow> bool"
    and x :: "(_, _, _, _, _, 'f) U" and y :: "(_, _, _, _, _, 'f) U"
  assume *: "rel_U (L1 OO L1') (Co1 OO Co1') (Co2 OO Co2')
    (Contra1 OO Contra1') (Contra2 OO Contra2') x y"
  let ?z = "map_U (relcompp_witness L1 L1') id id id id
    (rel_U_witness (L1 OO L1') Co1 Co1' Co2 Co2' Contra1 Contra1' Contra2 Contra2' (x, y))"
  show "rel_U L1 Co1 Co2 Contra1 Contra2 x ?z"
    apply(subst map_U_id[symmetric])
    apply(rule map_U_parametric[unfolded rel_fun_def, rule_format, rotated -1])
         apply(rule rel_U_witness1[OF assms *])
        apply(auto simp add: vimage2p_def del: relcomppE elim!: relcompp_witness)
    done
  show "rel_U L1' Co1' Co2' Contra1' Contra2' ?z y"
    apply(rewrite in "rel_U _ _ _ _ _ _ \<hole>" map_U_id[symmetric])
    apply(rule map_U_parametric[unfolded rel_fun_def, rule_format, rotated -1])
         apply(rule rel_U_witness2[OF assms *])
        apply(auto simp add: vimage2p_def del: relcomppE elim!: relcompp_witness)
    done
qed

lemma rel_U_pos_distr_cond_eq:
  "\<And>tytok. rel_U_pos_distr_cond (=) (=) (=) (=) (=) (=) (=) (=) tytok"
  by (intro rel_U_pos_distr_imp rel_G_pos_distr_cond_eq)

lemma rel_U_neg_distr_cond_eq:
  "\<And>tytok. rel_U_neg_distr_cond (=) (=) (=) (=) (=) (=) (=) (=) tytok"
  by (intro rel_U_neg_distr_imp rel_G_neg_distr_cond_eq)

text \<open>The BNF axioms are proved by the datatype package.\<close>

thm U.set_map U.bd_card_order U.bd_cinfinite U.set_bd U.map_cong[OF refl]
  U.rel_mono_strong U.wit

subsubsection \<open>Parametricity laws\<close>

context includes lifting_syntax begin

lemma C_U_parametric: "(rel_G (rel_U L1 Co1 Co2 Contra1 Contra2) L1 Co1 Co2 Contra1 Contra2 ===>
  rel_U L1 Co1 Co2 Contra1 Contra2) C_U C_U"
  by (fastforce intro: rel_U.intros)

lemma D_U_parametric: "(rel_U L1 Co1 Co2 Contra1 Contra2 ===>
  rel_G (rel_U L1 Co1 Co2 Contra1 Contra2) L1 Co1 Co2 Contra1 Contra2) D_U D_U"
  by (fast elim: rel_U.cases)

end

end


theory BananasBigStepDynamics
imports BananasSafety
begin

inductive total_eval :: "dynamic_environment \<Rightarrow> expr \<Rightarrow> val \<Rightarrow> val \<Rightarrow> bool"
    (infix "\<turnstile> _ \<cdot> _ \<Down>" 60) where
  tev_base [simp]: "\<Lambda> \<turnstile> \<epsilon> \<cdot> v \<Down> v"
| tev_step [simp]: "\<Lambda> \<turnstile> e \<cdot> v \<leadsto> e' \<cdot> v' \<Longrightarrow> \<Lambda> \<turnstile> e' \<cdot> v' \<Down> v'' \<Longrightarrow> \<Lambda> \<turnstile> e \<cdot> v \<Down> v''"

inductive total_evaluate_prog :: "prog \<Rightarrow> val \<Rightarrow> bool" (infix "\<Down>" 60) where
  ptev_base [simp]: "Prog \<Delta> \<epsilon> v \<Down> v"
| ptev_step [simp]: "Prog \<Delta> e v \<leadsto> Prog \<Delta> e' v' \<Longrightarrow> Prog \<Delta> e' v' \<Down> v'' \<Longrightarrow> Prog \<Delta> e v \<Down> v''"

inductive total_evaluate_prog' :: "prog \<Rightarrow> val \<Rightarrow> bool" (infix "\<Down>\<Down>" 60) where
  ptev_step' [simp]: "assemble_context empty_static \<Delta> \<Lambda> \<Longrightarrow> \<Lambda> \<turnstile> e \<cdot> v \<Down> v' \<Longrightarrow> Prog \<Delta> e v \<Down>\<Down> v'"

inductive_cases [elim]: "Prog \<Lambda> e v \<Down>\<Down> v'"

lemma [elim]: "\<Lambda> \<turnstile> f \<cdot> v \<Down> v' \<Longrightarrow> \<Lambda> \<turnstile> g \<cdot> v' \<Down> v'' \<Longrightarrow> \<Lambda> \<turnstile> (g \<cdot> f) \<cdot> v \<Down> v''"
  proof (induction \<Lambda> f v v' rule: total_eval.induct)
  case (tev_base \<Lambda> v)
    moreover have "\<Lambda> \<turnstile> (g \<cdot> \<epsilon>) \<cdot> v \<leadsto> g \<cdot> v" by simp
    ultimately show ?case by (metis tev_step)
  next case (tev_step \<Lambda> f v f' v' v''')
    hence "\<Lambda> \<turnstile> (g \<cdot> f) \<cdot> v \<leadsto> (g \<cdot> f') \<cdot> v'" by simp
    moreover from tev_step have "\<Lambda> \<turnstile> (g \<cdot> f') \<cdot> v' \<Down> v''" by simp
    ultimately show ?case by (metis total_eval.tev_step)
  qed

lemma eps_big_eval [elim]: "\<Lambda> \<turnstile> \<epsilon> \<cdot> v \<Down> v' \<Longrightarrow> v = v'"
  proof (induction \<Lambda> \<epsilon> v v' rule: total_eval.induct)
  case (tev_step \<Lambda> v e' v' v'')
    thus ?case by (induction \<epsilon> v e' v' rule: evaluate.induct)
  qed simp_all

lemma [simp]: "\<Lambda> \<turnstile> f\<^sub>2 \<cdot> v\<^sub>2 \<Down> v\<^sub>4 \<Longrightarrow> \<Lambda> \<turnstile> \<epsilon> \<parallel> f\<^sub>2 \<cdot> PairV v\<^sub>1 v\<^sub>2 \<Down> PairV v\<^sub>1 v\<^sub>4"
  proof (induction \<Lambda> f\<^sub>2 v\<^sub>2 v\<^sub>4 rule: total_eval.induct)
  case (tev_step \<Lambda> f\<^sub>2 v\<^sub>2 f\<^sub>2' v\<^sub>2' v\<^sub>4)
    hence "\<Lambda> \<turnstile> \<epsilon> \<parallel> f\<^sub>2 \<cdot> PairV v\<^sub>1 v\<^sub>2 \<leadsto> \<epsilon> \<parallel> f\<^sub>2' \<cdot> PairV v\<^sub>1 v\<^sub>2'" by simp
    moreover from tev_step have "\<Lambda> \<turnstile> \<epsilon> \<parallel> f\<^sub>2' \<cdot> PairV v\<^sub>1 v\<^sub>2' \<Down> PairV v\<^sub>1 v\<^sub>4" by simp
    ultimately show ?case by simp
  qed simp_all

lemma [simp]: "\<Lambda> \<turnstile> f\<^sub>1 \<cdot> v\<^sub>1 \<Down> v\<^sub>3 \<Longrightarrow> \<Lambda> \<turnstile> f\<^sub>2 \<cdot> v\<^sub>2 \<Down> v\<^sub>4 \<Longrightarrow>
    \<Lambda> \<turnstile> f\<^sub>1 \<parallel> f\<^sub>2 \<cdot> PairV v\<^sub>1 v\<^sub>2 \<Down> PairV v\<^sub>3 v\<^sub>4"
  proof (induction \<Lambda> f\<^sub>1 v\<^sub>1 v\<^sub>3 rule: total_eval.induct)
  case (tev_step \<Lambda> f\<^sub>1 v\<^sub>1 f\<^sub>1' v\<^sub>1' v\<^sub>3)
    hence "\<Lambda> \<turnstile> f\<^sub>1 \<parallel> f\<^sub>2 \<cdot> PairV v\<^sub>1 v\<^sub>2 \<leadsto> f\<^sub>1' \<parallel> f\<^sub>2 \<cdot> PairV v\<^sub>1' v\<^sub>2" by simp
    moreover from tev_step have "\<Lambda> \<turnstile> f\<^sub>1' \<parallel> f\<^sub>2 \<cdot> PairV v\<^sub>1' v\<^sub>2 \<Down> PairV v\<^sub>3 v\<^sub>4" by simp
    ultimately show ?case by simp
  qed simp_all

lemma pair_big_eval [elim]: "\<Lambda> \<turnstile> f\<^sub>1 \<parallel> f\<^sub>2 \<cdot> PairV v\<^sub>1 v\<^sub>2 \<Down> PairV v\<^sub>3 v\<^sub>4 \<Longrightarrow>
    (\<Lambda> \<turnstile> f\<^sub>1 \<cdot> v\<^sub>1 \<Down> v\<^sub>3) \<and> \<Lambda> \<turnstile> f\<^sub>2 \<cdot> v\<^sub>2 \<Down> v\<^sub>4"
  proof (induction \<Lambda> "f\<^sub>1 \<parallel> f\<^sub>2" "PairV v\<^sub>1 v\<^sub>2" "PairV v\<^sub>3 v\<^sub>4"
         arbitrary: f\<^sub>1 f\<^sub>2 v\<^sub>1 v\<^sub>2 rule: total_eval.induct)
  case (tev_step \<Lambda> e' v')
    thus ?case
      proof (induction \<Lambda> "f\<^sub>1 \<parallel> f\<^sub>2" "PairV v\<^sub>1 v\<^sub>2" e' v' arbitrary: f\<^sub>1 f\<^sub>2 v\<^sub>1 v\<^sub>2 rule: evaluate.induct)
      case (ev_pair3 \<Lambda> v\<^sub>1 v\<^sub>2)
        hence "PairV v\<^sub>1 v\<^sub>2 = PairV v\<^sub>3 v\<^sub>4" by (metis eps_big_eval)
        thus ?case by simp
      qed simp_all
  qed

lemma [simp]: "\<Lambda> \<turnstile> f\<^sub>l \<cdot> v \<Down> v' \<Longrightarrow> \<Lambda> \<turnstile> f\<^sub>l \<bar> f\<^sub>r \<cdot> InlV v \<Down> InlV v'"
  proof
    show "\<Lambda> \<turnstile> f\<^sub>l \<bar> f\<^sub>r \<cdot> InlV v \<leadsto> (\<iota>\<^sub>l \<cdot> f\<^sub>l) \<cdot> v" by simp
    show "\<Lambda> \<turnstile> f\<^sub>l \<cdot> v \<Down> v' \<Longrightarrow> \<Lambda> \<turnstile> (\<iota>\<^sub>l \<cdot> f\<^sub>l) \<cdot> v \<Down> InlV v'" by auto
  qed

lemma [simp]: "\<Lambda> \<turnstile> f\<^sub>r \<cdot> v \<Down> v' \<Longrightarrow> \<Lambda> \<turnstile> f\<^sub>l \<bar> f\<^sub>r \<cdot> InrV v \<Down> InrV v'"
  proof
    show "\<Lambda> \<turnstile> f\<^sub>l \<bar> f\<^sub>r \<cdot> InrV v \<leadsto> (\<iota>\<^sub>r \<cdot> f\<^sub>r) \<cdot> v" by simp
    show "\<Lambda> \<turnstile> f\<^sub>r \<cdot> v \<Down> v' \<Longrightarrow> \<Lambda> \<turnstile> (\<iota>\<^sub>r \<cdot> f\<^sub>r) \<cdot> v \<Down> InrV v'" by auto
  qed

lemma [simp]: "\<Pi> \<Down> v = \<Pi> \<Down>\<Down> v"
  proof
    show "\<Pi> \<Down> v \<Longrightarrow> \<Pi> \<Down>\<Down> v" by (induction \<Pi> v rule: total_evaluate_prog.induct) fastforce+
  next
    assume "\<Pi> \<Down>\<Down> v"
    thus "\<Pi> \<Down> v"
      proof (induction \<Pi> v rule: total_evaluate_prog'.induct)
      case (ptev_step' \<Delta> \<Lambda> e v v')
        with ptev_step'(2) show ?case
          proof (induction \<Lambda> e v v' rule: total_eval.induct)
          case (tev_step \<Lambda> e v e' v' v'')
            moreover hence "Prog \<Delta> e v \<leadsto> Prog \<Delta> e' v'" by simp
            ultimately show ?case by (metis total_evaluate_prog.ptev_step)
          qed simp_all
      qed
  qed

(* since we are a turing-complete language, total progress is not provable *)

theorem total_expr_preservation [simp]: "\<Lambda> \<turnstile> e \<cdot> v \<Down> v' \<Longrightarrow> \<Gamma> \<turnstile> e : t\<^sub>1 \<rightarrow> t\<^sub>2 \<Longrightarrow>
    \<Gamma> \<turnstile> v : t\<^sub>1 \<Longrightarrow> \<Gamma> \<tturnstile> \<Lambda> \<Longrightarrow> \<Gamma> \<turnstile> v' : t\<^sub>2"
  proof (induction \<Lambda> e v v' arbitrary: t\<^sub>1 rule: total_eval.induct)
  case (tev_step \<Lambda> e v e' v' v'')
    moreover then obtain t\<^sub>3 where "(\<Gamma> \<turnstile> e' : t\<^sub>3 \<rightarrow> t\<^sub>2) \<and> (\<Gamma> \<turnstile> v' : t\<^sub>3)"
      by (metis expr_preservation)
    ultimately show ?case by fastforce
  qed auto

lemma [simp]: "\<Pi> \<Down>\<Down> v \<Longrightarrow> \<Pi> \<TTurnstile> \<Gamma> \<rightarrow> t \<Longrightarrow> \<Gamma> \<turnstile> v : t"
  by (induction \<Pi> v rule: total_evaluate_prog'.induct) auto

theorem total_preservation: "\<Pi> \<Down> v \<Longrightarrow> \<Pi> \<TTurnstile> \<Gamma> \<rightarrow> t \<Longrightarrow> \<Gamma> \<turnstile> v : t"
  by simp

end


subsection\<open>Example\<close>
text\<open>This theory shows how contexts can be used to prove transition subsumption.\<close>
theory Drinks_Subsumption
imports "Extended_Finite_State_Machine_Inference-devel.Subsumption" "Extended_Finite_State_Machines.Drinks_Machine_2"
begin

lemma stop_at_3: "\<not>obtains 1 c drinks2 3 r t"
proof(induct t arbitrary: r)
  case Nil
  then show ?case
    by (simp add: obtains_base)
next
  case (Cons a t)
  then show ?case
    apply (case_tac a)
    apply (simp add: obtains_step)
    apply clarify
    apply (simp add: in_possible_steps[symmetric])
    by (simp add: drinks2_def)
qed

lemma no_1_2: "\<not>obtains 1 c drinks2 2 r t"
proof(induct t arbitrary: r)
  case Nil
  then show ?case
    by (simp add: obtains_base)
next
  case (Cons a t)
  then show ?case
    apply (case_tac a)
    apply (simp add: obtains_step)
    apply clarify
    apply (simp add: in_possible_steps[symmetric])
    apply (simp add: drinks2_def)
    apply clarsimp
    apply (simp add: drinks2_def[symmetric])
    apply (erule disjE)
     apply simp
    apply (erule disjE)
     apply simp
    by (simp add: stop_at_3)
qed

lemma no_change_1_1: "obtains 1 c drinks2 1 r t \<Longrightarrow> c = r"
proof(induct t)
  case Nil
  then show ?case
    by (simp add: obtains_base)
next
  case (Cons a t)
  then show ?case
    apply (case_tac a)
    apply (simp add: obtains_step)
    apply clarify
    apply (simp add: in_possible_steps[symmetric])
    apply (simp add: drinks2_def)
    apply clarsimp
    apply (simp add: drinks2_def[symmetric])
    apply (erule disjE)
     apply (simp add: vend_nothing_def apply_updates_def)
    by (simp add: no_1_2)
qed

lemma obtains_1: "obtains 1 c drinks2 0 <> t \<Longrightarrow> c $ 2 = Some (Num 0)"
proof(induct t)
  case Nil
  then show ?case
    by (simp add: obtains_base)
next
  case (Cons a t)
  then show ?case
    apply (case_tac a)
    apply (simp add: obtains_step)
    apply clarify
    apply (simp add: in_possible_steps[symmetric])
    apply (simp add: drinks2_def)
    apply (simp add: drinks2_def[symmetric])
    apply (simp add: select_def can_take apply_updates_def)
    using no_change_1_1 by fastforce
qed

lemma obtains_1_1_2:
  "obtains 1 c1 drinks2 1 r t \<Longrightarrow>
   obtains 1 c2 drinks 1 r t \<Longrightarrow>
   c1 = r \<and> c2 = r"
proof(induct t arbitrary: r)
  case Nil
  then show ?case
    by (simp add: obtains_base)
next
  case (Cons a t)
  then show ?case
    apply (case_tac a)
    apply (simp add: obtains_step)
    apply clarify
    apply (simp add: in_possible_steps[symmetric])
    apply (simp add: drinks2_def drinks_def)
    apply clarsimp
    apply (simp add: drinks2_def[symmetric] drinks_def[symmetric])
    apply safe
    using Cons.prems(1) no_change_1_1 apply blast
              apply (simp add: coin_def vend_nothing_def)
    using Cons.prems(1) no_change_1_1 apply blast
            apply (simp add: vend_fail_def vend_nothing_def apply_updates_def)
    using Cons.prems(1) no_change_1_1 apply blast
          apply (metis drinks_rejects_future numeral_eq_one_iff obtains.cases obtains_recognises semiring_norm(85))
    using no_1_2 apply blast
    using no_1_2 apply blast
    using Cons.prems(1) no_change_1_1 apply blast
    using no_1_2 apply blast
    using no_1_2 apply blast
    using no_1_2 by blast
qed

lemma obtains_1_c2:
  "obtains 1 c1 drinks2 0 <> t \<Longrightarrow> obtains 1 c2 drinks 0 <> t \<Longrightarrow> c2 $ 2 = Some (Num 0)"
proof(induct t)
  case Nil
  then show ?case
    by (simp add: obtains_base)
next
  case (Cons a t)
  then show ?case
    apply (case_tac a)
    apply (simp add: obtains_step)
    apply clarify
    apply (simp add: in_possible_steps[symmetric])
    apply (simp add: drinks2_def drinks_def)
    apply clarsimp
    apply (simp add: drinks2_def[symmetric] drinks_def[symmetric])
    apply (simp add: select_def can_take apply_updates_def)
    using obtains_1_1_2 by fastforce
qed

lemma directly_subsumes: "directly_subsumes drinks2 drinks 1 1 vend_fail vend_nothing"
  apply (rule direct_subsumption[of _ _ _ _ "\<lambda>c2. c2 $ 2 = Some (Num 0)"])
   apply (simp add: obtains_1_c2)
  apply (rule subsumption)
     apply (simp add: vend_fail_def vend_nothing_def)
    apply (simp add: vend_fail_def vend_nothing_def can_take value_gt_true)
   apply (simp add: vend_fail_def vend_nothing_def)
  by (simp add: posterior_separate_def vend_fail_def vend_nothing_def)

lemma directly_subsumes_flip: "directly_subsumes drinks2 drinks 1 1 vend_nothing vend_fail"
  apply (rule direct_subsumption[of _ _ _ _ "\<lambda>c2. c2 $ 2 = Some (Num 0)"])
   apply (simp add: obtains_1_c2)
  apply (rule subsumption)
     apply (simp add: vend_fail_def vend_nothing_def)
    apply (simp add: vend_fail_def vend_nothing_def can_take value_gt_true)
   apply (simp add: vend_fail_def vend_nothing_def can_take value_gt_true)
  by (simp add: posterior_separate_def vend_fail_def vend_nothing_def)

end