(*  Title:      ZF/Constructible/Separation.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section{*Early Instances of Separation and Strong Replacement*}

theory Separation imports L_axioms WF_absolute begin

text{*This theory proves all instances needed for locale @{text "M_basic"}*}

text{*Helps us solve for de Bruijn indices!*}
lemma nth_ConsI: "[|nth(n,l) = x; n \<in> nat|] ==> nth(succ(n), Cons(a,l)) = x"
by simp

lemmas nth_rules = nth_0 nth_ConsI nat_0I nat_succI
lemmas sep_rules = nth_0 nth_ConsI FOL_iff_sats function_iff_sats
                   fun_plus_iff_sats

lemma Collect_conj_in_DPow:
     "[| {x\<in>A. P(x)} \<in> DPow(A);  {x\<in>A. Q(x)} \<in> DPow(A) |]
      ==> {x\<in>A. P(x) & Q(x)} \<in> DPow(A)"
by (simp add: Int_in_DPow Collect_Int_Collect_eq [symmetric])

lemma Collect_conj_in_DPow_Lset:
     "[|z \<in> Lset(j); {x \<in> Lset(j). P(x)} \<in> DPow(Lset(j))|]
      ==> {x \<in> Lset(j). x \<in> z & P(x)} \<in> DPow(Lset(j))"
apply (frule mem_Lset_imp_subset_Lset)
apply (simp add: Collect_conj_in_DPow Collect_mem_eq
                 subset_Int_iff2 elem_subset_in_DPow)
done

lemma separation_CollectI:
     "(\<And>z. L(z) ==> L({x \<in> z . P(x)})) ==> separation(L, \<lambda>x. P(x))"
apply (unfold separation_def, clarify)
apply (rule_tac x="{x\<in>z. P(x)}" in rexI)
apply simp_all
done

text{*Reduces the original comprehension to the reflected one*}
lemma reflection_imp_L_separation:
      "[| \<forall>x\<in>Lset(j). P(x) \<longleftrightarrow> Q(x);
          {x \<in> Lset(j) . Q(x)} \<in> DPow(Lset(j));
          Ord(j);  z \<in> Lset(j)|] ==> L({x \<in> z . P(x)})"
apply (rule_tac i = "succ(j)" in L_I)
 prefer 2 apply simp
apply (subgoal_tac "{x \<in> z. P(x)} = {x \<in> Lset(j). x \<in> z & (Q(x))}")
 prefer 2
 apply (blast dest: mem_Lset_imp_subset_Lset)
apply (simp add: Lset_succ Collect_conj_in_DPow_Lset)
done

text{*Encapsulates the standard proof script for proving instances of
      Separation.*}
lemma gen_separation:
 assumes reflection: "REFLECTS [P,Q]"
     and Lu:         "L(u)"
     and collI: "!!j. u \<in> Lset(j)
                \<Longrightarrow> Collect(Lset(j), Q(j)) \<in> DPow(Lset(j))"
 shows "separation(L,P)"
apply (rule separation_CollectI)
apply (rule_tac A="{u,z}" in subset_LsetE, blast intro: Lu)
apply (rule ReflectsE [OF reflection], assumption)
apply (drule subset_Lset_ltD, assumption)
apply (erule reflection_imp_L_separation)
  apply (simp_all add: lt_Ord2, clarify)
apply (rule collI, assumption)
done

text{*As above, but typically @{term u} is a finite enumeration such as
  @{term "{a,b}"}; thus the new subgoal gets the assumption
  @{term "{a,b} \<subseteq> Lset(i)"}, which is logically equivalent to
  @{term "a \<in> Lset(i)"} and @{term "b \<in> Lset(i)"}.*}
lemma gen_separation_multi:
 assumes reflection: "REFLECTS [P,Q]"
     and Lu:         "L(u)"
     and collI: "!!j. u \<subseteq> Lset(j)
                \<Longrightarrow> Collect(Lset(j), Q(j)) \<in> DPow(Lset(j))"
 shows "separation(L,P)"
apply (rule gen_separation [OF reflection Lu])
apply (drule mem_Lset_imp_subset_Lset)
apply (erule collI)
done

subsection{*Separation for Intersection*}

lemma Inter_Reflects:
     "REFLECTS[\<lambda>x. \<forall>y[L]. y\<in>A \<longrightarrow> x \<in> y,
               \<lambda>i x. \<forall>y\<in>Lset(i). y\<in>A \<longrightarrow> x \<in> y]"
by (intro FOL_reflections)

lemma Inter_separation:
     "L(A) ==> separation(L, \<lambda>x. \<forall>y[L]. y\<in>A \<longrightarrow> x\<in>y)"
apply (rule gen_separation [OF Inter_Reflects], simp)
apply (rule DPow_LsetI)
 txt{*I leave this one example of a manual proof.  The tedium of manually
      instantiating @{term i}, @{term j} and @{term env} is obvious. *}
apply (rule ball_iff_sats)
apply (rule imp_iff_sats)
apply (rule_tac [2] i=1 and j=0 and env="[y,x,A]" in mem_iff_sats)
apply (rule_tac i=0 and j=2 in mem_iff_sats)
apply (simp_all add: succ_Un_distrib [symmetric])
done

subsection{*Separation for Set Difference*}

lemma Diff_Reflects:
     "REFLECTS[\<lambda>x. x \<notin> B, \<lambda>i x. x \<notin> B]"
by (intro FOL_reflections)

lemma Diff_separation:
     "L(B) ==> separation(L, \<lambda>x. x \<notin> B)"
apply (rule gen_separation [OF Diff_Reflects], simp)
apply (rule_tac env="[B]" in DPow_LsetI)
apply (rule sep_rules | simp)+
done

subsection{*Separation for Cartesian Product*}

lemma cartprod_Reflects:
     "REFLECTS[\<lambda>z. \<exists>x[L]. x\<in>A & (\<exists>y[L]. y\<in>B & pair(L,x,y,z)),
                \<lambda>i z. \<exists>x\<in>Lset(i). x\<in>A & (\<exists>y\<in>Lset(i). y\<in>B &
                                   pair(##Lset(i),x,y,z))]"
by (intro FOL_reflections function_reflections)

lemma cartprod_separation:
     "[| L(A); L(B) |]
      ==> separation(L, \<lambda>z. \<exists>x[L]. x\<in>A & (\<exists>y[L]. y\<in>B & pair(L,x,y,z)))"
apply (rule gen_separation_multi [OF cartprod_Reflects, of "{A,B}"], auto)
apply (rule_tac env="[A,B]" in DPow_LsetI)
apply (rule sep_rules | simp)+
done

subsection{*Separation for Image*}

lemma image_Reflects:
     "REFLECTS[\<lambda>y. \<exists>p[L]. p\<in>r & (\<exists>x[L]. x\<in>A & pair(L,x,y,p)),
           \<lambda>i y. \<exists>p\<in>Lset(i). p\<in>r & (\<exists>x\<in>Lset(i). x\<in>A & pair(##Lset(i),x,y,p))]"
by (intro FOL_reflections function_reflections)

lemma image_separation:
     "[| L(A); L(r) |]
      ==> separation(L, \<lambda>y. \<exists>p[L]. p\<in>r & (\<exists>x[L]. x\<in>A & pair(L,x,y,p)))"
apply (rule gen_separation_multi [OF image_Reflects, of "{A,r}"], auto)
apply (rule_tac env="[A,r]" in DPow_LsetI)
apply (rule sep_rules | simp)+
done

subsection{*Separation for Converse*}

lemma converse_Reflects:
  "REFLECTS[\<lambda>z. \<exists>p[L]. p\<in>r & (\<exists>x[L]. \<exists>y[L]. pair(L,x,y,p) & pair(L,y,x,z)),
     \<lambda>i z. \<exists>p\<in>Lset(i). p\<in>r & (\<exists>x\<in>Lset(i). \<exists>y\<in>Lset(i).
                     pair(##Lset(i),x,y,p) & pair(##Lset(i),y,x,z))]"
by (intro FOL_reflections function_reflections)

lemma converse_separation:
     "L(r) ==> separation(L,
         \<lambda>z. \<exists>p[L]. p\<in>r & (\<exists>x[L]. \<exists>y[L]. pair(L,x,y,p) & pair(L,y,x,z)))"
apply (rule gen_separation [OF converse_Reflects], simp)
apply (rule_tac env="[r]" in DPow_LsetI)
apply (rule sep_rules | simp)+
done

subsection{*Separation for Restriction*}

lemma restrict_Reflects:
     "REFLECTS[\<lambda>z. \<exists>x[L]. x\<in>A & (\<exists>y[L]. pair(L,x,y,z)),
        \<lambda>i z. \<exists>x\<in>Lset(i). x\<in>A & (\<exists>y\<in>Lset(i). pair(##Lset(i),x,y,z))]"
by (intro FOL_reflections function_reflections)

lemma restrict_separation:
   "L(A) ==> separation(L, \<lambda>z. \<exists>x[L]. x\<in>A & (\<exists>y[L]. pair(L,x,y,z)))"
apply (rule gen_separation [OF restrict_Reflects], simp)
apply (rule_tac env="[A]" in DPow_LsetI)
apply (rule sep_rules | simp)+
done

subsection{*Separation for Composition*}

lemma comp_Reflects:
     "REFLECTS[\<lambda>xz. \<exists>x[L]. \<exists>y[L]. \<exists>z[L]. \<exists>xy[L]. \<exists>yz[L].
                  pair(L,x,z,xz) & pair(L,x,y,xy) & pair(L,y,z,yz) &
                  xy\<in>s & yz\<in>r,
        \<lambda>i xz. \<exists>x\<in>Lset(i). \<exists>y\<in>Lset(i). \<exists>z\<in>Lset(i). \<exists>xy\<in>Lset(i). \<exists>yz\<in>Lset(i).
                  pair(##Lset(i),x,z,xz) & pair(##Lset(i),x,y,xy) &
                  pair(##Lset(i),y,z,yz) & xy\<in>s & yz\<in>r]"
by (intro FOL_reflections function_reflections)

lemma comp_separation:
     "[| L(r); L(s) |]
      ==> separation(L, \<lambda>xz. \<exists>x[L]. \<exists>y[L]. \<exists>z[L]. \<exists>xy[L]. \<exists>yz[L].
                  pair(L,x,z,xz) & pair(L,x,y,xy) & pair(L,y,z,yz) &
                  xy\<in>s & yz\<in>r)"
apply (rule gen_separation_multi [OF comp_Reflects, of "{r,s}"], auto)
txt{*Subgoals after applying general ``separation'' rule:
     @{subgoals[display,indent=0,margin=65]}*}
apply (rule_tac env="[r,s]" in DPow_LsetI)
txt{*Subgoals ready for automatic synthesis of a formula:
     @{subgoals[display,indent=0,margin=65]}*}
apply (rule sep_rules | simp)+
done

subsection{*Separation for Predecessors in an Order*}

lemma pred_Reflects:
     "REFLECTS[\<lambda>y. \<exists>p[L]. p\<in>r & pair(L,y,x,p),
                    \<lambda>i y. \<exists>p \<in> Lset(i). p\<in>r & pair(##Lset(i),y,x,p)]"
by (intro FOL_reflections function_reflections)

lemma pred_separation:
     "[| L(r); L(x) |] ==> separation(L, \<lambda>y. \<exists>p[L]. p\<in>r & pair(L,y,x,p))"
apply (rule gen_separation_multi [OF pred_Reflects, of "{r,x}"], auto)
apply (rule_tac env="[r,x]" in DPow_LsetI)
apply (rule sep_rules | simp)+
done

subsection{*Separation for the Membership Relation*}

lemma Memrel_Reflects:
     "REFLECTS[\<lambda>z. \<exists>x[L]. \<exists>y[L]. pair(L,x,y,z) & x \<in> y,
            \<lambda>i z. \<exists>x \<in> Lset(i). \<exists>y \<in> Lset(i). pair(##Lset(i),x,y,z) & x \<in> y]"
by (intro FOL_reflections function_reflections)

lemma Memrel_separation:
     "separation(L, \<lambda>z. \<exists>x[L]. \<exists>y[L]. pair(L,x,y,z) & x \<in> y)"
apply (rule gen_separation [OF Memrel_Reflects nonempty])
apply (rule_tac env="[]" in DPow_LsetI)
apply (rule sep_rules | simp)+
done

subsection{*Replacement for FunSpace*}

lemma funspace_succ_Reflects:
 "REFLECTS[\<lambda>z. \<exists>p[L]. p\<in>A & (\<exists>f[L]. \<exists>b[L]. \<exists>nb[L]. \<exists>cnbf[L].
            pair(L,f,b,p) & pair(L,n,b,nb) & is_cons(L,nb,f,cnbf) &
            upair(L,cnbf,cnbf,z)),
        \<lambda>i z. \<exists>p \<in> Lset(i). p\<in>A & (\<exists>f \<in> Lset(i). \<exists>b \<in> Lset(i).
              \<exists>nb \<in> Lset(i). \<exists>cnbf \<in> Lset(i).
                pair(##Lset(i),f,b,p) & pair(##Lset(i),n,b,nb) &
                is_cons(##Lset(i),nb,f,cnbf) & upair(##Lset(i),cnbf,cnbf,z))]"
by (intro FOL_reflections function_reflections)

lemma funspace_succ_replacement:
     "L(n) ==>
      strong_replacement(L, \<lambda>p z. \<exists>f[L]. \<exists>b[L]. \<exists>nb[L]. \<exists>cnbf[L].
                pair(L,f,b,p) & pair(L,n,b,nb) & is_cons(L,nb,f,cnbf) &
                upair(L,cnbf,cnbf,z))"
apply (rule strong_replacementI)
apply (rule_tac u="{n,B}" in gen_separation_multi [OF funspace_succ_Reflects],
       auto)
apply (rule_tac env="[n,B]" in DPow_LsetI)
apply (rule sep_rules | simp)+
done

subsection{*Separation for a Theorem about @{term "is_recfun"}*}

lemma is_recfun_reflects:
  "REFLECTS[\<lambda>x. \<exists>xa[L]. \<exists>xb[L].
                pair(L,x,a,xa) & xa \<in> r & pair(L,x,b,xb) & xb \<in> r &
                (\<exists>fx[L]. \<exists>gx[L]. fun_apply(L,f,x,fx) & fun_apply(L,g,x,gx) &
                                   fx \<noteq> gx),
   \<lambda>i x. \<exists>xa \<in> Lset(i). \<exists>xb \<in> Lset(i).
          pair(##Lset(i),x,a,xa) & xa \<in> r & pair(##Lset(i),x,b,xb) & xb \<in> r &
                (\<exists>fx \<in> Lset(i). \<exists>gx \<in> Lset(i). fun_apply(##Lset(i),f,x,fx) &
                  fun_apply(##Lset(i),g,x,gx) & fx \<noteq> gx)]"
by (intro FOL_reflections function_reflections fun_plus_reflections)

lemma is_recfun_separation:
     --{*for well-founded recursion*}
     "[| L(r); L(f); L(g); L(a); L(b) |]
     ==> separation(L,
            \<lambda>x. \<exists>xa[L]. \<exists>xb[L].
                pair(L,x,a,xa) & xa \<in> r & pair(L,x,b,xb) & xb \<in> r &
                (\<exists>fx[L]. \<exists>gx[L]. fun_apply(L,f,x,fx) & fun_apply(L,g,x,gx) &
                                   fx \<noteq> gx))"
apply (rule gen_separation_multi [OF is_recfun_reflects, of "{r,f,g,a,b}"],
            auto)
apply (rule_tac env="[r,f,g,a,b]" in DPow_LsetI)
apply (rule sep_rules | simp)+
done

subsection{*Instantiating the locale @{text M_basic}*}
text{*Separation (and Strong Replacement) for basic set-theoretic constructions
such as intersection, Cartesian Product and image.*}

lemma M_basic_axioms_L: "M_basic_axioms(L)"
  apply (rule M_basic_axioms.intro)
       apply (assumption | rule
         Inter_separation Diff_separation cartprod_separation image_separation
         converse_separation restrict_separation
         comp_separation pred_separation Memrel_separation
         funspace_succ_replacement is_recfun_separation)+
  done

theorem M_basic_L: "PROP M_basic(L)"
by (rule M_basic.intro [OF M_trivial_L M_basic_axioms_L])

interpretation L?: M_basic L by (rule M_basic_L)

end


section \<open>Sets by Lists that Own their Elements\<close>
theory IICF_List_SetO
imports "../Intf/IICF_Set"
begin
  text \<open>Minimal implementation, only supporting a few operations\<close>

  definition "lso_assn A \<equiv> hr_comp (list_assn A) (br set (\<lambda>_. True))"
  lemmas [fcomp_norm_unfold] = lso_assn_def[symmetric]
  lemma lso_is_pure[safe_constraint_rules]: "is_pure A \<Longrightarrow> is_pure (lso_assn A)"
    unfolding lso_assn_def by safe_constraint

  lemma lso_empty_aref: "(uncurry0 (RETURNT []), uncurry0 (RETURNT op_set_empty))
    \<in> unit_rel  \<rightarrow>\<^sub>f \<langle>br set (\<lambda>_. True)\<rangle>nrest_rel"
    apply rule
    by (auto simp: in_br_conv intro!: frefI nres_relI)

  lemma lso_ins_aref: "(uncurry (RETURN oo ((#) )), uncurry (RETURN oo op_set_insert))
    \<in> Id \<times>\<^sub>r br set (\<lambda>_. True) \<rightarrow>\<^sub>f \<langle>br set (\<lambda>_. True)\<rangle>nres_rel"
    by (auto simp: in_br_conv intro!: frefI nres_relI)

  sepref_decl_impl (no_register) lso_empty: hn_Nil[to_hfref] uses lso_empty_aref .
  definition [simp]: "op_lso_empty \<equiv> op_set_empty"
  lemma lso_fold_custom_empty:
    "{} = op_lso_empty"
    "op_set_empty = op_lso_empty"
    by auto
  lemmas [sepref_fr_rules] = lso_empty_hnr[folded op_lso_empty_def]

  sepref_decl_impl lso_insert: hn_Cons[to_hfref] uses lso_ins_aref .

  thm hn_Cons[FCOMP lso_ins_aref]

  (* TODO: Allow (controlled) backtracking over comb-rules, then we can have a general list-bex operation! *)
  definition [simp]: "op_lso_bex P S \<equiv> \<exists>x\<in>S. P x"
  lemma fold_lso_bex: "Bex \<equiv> \<lambda>s P. op_lso_bex P s" by auto

  definition [simp]: "mop_lso_bex P S \<equiv> ASSERT (\<forall>x\<in>S. \<exists>y. P x = RETURN y) \<then> RETURN (\<exists>x\<in>S. P x = RETURN True)"

  lemma op_mop_lso_bex:  "RETURN (op_lso_bex P S) = mop_lso_bex (RETURN o P) S" by simp

  sepref_register op_lso_bex
  lemma lso_bex_arity[sepref_monadify_arity]:
    "op_lso_bex \<equiv> \<lambda>\<^sub>2P s. SP op_lso_bex$(\<lambda>\<^sub>2x. P$x)$s" by (auto intro!: eq_reflection ext)
  lemma op_lso_bex_monadify[sepref_monadify_comb]:
    "EVAL$(op_lso_bex$(\<lambda>\<^sub>2x. P x)$s) \<equiv> (\<bind>) $(EVAL$s)$(\<lambda>\<^sub>2s. mop_lso_bex$(\<lambda>\<^sub>2x. EVAL $ P x)$s)" by simp

  definition "lso_abex P l \<equiv> nfoldli l (Not) (\<lambda>x _. P x) False"
  lemma lso_abex_to_set: "lso_abex P l \<le> mop_lso_bex P (set l)"
  proof -
    { fix b
      have "nfoldli l (Not) (\<lambda>x _. P x) b \<le> ASSERT (\<forall>x\<in>set l. \<exists>y. P x = RETURN y) \<then> RETURN ((\<exists>x\<in>set l. P x = RETURN True) \<or> b)"
        apply (induction l arbitrary: b)
        applyS simp
        applyS (clarsimp simp add: pw_le_iff refine_pw_simps; blast)
        done
    } from this[of False] show ?thesis by (simp add: lso_abex_def)
  qed

  locale lso_bex_impl_loc =
    fixes Pi and P :: "'a \<Rightarrow> bool nres"
    fixes li :: "'c list" and l :: "'a list"
    fixes A :: "'a \<Rightarrow> 'c \<Rightarrow> assn"
    fixes F :: assn

    assumes Prl: "\<And>x xi. \<lbrakk>x\<in>set l\<rbrakk> \<Longrightarrow> hn_refine (F * hn_ctxt A x xi) (Pi xi) (F * hn_ctxt A x xi) bool_assn (P x)"
  begin
    sepref_register l
    sepref_register P

    lemma [sepref_comb_rules]:
      assumes "\<Gamma> \<Longrightarrow>\<^sub>t F' * F * hn_ctxt A x xi"
      assumes "x\<in>set l"
      shows "hn_refine \<Gamma> (Pi xi) (F' * F * hn_ctxt A x xi) bool_assn (P$x)"
      using hn_refine_frame[OF Prl[OF assms(2)], of \<Gamma> F'] assms(1)
      by (simp add: assn_assoc)

    schematic_goal lso_bex_impl:
      "hn_refine (hn_ctxt (list_assn A) l li * F) (?c) (F * hn_ctxt (list_assn A) l li) bool_assn (lso_abex P l)"
      unfolding lso_abex_def[abs_def]
      by sepref
  end
  concrete_definition lso_bex_impl uses lso_bex_impl_loc.lso_bex_impl

  lemma hn_lso_bex[sepref_prep_comb_rule,sepref_comb_rules]:
    assumes FR: "\<Gamma> \<Longrightarrow>\<^sub>t hn_ctxt (lso_assn A) s li * F"
    assumes Prl: "\<And>x xi. \<lbrakk>x\<in>s\<rbrakk> \<Longrightarrow> hn_refine (F * hn_ctxt A x xi) (Pi xi) (F * hn_ctxt A x xi) bool_assn (P x)"
    notes [simp del] = mop_lso_bex_def
    shows "hn_refine \<Gamma> (lso_bex_impl Pi li) (F * hn_ctxt (lso_assn A) s li) bool_assn (mop_lso_bex$(\<lambda>\<^sub>2x. P x)$s)"
    apply (rule hn_refine_cons_pre[OF FR])
    apply (clarsimp simp: hn_ctxt_def lso_assn_def hr_comp_def in_br_conv hnr_pre_ex_conv)
    apply (rule hn_refine_preI)
    apply (drule mod_starD; clarsimp)
    apply (rule hn_refine_ref[OF lso_abex_to_set])
  proof -
    fix l assume [simp]: "s=set l"

    from Prl have Prl': "\<And>x xi. \<lbrakk>x\<in>set l\<rbrakk> \<Longrightarrow> hn_refine (F * hn_ctxt A x xi) (Pi xi) (F * hn_ctxt A x xi) bool_assn (P x)"
      by simp

    show "hn_refine (list_assn A l li * F) (lso_bex_impl Pi li) (\<exists>\<^sub>Aba. F * list_assn A ba li * \<up> (set l = set ba)) bool_assn
           (lso_abex P l)"
      apply (rule hn_refine_cons[OF _ lso_bex_impl.refine])
      applyS (simp add: hn_ctxt_def; rule entt_refl)
      apply1 unfold_locales apply1 (rule Prl') applyS simp
      applyS (sep_auto intro!: enttI simp: hn_ctxt_def)
      applyS (rule entt_refl)
      done
  qed

end


(*  Title:      ZF/Resid/Reduction.thy
    Author:     Ole Rasmussen
    Copyright   1995  University of Cambridge
*)

theory Reduction imports Residuals begin

(**** Lambda-terms ****)

consts
  lambda        :: "i"
  unmark        :: "i\<Rightarrow>i"

abbreviation
  Apl :: "[i,i]\<Rightarrow>i" where
  "Apl(n,m) \<equiv> App(0,n,m)"

inductive
  domains       "lambda" \<subseteq> redexes
  intros
    Lambda_Var:  "               n \<in> nat \<Longrightarrow>     Var(n) \<in> lambda"
    Lambda_Fun:  "            u \<in> lambda \<Longrightarrow>     Fun(u) \<in> lambda"
    Lambda_App:  "\<lbrakk>u \<in> lambda; v \<in> lambda\<rbrakk> \<Longrightarrow> Apl(u,v) \<in> lambda"
  type_intros    redexes.intros bool_typechecks

declare lambda.intros [intro]

primrec
  "unmark(Var(n)) = Var(n)"
  "unmark(Fun(u)) = Fun(unmark(u))"
  "unmark(App(b,f,a)) = Apl(unmark(f), unmark(a))"

declare lambda.intros [simp]
declare lambda.dom_subset [THEN subsetD, simp, intro]

(* ------------------------------------------------------------------------- *)
(*        unmark lemmas                                                      *)
(* ------------------------------------------------------------------------- *)

lemma unmark_type [intro, simp]:
     "u \<in> redexes \<Longrightarrow> unmark(u) \<in> lambda"
by (erule redexes.induct, simp_all)

lemma lambda_unmark: "u \<in> lambda \<Longrightarrow> unmark(u) = u"
by (erule lambda.induct, simp_all)

(* ------------------------------------------------------------------------- *)
(*         lift and subst preserve lambda                                    *)
(* ------------------------------------------------------------------------- *)

lemma liftL_type [rule_format]:
     "v \<in> lambda \<Longrightarrow> \<forall>k \<in> nat. lift_rec(v,k) \<in> lambda"
by (erule lambda.induct, simp_all add: lift_rec_Var)

lemma substL_type [rule_format, simp]:
     "v \<in> lambda \<Longrightarrow>  \<forall>n \<in> nat. \<forall>u \<in> lambda. subst_rec(u,v,n) \<in> lambda"
by (erule lambda.induct, simp_all add: liftL_type subst_Var)

(* ------------------------------------------------------------------------- *)
(*        type-rule for reduction definitions                               *)
(* ------------------------------------------------------------------------- *)

lemmas red_typechecks = substL_type nat_typechecks lambda.intros
                        bool_typechecks

consts
  Sred1     :: "i"
  Sred      :: "i"
  Spar_red1 :: "i"
  Spar_red  :: "i"

abbreviation
  Sred1_rel (infixl \<open>-1->\<close> 50) where
  "a -1-> b \<equiv> \<langle>a,b\<rangle> \<in> Sred1"

abbreviation
  Sred_rel (infixl \<open>-\<longrightarrow>\<close> 50) where
  "a -\<longrightarrow> b \<equiv> \<langle>a,b\<rangle> \<in> Sred"

abbreviation
  Spar_red1_rel (infixl \<open>=1\<Rightarrow>\<close> 50) where
  "a =1\<Rightarrow> b \<equiv> \<langle>a,b\<rangle> \<in> Spar_red1"

abbreviation
  Spar_red_rel (infixl \<open>=\<Longrightarrow>\<close> 50) where
  "a =\<Longrightarrow> b \<equiv> \<langle>a,b\<rangle> \<in> Spar_red"

inductive
  domains       "Sred1" \<subseteq> "lambda*lambda"
  intros
    beta:       "\<lbrakk>m \<in> lambda; n \<in> lambda\<rbrakk> \<Longrightarrow> Apl(Fun(m),n) -1-> n/m"
    rfun:       "\<lbrakk>m -1-> n\<rbrakk> \<Longrightarrow> Fun(m) -1-> Fun(n)"
    apl_l:      "\<lbrakk>m2 \<in> lambda; m1 -1-> n1\<rbrakk> \<Longrightarrow> Apl(m1,m2) -1-> Apl(n1,m2)"
    apl_r:      "\<lbrakk>m1 \<in> lambda; m2 -1-> n2\<rbrakk> \<Longrightarrow> Apl(m1,m2) -1-> Apl(m1,n2)"
  type_intros    red_typechecks

declare Sred1.intros [intro, simp]

inductive
  domains       "Sred" \<subseteq> "lambda*lambda"
  intros
    one_step:   "m-1->n \<Longrightarrow> m-\<longrightarrow>n"
    refl:       "m \<in> lambda\<Longrightarrow>m -\<longrightarrow>m"
    trans:      "\<lbrakk>m-\<longrightarrow>n; n-\<longrightarrow>p\<rbrakk> \<Longrightarrow>m-\<longrightarrow>p"
  type_intros    Sred1.dom_subset [THEN subsetD] red_typechecks

declare Sred.one_step [intro, simp]
declare Sred.refl     [intro, simp]

inductive
  domains       "Spar_red1" \<subseteq> "lambda*lambda"
  intros
    beta:       "\<lbrakk>m =1\<Rightarrow> m'; n =1\<Rightarrow> n'\<rbrakk> \<Longrightarrow> Apl(Fun(m),n) =1\<Rightarrow> n'/m'"
    rvar:       "n \<in> nat \<Longrightarrow> Var(n) =1\<Rightarrow> Var(n)"
    rfun:       "m =1\<Rightarrow> m' \<Longrightarrow> Fun(m) =1\<Rightarrow> Fun(m')"
    rapl:       "\<lbrakk>m =1\<Rightarrow> m'; n =1\<Rightarrow> n'\<rbrakk> \<Longrightarrow> Apl(m,n) =1\<Rightarrow> Apl(m',n')"
  type_intros    red_typechecks

declare Spar_red1.intros [intro, simp]

inductive
  domains "Spar_red" \<subseteq> "lambda*lambda"
  intros
    one_step:   "m =1\<Rightarrow> n \<Longrightarrow> m =\<Longrightarrow> n"
    trans:      "\<lbrakk>m=\<Longrightarrow>n; n=\<Longrightarrow>p\<rbrakk> \<Longrightarrow> m=\<Longrightarrow>p"
  type_intros    Spar_red1.dom_subset [THEN subsetD] red_typechecks

declare Spar_red.one_step [intro, simp]

(* ------------------------------------------------------------------------- *)
(*     Setting up rule lists for reduction                                   *)
(* ------------------------------------------------------------------------- *)

lemmas red1D1 [simp] = Sred1.dom_subset [THEN subsetD, THEN SigmaD1]
lemmas red1D2 [simp] = Sred1.dom_subset [THEN subsetD, THEN SigmaD2]
lemmas redD1 [simp] = Sred.dom_subset [THEN subsetD, THEN SigmaD1]
lemmas redD2 [simp] = Sred.dom_subset [THEN subsetD, THEN SigmaD2]

lemmas par_red1D1 [simp] = Spar_red1.dom_subset [THEN subsetD, THEN SigmaD1]
lemmas par_red1D2 [simp] = Spar_red1.dom_subset [THEN subsetD, THEN SigmaD2]
lemmas par_redD1 [simp] = Spar_red.dom_subset [THEN subsetD, THEN SigmaD1]
lemmas par_redD2 [simp] = Spar_red.dom_subset [THEN subsetD, THEN SigmaD2]

declare bool_typechecks [intro]

inductive_cases  [elim!]: "Fun(t) =1\<Rightarrow> Fun(u)"

(* ------------------------------------------------------------------------- *)
(*     Lemmas for reduction                                                  *)
(* ------------------------------------------------------------------------- *)

lemma red_Fun: "m-\<longrightarrow>n \<Longrightarrow> Fun(m) -\<longrightarrow> Fun(n)"
apply (erule Sred.induct)
apply (rule_tac [3] Sred.trans, simp_all)
done

lemma red_Apll: "\<lbrakk>n \<in> lambda; m -\<longrightarrow> m'\<rbrakk> \<Longrightarrow> Apl(m,n)-\<longrightarrow>Apl(m',n)"
apply (erule Sred.induct)
apply (rule_tac [3] Sred.trans, simp_all)
done

lemma red_Aplr: "\<lbrakk>n \<in> lambda; m -\<longrightarrow> m'\<rbrakk> \<Longrightarrow> Apl(n,m)-\<longrightarrow>Apl(n,m')"
apply (erule Sred.induct)
apply (rule_tac [3] Sred.trans, simp_all)
done

lemma red_Apl: "\<lbrakk>m -\<longrightarrow> m'; n-\<longrightarrow>n'\<rbrakk> \<Longrightarrow> Apl(m,n)-\<longrightarrow>Apl(m',n')"
apply (rule_tac n = "Apl (m',n) " in Sred.trans)
apply (simp_all add: red_Apll red_Aplr)
done

lemma red_beta: "\<lbrakk>m \<in> lambda; m':lambda; n \<in> lambda; n':lambda; m -\<longrightarrow> m'; n-\<longrightarrow>n'\<rbrakk> \<Longrightarrow>
               Apl(Fun(m),n)-\<longrightarrow> n'/m'"
apply (rule_tac n = "Apl (Fun (m'),n') " in Sred.trans)
apply (simp_all add: red_Apl red_Fun)
done

(* ------------------------------------------------------------------------- *)
(*      Lemmas for parallel reduction                                        *)
(* ------------------------------------------------------------------------- *)

lemma refl_par_red1: "m \<in> lambda\<Longrightarrow> m =1\<Rightarrow> m"
by (erule lambda.induct, simp_all)

lemma red1_par_red1: "m-1->n \<Longrightarrow> m=1\<Rightarrow>n"
by (erule Sred1.induct, simp_all add: refl_par_red1)

lemma red_par_red: "m-\<longrightarrow>n \<Longrightarrow> m=\<Longrightarrow>n"
apply (erule Sred.induct)
apply (rule_tac [3] Spar_red.trans)
apply (simp_all add: refl_par_red1 red1_par_red1)
done

lemma par_red_red: "m=\<Longrightarrow>n \<Longrightarrow> m-\<longrightarrow>n"
apply (erule Spar_red.induct)
apply (erule Spar_red1.induct)
apply (rule_tac [5] Sred.trans)
apply (simp_all add: red_Fun red_beta red_Apl)
done

(* ------------------------------------------------------------------------- *)
(*      Simulation                                                           *)
(* ------------------------------------------------------------------------- *)

lemma simulation: "m=1\<Rightarrow>n \<Longrightarrow> \<exists>v. m|>v = n \<and> m \<sim> v \<and> regular(v)"
by (erule Spar_red1.induct, force+)

(* ------------------------------------------------------------------------- *)
(*           commuting of unmark and subst                                   *)
(* ------------------------------------------------------------------------- *)

lemma unmmark_lift_rec:
     "u \<in> redexes \<Longrightarrow> \<forall>k \<in> nat. unmark(lift_rec(u,k)) = lift_rec(unmark(u),k)"
by (erule redexes.induct, simp_all add: lift_rec_Var)

lemma unmmark_subst_rec:
 "v \<in> redexes \<Longrightarrow> \<forall>k \<in> nat. \<forall>u \<in> redexes.
                  unmark(subst_rec(u,v,k)) = subst_rec(unmark(u),unmark(v),k)"
by (erule redexes.induct, simp_all add: unmmark_lift_rec subst_Var)

(* ------------------------------------------------------------------------- *)
(*        Completeness                                                       *)
(* ------------------------------------------------------------------------- *)

lemma completeness_l [rule_format]:
     "u \<sim> v \<Longrightarrow> regular(v) \<longrightarrow> unmark(u) =1\<Rightarrow> unmark(u|>v)"
apply (erule Scomp.induct)
apply (auto simp add: unmmark_subst_rec)
done

lemma completeness: "\<lbrakk>u \<in> lambda; u \<sim> v; regular(v)\<rbrakk> \<Longrightarrow> u =1\<Rightarrow> unmark(u|>v)"
by (drule completeness_l, simp_all add: lambda_unmark)

end


theory Atomics
  imports Syntax State
begin

chapter \<open>Atomic Actions\<close>

text \<open>
Describe concepts the logic must know about atomic instructions.
\<close>

section \<open>Atomic Properties\<close>

text \<open>Weakest precondition of a basic instruction, based on the locale's
      verification conditions and behaviours.\<close>
abbreviation wp\<^sub>\<alpha> :: "('a,'b) basic \<Rightarrow> 'b pred \<Rightarrow> 'b pred"
  where "wp\<^sub>\<alpha> \<alpha> Q \<equiv> wp (vc \<alpha>) (beh \<alpha>) Q"

text \<open>Specification check, ensuring an instruction conforms to a relation\<close>
abbreviation guar\<^sub>\<alpha> :: "('a,'b) basic \<Rightarrow> 'b rpred \<Rightarrow> bool"
  where "guar\<^sub>\<alpha> \<alpha> G \<equiv> guar (vc \<alpha>) (beh \<alpha>) G"

section \<open>Atomic Rule\<close>

text \<open>Rule for an atomic operation\<close>
definition atomic_rule :: "'b rpred \<Rightarrow> 'b rpred \<Rightarrow> 'b pred \<Rightarrow> ('a,'b) basic \<Rightarrow> 'b pred \<Rightarrow> bool"
  ("_,_ \<turnstile>\<^sub>A _ {_} _" [65,0,0,0,65] 65)
  where "R,G \<turnstile>\<^sub>A P {\<alpha>} Q \<equiv> P \<subseteq> wp\<^sub>\<alpha> \<alpha> Q \<and> guar\<^sub>\<alpha> \<alpha> G \<and> stable R P \<and> stable R Q"

lemma atomicI [intro]:
  assumes "P \<subseteq> wp\<^sub>\<alpha> \<alpha> Q" "guar\<^sub>\<alpha> \<alpha> G" "stable R P" "stable R Q"
  shows "R,G \<turnstile>\<^sub>A P {\<alpha>} Q"
using assms
by (auto simp add: atomic_rule_def)

(*
lemma thr_atomic:
  assumes "R,G \<turnstile>\<^sub>A P {\<alpha>} Q"
  shows "thr\<^sub>R op R,thr\<^sub>G op G \<turnstile>\<^sub>A thr\<^sub>P op l P {thr\<^sub>\<alpha> op l l' \<alpha>} thr\<^sub>P op l' Q"
using assms
unfolding atomic_rule_def thr\<^sub>\<alpha>_def
(* by (simp add: thr_stable thr_wp thr_guar) *)
oops
 *)

subsection \<open>Derived Properties\<close>

text \<open>the postcondition may be weakened (i.e. made larger, accepting more states).\<close>
lemma wp\<^sub>\<alpha>_mono: "Q \<subseteq> Q' \<Longrightarrow> wp\<^sub>\<alpha> \<alpha> Q \<subseteq> wp\<^sub>\<alpha> \<alpha> Q'"
unfolding wp_def by auto

text \<open>Re-establish an atomic judgement over a stronger stable precondition\<close>
lemma atomic_pre:
  assumes "R,G \<turnstile>\<^sub>A P {\<alpha>} Q" "P' \<subseteq> P" "stable R P'"
  shows "R,G \<turnstile>\<^sub>A P' {\<alpha>} Q"
  using assms unfolding atomic_rule_def by fast

text \<open>Strengthen the rely and weaken the guarantee for an atomic judgement\<close>
lemma atomic_conseqI [intro]:
  assumes "R,G \<turnstile>\<^sub>A P {\<alpha>} Q" "R' \<subseteq> R" "G \<subseteq> G'"
  shows "R',G' \<turnstile>\<^sub>A P {\<alpha>} Q"
  using assms unfolding atomic_rule_def guar_def by blast

text \<open>Atomic judgements over the same instruction can be combined\<close>
lemma actomic_conjI [intro]:
  assumes "R,G \<turnstile>\<^sub>A P\<^sub>1 {\<alpha>} Q\<^sub>1" "R,G  \<turnstile>\<^sub>A P\<^sub>2 {\<alpha>} Q\<^sub>2"
  shows "R,G \<turnstile>\<^sub>A P\<^sub>1 \<inter> P\<^sub>2 {\<alpha>} Q\<^sub>1 \<inter> Q\<^sub>2"
  using assms unfolding atomic_rule_def wp_def stable_def by blast

text \<open>Add an invariant across an atomic judgement\<close>
lemma atomic_invI [intro]:
  assumes "R,G \<turnstile>\<^sub>A P {\<alpha>} Q"
  assumes "stable R\<^sub>2 I" "G \<subseteq> R\<^sub>2"
  shows "R \<inter> R\<^sub>2,G \<turnstile>\<^sub>A P \<inter> I {\<alpha>} Q \<inter> I"
  unfolding atomic_rule_def
proof (safe, goal_cases)
  case (1 m)
  hence "{(m,m'). m \<in> P \<inter> vc \<alpha> \<and> (m,m') \<in> beh \<alpha>} \<subseteq> R\<^sub>2\<^sup>=" "m \<in> vc \<alpha>"
    using assms(1,3) by (auto simp: wp_def guar_def atomic_rule_def)
  hence "m \<in> wp\<^sub>\<alpha> \<alpha> I" using assms(2) 1 by (auto simp: wp_def stable_def)
  moreover have "m \<in> wp\<^sub>\<alpha> \<alpha> Q" using 1 assms(1) by (auto simp: atomic_rule_def wp_def)
  ultimately show ?case by (auto simp: wp_def)
qed (insert assms, auto simp: atomic_rule_def wp_def)

text \<open>Atomic rule for a false precondition\<close>
lemma atomic_falseI [intro]:
  assumes "guar\<^sub>\<alpha> \<beta> G"
  shows "R,G \<turnstile>\<^sub>A {} {\<beta>} {}"
  using assms unfolding atomic_rule_def by auto

definition stabilise :: "'b rel \<Rightarrow> 'b set \<Rightarrow> 'b set" where
"stabilise R P \<equiv> P \<union> R\<^sup>+ `` P"

lemma stabilise_rtrancl: "stabilise R P = (R\<^sup>*) `` P"
unfolding stabilise_def
by (simp add: Un_Image Un_commute rtrancl_trancl_reflcl)

lemma stable_stabilise: "stable R (stabilise R P)"
unfolding stable_rel stabilise_def
by auto (metis ImageI Transitive_Closure.trancl_into_trancl)

lemma stabilise_supset: "P \<subseteq> stabilise R P"
unfolding stabilise_def
by auto

lemma stabilise_stable: "stable R P \<Longrightarrow> stabilise R P = P"
unfolding stable_rel stabilise_def
by (erule Image_closed_trancl')

lemma stabilise_inter_P: "stabilise R (P1 \<inter> P2) \<subseteq> stabilise R P1 \<inter> stabilise R P2"
unfolding stabilise_def
by auto

lemma stabilise_inter_R1: "stabilise (R1 \<inter> R2) P \<subseteq> stabilise R1 P"
unfolding stabilise_def
by safe (metis Int_lower1 rev_ImageI trancl_mono)

lemma stabilise_inter_R2: "stabilise (R1 \<inter> R2) P \<subseteq> stabilise R2 P"
by (metis stabilise_inter_R1 Int_commute)

lemma stabilise_inter_RP: "stabilise (R1 \<inter> R2) (P1 \<inter> P2) \<subseteq> stabilise R1 P1 \<inter> stabilise R2 P2"
unfolding stabilise_def
by (safe; meson Image_iff inf_sup_ord(1,2) trancl_mono)

lemma stabilise_mono: "P \<subseteq> P' \<Longrightarrow> stabilise R P \<subseteq> stabilise R P'"
unfolding stabilise_def
by auto

lemma stabilise_mono_R: "R \<subseteq> R' \<Longrightarrow> stabilise R P \<subseteq> stabilise R' P"
by (metis inf.orderE stabilise_inter_R2)

lemma stabilise_mono_RP: "R \<subseteq> R' \<Longrightarrow> P \<subseteq> P' \<Longrightarrow> stabilise R P \<subseteq> stabilise R' P'"
by (metis stabilise_mono stabilise_mono_R subset_trans)

lemma stabilise_pushrel: "stabilise (pushrelSame R) (pushpred s P) = pushpred s (stabilise R P)"
unfolding stabilise_def
by (simp add: pushpred_relimage pushpred_union pushrelSame_trancl)

lemma stabilise_atomic: "R,G \<turnstile>\<^sub>A P {c} Q \<Longrightarrow> R,G \<turnstile>\<^sub>A stabilise R P {c} Q"
unfolding atomic_rule_def
by (simp add: stabilise_stable)

lemma stabilise_atomic_post: "R,G \<turnstile>\<^sub>A P {c} Q \<Longrightarrow> R,G \<turnstile>\<^sub>A P {c} stabilise R Q"
unfolding atomic_rule_def
by (simp add: stabilise_stable)

lemma stabilise_min: "P \<subseteq> P' \<Longrightarrow> stable R P' \<Longrightarrow> stabilise R P \<subseteq> P'"
unfolding stabilise_rtrancl
by auto (metis stable_transitive subset_iff)

text \<open>Manually computing the strongest postcondition which might hold.\<close>
definition sp :: "('a,'b) basic \<Rightarrow> 'b pred \<Rightarrow> 'b pred" where
  "sp \<alpha> P \<equiv> beh \<alpha> `` (P)"

lemma wp_sp: "P \<subseteq> vc \<alpha> \<Longrightarrow> P \<subseteq> wp\<^sub>\<alpha> \<alpha> (sp \<alpha> P)"
unfolding sp_def wp_def
by auto

lemma sp_wp: "sp \<alpha> (wp\<^sub>\<alpha> \<alpha> Q) \<subseteq> Q"
unfolding sp_def wp_def
by auto

lemma sp_mono: "P \<subseteq> P' \<Longrightarrow> sp \<alpha> P \<subseteq> sp \<alpha> P'"
unfolding sp_def by auto

lemma sp_pushbasic: "sp (pushbasic s s' \<alpha>) (pushpred s P) = pushpred s' (sp \<alpha> P)"
unfolding pushpred_def pushrel_def sp_def
by auto (metis ImageI pop_push)

text \<open>Definitions and lemmas for capturing guarantee and stability properties.\<close>

lemma stable_uncap: "stable (uncapRely R) (uncapPred s P) \<Longrightarrow> stable R P"
unfolding stable_def pushrelSame_def pushpred_def
by (auto, metis pop_push)

(*
lemma stable_mix: "stable (pushrelSame R) M \<Longrightarrow> stable R (poppred M)"
unfolding stable_def pushrelSame_def poppred_def
by auto (metis pop_push push_pop) *)

lemma stable_pushrelSame: "stable R P \<Longrightarrow> stable (pushrelSame R) (pushpred s P)"
unfolding stable_rel
using pushpred_relimage pushpred_mono
by metis

lemma stable_pushrelAll: "stable R P \<Longrightarrow> stable (pushrelAll R) (pushpredAll P)"
unfolding stable_rel
using pushpredAll_relimage pushpredAll_mono
by blast

lemma guar\<^sub>\<alpha>_rel: "guar\<^sub>\<alpha> \<alpha> G = (Id_on (vc \<alpha>) O beh \<alpha> \<subseteq> G)"
unfolding guar_def by fast

lemma guar_uncapE:
  "guar\<^sub>\<alpha> (pushbasic s s' \<alpha>) (uncapGuar G) \<Longrightarrow> guar\<^sub>\<alpha> \<alpha> G"
unfolding guar\<^sub>\<alpha>_rel
proof -
  assume assms: "Id_on (vc (pushbasic s s' \<alpha>)) O beh (pushbasic s s' \<alpha>) \<subseteq> uncapGuar G"
  have "capGuar (Id_on (uncapPred s (vc \<alpha>)) O uncapBeh s s' (beh \<alpha>)) = Id_on (vc \<alpha>) O beh \<alpha>"
    by (simp add: poprel_relcomp_pushpred)
  thus "Id_on (vc \<alpha>) O beh \<alpha> \<subseteq> G"
    using poprel_mono[OF assms] by simp
qed

lemma guar_uncapI:
  "guar\<^sub>\<alpha> \<alpha> G \<Longrightarrow> guar\<^sub>\<alpha> (pushbasic s s' \<alpha>) (uncapGuar G)"
unfolding guar\<^sub>\<alpha>_rel
proof -
  assume "Id_on (vc \<alpha>) O beh \<alpha> \<subseteq> G"
  hence subset: "pushrel s s' (Id_on (vc \<alpha>) O beh \<alpha>) \<subseteq> pushrel s s' G"
    by simp
  have "pushrel s s' (Id_on (vc \<alpha>) O beh \<alpha>) = Id_on (pushpred s (vc \<alpha>)) O pushrel s s' (beh \<alpha>)"
    by (rule pushrel_relcomp_id)
  hence "Id_on (pushpred s (vc \<alpha>)) O pushrel s s' (beh \<alpha>) \<subseteq> pushrel s s' G"
    using subset by simp
  thus "Id_on (vc (pushbasic s s' \<alpha>)) O beh (pushbasic s s' \<alpha>) \<subseteq> uncapGuar G"
    using pushrel_in_pushrelAll[of s s'] by auto
qed

(*
lemma guar_mix:
  assumes "\<forall>s s'. guar\<^sub>\<alpha> (popbasic s s' \<alpha>) G"
  shows "guar\<^sub>\<alpha> \<alpha> (uncapGuar G)"
  unfolding guar\<^sub>\<alpha>_rel Id_on_def poprel'_def poppred'_def
proof (clarsimp)
  fix m\<^sub>1 m\<^sub>2
  assume a: "(m\<^sub>1, m\<^sub>2) \<in> beh \<alpha>" "m\<^sub>1 \<in> vc \<alpha>"
  obtain s\<^sub>1 s\<^sub>2 where s: "m\<^sub>1 = push (pop m\<^sub>1) s\<^sub>1" "m\<^sub>2 = push (pop m\<^sub>2) s\<^sub>2" using push_pop by metis+
  hence a': "(push (pop m\<^sub>1) s\<^sub>1, push (pop m\<^sub>2) s\<^sub>2) \<in> beh \<alpha>" "push (pop m\<^sub>1) s\<^sub>1 \<in> vc \<alpha>"
    using a by simp+
  hence "(pop m\<^sub>1, pop m\<^sub>2) \<in> G"
    using assms unfolding guar\<^sub>\<alpha>_rel poprel'_def poppred'_def guar_def by auto
  thus "(m\<^sub>1, m\<^sub>2) \<in> pushrelAll G" using s by (auto simp: pushrelAll_def)
qed*)

(*
lemma guar_capE:
  "guar\<^sub>\<alpha> (popbasic \<alpha>) (capGuar G) \<Longrightarrow> guar\<^sub>\<alpha> \<alpha> G"
unfolding guar\<^sub>\<alpha>_rel
proof -
  assume "Id_on (vc (popbasic \<alpha>)) O beh (popbasic \<alpha>) \<subseteq> capGuar G"
  hence "uncapGuar (Id_on (capPred (vc \<alpha>))) O beh \<alpha> \<subseteq> G"

  thus "Id_on (vc \<alpha>) O beh \<alpha> \<subseteq> G"
    using Id_in_pushrelAll_poppred by fast
oops

lemma guar_capI:
  "guar\<^sub>\<alpha> \<alpha> G \<Longrightarrow> guar\<^sub>\<alpha> (popbasic \<alpha>) (capGuar G)"
unfolding guar\<^sub>\<alpha>_rel
proof -
  assume "Id_on (vc \<alpha>) O beh \<alpha> \<subseteq> G"
  hence "poprel (Id_on (vc \<alpha>) O beh \<alpha>) \<subseteq> poprel G" by simp
  hence "poprel (Id_on (vc \<alpha>)) O poprel (beh \<alpha>) \<subseteq> poprel G"
    using poprel_relcomp poprel_mono
  moreover have "Id_on (capPred (vc \<alpha>)) = capGuar (Id_on (vc \<alpha>))"
    using poppred_eq_poprel by auto
  ultimately show "Id_on (vc (popbasic \<alpha>)) O beh (popbasic \<alpha>) \<subseteq> capGuar G"
    by auto
oops*)

(*
text \<open>If P satisfies the wp of a pushbasic, then it must have had 's' pushed onto it.\<close>
lemma wp_pushbasic_poppable:
  assumes "P \<subseteq> wp\<^sub>\<alpha> (pushbasic s s' \<alpha>) Q"
  shows "poppable s P"
proof -
  have "P \<subseteq> Domain (pushrel s s' (beh \<alpha>))" using assms unfolding wp_rel by simp
  hence "P \<subseteq> pushpred s (Domain (beh \<alpha>))" by (simp add: domain_pushrel)
  thus ?thesis by (rule pushpred_poppable)
qed

lemma atomic_poppable:
  assumes "R,G \<turnstile>\<^sub>A P {pushbasic s s' \<alpha>} Q"
  shows "poppable s P"
using assms unfolding atomic_rule_def
by (intro wp_pushbasic_poppable) auto
*)

text \<open>We can replace an atomic judgement with its strongest postcondition.\<close>
lemma atomic_spI:
  assumes "R,G \<turnstile>\<^sub>A P {\<alpha>} Q"
  shows "R,G \<turnstile>\<^sub>A P {\<alpha>} stabilise R (sp \<alpha> P)"
        "stabilise R (sp \<alpha> P) \<subseteq> Q"
unfolding atomic_rule_def
proof (intro conjI)
  have A:
    "P \<subseteq> wp\<^sub>\<alpha> \<alpha> Q"
    "guar\<^sub>\<alpha> \<alpha> G"
    "stable R P"
    "stable R Q"
    using assms unfolding atomic_rule_def by auto
  thus "stable R P" "guar\<^sub>\<alpha> \<alpha> G" by auto

  show "stable R (stabilise R (sp \<alpha> P))" by (rule stable_stabilise)

  have "P \<subseteq> vc \<alpha>" using A(1) unfolding wp_def by auto
  hence "P \<subseteq> wp\<^sub>\<alpha> \<alpha> (sp \<alpha> P)" by (intro wp_sp, simp)
  moreover have "sp \<alpha> P \<subseteq> stabilise R (sp \<alpha> P)" by (rule stabilise_supset)
  ultimately show "P \<subseteq> wp\<^sub>\<alpha> \<alpha> (stabilise R (sp \<alpha> P))" using wp\<^sub>\<alpha>_mono by fastforce

  have "sp \<alpha> P \<subseteq> Q" using A(1) sp_mono sp_wp by fast
  thus "stabilise R (sp \<alpha> P) \<subseteq> Q" using A(4) stabilise_min[of _ Q] by simp
qed

lemma poppable_stabilise_sp:
  assumes "poppable s P"
  shows "poppable s' (stabilise (pushrelSame R) (sp (pushbasic s s' \<alpha>) P))"
proof -
  define Q' where "Q' = stabilise (pushrelSame R) (sp (pushbasic s s' \<alpha>) P)"

  have "sp (pushbasic s s' \<alpha>) P = sp (pushbasic s s' \<alpha>) (pushpred s (poppred P))"
    using assms by simp
  also have "... = pushpred s' (sp \<alpha> (poppred P))"
    using sp_pushbasic by fastforce

  finally have "Q' = pushpred s' (stabilise R (sp \<alpha> (poppred P)))"
    using stabilise_pushrel unfolding Q'_def by fastforce
  thus "poppable s' Q'" by simp
qed

(*
lemma atomic_pushbasic_postE:
  assumes "pushrelSame R,G \<turnstile>\<^sub>A P {pushbasic s s' \<alpha>} Q"
  obtains Q' where "Q' \<subseteq> Q" "poppable s' Q'" "pushrelSame R,G \<turnstile>\<^sub>A P {pushbasic s s' \<alpha>} Q'"
using assms atomic_spI poppable_stabilise_sp[OF atomic_poppable]
by metis

lemma poppred_wp_subset: "poppred (wp\<^sub>\<alpha> (pushbasic s s' \<alpha>) (pushpred s' Q)) \<subseteq> wp\<^sub>\<alpha> \<alpha> Q"
unfolding wp_def poppred_def pushpred_def pushrel_def
by auto (metis popl_push)+

lemma atomic_pushbasic:
  assumes "pushrelSame R,pushrelAll G \<turnstile>\<^sub>A pushpred s P {pushbasic s s' \<alpha>} pushpred s' Q"
  shows "R,G \<turnstile>\<^sub>A P {\<alpha>} Q"
unfolding atomic_rule_def
proof (intro conjI)
  have a:
    "pushpred s P \<subseteq> wp\<^sub>\<alpha> (pushbasic s s' \<alpha>) (pushpred s' Q)"
    "guar\<^sub>\<alpha> (pushbasic s s' \<alpha>) (pushrelAll G)"
    "stable (pushrelSame R) (pushpred s P)"
    "stable (pushrelSame R) (pushpred s' Q)"
    using assms unfolding atomic_rule_def by auto

  show "P \<subseteq> wp\<^sub>\<alpha> \<alpha> Q" using poppred_mono[OF a(1)] poppred_wp_subset by fastforce
  show "guar\<^sub>\<alpha> \<alpha> G" using guar_uncapE[OF a(2)] by simp
  show "stable R P" "stable R Q" using a(3,4) stable_uncap by auto
qed*)

lemma help1:
  assumes "stable (pushrelSame R) M"
  shows "stable R (poppred' n M)"
  unfolding stable_def poppred'_def
proof (clarsimp)
  fix m m' assume a: "push m n \<in> M" "(m,m') \<in> R"
  hence "(push m n, push m' n) \<in> pushrelSame R" by (auto simp: pushrelSame_def)
  thus "push m' n \<in> M" using a assms by (auto simp: stable_def)
qed

lemma help3:
  assumes "guar\<^sub>\<alpha> \<alpha> (pushrelAll G)"
  shows "guar (poppred' s (vc \<alpha>)) (poprel' s s' (beh \<alpha>)) G"
  unfolding guar_def
proof (clarify)
  fix m m' assume a: "m \<in> poppred' s (vc \<alpha>)" "(m,m') \<in> poprel' s s' (beh \<alpha>)"
  hence "push m s \<in> vc \<alpha>" by (auto simp: poppred'_def)
  moreover have "(push m s, push m' s') \<in> beh \<alpha>" using a by (auto simp: poprel'_def)
  ultimately have "(push m s, push m' s') \<in> pushrelAll G" using assms by (auto simp: guar_def)
  thus "(m,m') \<in> G" unfolding pushrelAll_def using push_inj apply (auto ) by blast
qed

lemma help4:
  assumes "pushpred s P \<subseteq> wp\<^sub>\<alpha> \<alpha> M"
  shows "P \<subseteq> wp\<^sub>\<alpha> (popbasic s s' \<alpha>) (poppred' s' M)"
  unfolding wp_def
proof (clarify)
  fix x assume "x \<in> P"
  hence "push x s \<in> pushpred s P" by (auto simp: pushpred_def)
  hence "push x s \<in> wp\<^sub>\<alpha> \<alpha> M" using assms by auto
  hence "push x s \<in> vc \<alpha> \<inter> {m. (\<forall>m'. (m, m') \<in> beh \<alpha> \<longrightarrow> m' \<in> M)}" unfolding wp_def by auto
  thus "x \<in> vc (popbasic s s' \<alpha>) \<inter>
              {m. (\<forall>m'. (m, m') \<in> beh (popbasic s s' \<alpha>) \<longrightarrow> m' \<in> (poppred' s' M))}"
    by (auto simp: poppred'_def poprel'_def)
qed

text \<open>
Critical for soundness: atomic judgement with a hidden top-most state fixed to an initial s
can be lifted to a judgement over its observable behaviour fixed to a final internal state s'\<close>
lemma helpa:
  assumes "pushrelSame R,pushrelAll G \<turnstile>\<^sub>A pushpred s P {\<alpha>} M"
  shows "R,G \<turnstile>\<^sub>A P {popbasic s s' \<alpha>} (poppred' s' M)"
proof (unfold atomic_rule_def, intro conjI, goal_cases)
  case 1
  then show ?case using assms help4 unfolding atomic_rule_def by blast
next
  case 2
  then show ?case using assms help3 by (auto simp: atomic_rule_def)
next
  case 3
  then show ?case using assms stable_uncap by (auto simp: atomic_rule_def)
next
  case 4
  then show ?case using assms help1 by (auto simp: atomic_rule_def)
qed

end


theory Proof_3_5
  imports HandDryer VCTheoryLemmas Extra
begin

theorem proof_3_5:
"VC5 inv3 s0 hands_value"
  apply(simp only: VC5_def inv3_def  R3_def
  dryer_def)
  apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply(simp)
proof -
  define s:: state where
"s =(toEnv
                (reset (setVarAny s0 hands_value)
                  Ctrl))"
  assume VC: "  ((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          10 \<le> toEnvNum s2 s0 \<and>
          getVarBool s1 hands = ON \<and>
          getVarBool s1 (Suc (Suc 0)) = ON \<and>
          getVarBool s2 hands = OFF \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> 10 \<and>
                (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
                 getVarBool s4 hands = ON) \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 (Suc (Suc 0)) =
                      ON \<and>
                      getVarBool s3 hands =
                      OFF)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    drying \<and>
    getVarBool (setVarAny s0 hands_value) hands =
    ON \<and>
    \<not> 10 \<le> ltimeEnv
             (reset (setVarAny s0 hands_value) Ctrl)
             Ctrl"
  show " \<forall>s1 s2.
       substate s1 s2 \<and>
       substate s2
        (toEnv
          (reset (setVarAny s0 hands_value) Ctrl)) \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvNum s1 s2 = hands \<and>
       10 \<le> toEnvNum s2
              (toEnv
                (reset (setVarAny s0 hands_value)
                  Ctrl)) \<and>
       getVarBool s1 hands = ON \<and>
       getVarBool s1 (Suc (Suc 0)) = ON \<and>
       getVarBool s2 hands = OFF \<longrightarrow>
       (\<exists>s4. toEnvP s4 \<and>
             substate s2 s4 \<and>
             substate s4
              (toEnv
                (reset (setVarAny s0 hands_value)
                  Ctrl)) \<and>
             toEnvNum s2 s4 \<le> 10 \<and>
             (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
              getVarBool s4 hands = ON) \<and>
             (\<forall>s3. toEnvP s3 \<and>
                   substate s2 s3 \<and>
                   substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                   getVarBool s3 (Suc (Suc 0)) =
                   ON \<and>
                   getVarBool s3 hands = OFF))"
    apply(simp only: s_def[symmetric])
  proof(rule allI; rule allI; rule impI)
    fix s1 s2
    assume req_prems: "substate s1 s2 \<and>
       substate s2 s \<and>
       toEnvP s1 \<and>
       toEnvP s2 \<and>
       toEnvNum s1 s2 = hands \<and>
       10 \<le> toEnvNum s2 s \<and>
       getVarBool s1 hands = ON \<and>
       getVarBool s1 (Suc (Suc 0)) = ON \<and>
       getVarBool s2 hands = OFF"
    then obtain "10 \<le> toEnvNum s2 s" by auto
    from le_imp_less_or_eq[OF this]
    show " \<exists>s4. toEnvP s4 \<and>
            substate s2 s4 \<and>
            substate s4 s \<and>
            toEnvNum s2 s4 \<le> 10 \<and>
            (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
             getVarBool s4 hands = ON) \<and>
            (\<forall>s3. toEnvP s3 \<and>
                  substate s2 s3 \<and>
                  substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                  getVarBool s3 (Suc (Suc 0)) = ON \<and>
                  getVarBool s3 hands = OFF)"
    proof
      assume 1: "10 < toEnvNum s2 s"
      with req_prems substate_eq_or_predEnv
 toEnvNum_id s_def  have 2: "substate s2 s0"
        by (simp add: s_def split: if_splits)
      from VC obtain "\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          10 \<le> toEnvNum s2 s0 \<and>
          getVarBool s1 hands = ON \<and>
          getVarBool s1 (Suc (Suc 0)) = ON \<and>
          getVarBool s2 hands = OFF \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> 10 \<and>
                (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
                 getVarBool s4 hands = ON) \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 (Suc (Suc 0)) =
                      ON \<and>
                      getVarBool s3 hands =
                      OFF))"
        by auto
      with req_prems 1 2 have "\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> 10 \<and>
                (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
                 getVarBool s4 hands = ON) \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 (Suc (Suc 0)) =
                      ON \<and>
                      getVarBool s3 hands =
                      OFF)"
        by (auto simp add: s_def split: if_splits)
      then obtain s4 where 3: " toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> 10 \<and>
                (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
                 getVarBool s4 hands = ON) \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 (Suc (Suc 0)) =
                      ON \<and>
                      getVarBool s3 hands =
                      OFF)" ..
      have  "(toEnvP s4 \<and>
      substate s2 s4 \<and>
      substate s4 s \<and>
      toEnvNum s2 s4 \<le> 10 \<and>
      (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
       getVarBool s4 hands = ON)) \<and>
      (\<forall>s3. toEnvP s3 \<and>
            substate s2 s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
            getVarBool s3 (Suc (Suc 0)) = ON \<and>
            getVarBool s3 hands = OFF)"
      proof
        from 3 show "toEnvP s4 \<and>
      substate s2 s4 \<and>
      substate s4 s \<and>
      toEnvNum s2 s4 \<le> 10 \<and>
      (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
       getVarBool s4 hands = ON)"
          by (simp add: s_def)
      next
        from 3 show "\<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
         getVarBool s3 (Suc (Suc 0)) = ON \<and>
         getVarBool s3 hands = OFF"
          by simp
      qed
      thus ?thesis by auto
    next
      assume 4: "10 = toEnvNum s2 s"
      from substate_asym have 5:
"\<forall>s3. toEnvP s3 \<and>
               substate s2 s3 \<and>
               substate s3 s2 \<and> s3 \<noteq> s2 \<longrightarrow>
               getVarBool s3 (Suc (Suc 0)) = ON \<and>
               getVarBool s3 hands = OFF"
        by auto
      show ?thesis
      proof -
        define s5:: state where "s5=s2"
        have "toEnvP s5 \<and> substate s2 s5 \<and>
substate s5 s \<longrightarrow>pred3 s2 s s5"
        proof(induction rule: state_down_ind)
          case 1
          then show ?case
            using req_prems s_def by auto
        next
          case 2
          then show ?case
            apply(simp only: pred3_def)
          proof
            assume 6: " \<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3 s \<and> s3 \<noteq> s \<longrightarrow>
         getVarBool s3 (Suc (Suc 0)) = ON \<and>
         getVarBool s3 hands = OFF"
            have " (toEnvP s \<and>
         substate s s \<and>
         substate s s \<and>
         toEnvNum s2 s \<le> 10) \<and>
         (getVarBool s (Suc (Suc 0)) = OFF \<or>
          getVarBool s hands = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate s s3 \<and>
               substate s3 s \<and> s3 \<noteq> s \<longrightarrow>
               getVarBool s3 (Suc (Suc 0)) = ON \<and>
               getVarBool s3 hands = OFF)"
            proof
              from 4 substate_refl s_def  req_prems
              show "(toEnvP s \<and>
         substate s s \<and>
         substate s s \<and>
         toEnvNum s2 s \<le> 10 )"
                by auto
            next
              from VC have " (getVarBool s (Suc (Suc 0)) = OFF \<or>
     getVarBool s hands = ON)"
                by (simp add: s_def)
              moreover from substate_asym have
             "\<forall>s3. toEnvP s3 \<and>
          substate s s3 \<and>
          substate s3 s \<and> s3 \<noteq> s \<longrightarrow>
          getVarBool s3 (Suc (Suc 0)) = ON \<and>
          getVarBool s3 hands = OFF" by auto
              ultimately show
"(getVarBool s (Suc (Suc 0)) = OFF \<or>
     getVarBool s hands = ON) \<and>
    (\<forall>s3. toEnvP s3 \<and>
          substate s s3 \<and>
          substate s3 s \<and> s3 \<noteq> s \<longrightarrow>
          getVarBool s3 (Suc (Suc 0)) = ON \<and>
          getVarBool s3 hands = OFF)" ..
            qed
            thus "\<exists>s4. toEnvP s4 \<and>
         substate s s4 \<and>
         substate s4 s \<and>
         toEnvNum s2 s4 \<le> 10 \<and>
         (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
          getVarBool s4 hands = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate s s3 \<and>
               substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
               getVarBool s3 (Suc (Suc 0)) = ON \<and>
               getVarBool s3 hands = OFF)"
              by auto
          qed
        next
          case (3 s5)
          then show ?case
            apply(simp only: pred3_def)
          proof
            from 3(3) have  6: " (\<forall>s3. toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s5 \<and> s3 \<noteq> s5 \<longrightarrow>
          getVarBool s3 (Suc (Suc 0)) = ON \<and>
          getVarBool s3 hands = OFF) \<Longrightarrow>
    (\<exists>s4. toEnvP s4 \<and>
          substate s5 s4 \<and>
          substate s4 s \<and>
          toEnvNum s2 s4 \<le> 10 \<and>
          (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
           getVarBool s4 hands = ON) \<and>
          (\<forall>s3. toEnvP s3 \<and>
                substate s5 s3 \<and>
                substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                getVarBool s3 (Suc (Suc 0)) = ON \<and>
                getVarBool s3 hands = OFF)) "
              by (auto simp add: pred3_def)
            assume 7: " \<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3 (predEnv s5) \<and>
         s3 \<noteq> predEnv s5 \<longrightarrow>
         getVarBool s3 (Suc (Suc 0)) = ON \<and>
         getVarBool s3 hands = OFF"
            show "\<exists>s4. toEnvP s4 \<and>
         substate (predEnv s5) s4 \<and>
         substate s4 s \<and>
         toEnvNum s2 s4 \<le> 10 \<and>
         (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
          getVarBool s4 hands = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate (predEnv s5) s3 \<and>
               substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
               getVarBool s3 (Suc (Suc 0)) = ON \<and>
               getVarBool s3 hands = OFF)"
            proof cases
              assume 10: "(getVarBool (predEnv s5) (Suc (Suc 0)) = OFF \<or>
          getVarBool (predEnv s5) hands = ON)"
              from predEnv_substate 3
substate_trans have 8:  "substate (predEnv s5) s"
                by blast
              from 3(2) substate_eq_or_predEnv req_prems
              have 9: "substate s2 (predEnv s5)"
                by auto
              have "toEnvP (predEnv s5) \<and>
         substate (predEnv s5) (predEnv s5) \<and>
         substate (predEnv s5) s \<and>
         toEnvNum s2 (predEnv s5) \<le> 10 \<and>
         (getVarBool (predEnv s5) (Suc (Suc 0)) = OFF \<or>
          getVarBool (predEnv s5) hands = ON) \<and>
         (\<forall>s3. toEnvP s3 \<and>
               substate (predEnv s5) s3 \<and>
               substate s3 (predEnv s5) \<and>
 s3 \<noteq> (predEnv s5) \<longrightarrow>
               getVarBool s3 (Suc (Suc 0)) = ON \<and>
               getVarBool s3 hands = OFF)"
              proof -
                from predEnvP_or_emptyState[of s5]
                have "toEnvP (predEnv s5)"
                proof
                  assume "toEnvP (predEnv s5)"
                  thus ?thesis by assumption
                next
                  assume   "predEnv s5 = emptyState"
                  with 9 req_prems show ?thesis
                    by (cases s2; auto)
                qed
                moreover from substate_refl have
" substate (predEnv s5) (predEnv s5)" by auto
                moreover from 8
                have "substate (predEnv s5) s"
                  by assumption
                moreover from 4 8 9 toEnvNum3
                have "toEnvNum s2 (predEnv s5) \<le> 10"
                  by auto
                moreover from 10
                have "(getVarBool (predEnv s5) (Suc (Suc 0)) = OFF \<or>
     getVarBool (predEnv s5) hands = ON)"
                  by assumption
                moreover from substate_asym
                have "\<forall>s3. toEnvP s3 \<and>
          substate (predEnv s5) s3 \<and>
          substate s3 (predEnv s5) \<and>
          s3 \<noteq> predEnv s5 \<longrightarrow>
          getVarBool s3 (Suc (Suc 0)) = ON \<and>
          getVarBool s3 hands = OFF" by auto
                ultimately show ?thesis by auto
              qed
              thus ?thesis by auto
            next
              assume 10: "\<not> (getVarBool (predEnv s5) (Suc (Suc 0)) = OFF \<or>
        getVarBool (predEnv s5) hands = ON)"
              with substate_eq_or_predEnv 7
              have " \<forall>s3. toEnvP s3 \<and>
         substate s2 s3 \<and>
         substate s3  s5 \<and>
         s3 \<noteq> s5 \<longrightarrow>
         getVarBool s3 (Suc (Suc 0)) = ON \<and>
         getVarBool s3 hands = OFF"
                by auto
              from 6[OF this] obtain s4 where 11:
"toEnvP s4 \<and>
       substate s5 s4 \<and>
       substate s4 s \<and>
       toEnvNum s2 s4 \<le> 10 \<and>
       (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
        getVarBool s4 hands = ON) \<and>
       (\<forall>s3. toEnvP s3 \<and>
             substate s5 s3 \<and>
             substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
             getVarBool s3 (Suc (Suc 0)) = ON \<and>
             getVarBool s3 hands = OFF)" ..
              have "(toEnvP s4 \<and>
      substate (predEnv s5) s4 \<and>
      substate s4 s \<and>
      toEnvNum s2 s4 \<le> 10 \<and>
      (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
       getVarBool s4 hands = ON)) \<and>
      (\<forall>s3. toEnvP s3 \<and>
            substate (predEnv s5) s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
            getVarBool s3 (Suc (Suc 0)) = ON \<and>
            getVarBool s3 hands = OFF)"
              proof
                from 11 predEnv_substate substate_trans
                show "toEnvP s4 \<and>
      substate (predEnv s5) s4 \<and>
      substate s4 s \<and>
      toEnvNum s2 s4 \<le> 10 \<and>
      (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
       getVarBool s4 hands = ON)" by blast
              next
                show "\<forall>s3. toEnvP s3 \<and>
            substate (predEnv s5) s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
            getVarBool s3 (Suc (Suc 0)) = ON \<and>
            getVarBool s3 hands = OFF"
                proof(rule allI; rule impI)
                  fix s3
                  assume 12: "toEnvP s3 \<and>
            substate (predEnv s5) s3 \<and>
            substate s3 s4 \<and> s3 \<noteq> s4"
                  with  11 3(1) predEnv_substate_imp_eq_or_substate
                  have "s3 = predEnv s5 \<or> substate s5 s3"
                    by auto
                  with 10 11 12 show "getVarBool s3 (Suc (Suc 0)) = ON \<and>
            getVarBool s3 hands = OFF"
                    by auto

                qed
              qed
              thus ?thesis by auto
            qed
          qed
        qed
        with s5_def req_prems substate_refl
 pred3_def 5 show ?thesis by auto
      qed
    qed
  qed
next
  assume " ((toEnvP s0 \<and>
      (\<forall>s1 s2.
          substate s1 s2 \<and>
          substate s2 s0 \<and>
          toEnvP s1 \<and>
          toEnvP s2 \<and>
          toEnvNum s1 s2 = hands \<and>
          10 \<le> toEnvNum s2 s0 \<and>
          getVarBool s1 hands = ON \<and>
          getVarBool s1 (Suc (Suc 0)) = ON \<and>
          getVarBool s2 hands = OFF \<longrightarrow>
          (\<exists>s4. toEnvP s4 \<and>
                substate s2 s4 \<and>
                substate s4 s0 \<and>
                toEnvNum s2 s4 \<le> 10 \<and>
                (getVarBool s4 (Suc (Suc 0)) = OFF \<or>
                 getVarBool s4 hands = ON) \<and>
                (\<forall>s3. toEnvP s3 \<and>
                      substate s2 s3 \<and>
                      substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
                      getVarBool s3 (Suc (Suc 0)) =
                      ON \<and>
                      getVarBool s3 hands =
                      OFF)))) \<and>
     extraInv s0) \<and>
    env (setVarAny s0 hands_value) hands_value \<and>
    getPstate (setVarAny s0 hands_value) Ctrl =
    drying \<and>
    getVarBool (setVarAny s0 hands_value) hands =
    ON \<and>
    \<not> 10 \<le> ltimeEnv
             (reset (setVarAny s0 hands_value) Ctrl)
             Ctrl"
  with extra5 show "extraInv
     (toEnv (reset (setVarAny s0 hands_value) Ctrl))"
    by (auto simp add: VC5_def)
qed

end


theory "InstructionRelocate"

imports
   "InstructionAux"

begin

declare instruction_failure_result_def [simp]
declare vctx_advance_pc_def [simp]

theorem lemma_stack_2_1_op [simp] :
"stack_2_1_op v c f = InstructionContinue nv \<Longrightarrow>
 vctx_next_instruction v c =
    vctx_next_instruction (v\<lparr>vctx_pc:=vctx_pc v+x\<rparr>) c2 \<Longrightarrow>
 stack_2_1_op (v\<lparr>vctx_pc:=vctx_pc v+x\<rparr>) c2 f =
    InstructionContinue (nv\<lparr>vctx_pc:=vctx_pc nv+x\<rparr>)"
apply(auto simp:stack_2_1_op_def)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto split:option.split)
done

theorem lemma_stack_3_1_op [simp] :
"stack_3_1_op v c f = InstructionContinue nv \<Longrightarrow>
 vctx_next_instruction v c =
    vctx_next_instruction (v\<lparr>vctx_pc:=vctx_pc v+x\<rparr>) c2 \<Longrightarrow>
 stack_3_1_op (v\<lparr>vctx_pc:=vctx_pc v+x\<rparr>) c2 f =
    InstructionContinue (nv\<lparr>vctx_pc:=vctx_pc nv+x\<rparr>)"
apply(auto simp:stack_3_1_op_def)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto split:option.split)
done

theorem lemma_stack_1_1_op [simp] :
"stack_1_1_op v c f = InstructionContinue nv \<Longrightarrow>
 vctx_next_instruction v c =
    vctx_next_instruction (v\<lparr>vctx_pc:=vctx_pc v+x\<rparr>) c2 \<Longrightarrow>
 stack_1_1_op (v\<lparr>vctx_pc:=vctx_pc v+x\<rparr>) c2 f =
    InstructionContinue (nv\<lparr>vctx_pc:=vctx_pc nv+x\<rparr>)"
apply(auto simp:stack_1_1_op_def)
apply(cases "vctx_stack v")
apply(auto split:option.split)
done

theorem "lemma_next_ind" [simp]:
"vctx_next_instruction (v\<lparr>vctx_stack := list\<rparr>) c =
 vctx_next_instruction v c"
apply(auto simp:vctx_next_instruction_def)
done

theorem lemma_pop_stack [simp] :
"vctx_next_instruction (vctx_pop_stack n v) c =
vctx_next_instruction v c"
apply(auto simp:vctx_pop_stack_def)
done

theorem lemma_update_storage [simp] :
"vctx_pc (vctx_update_storage a aa v) = vctx_pc v"
apply(auto simp:vctx_update_storage_def)
done

theorem lemma_gas [simp] :
 "gas (v\<lparr>vctx_pc := vctx_pc v + x\<rparr>) = gas v"
apply(auto simp:gas_def)
done

theorem lemma_mstore [simp] :
"mstore v c = InstructionContinue nv \<Longrightarrow>
 vctx_next_instruction v c =
    vctx_next_instruction (v\<lparr>vctx_pc:=vctx_pc v+x\<rparr>) c2 \<Longrightarrow>
 mstore (v\<lparr>vctx_pc:=vctx_pc v+x\<rparr>) c2 =
    InstructionContinue (nv\<lparr>vctx_pc:=vctx_pc nv+x\<rparr>)"
apply(auto simp:mstore_def)
apply(cases "vctx_stack v")
apply(simp)
apply(cases "tl (vctx_stack v)")
apply(auto split:option.split)
done

theorem lemma_venv_memory [simp] :
  "vctx_memory (v\<lparr>vctx_pc := vctx_pc v + x\<rparr>) p =
   vctx_memory v p"
apply(auto)
done

theorem lemma_mem_update [simp] :
 "(\<lambda>p. if p = a then ucast aa
                  else vctx_memory
                        (v\<lparr>vctx_pc := vctx_pc v + x\<rparr>)
                        p) =
(\<lambda>p. if p = a then ucast aa
                  else vctx_memory v p)"
apply(auto)
done

theorem lemma_mstore8 [simp] :
"mstore8 v c = InstructionContinue nv \<Longrightarrow>
 vctx_next_instruction v c =
    vctx_next_instruction (v\<lparr>vctx_pc:=vctx_pc v+x\<rparr>) c2 \<Longrightarrow>
 mstore8 (v\<lparr>vctx_pc:=vctx_pc v+x\<rparr>) c2 =
    InstructionContinue (nv\<lparr>vctx_pc:=vctx_pc nv+x\<rparr>)"
apply(auto simp:mstore8_def)
apply(cases "vctx_stack v")
apply(simp)
apply(cases "tl (vctx_stack v)")
apply(simp)
apply(auto split:option.split)
done

theorem "lemma_lambda" [simp] :
"(\<lambda>xa. if xa = a then aa
                else vctx_storage (v\<lparr>vctx_pc := x\<rparr>) xa) =
(\<lambda>x. if x = a then aa else vctx_storage v x)"
apply(auto)
done

theorem "lemma_update2" [simp] :
"vctx_update_storage a aa (v\<lparr>vctx_pc := x\<rparr>) =
 (vctx_update_storage a aa v) \<lparr>vctx_pc := x\<rparr>"
apply(auto simp:vctx_update_storage_def)
done

theorem lemma_venv_next_update [simp] :
"vctx_next_instruction
        (vctx_update_storage a aa v) c =
       vctx_next_instruction v c"
apply(auto simp:vctx_next_instruction_def)
done

theorem lemma_venv_next_update2 [simp] :
"vctx_next_instruction
        (vctx_update_storage a aa v
         \<lparr>vctx_pc := vctx_pc v + x\<rparr>) c =
 vctx_next_instruction (v\<lparr>vctx_pc := vctx_pc v + x \<rparr>) c"
apply(auto simp:vctx_next_instruction_def)
done

theorem lemma_cutdata [simp] :
"cut_data (v\<lparr>vctx_pc := vctx_pc v + x\<rparr>) = cut_data v"
apply(auto simp:cut_data_def)
done

theorem lemma_pop_s [simp] :
"vctx_pop_stack n (v\<lparr> vctx_pc := x \<rparr>) =
 (vctx_pop_stack n v) \<lparr> vctx_pc := x \<rparr>"
apply(auto simp:vctx_pop_stack_def)
done

theorem lemma_pop_stack_pc [simp] :
"vctx_pc (vctx_pop_stack n v) = vctx_pc v"
apply(auto simp:vctx_pop_stack_def)
done

theorem lemma_stack_default [simp] :
"vctx_stack_default n (v\<lparr>vctx_pc := x\<rparr>) =
 vctx_stack_default n v"
apply(auto simp:vctx_stack_default_def)
done

fun relocatable :: "inst \<Rightarrow> bool" where
   "relocatable (Pc _) = False"
|  "relocatable (Info _) = False"
|  "relocatable (Memory CODECOPY) = False"
|  "relocatable _ = True"

lemma lemma_create_log [simp] :
   "cctx_this c2 = cctx_this c1 \<Longrightarrow>
    create_log_entry n (v\<lparr>vctx_pc := x\<rparr>) c2 =
    create_log_entry n v c1"
apply(auto simp:create_log_entry_def)
apply(auto simp:vctx_returned_bytes_def)
apply(cases "vctx_stack v")
apply(auto)
done

theorem relocatable_inst :
  "relocatable inst \<Longrightarrow>
   instruction_aux v c inst = InstructionContinue nv \<Longrightarrow>
   vctx_next_instruction v c =
    vctx_next_instruction (v\<lparr>vctx_pc:=vctx_pc v+x\<rparr>) c2 \<Longrightarrow>
   cctx_this c2 = cctx_this c \<Longrightarrow>
   instruction_aux (v\<lparr>vctx_pc:=vctx_pc v+x\<rparr>) c2 inst =
    InstructionContinue (nv\<lparr>vctx_pc:=vctx_pc nv+x\<rparr>)"
apply(cases inst)
apply(auto simp:instruction_aux_def)

apply(cases "get_bits (Some inst)", auto)
apply(cases "get_sarith (Some inst)", auto)
apply(cases "get_arith (Some inst)", auto)

apply(auto simp:sha3_def)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto split:option.split)
(*
apply(cases "get_info (Some inst)")
apply(auto split:option.split)
*)
apply(simp add:general_dup_def)
apply(cases "index (venv_stack v) (unat (get_dup (Some inst)))")
apply(auto split:option.split)
apply(cases "get_memory (Some inst)")
apply(auto simp:mload_def stack_0_1_op_def)
apply(cases "vctx_stack v")
apply(auto split:option.split)
apply(simp add:calldatacopy_def)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto split:option.split)
apply(simp add:extcodecopy_def)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto)
apply(cases "tl (tl (tl (vctx_stack v)))")
apply(auto split:option.split)
apply(cases "get_storage (Some inst)")
apply(auto)
apply(simp add:sstore_def)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto simp:strict_if_def vctx_next_instruction_def
   split:option.split)

apply(cases "get_stack inst")
apply(auto)
apply(simp add:pop_def)
apply(cases "vctx_stack v")
apply(auto simp:vctx_next_instruction_def stack_0_1_op_def split:option.split)
apply(simp add:swap_def)
apply(cases "list_swap (Suc (unat (get_swap (Some inst)))) (vctx_stack v)")
apply(auto simp:vctx_next_instruction_def split:option.split)
apply(cases "get_log (Some inst)")
apply(auto simp:log_def split:option.split)
apply(auto simp:vctx_next_instruction_def vctx_pop_stack_def
  split:option.split)
apply(cases "get_misc (Some inst)")
apply(auto)
apply(simp add:stop_def)
apply(simp add:create_def)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto simp:vctx_next_instruction_def split:option.split)
apply(cases "vctx_balance v (cctx_this c) < hd (vctx_stack v)")
apply(auto)
apply (meson instruction_result.simps(6))
apply(simp add:call_def)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto)
apply(cases "tl (tl (tl (vctx_stack v)))")
apply(auto)
apply(cases "tl (tl (tl (tl (vctx_stack v))))")
apply(auto)
apply(cases "tl (tl (tl (tl (tl (vctx_stack v)))))")
apply(auto)
apply(cases "tl (tl (tl (tl (tl (tl (vctx_stack v))))))")
apply(auto)
apply(cases "vctx_balance v (cctx_this c) <
    hd (tl (tl (vctx_stack v)))")
apply(auto simp:strict_if_def vctx_next_instruction_def update_balance_def
 split:option.split)
apply(simp add:callcode_def)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto)
apply(cases "tl (tl (tl (vctx_stack v)))")
apply(auto)
apply(cases "tl (tl (tl (tl (vctx_stack v))))")
apply(auto)
apply(cases "tl (tl (tl (tl (tl (vctx_stack v)))))")
apply(auto)
apply(cases "tl (tl (tl (tl (tl (tl (vctx_stack v))))))")
apply(simp)
apply(cases "vctx_balance v (cctx_this c) <
    hd (tl (tl (vctx_stack v)))")
apply(auto simp:strict_if_def vctx_next_instruction_def update_balance_def
 split:option.split)
apply(simp add:delegatecall_def)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(cases "tl (tl (vctx_stack v))")
apply(auto)
apply(cases "tl (tl (tl (vctx_stack v)))")
apply(auto)
apply(cases "tl (tl (tl (tl (vctx_stack v))))")
apply(auto)
apply(cases "tl (tl (tl (tl (tl (vctx_stack v)))))")
apply(simp)
apply(cases "vctx_balance v (cctx_this c) <
    vctx_value_sent v")
apply(auto simp:strict_if_def vctx_next_instruction_def update_balance_def
 split:option.split)
apply(simp add:ret_def)
apply(cases "vctx_stack v")
apply(auto)
apply(cases "tl (vctx_stack v)")
apply(auto)
apply(simp add:suicide_def)
apply(cases "vctx_stack v")
apply(auto)
done

end


theory AND_Gate
imports Uniform_Sampling
begin

definition A :: "bool \<Rightarrow> (bool \<times> bool) spmf"
where "A e = do {
  r0 :: bool \<leftarrow> coin_spmf;
  r1 \<leftarrow> coin_spmf;
  let re = (if e then r1 else r0);
  let re' = (if e then r0 else r1);
  return_spmf (re, re')}"

definition A' :: "bool \<Rightarrow> (bool \<times> bool) spmf"
where "A' e = do {
  r0 :: bool \<leftarrow> coin_spmf;
  r1 :: bool \<leftarrow> coin_spmf;
  return_spmf (r0, r1)}"

lemma A_eq_A': "A e = A' e"
proof(cases e)
case True
have "A e = do {
  r0 :: bool \<leftarrow> coin_spmf;
  r1 \<leftarrow> coin_spmf;
  return_spmf (r1, r0)}"
using True by(simp add: A_def)
also have "... = do {
   r0 :: bool \<leftarrow> coin_spmf;
  r1 \<leftarrow> coin_spmf;
  return_spmf (r0, r1)}"
    apply(rewrite bind_commute_spmf [where p="coin_spmf"]) by(simp)
    ultimately show ?thesis by(simp add: A'_def)
next case False
show ?thesis using False by(simp add: A_def A'_def)
qed

(*OT (with trusted initialiser) to be used in AND gate protocol*)
definition Trusted :: "(bool \<times> bool \<times> bool \<times> bool) spmf"
where "Trusted = do {
  d \<leftarrow> coin_spmf;
  r0 :: bool \<leftarrow> coin_spmf;
  r1 \<leftarrow> coin_spmf;
  return_spmf (r0, r1, d, if d then r1 else r0)}"

definition R\<^sub>1 :: "(bool \<times> bool) \<Rightarrow> bool \<Rightarrow> bool spmf"
where "R\<^sub>1 msg c = do {
  let (m0, m1) = msg;
  (r0, r1, d, rd) \<leftarrow> Trusted;
  let e = xor c d;
  return_spmf e}"

definition S\<^sub>1 :: "(bool \<times> bool) \<Rightarrow> bool spmf"
where "S\<^sub>1 msg = do {
  e' :: bool \<leftarrow> coin_spmf;
  return_spmf e'}"

lemma OT_sec_P\<^sub>1: "R\<^sub>1 msg c = S\<^sub>1 msg"
proof-
have "R\<^sub>1 msg c = do {
  let (m0, m1) = msg;
  d :: bool \<leftarrow> coin_spmf;
  r0 :: bool \<leftarrow> coin_spmf;
  r1 :: bool \<leftarrow> coin_spmf;
  let e = xor c d;
  return_spmf e}"
    by(simp add: R\<^sub>1_def Trusted_def)
also have "... = do {
  let (m0, m1) = msg;
  r0 :: bool \<leftarrow> coin_spmf;
  r1 :: bool \<leftarrow> coin_spmf;
  e \<leftarrow> map_spmf (\<lambda> d. xor c d) (coin_spmf);
  return_spmf e}"
    by(simp add: bind_spmf_const map_spmf_conv_bind_spmf)
also have "... = do {
  r0 :: bool \<leftarrow> coin_spmf;
  r1 :: bool \<leftarrow> coin_spmf;
  e \<leftarrow> (coin_spmf);
  return_spmf e}"
    by(simp add: xor_uni_samp)
ultimately show ?thesis by(simp add: S\<^sub>1_def bind_spmf_const)
qed

definition R\<^sub>2 :: "(bool \<times> bool) \<Rightarrow> bool \<Rightarrow> (bool \<times> bool) spmf"
where "R\<^sub>2 msg c = do {
  let (m0, m1) = msg;
  (r0, r1, d, rd) \<leftarrow> Trusted;
  let e = xor c d;
  let re = (if e then r1 else r0);
  let re' = (if e then r0 else r1);
  let f0 = xor m0 re;
  let f1 = xor m1 re';
  return_spmf (f0, f1) }"

definition S\<^sub>2 :: "bool \<Rightarrow> (bool \<times> bool) spmf"
where "S\<^sub>2 c = do {
  r0 \<leftarrow> coin_spmf;
  r1 :: bool \<leftarrow> coin_spmf;
  return_spmf (r0, r1)}"

lemma OT_sec_P\<^sub>2: "R\<^sub>2 msg c = S\<^sub>2 c"
proof-
have "R\<^sub>2 msg c = do {
  let (m0, m1) = msg;
  e \<leftarrow> map_spmf (\<lambda> d. xor c d) coin_spmf;
  r0 \<leftarrow> coin_spmf;
  r1 \<leftarrow> coin_spmf;
  let re = (if e then r1 else r0);
  let re' = (if e then r0 else r1);
  let f0 = xor m0 re;
  let f1 = xor m1 re';
  return_spmf (f0, f1) }"
    by(simp add: R\<^sub>2_def Trusted_def bind_spmf_const map_spmf_conv_bind_spmf Let_def)
also have "... = do {
  let (m0, m1) = msg;
  e \<leftarrow> coin_spmf;
  (re, re') \<leftarrow> A e;
  let f0 = xor m0 re;
  let f1 = xor m1 re';
  return_spmf (f0, f1) }"
    by(simp add: A_def xor_uni_samp)
also have "... = do {
   let (m0, m1) = msg;
  e \<leftarrow> coin_spmf;
  (re, re') \<leftarrow> A' e;
  let f0 = xor m0 re;
  let f1 = xor m1 re';
  return_spmf (f0, f1) }"
    by(simp add: A_eq_A')
also have "... = do {
  let (m0, m1) = msg;
  e :: bool \<leftarrow> coin_spmf;
  re :: bool \<leftarrow> coin_spmf;
  re' :: bool \<leftarrow> coin_spmf;
  let f0 = xor m0 re;
  let f1 = xor m1 re';
  return_spmf (f0, f1) }"
    by(simp add: A'_def)
also have "... = do {
  let (m0, m1) = msg;
  f0 :: bool \<leftarrow> map_spmf (\<lambda> re.  xor m0 re) coin_spmf;
  f1 \<leftarrow> map_spmf (\<lambda> re'. xor m1 re') coin_spmf;
  return_spmf (f0, f1) }"
    by(simp add: bind_spmf_const map_spmf_conv_bind_spmf Let_def)
also have "... = do {
  f0 :: bool \<leftarrow> coin_spmf;
  f1 \<leftarrow> coin_spmf;
  return_spmf (f0, f1) }"
    by(simp add: xor_uni_samp)
ultimately show ?thesis by(simp add: S\<^sub>2_def)
qed

(*AND gate security*)

definition R\<^sub>a :: "bool \<Rightarrow> bool \<Rightarrow> (bool \<times> bool) spmf"
where "R\<^sub>a a b = do {
  u \<leftarrow> coin_spmf;
  let m0 = \<not> u;
  let m1 = xor a (\<not> u);
  r \<leftarrow> R\<^sub>1 (m0,m1) b;
  return_spmf (u, r)}"

definition S\<^sub>a :: "bool \<Rightarrow> (bool \<times> bool) spmf"
where "S\<^sub>a a = do {
  u \<leftarrow> coin_spmf;
  let m0 = \<not> u;
  let m1 = xor a (\<not> u);
  r \<leftarrow> S\<^sub>1 (m0, m1);
  return_spmf (u, r)}"

lemma AND_sec\<^sub>a: "R\<^sub>a a b = S\<^sub>a a"
by(simp add: OT_sec_P\<^sub>1 R\<^sub>a_def S\<^sub>a_def)

definition R\<^sub>b :: "bool \<Rightarrow> bool \<Rightarrow> (bool \<times> bool \<times> bool) spmf"
where "R\<^sub>b a b = do {
  u :: bool \<leftarrow> coin_spmf;
  let m0 = \<not> u;
  let m1 = xor a (\<not> u);
  r \<leftarrow> R\<^sub>2 (m0, m1) b;
  return_spmf (b,r)}"

definition S\<^sub>b :: "bool \<Rightarrow> (bool \<times> bool \<times> bool) spmf"
where "S\<^sub>b b = do {
  r \<leftarrow> S\<^sub>2 b;
  return_spmf (b,r)}"

lemma AND_sec\<^sub>b: "R\<^sub>b a b = S\<^sub>b b"
by(simp add: OT_sec_P\<^sub>2 R\<^sub>b_def S\<^sub>b_def bind_spmf_const)

end


theory Small_Examples
imports "../Primitive_Matchers/Code_Interface"
begin

section\<open>Small Examples\<close>
context
begin
  lemma "let fw = [''FORWARD'' \<mapsto> [Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (10,0,0,0)) 8))) (Call ''foo'')],
                   ''foo'' \<mapsto> [Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (10,128,0,0)) 9))) action.Return,
                               Rule (Match (Prot (Proto TCP))) action.Accept]
                   ] in
    let simplfw = to_simple_firewall
      (upper_closure (optimize_matches abstract_for_simple_firewall
        (upper_closure (packet_assume_new (unfold_ruleset_FORWARD action.Drop fw)))))
    in map simple_rule_ipv4_toString simplfw =
    [''ACCEPT     tcp  --  10.0.0.0/9            0.0.0.0/0    '',
     ''DROP     all  --  0.0.0.0/0            0.0.0.0/0    '']" by eval

  private definition "cool_example \<equiv> (let fw =
                [''FORWARD'' \<mapsto> [Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (10,0,0,0)) 8))) (Call ''foo'')],
                 ''foo'' \<mapsto> [Rule (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (10,0,0,0)) 9)))) action.Drop,
                             Rule (Match (Prot (Proto TCP))) action.Accept]
                 ] in
    to_simple_firewall (upper_closure (optimize_matches abstract_for_simple_firewall
                          (upper_closure (packet_assume_new (unfold_ruleset_FORWARD action.Drop fw))))))"
  lemma " map simple_rule_ipv4_toString cool_example =
    [''DROP     all  --  10.128.0.0/9            0.0.0.0/0    '',
     ''ACCEPT     tcp  --  10.0.0.0/8            0.0.0.0/0    '',
     ''DROP     all  --  0.0.0.0/0            0.0.0.0/0    '']"
  by eval

  lemma "map ipv4addr_wordinterval_toString (getParts cool_example) =
    [''{10.128.0.0 .. 10.255.255.255}'',
     ''{10.0.0.0 .. 10.127.255.255}'',
     ''{0.0.0.0 .. 9.255.255.255} u {11.0.0.0 .. 255.255.255.255}'']" by eval

  lemma "map ipv4addr_wordinterval_toString (build_ip_partition parts_connection_ssh cool_example) =
    [''{0.0.0.0 .. 9.255.255.255} u {10.128.0.0 .. 255.255.255.255}'',
     ''{10.0.0.0 .. 10.127.255.255}'']" by eval

  (*it is not minimal if we allow to further compress the node definitions?
  the receiver nodes could be combined to UNIV
  But minimal for a symmetric matrix*)
  lemma "access_matrix_pretty_ipv4 parts_connection_ssh cool_example =
    ([(''0.0.0.0'', ''{0.0.0.0 .. 9.255.255.255} u {10.128.0.0 .. 255.255.255.255}''),
      (''10.0.0.0'', ''{10.0.0.0 .. 10.127.255.255}'')],
     [(''10.0.0.0'', ''0.0.0.0''),
      (''10.0.0.0'', ''10.0.0.0'')])" by eval
end
context
begin
  (*now with a destination IP*)
  private definition "cool_example2 \<equiv> (let fw =
    [''FORWARD'' \<mapsto> [Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (10,0,0,0)) 8))) (Call ''foo'')],
     ''foo'' \<mapsto> [Rule (MatchNot (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (10,0,0,0)) 9)))) action.Drop,
                 Rule (MatchAnd (Match (Prot (Proto TCP))) (Match (Dst (IpAddrNetmask (ipv4addr_of_dotdecimal (10,0,0,42)) 32)))) action.Accept]
                ] in
    to_simple_firewall (upper_closure (optimize_matches abstract_for_simple_firewall
                          (upper_closure (packet_assume_new (unfold_ruleset_FORWARD action.Drop fw))))))"
  lemma "map simple_rule_ipv4_toString cool_example2 =
    [''DROP     all  --  10.128.0.0/9            0.0.0.0/0    '',
     ''ACCEPT     tcp  --  10.0.0.0/8            10.0.0.42/32    '',
     ''DROP     all  --  0.0.0.0/0            0.0.0.0/0    '']" by eval

  (*not minimal*)
  lemma "map ipv4addr_wordinterval_toString (getParts cool_example2) =
    [''{10.128.0.0 .. 10.255.255.255}'', ''10.0.0.42'',
     ''{10.0.0.0 .. 10.0.0.41} u {10.0.0.43 .. 10.127.255.255}'',
     ''{0.0.0.0 .. 9.255.255.255} u {11.0.0.0 .. 255.255.255.255}'']" by eval

  lemma "map ipv4addr_wordinterval_toString (build_ip_partition parts_connection_ssh cool_example2) =
    [''{0.0.0.0 .. 9.255.255.255} u {10.128.0.0 .. 255.255.255.255}'', ''10.0.0.42'',
     ''{10.0.0.0 .. 10.0.0.41} u {10.0.0.43 .. 10.127.255.255}'']" by eval

  lemma "access_matrix_pretty_ipv4 parts_connection_ssh cool_example2 =
    ([(''0.0.0.0'', ''{0.0.0.0 .. 9.255.255.255} u {10.128.0.0 .. 255.255.255.255}''),
      (''10.0.0.42'', ''10.0.0.42''),
      (''10.0.0.0'', ''{10.0.0.0 .. 10.0.0.41} u {10.0.0.43 .. 10.127.255.255}'')
     ],
     [(''10.0.0.42'', ''10.0.0.42''),
      (''10.0.0.0'', ''10.0.0.42'')
     ])" by eval
  end

end


(*
   Copyright 2021-2022 Boris Shminke

   Licensed under the Apache License, Version 2.0 (the "License");
   you may not use this file except in compliance with the License.
   You may obtain a copy of the License at

       http://www.apache.org/licenses/LICENSE-2.0

   Unless required by applicable law or agreed to in writing, software
   distributed under the License is distributed on an "AS IS" BASIS,
   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
   See the License for the specific language governing permissions and
   limitations under the License.
*)
theory DistributiveCase
  imports Residuated_Lattices.Residuated_Lattices
begin
  class DistributiveResiduatedBinar=residuated_lgroupoid + distrib_lattice
  begin
  lemma lemma2_2_3:
  "(\<forall> x y z w. (x \<squnion> y) \<rightarrow> (z \<squnion> w) \<le> (x \<rightarrow> z) \<squnion> (y \<rightarrow> w)) \<longleftrightarrow>
    (\<forall> x y z. x \<rightarrow> (y \<squnion> z) = (x \<rightarrow> y) \<squnion> (x \<rightarrow> z))"
    by (metis local.resr_subdist local.resr_superdist_var local.sup_absorb2 local.sup_commute local.sup_idem local.sup_mono)
  lemma lemma2_2_5:
  "(\<forall> x y z w. (x \<sqinter> y) \<rightarrow> (z \<sqinter> w) \<le> (x \<rightarrow> z) \<squnion> (y \<rightarrow> w)) \<longleftrightarrow>
    (\<forall> x y z. (x \<sqinter> y) \<rightarrow> z = (x \<rightarrow> z) \<squnion> (y \<rightarrow> z))"
  proof -
    have "(\<forall> x y z w. (x \<sqinter> y) \<rightarrow> (z \<sqinter> w) \<le> (x \<rightarrow> z) \<squnion> (y \<rightarrow> w)) \<longrightarrow>
    (\<forall> x y z. (x \<sqinter> y) \<rightarrow> z = (x \<rightarrow> z) \<squnion> (y \<rightarrow> z))"
      by (smt (z3) abel_semigroup.commute local.distrib_inf_le local.inf.abel_semigroup_axioms local.inf.orderE local.inf.semilattice_axioms local.resr_distl local.sup_inf_absorb semilattice.idem)
    have "(\<forall> x y z. (x \<sqinter> y) \<rightarrow> z = (x \<rightarrow> z) \<squnion> (y \<rightarrow> z)) \<longrightarrow>
    (\<forall> x y z w. (x \<sqinter> y) \<rightarrow> (z \<sqinter> w) \<le> (x \<rightarrow> z) \<squnion> (y \<rightarrow> w))"
      by (metis local.inf.cobounded1 local.inf.commute local.resr_iso local.sup.mono)
    show ?thesis
      using \<open>(\<forall>x y z w. x \<sqinter> y \<rightarrow> z \<sqinter> w \<le> (x \<rightarrow> z) \<squnion> (y \<rightarrow> w)) \<longrightarrow> (\<forall>x y z. x \<sqinter> y \<rightarrow> z = (x \<rightarrow> z) \<squnion> (y \<rightarrow> z))\<close> \<open>(\<forall>x y z. x \<sqinter> y \<rightarrow> z = (x \<rightarrow> z) \<squnion> (y \<rightarrow> z)) \<longrightarrow> (\<forall>x y z w. x \<sqinter> y \<rightarrow> z \<sqinter> w \<le> (x \<rightarrow> z) \<squnion> (y \<rightarrow> w))\<close> by blast
  qed
  theorem Main:
    assumes one: "\<forall>x y z. (x \<squnion> y) \<leftarrow> z = (x \<leftarrow> z) \<squnion> (y \<leftarrow> z)"
    and two: "\<forall>x y z. (x \<sqinter> y) \<rightarrow> z = (x \<rightarrow> z) \<squnion> (y \<rightarrow> z)"
    shows "\<forall>x y z. x \<rightarrow> (y \<squnion> z) = (x \<rightarrow> y) \<squnion> (x \<rightarrow> z)"
  proof -
    {
      fix x y z w u
      assume "u = (x \<squnion> y) \<rightarrow> (z \<squnion> w)"
      have "u \<le> ((x \<sqinter> (z \<leftarrow> u)) \<rightarrow> z) \<squnion> ((y \<sqinter> (w \<leftarrow> u)) \<rightarrow> w)"
        using local.inf.cobounded2 local.resl_galois local.sup.coboundedI1 by blast
      have "u \<le> ((x \<sqinter> (z \<leftarrow> u)) \<rightarrow> z) \<squnion> ((y \<sqinter> (z \<leftarrow> u)) \<rightarrow> w)"
        using local.inf.cobounded2 local.le_supI1 local.resl_galois by blast
      have "u \<le> ((x \<sqinter> (w \<leftarrow> u)) \<rightarrow> z) \<squnion> ((y \<sqinter> (w \<leftarrow> u)) \<rightarrow> w)"
        using local.inf.cobounded2 local.resl_galois local.sup.coboundedI2 by blast
      have "u \<le> ((x \<sqinter> (w \<leftarrow> u)) \<sqinter> (y \<sqinter> (z \<leftarrow> u))) \<rightarrow> (z \<sqinter> w)"
        by (meson local.inf_le1 local.inf_le2 local.le_inf_iff local.resl_galois local.resrI)
      have "u \<le> ((x \<sqinter> (w \<leftarrow> u)) \<rightarrow> z) \<squnion> ((y \<sqinter> (z \<leftarrow> u)) \<rightarrow> w)"
        using \<open>u \<le> x \<sqinter> (w \<leftarrow> u) \<sqinter> (y \<sqinter> (z \<leftarrow> u)) \<rightarrow> z \<sqinter> w\<close> lemma2_2_5 local.dual_order.trans two by blast
      have "u \<le>
    (
    (((x \<sqinter> (w \<leftarrow> u)) \<rightarrow> z)
     \<sqinter> ((x \<sqinter> (z \<leftarrow> u))\<rightarrow> z))
     \<squnion> ((y \<sqinter> (z \<leftarrow> u)) \<rightarrow> w)
    ) \<sqinter> (
    (((x \<sqinter> (z \<leftarrow> u)) \<rightarrow> z)
    \<sqinter> ((x \<sqinter> (w \<leftarrow> u)) \<rightarrow> z))
    \<squnion> ((y \<sqinter> (w \<leftarrow> u)) \<rightarrow> w))"
        by (simp add: \<open>u \<le> (x \<sqinter> (w \<leftarrow> u) \<rightarrow> z) \<squnion> (y \<sqinter> (w \<leftarrow> u) \<rightarrow> w)\<close> \<open>u \<le> (x \<sqinter> (w \<leftarrow> u) \<rightarrow> z) \<squnion> (y \<sqinter> (z \<leftarrow> u) \<rightarrow> w)\<close> \<open>u \<le> (x \<sqinter> (z \<leftarrow> u) \<rightarrow> z) \<squnion> (y \<sqinter> (w \<leftarrow> u) \<rightarrow> w)\<close> \<open>u \<le> (x \<sqinter> (z \<leftarrow> u) \<rightarrow> z) \<squnion> (y \<sqinter> (z \<leftarrow> u) \<rightarrow> w)\<close> local.sup_inf_distrib2)
      have "u \<le> (x \<rightarrow> z) \<squnion> (y \<rightarrow> w)"
        by (metis \<open>u = x \<squnion> y \<rightarrow> z \<squnion> w\<close> \<open>u \<le> (x \<sqinter> (w \<leftarrow> u) \<rightarrow> z) \<sqinter> (x \<sqinter> (z \<leftarrow> u) \<rightarrow> z) \<squnion> (y \<sqinter> (z \<leftarrow> u) \<rightarrow> w) \<sqinter> ((x \<sqinter> (z \<leftarrow> u) \<rightarrow> z) \<sqinter> (x \<sqinter> (w \<leftarrow> u) \<rightarrow> z) \<squnion> (y \<sqinter> (w \<leftarrow> u) \<rightarrow> w))\<close> local.inf.order_iff local.inf_sup_distrib1 local.jipsen1l local.le_supE local.resr_distl local.sup.commute local.sup_inf_distrib2 one)
    }
    have "\<forall> x y z w. (x \<squnion> y) \<rightarrow> (z \<squnion> w) \<le> (x \<rightarrow> z) \<squnion> (y \<rightarrow> w)"
      by (simp add: \<open>\<And>z y x w u. u = x \<squnion> y \<rightarrow> z \<squnion> w \<Longrightarrow> u \<le> (x \<rightarrow> z) \<squnion> (y \<rightarrow> w)\<close>)
    show ?thesis
      using \<open>\<forall>x y z w. x \<squnion> y \<rightarrow> z \<squnion> w \<le> (x \<rightarrow> z) \<squnion> (y \<rightarrow> w)\<close> lemma2_2_3 by blast
    qed
  end
end


theory Matching_Embeddings
imports "Semantics_Ternary/Matching_Ternary" Matching "Semantics_Ternary/Unknown_Match_Tacs"
begin

section\<open>Boolean Matching vs. Ternary Matching\<close>

term Semantics.matches
term Matching_Ternary.matches
(*'a is the primitive match condition, e.g. IpSrc \<dots>*)

text\<open>The two matching semantics are related. However, due to the ternary logic, we cannot directly translate one to the other.
The problem are @{const MatchNot} expressions which evaluate to @{const TernaryUnknown} because @{text "MatchNot TernaryUnknown"} and
@{text TernaryUnknown} are semantically equal!\<close>
lemma "\<exists>m \<beta> \<alpha> a. Matching_Ternary.matches (\<beta>, \<alpha>) m a p \<noteq>
  Semantics.matches (\<lambda> atm p. case \<beta> atm p of TernaryTrue \<Rightarrow> True | TernaryFalse \<Rightarrow> False | TernaryUnknown \<Rightarrow> \<alpha> a p) m p"
apply(rule_tac x="MatchNot (Match X)" in exI) --\<open>any @{term "X::'a"}\<close>
by (auto split: ternaryvalue.split ternaryvalue.split_asm simp add: matches_case_ternaryvalue_tuple)

text\<open>the @{const the} in the next definition is always defined\<close>
lemma "\<forall>m \<in> {m. approx m p \<noteq> TernaryUnknown}. ternary_to_bool (approx m p) \<noteq> None"
  by(simp add: ternary_to_bool_None)

text\<open>
The Boolean and the ternary matcher agree (where the ternary matcher is defined)
\<close>
definition matcher_agree_on_exact_matches :: "('a, 'p) matcher \<Rightarrow> ('a \<Rightarrow> 'p \<Rightarrow> ternaryvalue) \<Rightarrow> bool" where
  "matcher_agree_on_exact_matches exact approx \<equiv> \<forall>p m. approx m p \<noteq> TernaryUnknown \<longrightarrow> exact m p = the (ternary_to_bool (approx m p))"

text\<open>We say the Boolean and ternary matchers agree iff they return the same result or the ternary matcher returns @{const TernaryUnknown}.\<close>
lemma "matcher_agree_on_exact_matches exact approx \<longleftrightarrow> (\<forall>p m. exact m p = the (ternary_to_bool (approx m p)) \<or> approx m p = TernaryUnknown)"
  unfolding matcher_agree_on_exact_matches_def by blast
lemma matcher_agree_on_exact_matches_alt: (*no `the`*)
  "matcher_agree_on_exact_matches exact approx \<longleftrightarrow> (\<forall>p m. approx m p \<noteq> TernaryUnknown \<longrightarrow> bool_to_ternary (exact m p) = approx m p)"
  unfolding matcher_agree_on_exact_matches_def
  by (metis (full_types) bool_to_ternary.simps(1) bool_to_ternary.simps(2) option.sel ternary_to_bool.simps(1)
                         ternary_to_bool.simps(2) ternaryvalue.exhaust)

lemma eval_ternary_Not_TrueD: "eval_ternary_Not m = TernaryTrue \<Longrightarrow> m = TernaryFalse"
  by (metis eval_ternary_Not.simps(1) eval_ternary_idempotence_Not)

lemma matches_comply_exact: "ternary_ternary_eval (map_match_tac \<beta> p m) \<noteq> TernaryUnknown \<Longrightarrow>
       matcher_agree_on_exact_matches \<gamma> \<beta> \<Longrightarrow>
        Semantics.matches \<gamma> m p = Matching_Ternary.matches (\<beta>, \<alpha>) m a p"
  proof(unfold matches_case_ternaryvalue_tuple,induction m)
  case Match thus ?case
       by(simp split: ternaryvalue.split add: matcher_agree_on_exact_matches_def)
  next
  case (MatchNot m) thus ?case
      apply(simp split: ternaryvalue.split add: matcher_agree_on_exact_matches_def)
      apply(case_tac "ternary_ternary_eval (map_match_tac \<beta> p m)")
        by(simp_all)
  next
  case (MatchAnd m1 m2)
    thus ?case
     apply(case_tac "ternary_ternary_eval (map_match_tac \<beta> p m1)")
       apply(case_tac [!] "ternary_ternary_eval (map_match_tac \<beta> p m2)")
                by(simp_all)
  next
  case MatchAny thus ?case by simp
  qed

lemma matcher_agree_on_exact_matches_gammaE:
  "matcher_agree_on_exact_matches \<gamma> \<beta> \<Longrightarrow> \<beta> X p = TernaryTrue \<Longrightarrow> \<gamma> X p"
  apply(simp add: matcher_agree_on_exact_matches_alt)
  apply(erule_tac x=p in allE)
  apply(erule_tac x=X in allE)
  apply(simp add: bool_to_ternary_simps)
  done

lemma in_doubt_allow_allows_Accept: "a = Accept \<Longrightarrow> matcher_agree_on_exact_matches \<gamma> \<beta> \<Longrightarrow>
        Semantics.matches \<gamma> m p \<Longrightarrow> Matching_Ternary.matches (\<beta>, in_doubt_allow) m a p"
  apply(case_tac "ternary_ternary_eval (map_match_tac \<beta> p m) \<noteq> TernaryUnknown")
   using matches_comply_exact apply fast
  apply(simp add: matches_case_ternaryvalue_tuple)
  done

lemma not_exact_match_in_doubt_allow_approx_match: "matcher_agree_on_exact_matches \<gamma> \<beta> \<Longrightarrow> a = Accept \<or> a = Reject \<or> a = Drop \<Longrightarrow>
  \<not> Semantics.matches \<gamma> m p \<Longrightarrow>
  (a = Accept \<and> Matching_Ternary.matches (\<beta>, in_doubt_allow) m a p) \<or> \<not> Matching_Ternary.matches (\<beta>, in_doubt_allow) m a p"
  apply(case_tac "ternary_ternary_eval (map_match_tac \<beta> p m) \<noteq> TernaryUnknown")
   apply(drule(1) matches_comply_exact[where \<alpha>=in_doubt_allow and a=a])
   apply(rule disjI2)
   apply fast
  apply(simp)
  apply(clarify)
  apply(simp add: matches_case_ternaryvalue_tuple)
  apply(cases a)
         apply(simp_all)
  done

lemma in_doubt_deny_denies_DropReject: "a = Drop \<or> a = Reject \<Longrightarrow> matcher_agree_on_exact_matches \<gamma> \<beta> \<Longrightarrow>
        Semantics.matches \<gamma> m p \<Longrightarrow> Matching_Ternary.matches (\<beta>, in_doubt_deny) m a p"
  apply(case_tac "ternary_ternary_eval (map_match_tac \<beta> p m) \<noteq> TernaryUnknown")
   using matches_comply_exact apply fast
   apply(simp)
  apply(auto simp add: matches_case_ternaryvalue_tuple)
  done

lemma not_exact_match_in_doubt_deny_approx_match: "matcher_agree_on_exact_matches \<gamma> \<beta> \<Longrightarrow> a = Accept \<or> a = Reject \<or> a = Drop \<Longrightarrow>
  \<not> Semantics.matches \<gamma> m p \<Longrightarrow>
  ((a = Drop \<or> a = Reject) \<and> Matching_Ternary.matches (\<beta>, in_doubt_deny) m a p) \<or> \<not> Matching_Ternary.matches (\<beta>, in_doubt_deny) m a p"
  apply(case_tac "ternary_ternary_eval (map_match_tac \<beta> p m) \<noteq> TernaryUnknown")
   apply(drule(1) matches_comply_exact[where \<alpha>=in_doubt_deny and a=a])
   apply(rule disjI2)
   apply fast
  apply(simp)
  apply(clarify)
  apply(simp add: matches_case_ternaryvalue_tuple)
  apply(cases a)
         apply(simp_all)
  done

text\<open>The ternary primitive matcher can return exactly the result of the Boolean primitive matcher\<close>
definition \<beta>\<^sub>m\<^sub>a\<^sub>g\<^sub>i\<^sub>c :: "('a, 'p) matcher \<Rightarrow> ('a \<Rightarrow> 'p \<Rightarrow> ternaryvalue)" where
  "\<beta>\<^sub>m\<^sub>a\<^sub>g\<^sub>i\<^sub>c \<gamma> \<equiv> (\<lambda> a p. if \<gamma> a p then TernaryTrue else TernaryFalse)"

lemma "matcher_agree_on_exact_matches \<gamma> (\<beta>\<^sub>m\<^sub>a\<^sub>g\<^sub>i\<^sub>c \<gamma>)"
  by(simp add: matcher_agree_on_exact_matches_def \<beta>\<^sub>m\<^sub>a\<^sub>g\<^sub>i\<^sub>c_def)

lemma \<beta>\<^sub>m\<^sub>a\<^sub>g\<^sub>i\<^sub>c_not_Unknown: "ternary_ternary_eval (map_match_tac (\<beta>\<^sub>m\<^sub>a\<^sub>g\<^sub>i\<^sub>c \<gamma>) p m) \<noteq> TernaryUnknown"
  proof(induction m)
  case MatchNot thus ?case using eval_ternary_Not_UnknownD \<beta>\<^sub>m\<^sub>a\<^sub>g\<^sub>i\<^sub>c_def
     by (simp) blast
  case (MatchAnd m1 m2) thus ?case
    apply(case_tac "ternary_ternary_eval (map_match_tac (\<beta>\<^sub>m\<^sub>a\<^sub>g\<^sub>i\<^sub>c \<gamma>) p m1)")
      apply(case_tac [!] "ternary_ternary_eval (map_match_tac (\<beta>\<^sub>m\<^sub>a\<^sub>g\<^sub>i\<^sub>c \<gamma>) p m2)")
            by(simp_all add: \<beta>\<^sub>m\<^sub>a\<^sub>g\<^sub>i\<^sub>c_def)
  qed (simp_all add: \<beta>\<^sub>m\<^sub>a\<^sub>g\<^sub>i\<^sub>c_def)

lemma \<beta>\<^sub>m\<^sub>a\<^sub>g\<^sub>i\<^sub>c_matching: "Matching_Ternary.matches ((\<beta>\<^sub>m\<^sub>a\<^sub>g\<^sub>i\<^sub>c \<gamma>), \<alpha>) m a p \<longleftrightarrow> Semantics.matches \<gamma> m p"
  proof(induction m)
  case Match thus ?case
    by(simp add: \<beta>\<^sub>m\<^sub>a\<^sub>g\<^sub>i\<^sub>c_def matches_case_ternaryvalue_tuple)
  case MatchNot thus ?case
    by(simp add: matches_case_ternaryvalue_tuple \<beta>\<^sub>m\<^sub>a\<^sub>g\<^sub>i\<^sub>c_not_Unknown split: ternaryvalue.split_asm)
  qed (simp_all add: matches_case_ternaryvalue_tuple split: ternaryvalue.split ternaryvalue.split_asm)

end