(*<*)
theory LoweOntologicalArgument_4
imports QML
begin

nitpick_params[box=false, user_axioms=true, show_all, expect=genuine, format = 3,  atoms e = a b c d]
sledgehammer_params[verbose=true]

consts isActualized::"e\<Rightarrow>wo" (infix "actualizedAt" 70)

abbreviation forallAct::"(e\<Rightarrow>wo)\<Rightarrow>wo" ("\<^bold>\<forall>\<^sup>A")
  where "\<^bold>\<forall>\<^sup>A\<Phi> \<equiv> \<lambda>w.\<forall>x. (x actualizedAt w)\<longrightarrow>(\<Phi> x w)"
abbreviation existsAct::"(e\<Rightarrow>wo)\<Rightarrow>wo" ("\<^bold>\<exists>\<^sup>A")
  where "\<^bold>\<exists>\<^sup>A\<Phi> \<equiv> \<lambda>w.\<exists>x. (x actualizedAt w) \<and> (\<Phi> x w)"
abbreviation mforallActB::"(e\<Rightarrow>wo)\<Rightarrow>wo" (binder"\<^bold>\<forall>\<^sup>A"[8]9)
  where "\<^bold>\<forall>\<^sup>Ax. (\<phi> x) \<equiv> \<^bold>\<forall>\<^sup>A\<phi>"
abbreviation mexistsActB::"(e\<Rightarrow>wo)\<Rightarrow>wo" (binder"\<^bold>\<exists>\<^sup>A"[8]9)
  where "\<^bold>\<exists>\<^sup>Ax. (\<phi> x) \<equiv> \<^bold>\<exists>\<^sup>A\<phi>"

definition Existence::"e\<Rightarrow>wo" ("E!") where "E! x  \<equiv> \<^bold>\<exists>\<^sup>Ay. y\<^bold>\<approx>x"
definition Necessary::"e\<Rightarrow>wo" where "Necessary x \<equiv>  \<^bold>\<box>E! x"
definition Contingent::"e\<Rightarrow>wo" where "Contingent x \<equiv>  \<^bold>\<diamond>E! x \<^bold>\<and> \<^bold>\<not>(Necessary x)"

consts Concrete::"e\<Rightarrow>wo"
abbreviation Abstract::"e\<Rightarrow>wo" where "Abstract x \<equiv>  \<^bold>\<not>(Concrete x)"

abbreviation Godlike::"e\<Rightarrow>wo"  where "Godlike x \<equiv> Necessary x \<^bold>\<and> Concrete x"

consts dependence::"e\<Rightarrow>e\<Rightarrow>wo" (infix "dependsOn" 100)
definition Dependent::"e\<Rightarrow>wo" where "Dependent x \<equiv> \<^bold>\<exists>\<^sup>Ay. x dependsOn y"
abbreviation Independent::"e\<Rightarrow>wo" where "Independent x  \<equiv> \<^bold>\<not>(Dependent x)"

axiomatization where
  P2: "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Necessary x \<^bold>\<and> Abstract x\<rfloor>" and
  P3: "\<lfloor>\<^bold>\<forall>\<^sup>Ax. Abstract x \<^bold>\<rightarrow> Dependent x\<rfloor>" and
  P4: "\<lfloor>\<^bold>\<forall>\<^sup>Ax. Dependent x \<^bold>\<rightarrow> (\<^bold>\<exists>\<^sup>Ay. Independent y \<^bold>\<and> x dependsOn y)\<rfloor>"
(*>*)

subsection \<open>Simplifying the Argument\<close>

text\<open>\noindent{After some further iterations we arrive at a new variant of the original argument:
Premises P1 to P4 remain unchanged and a new premise D5
("x depends for its existence on y := necessarily, x exists only if y exists") is added.
D5 corresponds to the `definition' of ontological dependence as put forth by
Lowe in his article (though just for illustrative purposes). As mentioned before, this purported definition was never meant by him to become part
of the argument. Nevertheless, we show here how, by assuming the left-to-right direction of this definition,
we get in a position to prove the main conclusions without any further assumptions.
}\<close>
axiomatization where
  D5: "\<lfloor>\<^bold>\<forall>\<^sup>Ax y. x dependsOn y \<^bold>\<rightarrow> \<^bold>\<box>(E! x \<^bold>\<rightarrow> E! y)\<rfloor>"

theorem C1:  "\<lfloor>\<^bold>\<forall>\<^sup>Ax. Abstract x \<^bold>\<rightarrow> (\<^bold>\<exists>y. Concrete y \<^bold>\<and> x dependsOn y)\<rfloor>"
  using P3 P4 by meson

theorem C5: "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Concrete x\<rfloor>"
  using P2 P3 P4 by meson

theorem C10:  "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Godlike x\<rfloor>"
  using Necessary_def P2 P3 P4 D5 by meson

text\<open>\noindent{In this variant we have been able to verify the conclusion of the argument without appealing
to the concept of metaphysical explanation. We were able to get by with just the concept of
ontological dependence by explicating it in terms of existence and necessity (as suggested by Lowe).}\<close>

text\<open>\noindent{As a side note, we can also prove that the original premise P5
("No contingent being can explain the existence of a necessary being")
directly follows from D5 by redefining metaphysical explanation
as the inverse relation of ontological dependence.}\<close>

abbreviation explanation::"(e\<Rightarrow>e\<Rightarrow>wo)" (infix "explains"(*<*)100(*>*))
  where "y explains x \<equiv> x dependsOn y"

lemma P5: "\<lfloor>\<^bold>\<not>(\<^bold>\<exists>\<^sup>Ax. \<^bold>\<exists>\<^sup>Ay. Contingent y \<^bold>\<and> Necessary x \<^bold>\<and> y explains x)\<rfloor>"
  using Necessary_def Contingent_def D5 by meson

text\<open>\noindent{In this series of iterations we have reworked the argument so as to get rid of the somewhat obscure
concept of metaphysical explanation;
we also got some insight into Lowe's concept of ontological dependence vis-a-vis its
inferential role in this argument.}\<close>
text\<open>\noindent{There are still some interesting issues to consider.
Note that the definitions of existence (\<open>Existence_def\<close>) and being "dependent" (\<open>Dependent_def\<close>)
are not needed in any of the highly optimized proofs found by our automated tools.
This raises some suspicions concerning the role played by the existence predicate in the
definitions of necessariness and contingency, as well as putting into question the need for
a definition of being "dependent" linked to the ontological dependence relation.
We will see in the following section that our suspicions are justified and that
this argument can be dramatically simplified.}\<close>

(*<*)
(* We carry out our `sanity checks' as usual.*)
lemma True nitpick[satisfy, user_axioms] oops (* model found: axioms are consistent *)
lemma "\<lfloor>Necessary x\<rfloor>" nitpick[user_axioms] oops (* counter-model found: axioms do not trivialize argument *)
lemma "\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<phi>\<rfloor>" nitpick[user_axioms] oops (* counter-model found: modal collapse is not valid *)

end
(*>*)


theory Virtual_Datatype
  imports "Phi_Statespace.StateFun"
  keywords "virtual_datatype" :: thy_decl
begin

locale "virtual_datatype" =
  fixes CONS_OF :: "'value \<Rightarrow> 'CONS_NAME"
begin

end

datatype ('CONS_NAME,'REP,'ABS) Field =
  Field (name: 'CONS_NAME) (project: "'REP \<Rightarrow> 'ABS") (inject: "'ABS \<Rightarrow> 'REP")

hide_const (open) name project inject

(* definition lift_Field :: \<open>('ABS \<Rightarrow> 'ABS')
                       \<Rightarrow> ('ABS' \<Rightarrow> 'ABS)
                       \<Rightarrow> ('CONS_NAME,'REP,'ABS) Field
                       \<Rightarrow> ('CONS_NAME,'REP,'ABS') Field\<close>
  where \<open>lift_Field f g field = (case field of Field name projector injector \<Rightarrow>
            Field name (f o projector) (injector o g))\<close>

lemma lift_Field[simp]:
  \<open>lift_Field f g (Field name projector injector) = Field name (f o projector) (injector o g)\<close>
  unfolding lift_Field_def by simp
*)

locale VDT_field =
  fixes field :: "('CONS_NAME,'value,'a) Field"
  assumes dest_mk[simp]: "Field.project field (Field.inject field x) = x"
begin

abbreviation "mk \<equiv> Field.inject field"
abbreviation "dest \<equiv> Field.project field"
abbreviation "name \<equiv> Field.name field"

lemma dest_mk_id[simp]: "dest o mk = id"
  using dest_mk destr_contstr_comp_id by blast

lemma dest_mk_cancle[simp]: "f o dest o mk = f"
  by fastforce

lemma mk_inj[iff]: "mk x = mk y \<longleftrightarrow> x = y"
  by (metis dest_mk)

definition "domain = {v. (\<exists>x. v = mk x)}"

lemma in_domainE[elim!]: "v \<in> domain \<Longrightarrow> (\<And>x. v = mk x \<Longrightarrow> C) \<Longrightarrow> C"
  using domain_def by blast

lemma mk_in_domain[simp,intro]: "mk x \<in> domain" using domain_def by blast

end

(*lemma VDT_field_lift:
  \<open>(\<And>x. f (g x) = x) \<Longrightarrow> VDT_field field \<Longrightarrow> VDT_field (lift_Field f g field)\<close>
  unfolding VDT_field_def
  by (cases field; simp)*)

locale field_entry =
  "virtual_datatype" CONS_OF + VDT_field field
  for CONS_OF :: "'value \<Rightarrow> 'CONS_NAME"
  and field :: "('CONS_NAME,'value,'a) Field"
+ assumes name_of[simp]: "CONS_OF (Field.inject field x) = Field.name field"
begin

lemma not_constructor_not_instance[simp]:
  \<open>CONS_OF v \<noteq> name \<Longrightarrow> v \<notin> domain \<equiv> True\<close>
  unfolding atomize_eq using name_of by blast

lemma in_domain_cons[simp]: "v \<in> domain \<Longrightarrow> CONS_OF v = name"
  using name_of domain_def by force

lemma in_domain_mk_dest[simp]: "v \<in> domain \<Longrightarrow> mk (dest v) = v"
  using domain_def dest_mk by fastforce

end

ML_file_debug \<open>Virtual_Datatype.ML\<close>

hide_type  (open) Field
hide_const (open) Field

end


(*<*)
theory AOT_RestrictedVariables
  imports AOT_PLM
  keywords "AOT_register_rigid_restricted_type" :: thy_goal
       and "AOT_register_restricted_type" :: thy_goal
begin
(*>*)

section\<open>Restricted Variables\<close>

locale AOT_restriction_condition =
  fixes \<psi> :: \<open>'a::AOT_Term_id_2 \<Rightarrow> \<o>\<close>
  assumes "res-var:2"[AOT]: \<open>[v \<Turnstile> \<exists>\<alpha> \<psi>{\<alpha>}]\<close>
  assumes "res-var:3"[AOT]: \<open>[v \<Turnstile> \<psi>{\<tau>} \<rightarrow> \<tau>\<down>]\<close>

ML\<open>
fun register_restricted_type (name:string, restriction:string) thy =
let
val ctxt = thy
val ctxt = setupStrictWorld ctxt
val trm = Syntax.check_term ctxt (AOT_read_term @{nonterminal \<phi>'} ctxt restriction)
val free = case (Term.add_frees trm []) of [f] => f |
    _ => raise Term.TERM ("Expected single free variable.", [trm])
val trm = Term.absfree free trm
val localeTerm = Const (\<^const_name>\<open>AOT_restriction_condition\<close>, dummyT) $ trm
val localeTerm = Syntax.check_term ctxt localeTerm
fun after_qed thms thy = let
val st = Interpretation.global_interpretation
  (([(@{locale AOT_restriction_condition}, ((name, true),
           (Expression.Named [("\<psi>", trm)], [])))], [])) [] thy
val st = Proof.refine_insert (flat thms) st
val thy = Proof.global_immediate_proof st

val thy = Local_Theory.background_theory
  (AOT_Constraints.map (Symtab.update
    (name, (term_of (snd free), term_of (snd free))))) thy
val thy = Local_Theory.background_theory
  (AOT_Restriction.map (Symtab.update
    (name, (trm, Const (\<^const_name>\<open>AOT_term_of_var\<close>, dummyT))))) thy

in thy end
in
Proof.theorem NONE after_qed [[(HOLogic.mk_Trueprop localeTerm, [])]] ctxt
end

val _ =
  Outer_Syntax.command
    \<^command_keyword>\<open>AOT_register_restricted_type\<close>
    "Register a restricted type."
    (((Parse.short_ident --| Parse.$$$ ":") -- Parse.term) >>
    (Toplevel.local_theory_to_proof NONE NONE o register_restricted_type));
\<close>

locale AOT_rigid_restriction_condition = AOT_restriction_condition +
  assumes rigid[AOT]: \<open>[v \<Turnstile> \<forall>\<alpha>(\<psi>{\<alpha>} \<rightarrow> \<box>\<psi>{\<alpha>})]\<close>
begin
lemma rigid_condition[AOT]: \<open>[v \<Turnstile> \<box>(\<psi>{\<alpha>} \<rightarrow> \<box>\<psi>{\<alpha>})]\<close>
  using rigid[THEN "\<forall>E"(2)] RN by simp
lemma type_set_nonempty[AOT_no_atp, no_atp]: \<open>\<exists>x . x \<in> { \<alpha> . [w\<^sub>0 \<Turnstile> \<psi>{\<alpha>}]}\<close>
  by (metis "instantiation" mem_Collect_eq "res-var:2")
end

locale AOT_restricted_type = AOT_rigid_restriction_condition +
  fixes Rep and Abs
  assumes AOT_restricted_type_definition[AOT_no_atp]:
    \<open>type_definition Rep Abs { \<alpha> . [w\<^sub>0 \<Turnstile> \<psi>{\<alpha>}]}\<close>
begin

AOT_theorem restricted_var_condition: \<open>\<psi>{\<guillemotleft>AOT_term_of_var (Rep \<alpha>)\<guillemotright>}\<close>
proof -
  interpret type_definition Rep Abs "{ \<alpha> . [w\<^sub>0 \<Turnstile> \<psi>{\<alpha>}]}"
    using AOT_restricted_type_definition.
  AOT_actually {
    AOT_have \<open>\<guillemotleft>AOT_term_of_var (Rep \<alpha>)\<guillemotright>\<down>\<close> and \<open>\<psi>{\<guillemotleft>AOT_term_of_var (Rep \<alpha>)\<guillemotright>}\<close>
      using AOT_sem_imp Rep "res-var:3" by auto
  }
  moreover AOT_actually {
    AOT_have \<open>\<psi>{\<alpha>} \<rightarrow> \<box>\<psi>{\<alpha>}\<close> for \<alpha>
      using AOT_sem_box rigid_condition by presburger
    AOT_hence \<open>\<psi>{\<tau>} \<rightarrow> \<box>\<psi>{\<tau>}\<close> if \<open>\<tau>\<down>\<close> for \<tau>
      by (metis AOT_model.AOT_term_of_var_cases AOT_sem_denotes that)
  }
  ultimately AOT_show \<open>\<psi>{\<guillemotleft>AOT_term_of_var (Rep \<alpha>)\<guillemotright>}\<close>
    using AOT_sem_box AOT_sem_imp by blast
qed
lemmas "\<psi>" = restricted_var_condition

AOT_theorem GEN: assumes \<open>for arbitrary \<alpha>: \<phi>{\<guillemotleft>AOT_term_of_var (Rep \<alpha>)\<guillemotright>}\<close>
  shows \<open>\<forall>\<alpha> (\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close>
proof(rule GEN; rule "\<rightarrow>I")
  interpret type_definition Rep Abs "{ \<alpha> . [w\<^sub>0 \<Turnstile> \<psi>{\<alpha>}]}"
    using AOT_restricted_type_definition.
  fix \<alpha>
  AOT_assume \<open>\<psi>{\<alpha>}\<close>
  AOT_hence \<open>\<^bold>\<A>\<psi>{\<alpha>}\<close>
    by (metis AOT_model_axiom_def AOT_sem_box AOT_sem_imp act_closure rigid_condition)
  hence 0: \<open>[w\<^sub>0 \<Turnstile> \<psi>{\<alpha>}]\<close> by (metis AOT_sem_act)
  {
    fix \<tau>
    assume \<alpha>_def: \<open>\<alpha> = Rep \<tau>\<close>
    AOT_have \<open>\<phi>{\<alpha>}\<close>
      unfolding \<alpha>_def
      using assms by blast
  }
  AOT_thus \<open>\<phi>{\<alpha>}\<close>
    using Rep_cases[simplified, OF 0]
    by blast
qed
lemmas "\<forall>I" = GEN

end

lemma AOT_restricted_type_intro[AOT_no_atp, no_atp]:
  assumes \<open>type_definition Rep Abs { \<alpha> . [w\<^sub>0 \<Turnstile> \<psi>{\<alpha>}]}\<close>
      and \<open>AOT_rigid_restriction_condition \<psi>\<close>
  shows \<open>AOT_restricted_type \<psi> Rep Abs\<close>
  by (auto intro!: assms AOT_restricted_type_axioms.intro AOT_restricted_type.intro)

ML\<open>
fun register_rigid_restricted_type (name:string, restriction:string) thy =
let
val ctxt = thy
val ctxt = setupStrictWorld ctxt
val trm = Syntax.check_term ctxt (AOT_read_term @{nonterminal \<phi>'} ctxt restriction)
val free = case (Term.add_frees trm []) of [f] => f
  | _ => raise Term.TERM ("Expected single free variable.", [trm])
val trm = Term.absfree free trm
val localeTerm = HOLogic.mk_Trueprop
  (Const (\<^const_name>\<open>AOT_rigid_restriction_condition\<close>, dummyT) $ trm)
val localeTerm = Syntax.check_prop ctxt localeTerm
val int_bnd = Binding.concealed (Binding.qualify true "internal" (Binding.name name))
val bnds = {Rep_name = Binding.qualify true name (Binding.name "Rep"),
            Abs_name = Binding.qualify true "Abs" int_bnd,
            type_definition_name = Binding.qualify true "type_definition" int_bnd}

fun after_qed witts thy = let
  val thms = (map (Element.conclude_witness ctxt) (flat witts))

  val typeset = HOLogic.mk_Collect ("\<alpha>", dummyT,
    \<^const>\<open>AOT_model_valid_in\<close> $ \<^const>\<open>w\<^sub>0\<close> $
    (trm $ (Const (\<^const_name>\<open>AOT_term_of_var\<close>, dummyT) $ Bound 0)))
  val typeset = Syntax.check_term thy typeset
  val nonempty_thm = Drule.OF
    (@{thm AOT_rigid_restriction_condition.type_set_nonempty}, thms)

  val ((_,st),thy) = Typedef.add_typedef {overloaded=true}
    (Binding.name name, [], Mixfix.NoSyn) typeset (SOME bnds)
    (fn ctxt => (Tactic.resolve_tac ctxt ([nonempty_thm]) 1)) thy
  val ({rep_type = _, abs_type = _, Rep_name = Rep_name, Abs_name = Abs_name,
        axiom_name = _},
     {inhabited = _, type_definition = type_definition, Rep = _,
      Rep_inverse = _, Abs_inverse = _, Rep_inject = _, Abs_inject = _,
      Rep_cases = _, Abs_cases = _, Rep_induct = _, Abs_induct = _}) = st

  val locale_thm = Drule.OF (@{thm AOT_restricted_type_intro}, type_definition::thms)

  val st = Interpretation.global_interpretation (([(@{locale AOT_restricted_type},
    ((name, true), (Expression.Named [
      ("\<psi>", trm),
      ("Rep", Const (Rep_name, dummyT)),
      ("Abs", Const (Abs_name, dummyT))], [])))
    ], [])) [] thy

  val st = Proof.refine_insert [locale_thm] st
  val thy = Proof.global_immediate_proof st

  val thy = Local_Theory.background_theory (AOT_Constraints.map (
    Symtab.update (name, (term_of (snd free), term_of (snd free))))) thy
  val thy = Local_Theory.background_theory (AOT_Restriction.map (
    Symtab.update (name, (trm, Const (Rep_name, dummyT))))) thy

  in thy end
in
Element.witness_proof after_qed [[localeTerm]] thy
end

val _ =
  Outer_Syntax.command
    \<^command_keyword>\<open>AOT_register_rigid_restricted_type\<close>
    "Register a restricted type."
    (((Parse.short_ident --| Parse.$$$ ":") -- Parse.term) >>
    (Toplevel.local_theory_to_proof NONE NONE o register_rigid_restricted_type));
\<close>

(* Generalized mechanism for "AOT_restricted_type.\<forall>I" followed by \<forall>E *)
ML\<open>
fun get_instantiated_allI ctxt varname thm = let
val trm = Thm.concl_of thm
val trm = case trm of (@{const Trueprop} $ (@{const AOT_model_valid_in} $ _ $ x)) => x
                      | _ => raise Term.TERM ("Expected simple theorem.", [trm])
fun extractVars (Const (\<^const_name>\<open>AOT_term_of_var\<close>, t) $ (Const rep $ Var v)) =
    (if fst (fst v) = fst varname
     then [Const (\<^const_name>\<open>AOT_term_of_var\<close>, t) $ (Const rep $ Var v)]
     else []) (* TODO: care about the index *)
  | extractVars (t1 $ t2) = extractVars t1 @ extractVars t2
  | extractVars (Abs (_, _, t)) = extractVars t
  | extractVars _ = []
val vars = extractVars trm
val vartrm = hd vars
val vars = fold Term.add_vars vars []
val var = hd vars
val trmty = (case vartrm of (Const (_, Type ("fun", [_, ty])) $ _) => ty
                       | _ => raise Match)
val varty = snd var
val tyname = fst (Term.dest_Type varty)
val b = tyname^".\<forall>I" (* TODO: better way to find the theorem *)
val thms = fst (Context.map_proof_result (fn ctxt => (Attrib.eval_thms ctxt
    [(Facts.Named ((b,Position.none),NONE),[])], ctxt)) ctxt)
val allthm = (case thms of (thm::_) => thm
    | _ => raise Fail "Unknown restricted type.")
val trm = Abs (Term.string_of_vname (fst var), trmty, Term.abstract_over (vartrm, trm))
val trm = Thm.cterm_of (Context.proof_of ctxt) trm
val phi = hd (Term.add_vars (Thm.prop_of allthm) [])
val allthm = Drule.instantiate_normalize (TVars.empty, Vars.make [(phi,trm)]) allthm
in
allthm
end
\<close>

(* TODO: unconstraining multiple variables does not work yet *)
attribute_setup "unconstrain" =
  \<open>Scan.lift (Scan.repeat1 Args.var) >> (fn args => Thm.rule_attribute []
  (fn ctxt => fn thm =>
    let
    val thm = fold (fn arg => fn thm => thm RS get_instantiated_allI ctxt arg thm)
                   args thm
    val thm = fold (fn _ => fn thm => thm RS @{thm "\<forall>E"(2)}) args thm
    in
     thm
    end))\<close>
  "Generalize a statement about restricted variables to a statement about
   unrestricted variables with explicit restriction condition."

context AOT_restricted_type
begin

AOT_theorem "rule-ui":
  assumes \<open>\<forall>\<alpha>(\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close>
  shows \<open>\<phi>{\<guillemotleft>AOT_term_of_var (Rep \<alpha>)\<guillemotright>}\<close>
proof -
  AOT_have \<open>\<phi>{\<alpha>}\<close> if \<open>\<psi>{\<alpha>}\<close> for \<alpha> using assms[THEN "\<forall>E"(2), THEN "\<rightarrow>E"] that by blast
  moreover AOT_have \<open>\<psi>{\<guillemotleft>AOT_term_of_var (Rep \<alpha>)\<guillemotright>}\<close>
    by (auto simp:  \<psi>)
  ultimately show ?thesis by blast
qed
lemmas "\<forall>E" = "rule-ui"

AOT_theorem "instantiation":
  assumes \<open>for arbitrary \<beta>: \<phi>{\<guillemotleft>AOT_term_of_var (Rep \<beta>)\<guillemotright>} \<^bold>\<turnstile> \<chi>\<close> and \<open>\<exists>\<alpha> (\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
  shows \<open>\<chi>\<close>
proof -
  AOT_have \<open>\<phi>{\<guillemotleft>AOT_term_of_var (Rep \<alpha>)\<guillemotright>} \<rightarrow> \<chi>\<close> for \<alpha>
    using assms(1)
    by (simp add: "deduction-theorem")
  AOT_hence 0: \<open>\<forall>\<alpha> (\<psi>{\<alpha>} \<rightarrow> (\<phi>{\<alpha>} \<rightarrow> \<chi>))\<close>
    using GEN by simp
  moreover AOT_obtain \<alpha> where \<open>\<psi>{\<alpha>} & \<phi>{\<alpha>}\<close> using assms(2) "\<exists>E"[rotated] by blast
  ultimately AOT_show \<open>\<chi>\<close> using "AOT_PLM.\<forall>E"(2)[THEN "\<rightarrow>E", THEN "\<rightarrow>E"] "&E" by fast
qed
lemmas "\<exists>E" = "instantiation"

AOT_theorem existential: assumes \<open>\<phi>{\<guillemotleft>AOT_term_of_var (Rep \<beta>)\<guillemotright>}\<close>
  shows \<open>\<exists> \<alpha> (\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
  by (meson AOT_restricted_type.\<psi> AOT_restricted_type_axioms assms
            "&I" "existential:2[const_var]")
lemmas "\<exists>I" = existential
end

context AOT_rigid_restriction_condition
begin

AOT_theorem "res-var-bound-reas[1]":
  \<open>\<forall>\<alpha>(\<psi>{\<alpha>} \<rightarrow> \<forall>\<beta> \<phi>{\<alpha>, \<beta>}) \<equiv> \<forall>\<beta>\<forall>\<alpha> (\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>, \<beta>})\<close>
proof(safe intro!: "\<equiv>I" "\<rightarrow>I" GEN)
  fix \<beta> \<alpha>
  AOT_assume \<open>\<forall>\<alpha> (\<psi>{\<alpha>} \<rightarrow> \<forall>\<beta> \<phi>{\<alpha>, \<beta>})\<close>
  AOT_hence \<open>\<psi>{\<alpha>} \<rightarrow> \<forall>\<beta> \<phi>{\<alpha>, \<beta>}\<close> using "\<forall>E"(2) by blast
  moreover AOT_assume \<open>\<psi>{\<alpha>}\<close>
  ultimately AOT_have \<open>\<forall>\<beta> \<phi>{\<alpha>, \<beta>}\<close> using "\<rightarrow>E" by blast
  AOT_thus \<open>\<phi>{\<alpha>, \<beta>}\<close> using "\<forall>E"(2) by blast
next
  fix \<alpha> \<beta>
  AOT_assume \<open>\<forall>\<beta>\<forall>\<alpha>(\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>, \<beta>})\<close>
  AOT_hence \<open>\<forall>\<alpha>(\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>, \<beta>})\<close> using "\<forall>E"(2) by blast
  AOT_hence \<open>\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>, \<beta>}\<close> using "\<forall>E"(2) by blast
  moreover AOT_assume \<open>\<psi>{\<alpha>}\<close>
  ultimately AOT_show \<open>\<phi>{\<alpha>, \<beta>}\<close> using "\<rightarrow>E" by blast
qed

AOT_theorem "res-var-bound-reas[BF]":
  \<open>\<forall>\<alpha>(\<psi>{\<alpha>} \<rightarrow> \<box>\<phi>{\<alpha>}) \<rightarrow> \<box>\<forall>\<alpha>(\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close>
proof(safe intro!: "\<rightarrow>I")
  AOT_assume \<open>\<forall>\<alpha>(\<psi>{\<alpha>} \<rightarrow> \<box>\<phi>{\<alpha>})\<close>
  AOT_hence \<open>\<psi>{\<alpha>} \<rightarrow> \<box>\<phi>{\<alpha>}\<close> for \<alpha>
    using "\<forall>E"(2) by blast
  AOT_hence \<open>\<box>(\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close> for \<alpha>
    by (metis "sc-eq-box-box:6" rigid_condition "vdash-properties:6")
  AOT_hence \<open>\<forall>\<alpha> \<box>(\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close>
    by (rule GEN)
  AOT_thus \<open>\<box>\<forall>\<alpha> (\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close>
    by (metis "BF" "vdash-properties:6")
qed

AOT_theorem "res-var-bound-reas[CBF]":
\<open>\<box>\<forall>\<alpha>(\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>}) \<rightarrow> \<forall>\<alpha>(\<psi>{\<alpha>} \<rightarrow> \<box>\<phi>{\<alpha>})\<close>
proof(safe intro!: "\<rightarrow>I" GEN)
  fix \<alpha>
  AOT_assume \<open>\<box>\<forall>\<alpha> (\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close>
  AOT_hence \<open>\<forall>\<alpha> \<box>(\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close>
    by (metis "CBF" "vdash-properties:6")
  AOT_hence 1: \<open>\<box>(\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close>
    using "\<forall>E"(2) by blast
  AOT_assume \<open>\<psi>{\<alpha>}\<close>
  AOT_hence \<open>\<box>\<psi>{\<alpha>}\<close>
    by (metis "B\<diamond>" "T\<diamond>" rigid_condition "vdash-properties:6")
  AOT_thus \<open>\<box>\<phi>{\<alpha>}\<close>
    using 1 "qml:1"[axiom_inst, THEN "\<rightarrow>E", THEN "\<rightarrow>E"] by blast
qed

AOT_theorem "res-var-bound-reas[2]":
\<open>\<forall>\<alpha> (\<psi>{\<alpha>} \<rightarrow> \<^bold>\<A>\<phi>{\<alpha>}) \<rightarrow> \<^bold>\<A>\<forall>\<alpha> (\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close>
proof(safe intro!: "\<rightarrow>I")
  AOT_assume \<open>\<forall>\<alpha> (\<psi>{\<alpha>} \<rightarrow> \<^bold>\<A>\<phi>{\<alpha>})\<close>
  AOT_hence \<open>\<psi>{\<alpha>} \<rightarrow> \<^bold>\<A>\<phi>{\<alpha>}\<close> for \<alpha>
    using "\<forall>E"(2) by blast
  AOT_hence \<open>\<^bold>\<A>(\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close> for \<alpha>
    by (metis "sc-eq-box-box:7" rigid_condition "vdash-properties:6")
  AOT_hence \<open>\<forall>\<alpha> \<^bold>\<A>(\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close>
    by (rule GEN)
  AOT_thus \<open>\<^bold>\<A>\<forall>\<alpha>(\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close>
    by (metis "\<equiv>E"(2) "logic-actual-nec:3"[axiom_inst])
qed

AOT_theorem "res-var-bound-reas[3]":
  \<open>\<^bold>\<A>\<forall>\<alpha> (\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>}) \<rightarrow> \<forall>\<alpha> (\<psi>{\<alpha>} \<rightarrow> \<^bold>\<A>\<phi>{\<alpha>})\<close>
proof(safe intro!: "\<rightarrow>I" GEN)
  fix \<alpha>
  AOT_assume \<open>\<^bold>\<A>\<forall>\<alpha> (\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close>
  AOT_hence \<open>\<forall>\<alpha> \<^bold>\<A>(\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close>
    by (metis "\<equiv>E"(1) "logic-actual-nec:3"[axiom_inst])
  AOT_hence 1: \<open>\<^bold>\<A>(\<psi>{\<alpha>} \<rightarrow> \<phi>{\<alpha>})\<close> by (metis "rule-ui:3")
  AOT_assume \<open>\<psi>{\<alpha>}\<close>
  AOT_hence \<open>\<^bold>\<A>\<psi>{\<alpha>}\<close>
    by (metis "nec-imp-act" "qml:2"[axiom_inst] rigid_condition "\<rightarrow>E")
  AOT_thus \<open>\<^bold>\<A>\<phi>{\<alpha>}\<close>
    using 1 by (metis "act-cond" "\<rightarrow>E")
qed

AOT_theorem "res-var-bound-reas[Buridan]":
  \<open>\<exists>\<alpha> (\<psi>{\<alpha>} & \<box>\<phi>{\<alpha>}) \<rightarrow> \<box>\<exists>\<alpha> (\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
proof (rule "\<rightarrow>I")
  AOT_assume \<open>\<exists>\<alpha> (\<psi>{\<alpha>} & \<box>\<phi>{\<alpha>})\<close>
  then AOT_obtain \<alpha> where \<open>\<psi>{\<alpha>} & \<box>\<phi>{\<alpha>}\<close>
    using "\<exists>E"[rotated] by blast
  AOT_hence \<open>\<box>(\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
    by (metis "KBasic:11" "KBasic:3" "T\<diamond>" "&I" "&E"(1) "&E"(2)
              "\<equiv>E"(2) "reductio-aa:1" rigid_condition "vdash-properties:6")
  AOT_hence \<open>\<exists>\<alpha> \<box>(\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
    by (rule "\<exists>I")
  AOT_thus \<open>\<box>\<exists>\<alpha> (\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
    by (rule Buridan[THEN "\<rightarrow>E"])
qed

AOT_theorem "res-var-bound-reas[BF\<diamond>]":
  \<open>\<diamond>\<exists>\<alpha> (\<psi>{\<alpha>} & \<phi>{\<alpha>}) \<rightarrow> \<exists>\<alpha> (\<psi>{\<alpha>} & \<diamond>\<phi>{\<alpha>})\<close>
proof(rule "\<rightarrow>I")
  AOT_assume \<open>\<diamond>\<exists>\<alpha> (\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
  AOT_hence \<open>\<exists>\<alpha> \<diamond>(\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
    using "BF\<diamond>"[THEN "\<rightarrow>E"] by blast
  then AOT_obtain \<alpha> where \<open>\<diamond>(\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
    using "\<exists>E"[rotated] by blast
  AOT_hence \<open>\<diamond>\<psi>{\<alpha>}\<close> and \<open>\<diamond>\<phi>{\<alpha>}\<close>
    using "KBasic2:3" "&E" "\<rightarrow>E" by blast+
  moreover AOT_have \<open>\<psi>{\<alpha>}\<close>
    using calculation rigid_condition by (metis "B\<diamond>" "K\<diamond>" "\<rightarrow>E")
  ultimately AOT_have \<open>\<psi>{\<alpha>} & \<diamond>\<phi>{\<alpha>}\<close>
    using "&I" by blast
  AOT_thus \<open>\<exists>\<alpha> (\<psi>{\<alpha>} & \<diamond>\<phi>{\<alpha>})\<close>
    by (rule "\<exists>I")
qed

AOT_theorem "res-var-bound-reas[CBF\<diamond>]":
  \<open>\<exists>\<alpha> (\<psi>{\<alpha>} & \<diamond>\<phi>{\<alpha>}) \<rightarrow> \<diamond>\<exists>\<alpha> (\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
proof(rule "\<rightarrow>I")
  AOT_assume \<open>\<exists>\<alpha> (\<psi>{\<alpha>} & \<diamond>\<phi>{\<alpha>})\<close>
  then AOT_obtain \<alpha> where \<open>\<psi>{\<alpha>} & \<diamond>\<phi>{\<alpha>}\<close>
    using "\<exists>E"[rotated] by blast
  AOT_hence \<open>\<box>\<psi>{\<alpha>}\<close> and \<open>\<diamond>\<phi>{\<alpha>}\<close>
    using rigid_condition[THEN "qml:2"[axiom_inst, THEN "\<rightarrow>E"], THEN "\<rightarrow>E"] "&E" by blast+
  AOT_hence \<open>\<diamond>(\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
    by (metis "KBasic:16" "con-dis-taut:5" "\<rightarrow>E")
  AOT_hence \<open>\<exists>\<alpha> \<diamond>(\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
    by (rule "\<exists>I")
  AOT_thus \<open>\<diamond>\<exists>\<alpha> (\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
    using "CBF\<diamond>"[THEN "\<rightarrow>E"] by fast
qed

AOT_theorem "res-var-bound-reas[A-Exists:1]":
  \<open>\<^bold>\<A>\<exists>!\<alpha> (\<psi>{\<alpha>} & \<phi>{\<alpha>}) \<equiv> \<exists>!\<alpha> (\<psi>{\<alpha>} & \<^bold>\<A>\<phi>{\<alpha>})\<close>
proof(safe intro!: "\<equiv>I" "\<rightarrow>I")
  AOT_assume \<open>\<^bold>\<A>\<exists>!\<alpha> (\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
  AOT_hence \<open>\<exists>!\<alpha> \<^bold>\<A>(\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
    using "A-Exists:1"[THEN "\<equiv>E"(1)] by blast
  AOT_hence \<open>\<exists>!\<alpha> (\<^bold>\<A>\<psi>{\<alpha>} & \<^bold>\<A>\<phi>{\<alpha>})\<close>
    apply(AOT_subst \<open>\<^bold>\<A>\<psi>{\<alpha>} & \<^bold>\<A>\<phi>{\<alpha>}\<close> \<open>\<^bold>\<A>(\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close> for: \<alpha>)
     apply (meson "Act-Basic:2" "intro-elim:3:f" "oth-class-taut:3:a")
    by simp
  AOT_thus \<open>\<exists>!\<alpha> (\<psi>{\<alpha>} & \<^bold>\<A>\<phi>{\<alpha>})\<close>
    apply (AOT_subst \<open>\<psi>{\<alpha>}\<close> \<open>\<^bold>\<A>\<psi>{\<alpha>}\<close> for: \<alpha>)
    using "Commutativity of \<equiv>" "intro-elim:3:b" "sc-eq-fur:2"
          "\<rightarrow>E" rigid_condition by blast
next
  AOT_assume \<open>\<exists>!\<alpha> (\<psi>{\<alpha>} & \<^bold>\<A>\<phi>{\<alpha>})\<close>
  AOT_hence \<open>\<exists>!\<alpha> (\<^bold>\<A>\<psi>{\<alpha>} & \<^bold>\<A>\<phi>{\<alpha>})\<close>
    apply (AOT_subst \<open>\<^bold>\<A>\<psi>{\<alpha>}\<close> \<open>\<psi>{\<alpha>}\<close> for: \<alpha>)
     apply (meson "sc-eq-fur:2" "\<rightarrow>E" rigid_condition)
    by simp
  AOT_hence \<open>\<exists>!\<alpha> \<^bold>\<A>(\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
    apply (AOT_subst \<open>\<^bold>\<A>(\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close> \<open>\<^bold>\<A>\<psi>{\<alpha>} & \<^bold>\<A>\<phi>{\<alpha>}\<close> for: \<alpha>)
     using "Act-Basic:2" apply presburger
     by simp
  AOT_thus \<open>\<^bold>\<A>\<exists>!\<alpha> (\<psi>{\<alpha>} & \<phi>{\<alpha>})\<close>
     by (metis "A-Exists:1" "intro-elim:3:b")
qed

end

(*<*)
end
(*>*)


section {* Executable Type Checker *}

theory Wasm_Checker imports Wasm_Checker_Types begin

fun convert_cond :: "t \<Rightarrow> t \<Rightarrow> sx option \<Rightarrow> bool" where
  "convert_cond t1 t2 sx = ((t1 \<noteq> t2) \<and> (t_sec t1 = t_sec t2) \<and> (sx = None) = ((is_float_t t1 \<and> is_float_t t2)
                                                        \<or> (is_int_t t1 \<and> is_int_t t2 \<and> (t_length t1 < t_length t2))))"

fun same_lab_h :: "nat list \<Rightarrow> (t list) list \<Rightarrow> t list \<Rightarrow> (t list) option" where
  "same_lab_h [] _ ts = Some ts"
| "same_lab_h (i#is) lab_c ts = (if i \<ge> length lab_c
                                 then None
                                 else (if lab_c!i = ts
                                       then same_lab_h is lab_c (lab_c!i)
                                       else None))"

fun same_lab :: "nat list \<Rightarrow> (t list) list \<Rightarrow> (t list) option" where
  "same_lab [] lab_c = None"
| "same_lab (i#is) lab_c = (if i \<ge> length lab_c
                            then None
                            else same_lab_h is lab_c (lab_c!i))"

lemma same_lab_h_conv_list_all:
  assumes "same_lab_h ils ls ts' = Some ts"
  shows "list_all (\<lambda>i. i < length ls \<and> ls!i = ts) ils \<and> ts' = ts"
  using assms
proof(induction ils)
  case (Cons a ils)
  thus ?case
    apply (simp,safe)
       apply (metis not_less option.distinct(1))+
    done
qed simp

lemma same_lab_conv_list_all:
  assumes "same_lab ils ls = Some ts"
  shows "list_all (\<lambda>i. i < length ls \<and> ls!i = ts) ils"
  using assms
proof (induction rule: same_lab.induct)
case (2 i "is" lab_c)
  thus ?case
    using same_lab_h_conv_list_all
    by (metis (mono_tags, lifting) list_all_simps(1) not_less option.distinct(1) same_lab.simps(2))
qed simp

lemma list_all_conv_same_lab_h:
  assumes "list_all (\<lambda>i. i < length ls \<and> ls!i = ts) ils"
  shows "same_lab_h ils ls ts = Some ts"
  using assms
  by (induction ils, simp_all)

lemma list_all_conv_same_lab:
  assumes "list_all (\<lambda>i. i < length ls \<and>ls!i = ts) (is@[i])"
  shows "same_lab (is@[i]) ls = Some ts"
  using assms
proof (induction "(is@[i])")
  case (Cons a x)
  thus ?case
    using list_all_conv_same_lab_h[OF Cons(3)]
    by (metis option.distinct(1) same_lab.simps(2) same_lab_h.simps(2))
qed auto

fun b_e_type_checker :: "t_context \<Rightarrow>  b_e list \<Rightarrow> tf \<Rightarrow> bool"
and check :: "t_context \<Rightarrow> b_e list \<Rightarrow> checker_type \<Rightarrow> checker_type"
and check_single :: "t_context \<Rightarrow>  b_e \<Rightarrow> checker_type \<Rightarrow> checker_type" where
  "b_e_type_checker \<C> es (tn _> tm) = c_types_agree (check \<C> es (Type tn)) tm"
| "check \<C> es ts = (case es of
                     [] \<Rightarrow> ts
                   | (e#es) \<Rightarrow> (case ts of
                                  Bot \<Rightarrow> Bot
                                | _ \<Rightarrow> check \<C> es (check_single \<C> e ts)))"
(*
foldl (\<lambda> ts e. (case ts of Bot \<Rightarrow> Bot | _ \<Rightarrow> check_single \<C> e ts)) es

primrec foldl :: "('b \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> 'b" where
foldl_Nil:  "foldl f a [] = a" |
foldl_Cons: "foldl f a (x # xs) = foldl f (f a x) xs"
*)
  (* num ops *)
| "check_single \<C> (C v) ts = type_update ts [] (Type [typeof v])"
| "check_single \<C> (Unop_i t _) ts = (if is_int_t t
                                       then type_update ts [TSome t] (Type [t])
                                       else Bot)"
| "check_single \<C> (Unop_f t _) ts = (if is_float_t t
                                       then type_update ts [TSome t] (Type [t])
                                       else Bot)"
| "check_single \<C> (Binop_i t iop) ts = (if is_int_t t \<and> (is_secret_t t \<longrightarrow> safe_binop_i iop)
                                          then type_update ts [TSome t, TSome t] (Type [t])
                                       else Bot)"
| "check_single \<C> (Binop_f t _) ts = (if is_float_t t
                                       then type_update ts [TSome t, TSome t] (Type [t])
                                       else Bot)"
| "check_single \<C> (Testop t _) ts = (if is_int_t t
                                       then type_update ts [TSome t] (Type [T_i32 (t_sec t)])
                                       else Bot)"
| "check_single \<C> (Relop_i t _) ts = (if is_int_t t
                                       then type_update ts [TSome t, TSome t] (Type [T_i32 (t_sec t)])
                                       else Bot)"
| "check_single \<C> (Relop_f t _) ts =  (if is_float_t t
                                       then type_update ts [TSome t, TSome t] (Type [T_i32 (t_sec t)])
                                       else Bot)"
  (* convert *)
| "check_single \<C> (Cvtop t1 Convert t2 sx) ts = (if (convert_cond t1 t2 sx)
                                                   then type_update ts [TSome t2] (Type [t1])
                                                   else Bot)"
  (* reinterpret *)
| "check_single \<C> (Cvtop t1 Reinterpret t2 sx) ts = (if ((t1 \<noteq> t2) \<and> (t_sec t1 = t_sec t2) \<and> t_length t1 = t_length t2 \<and> sx = None)
                                                       then type_update ts [TSome t2] (Type [t1])
                                                       else Bot)"
  (* classify *)
| "check_single \<C> (Cvtop t1 Classify t2 sx) ts = (if (is_int_t t2 \<and> is_public_t t2 \<and> classify_t t2 = t1 \<and> sx = None)
                                                    then type_update ts [TSome t2] (Type [t1])
                                                    else Bot)"
  (* declassify *)
| "check_single \<C> (Cvtop t1 Declassify t2 sx) ts = (if ((trust_t \<C>) = Trusted \<and> is_int_t t2 \<and> is_secret_t t2 \<and> declassify_t t2 = t1 \<and> sx = None)
                                                    then type_update ts [TSome t2] (Type [t1])
                                                    else Bot)"
  (* unreachable, nop, drop, select *)
| "check_single \<C> (Unreachable) ts = type_update ts [] (TopType [])"
| "check_single \<C> (Nop) ts = ts"
| "check_single \<C> (Drop) ts = type_update ts [TAny] (Type [])"
| "check_single \<C> (Select sec) ts = type_update_select sec ts"
  (* block *)
| "check_single \<C> (Block (tn _> tm) es) ts = (if (b_e_type_checker (\<C>\<lparr>label := ([tm] @ (label \<C>))\<rparr>) es (tn _> tm))
                                                then type_update ts (to_ct_list tn) (Type tm)
                                                else Bot)"
  (* loop *)
| "check_single \<C> (Loop (tn _> tm) es) ts = (if (b_e_type_checker (\<C>\<lparr>label := ([tn] @ (label \<C>))\<rparr>) es (tn _> tm))
                                                then type_update ts (to_ct_list tn) (Type tm)
                                                else Bot)"
  (* if *)
| "check_single \<C> (If (tn _> tm) es1 es2) ts = (if (b_e_type_checker (\<C>\<lparr>label := ([tm] @ (label \<C>))\<rparr>) es1 (tn _> tm)
                                                    \<and> b_e_type_checker (\<C>\<lparr>label := ([tm] @ (label \<C>))\<rparr>) es2 (tn _> tm))
                                                then type_update ts (to_ct_list (tn@[T_i32 Public])) (Type tm)
                                                else Bot)"
  (* br *)
| "check_single \<C> (Br i) ts = (if i < length (label \<C>)
                                 then type_update ts (to_ct_list ((label \<C>)!i)) (TopType [])
                                 else Bot)"
  (* br_if *)
| "check_single \<C> (Br_if i) ts = (if i < length (label \<C>)
                                    then type_update ts (to_ct_list ((label \<C>)!i @ [T_i32 Public])) (Type ((label \<C>)!i))
                                    else Bot)"
  (* br_table *)
| "check_single \<C> (Br_table is i) ts = (case (same_lab (is@[i]) (label \<C>)) of
                                        None \<Rightarrow> Bot
                                      | Some tls \<Rightarrow> type_update ts (to_ct_list (tls @ [T_i32 Public])) (TopType []))"
  (* return *)
| "check_single \<C> (Return) ts = (case (return \<C>) of
                                   None \<Rightarrow> Bot
                                 | Some tls \<Rightarrow> type_update ts (to_ct_list tls) (TopType []))"
  (* call *)
| "check_single \<C> (Call i) ts = (if i < length (func_t \<C>)
                                    then (case ((func_t \<C>)!i) of
                                            (tr,(tn _> tm)) \<Rightarrow> if (trust_compat (trust_t \<C>) tr)
                                                                 then type_update ts (to_ct_list tn) (Type tm)
                                                                 else Bot)
                                    else Bot)"
  (* call_indirect *)
| "check_single \<C> (Call_indirect i) ts = (if (table \<C>) \<noteq> None \<and> i < length (types_t \<C>)
                                            then (case ((types_t \<C>)!i) of
                                                    (tr,(tn _> tm)) \<Rightarrow> if (trust_compat (trust_t \<C>) tr)
                                                                         then type_update ts (to_ct_list (tn@[T_i32 Public])) (Type tm)
                                                                         else Bot)
                                            else Bot)"
  (* get_local *)
| "check_single \<C> (Get_local i) ts = (if i < length (local \<C>)
                                        then type_update ts [] (Type [(local \<C>)!i])
                                        else Bot)"
  (* set_local *)
| "check_single \<C> (Set_local i) ts = (if i < length (local \<C>)
                                        then type_update ts [TSome ((local \<C>)!i)] (Type [])
                                        else Bot)"
  (* tee_local *)
| "check_single \<C> (Tee_local i) ts = (if i < length (local \<C>)
                                 then type_update ts [TSome ((local \<C>)!i)] (Type [(local \<C>)!i])
                                 else Bot)"
  (* get_global *)
| "check_single \<C> (Get_global i) ts = (if i < length (global \<C>)
                                         then type_update ts [] (Type [tg_t ((global \<C>)!i)])
                                         else Bot)"
  (* set_global *)
| "check_single \<C> (Set_global i) ts = (if i < length (global \<C>) \<and> is_mut (global \<C> ! i)
                                         then type_update ts [TSome (tg_t ((global \<C>)!i))] (Type [])
                                         else Bot)"
  (* load *)
| "check_single \<C> (Load t tp_sx a off) ts =
                              (case (memory \<C>) of
                                 Some (m, sec) \<Rightarrow>
                                 if t_sec t = sec \<and> load_store_t_bounds a (option_projl tp_sx) t
                                   then type_update ts [TSome (T_i32 Public)] (Type [t])
                                   else Bot
                               | None \<Rightarrow> Bot)"
  (* store *)
| "check_single \<C> (Store t tp a off) ts =
                              (case (memory \<C>) of
                                 Some (m, sec) \<Rightarrow>
                                 if t_sec t = sec \<and> load_store_t_bounds a tp t
                                   then type_update ts [TSome (T_i32 Public),TSome t] (Type [])
                                   else Bot
                               | None \<Rightarrow> Bot)"
  (* current_memory *)
| "check_single \<C> Current_memory ts = (if (memory \<C>) \<noteq> None
                                         then type_update ts [] (Type [T_i32 Public])
                                         else Bot)"
  (* grow_memory *)
| "check_single \<C> Grow_memory ts = (if (memory \<C>) \<noteq> None
                                      then type_update ts [TSome (T_i32 Public)] (Type [T_i32 Public])
                                      else Bot)"

end


theory SuccessSensitiveness
  imports SourceTargetRelation
begin

section \<open>Success Sensitiveness and Barbs\<close>

text \<open>To compare the abstract behavior of two terms, often some notion of success or successful
        termination is used. Daniele Gorla assumes a constant process (similar to the empty
        process) that represents successful termination in order to compare the behavior of source
        terms with their literal translations. Then an encoding is success sensitive if, for all
        source terms S, S reaches success iff the translation of S reaches success. Successful
        termination can be considered as some special kind of barb. Accordingly we generalize
        successful termination to the respection of an arbitrary subset of barbs. An encoding
        respects a set of barbs if, for every source term S and all considered barbs a, S reaches a
        iff the translation of S reaches a.\<close>

abbreviation (in encoding_wrt_barbs) enc_weakly_preserves_barb_set :: "'barbs set \<Rightarrow> bool" where
  "enc_weakly_preserves_barb_set Barbs \<equiv> enc_preserves_binary_pred (\<lambda>P a. a \<in> Barbs \<and> P\<Down>.a)"

abbreviation (in encoding_wrt_barbs) enc_weakly_preserves_barbs :: "bool" where
  "enc_weakly_preserves_barbs \<equiv> enc_preserves_binary_pred (\<lambda>P a. P\<Down>.a)"

lemma (in encoding_wrt_barbs) enc_weakly_preserves_barbs_and_barb_set:
  shows "enc_weakly_preserves_barbs = (\<forall>Barbs. enc_weakly_preserves_barb_set Barbs)"
    by blast

abbreviation (in encoding_wrt_barbs) enc_weakly_reflects_barb_set :: "'barbs set \<Rightarrow> bool" where
  "enc_weakly_reflects_barb_set Barbs \<equiv> enc_reflects_binary_pred (\<lambda>P a. a \<in> Barbs \<and> P\<Down>.a)"

abbreviation (in encoding_wrt_barbs) enc_weakly_reflects_barbs :: "bool" where
  "enc_weakly_reflects_barbs \<equiv> enc_reflects_binary_pred (\<lambda>P a. P\<Down>.a)"

lemma (in encoding_wrt_barbs) enc_weakly_reflects_barbs_and_barb_set:
  shows "enc_weakly_reflects_barbs = (\<forall>Barbs. enc_weakly_reflects_barb_set Barbs)"
    by blast

abbreviation (in encoding_wrt_barbs) enc_weakly_respects_barb_set :: "'barbs set \<Rightarrow> bool" where
  "enc_weakly_respects_barb_set Barbs \<equiv>
   enc_weakly_preserves_barb_set Barbs \<and> enc_weakly_reflects_barb_set Barbs"

abbreviation (in encoding_wrt_barbs) enc_weakly_respects_barbs :: "bool" where
  "enc_weakly_respects_barbs \<equiv> enc_weakly_preserves_barbs \<and> enc_weakly_reflects_barbs"

lemma (in encoding_wrt_barbs) enc_weakly_respects_barbs_and_barb_set:
  shows "enc_weakly_respects_barbs = (\<forall>Barbs. enc_weakly_respects_barb_set Barbs)"
proof -
  have "(\<forall>Barbs. enc_weakly_respects_barb_set Barbs)
        = (\<forall>Barbs. (\<forall>S x. x \<in> Barbs \<and> S\<Down><SWB>x \<longrightarrow> \<lbrakk>S\<rbrakk>\<Down><TWB>x)
          \<and> (\<forall>S x. x \<in> Barbs \<and> \<lbrakk>S\<rbrakk>\<Down><TWB>x \<longrightarrow> S\<Down><SWB>x))"
    by simp
  hence "(\<forall>Barbs. enc_weakly_respects_barb_set Barbs)
        = ((\<forall>Barbs. enc_weakly_preserves_barb_set Barbs)
            \<and> (\<forall>Barbs. enc_weakly_reflects_barb_set Barbs))"
    apply simp by fast
  thus ?thesis
    apply simp by blast
qed

text \<open>An encoding strongly respects some set of barbs if, for every source term S and all
        considered barbs a, S has a iff the translation of S has a.\<close>

abbreviation (in encoding_wrt_barbs) enc_preserves_barb_set :: "'barbs set \<Rightarrow> bool" where
  "enc_preserves_barb_set Barbs \<equiv> enc_preserves_binary_pred (\<lambda>P a. a \<in> Barbs \<and> P\<down>.a)"

abbreviation (in encoding_wrt_barbs) enc_preserves_barbs :: "bool" where
  "enc_preserves_barbs \<equiv> enc_preserves_binary_pred (\<lambda>P a. P\<down>.a)"

lemma (in encoding_wrt_barbs) enc_preserves_barbs_and_barb_set:
  shows "enc_preserves_barbs = (\<forall>Barbs. enc_preserves_barb_set Barbs)"
    by blast

abbreviation (in encoding_wrt_barbs) enc_reflects_barb_set :: "'barbs set \<Rightarrow> bool" where
  "enc_reflects_barb_set Barbs \<equiv> enc_reflects_binary_pred (\<lambda>P a. a \<in> Barbs \<and> P\<down>.a)"

abbreviation (in encoding_wrt_barbs) enc_reflects_barbs :: "bool" where
  "enc_reflects_barbs \<equiv> enc_reflects_binary_pred (\<lambda>P a. P\<down>.a)"

lemma (in encoding_wrt_barbs) enc_reflects_barbs_and_barb_set:
  shows "enc_reflects_barbs = (\<forall>Barbs. enc_reflects_barb_set Barbs)"
    by blast

abbreviation (in encoding_wrt_barbs) enc_respects_barb_set :: "'barbs set \<Rightarrow> bool" where
  "enc_respects_barb_set Barbs \<equiv> enc_preserves_barb_set Barbs \<and> enc_reflects_barb_set Barbs"

abbreviation (in encoding_wrt_barbs) enc_respects_barbs :: "bool" where
  "enc_respects_barbs \<equiv> enc_preserves_barbs \<and> enc_reflects_barbs"

lemma (in encoding_wrt_barbs) enc_respects_barbs_and_barb_set:
  shows "enc_respects_barbs = (\<forall>Barbs. enc_respects_barb_set Barbs)"
proof -
  have "(\<forall>Barbs. enc_respects_barb_set Barbs)
        = ((\<forall>Barbs. enc_preserves_barb_set Barbs)
            \<and> (\<forall>Barbs. enc_reflects_barb_set Barbs))"
    apply simp by fast
  thus ?thesis
    apply simp by blast
qed

text \<open>An encoding (weakly) preserves barbs iff
        (1) there exists a relation, like indRelR, that relates source terms and their literal
            translations and preserves (reachability/)existence of barbs, or
        (2) there exists a relation, like indRelL, that relates literal translations and their
            source terms and reflects (reachability/)existence of barbs.\<close>

lemma (in encoding_wrt_barbs) enc_weakly_preserves_barb_set_iff_source_target_rel:
  fixes Barbs :: "'barbs set"
    and TRel  :: "('procT \<times> 'procT) set"
  shows "enc_weakly_preserves_barb_set Barbs
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_weakly_preserves_barb_set Rel (STCalWB SWB TWB) Barbs)"
      using enc_preserves_binary_pred_iff_source_target_rel_preserves_binary_pred[where
             Pred="\<lambda>P a. a \<in> Barbs \<and> P\<Down><STCalWB SWB TWB>a"] STCalWB_reachesBarbST
    by simp

lemma (in encoding_wrt_barbs) enc_weakly_preserves_barbs_iff_source_target_rel:
  shows "enc_weakly_preserves_barbs
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_weakly_preserves_barbs Rel (STCalWB SWB TWB))"
      using enc_preserves_binary_pred_iff_source_target_rel_preserves_binary_pred[where
             Pred="\<lambda>P a. P\<Down><STCalWB SWB TWB>a"] STCalWB_reachesBarbST
    by simp

lemma (in encoding_wrt_barbs) enc_preserves_barb_set_iff_source_target_rel:
  fixes Barbs :: "'barbs set"
  shows "enc_preserves_barb_set Barbs
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_preserves_barb_set Rel (STCalWB SWB TWB) Barbs)"
      using enc_preserves_binary_pred_iff_source_target_rel_preserves_binary_pred[where
             Pred="\<lambda>P a. a \<in> Barbs \<and> P\<down><STCalWB SWB TWB>a"] STCalWB_hasBarbST
    by simp

lemma (in encoding_wrt_barbs) enc_preserves_barbs_iff_source_target_rel:
  shows "enc_preserves_barbs
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_preserves_barbs Rel (STCalWB SWB TWB))"
      using enc_preserves_binary_pred_iff_source_target_rel_preserves_binary_pred[where
             Pred="\<lambda>P a. P\<down><STCalWB SWB TWB>a"] STCalWB_hasBarbST
    by simp

text \<open>An encoding (weakly) reflects barbs iff
        (1) there exists a relation, like indRelR, that relates source terms and their literal
            translations and reflects (reachability/)existence of barbs, or
        (2) there exists a relation, like indRelL, that relates literal translations and their
            source terms and preserves (reachability/)existence of barbs.\<close>

lemma (in encoding_wrt_barbs) enc_weakly_reflects_barb_set_iff_source_target_rel:
  fixes Barbs :: "'barbs set"
  shows "enc_weakly_reflects_barb_set Barbs
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_weakly_reflects_barb_set Rel (STCalWB SWB TWB) Barbs)"
      using enc_reflects_binary_pred_iff_source_target_rel_reflects_binary_pred[where
             Pred="\<lambda>P a. a \<in> Barbs \<and> P\<Down><STCalWB SWB TWB>a"] STCalWB_reachesBarbST
    by simp

lemma (in encoding_wrt_barbs) enc_weakly_reflects_barbs_iff_source_target_rel:
  shows "enc_weakly_reflects_barbs
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_weakly_reflects_barbs Rel (STCalWB SWB TWB))"
      using enc_reflects_binary_pred_iff_source_target_rel_reflects_binary_pred[where
             Pred="\<lambda>P a. P\<Down><STCalWB SWB TWB>a"] STCalWB_reachesBarbST
    by simp

lemma (in encoding_wrt_barbs) enc_reflects_barb_set_iff_source_target_rel:
  fixes Barbs :: "'barbs set"
  shows "enc_reflects_barb_set Barbs
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_reflects_barb_set Rel (STCalWB SWB TWB) Barbs)"
      using enc_reflects_binary_pred_iff_source_target_rel_reflects_binary_pred[where
             Pred="\<lambda>P a. a \<in> Barbs \<and> P\<down><STCalWB SWB TWB>a"] STCalWB_hasBarbST
    by simp

lemma (in encoding_wrt_barbs) enc_reflects_barbs_iff_source_target_rel:
  shows "enc_reflects_barbs
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_reflects_barbs Rel (STCalWB SWB TWB))"
      using enc_reflects_binary_pred_iff_source_target_rel_reflects_binary_pred[where
             Pred="\<lambda>P a. P\<down><STCalWB SWB TWB>a"] STCalWB_hasBarbST
    by simp

text \<open>An encoding (weakly) respects barbs iff
        (1) there exists a relation, like indRelR, that relates source terms and their literal
            translations and respects (reachability/)existence of barbs, or
        (2) there exists a relation, like indRelL, that relates literal translations and their
            source terms and respects (reachability/)existence of barbs, or
        (3) there exists a relation, like indRel, that relates source terms and their literal
            translations in both directions and respects (reachability/)existence of barbs.\<close>

lemma (in encoding_wrt_barbs) enc_weakly_respects_barb_set_iff_source_target_rel:
  fixes Barbs :: "'barbs set"
  shows "enc_weakly_respects_barb_set Barbs
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_weakly_respects_barb_set Rel (STCalWB SWB TWB) Barbs)"
      using enc_respects_binary_pred_iff_source_target_rel_respects_binary_pred_encR[where
             Pred="\<lambda>P a. a \<in> Barbs \<and> P\<Down><STCalWB SWB TWB>a"] STCalWB_reachesBarbST
    by simp

lemma (in encoding_wrt_barbs) enc_weakly_respects_barbs_iff_source_target_rel:
  shows "enc_weakly_respects_barbs
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_weakly_respects_barbs Rel (STCalWB SWB TWB))"
      using enc_respects_binary_pred_iff_source_target_rel_respects_binary_pred_encR[where
             Pred="\<lambda>P a. P\<Down><STCalWB SWB TWB>a"] STCalWB_reachesBarbST
    by simp

lemma (in encoding_wrt_barbs) enc_respects_barb_set_iff_source_target_rel:
  fixes Barbs :: "'barbs set"
  shows "enc_respects_barb_set Barbs
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_respects_barb_set Rel (STCalWB SWB TWB) Barbs)"
      using enc_respects_binary_pred_iff_source_target_rel_respects_binary_pred_encR[where
             Pred="\<lambda>P a. a \<in> Barbs \<and> P\<down><STCalWB SWB TWB>a"] STCalWB_hasBarbST
    by simp

lemma (in encoding_wrt_barbs) enc_respects_barbs_iff_source_target_rel:
  shows "enc_respects_barbs
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_respects_barbs Rel (STCalWB SWB TWB))"
      using enc_respects_binary_pred_iff_source_target_rel_respects_binary_pred_encR[where
             Pred="\<lambda>P a. P\<down><STCalWB SWB TWB>a"] STCalWB_hasBarbST
    by simp

text \<open>Accordingly an encoding is success sensitive iff there exists such a relation between
        source and target terms that weakly respects the barb success.\<close>

lemma (in encoding_wrt_barbs) success_sensitive_cond:
  fixes success :: "'barbs"
  shows "enc_weakly_respects_barb_set {success} = (\<forall>S. S\<Down><SWB>success \<longleftrightarrow> \<lbrakk>S\<rbrakk>\<Down><TWB>success)"
    by auto

lemma (in encoding_wrt_barbs) success_sensitive_iff_source_target_rel_weakly_respects_success:
  fixes success :: "'barbs"
  shows "enc_weakly_respects_barb_set {success}
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_weakly_respects_barb_set Rel (STCalWB SWB TWB) {success})"
    by (rule enc_weakly_respects_barb_set_iff_source_target_rel[where Barbs="{success}"])+

lemma (in encoding_wrt_barbs) success_sensitive_iff_source_target_rel_respects_success:
  fixes success :: "'barbs"
  shows "enc_respects_barb_set {success}
         = (\<exists>Rel. (\<forall>S. (SourceTerm S, TargetTerm (\<lbrakk>S\<rbrakk>)) \<in> Rel)
            \<and> rel_respects_barb_set Rel (STCalWB SWB TWB) {success})"
    by (rule enc_respects_barb_set_iff_source_target_rel[where Barbs="{success}"])

end


(*  Title:      Containers/RBT_Set2.thy
    Author:     Andreas Lochbihler, KIT *)

theory RBT_Set2
imports
  RBT_Mapping2
begin

section \<open>Sets implemented by red-black trees\<close>

lemma map_of_map_Pair_const:
  "map_of (map (\<lambda>x. (x, v)) xs) = (\<lambda>x. if x \<in> set xs then Some v else None)"
by(induct xs) auto

lemma map_of_rev_unit [simp]:
  fixes xs :: "('a * unit) list"
  shows "map_of (rev xs) = map_of xs"
by(induct xs rule: rev_induct)(auto simp add: map_add_def split: option.split)

lemma fold_split_conv_map_fst: "fold (\<lambda>(x, y). f x) xs = fold f (map fst xs)"
by(simp add: fold_map o_def split_def)

lemma foldr_split_conv_map_fst: "foldr (\<lambda>(x, y). f x) xs = foldr f (map fst xs)"
by(simp add: foldr_map o_def split_def fun_eq_iff)

lemma set_foldr_Cons:
  "set (foldr (\<lambda>x xs. if P x xs then x # xs else xs) as []) \<subseteq> set as"
by(induct as) auto

lemma distinct_fst_foldr_Cons:
  "distinct (map f as) \<Longrightarrow> distinct (map f (foldr (\<lambda>x xs. if P x xs then x # xs else xs) as []))"
proof(induct as)
  case (Cons a as)
  with set_foldr_Cons[of P as] show ?case by auto
qed simp

lemma filter_conv_foldr:
  "filter P xs = foldr (\<lambda>x xs. if P x then x # xs else xs) xs []"
by(induct xs) simp_all

lemma map_of_filter: "map_of (filter (\<lambda>x. P (fst x)) xs) = map_of xs |` Collect P"
by(induct xs)(simp_all add: fun_eq_iff restrict_map_def)

lemma map_of_map_Pair_key: "map_of (map (\<lambda>k. (k, f k)) xs) x = (if x \<in> set xs then Some (f x) else None)"
by(induct xs) simp_all

lemma neq_Empty_conv: "t \<noteq> rbt.Empty \<longleftrightarrow> (\<exists>c l k v r. t = Branch c l k v r)"
by(cases t) simp_all

context linorder begin

lemma is_rbt_RBT_fold_rbt_insert [simp]:
  "is_rbt t \<Longrightarrow> is_rbt (fold (\<lambda>(k, v). rbt_insert k v) xs t)"
by(induct xs arbitrary: t)(simp_all add: split_beta)

lemma rbt_lookup_RBT_fold_rbt_insert [simp]:
  "is_rbt t \<Longrightarrow> rbt_lookup (fold (\<lambda>(k, v). rbt_insert k v) xs t) = rbt_lookup t ++ map_of (rev xs)"
apply(induct xs arbitrary: t rule: rev_induct)
apply(simp_all add: split_beta fun_eq_iff rbt_lookup_rbt_insert)
done

lemma is_rbt_fold_rbt_delete [simp]:
  "is_rbt t \<Longrightarrow> is_rbt (fold rbt_delete xs t)"
by(induct xs arbitrary: t)(simp_all)

lemma rbt_lookup_fold_rbt_delete [simp]:
  "is_rbt t \<Longrightarrow> rbt_lookup (fold rbt_delete xs t) = rbt_lookup t |` (- set xs)"
apply(induct xs rule: rev_induct)
apply(simp_all add: rbt_lookup_rbt_delete ext)
apply(metis Un_insert_right compl_sup sup_bot_right)
done

lemma is_rbt_fold_rbt_insert: "is_rbt t \<Longrightarrow> is_rbt (fold (\<lambda>k. rbt_insert k (f k)) xs t)"
by(induct xs rule: rev_induct) simp_all

lemma rbt_lookup_fold_rbt_insert:
  "is_rbt t \<Longrightarrow>
  rbt_lookup (fold (\<lambda>k. rbt_insert k (f k)) xs t) =
  rbt_lookup t ++ map_of (map (\<lambda>k. (k, f k)) xs)"
by(induct xs arbitrary: t)(auto simp add: rbt_lookup_rbt_insert map_add_def fun_eq_iff map_of_map_Pair_key split: option.splits)

end

definition fold_rev :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> 'c \<Rightarrow> 'c"
where "fold_rev f t = List.foldr (\<lambda>(k, v). f k v) (RBT_Impl.entries t)"

lemma fold_rev_simps [simp, code]:
  "fold_rev f RBT_Impl.Empty = id"
  "fold_rev f (Branch c l k v r) = fold_rev f l o f k v o fold_rev f r"
by(simp_all add: fold_rev_def fun_eq_iff)

definition (in ord) rbt_minus :: "('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
where
  "rbt_minus t1 t2 =
  (let h1 = bheight t1; h2 = bheight t2
   in if 2 * h1 \<le> h2 then rbtreeify (fold_rev (\<lambda>k v kvs. if rbt_lookup t2 k = None then (k, v) # kvs else kvs) t1 [])
      else RBT_Impl.fold (\<lambda>k v. rbt_delete k) t2 t1)"

definition rbt_comp_minus :: "'a comparator \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
where
  "rbt_comp_minus c t1 t2 =
  (let h1 = bheight t1; h2 = bheight t2
   in if 2 * h1 \<le> h2 then rbtreeify (fold_rev (\<lambda>k v kvs. if rbt_comp_lookup c t2 k = None then (k, v) # kvs else kvs) t1 [])
      else RBT_Impl.fold (\<lambda>k v. rbt_comp_delete c k) t2 t1)"

lemma rbt_comp_minus: assumes c: "comparator c"
  shows "rbt_comp_minus c = ord.rbt_minus (lt_of_comp c)"
  by (intro ext, unfold rbt_comp_minus_def ord.rbt_minus_def, auto simp: rbt_comp_simps[OF c])

context linorder begin

lemma sorted_fst_foldr_Cons:
  "sorted (map f as) \<Longrightarrow> sorted (map f (foldr (\<lambda>x xs. if P x xs then x # xs else xs) as []))"
proof(induct as)
  case (Cons a as)
  with set_foldr_Cons[of P as] show ?case by(auto)
qed simp

lemma is_rbt_rbt_minus:
  "\<lbrakk> is_rbt t1; is_rbt t2 \<rbrakk> \<Longrightarrow> is_rbt (rbt_minus t1 t2)"
by(auto simp add: rbt_minus_def Let_def RBT_Impl.fold_def fold_rev_def is_rbt_fold_rbt_delete[where xs="map fst (RBT_Impl.entries t2)", simplified fold_map o_def] split_def is_rbt_rbtreeify sorted_fst_foldr_Cons rbt_sorted_entries distinct_fst_foldr_Cons distinct_entries cong: if_cong)

lemma rbt_lookup_rbt_minus:
  "\<lbrakk> is_rbt t1; is_rbt t2 \<rbrakk>
  \<Longrightarrow> rbt_lookup (rbt_minus t1 t2) = rbt_lookup t1 |` (- dom (rbt_lookup t2))"
apply(clarsimp simp add: rbt_minus_def Let_def domIff[symmetric] rbt_lookup_keys rbt_lookup_rbtreeify RBT_Impl.keys_def trans[OF RBT_Impl.fold_def fold_split_conv_map_fst] split_def sorted_fst_foldr_Cons rbt_sorted_entries distinct_fst_foldr_Cons distinct_entries fold_rev_def simp del: set_map cong: if_cong)
apply(auto simp add: map_of_entries[symmetric] filter_conv_foldr[symmetric] map_of_filter[where P="\<lambda>k. map_of (RBT_Impl.entries t2) k = None"] intro!: arg_cong[where f="\<lambda>x. map_of (RBT_Impl.entries t1) |` x"] dest: map_of_eq_None_iff[THEN iffD1] intro: map_of_eq_None_iff[THEN iffD2])
done

end

subsection \<open>Type and operations\<close>

type_synonym 'a set_rbt = "('a, unit) mapping_rbt"

translations
  (type) "'a set_rbt" <= (type) "('a, unit) mapping_rbt"

abbreviation (input) Set_RBT :: "('a :: ccompare, unit) RBT_Impl.rbt \<Rightarrow> 'a set_rbt"
where "Set_RBT \<equiv> Mapping_RBT"

subsection \<open>Primitive operations\<close>

lift_definition member :: "'a :: ccompare set_rbt \<Rightarrow> 'a \<Rightarrow> bool" is
  "\<lambda>t x. x \<in> dom (rbt_comp_lookup ccomp t)" .

abbreviation empty :: "'a :: ccompare set_rbt"
where "empty \<equiv> RBT_Mapping2.empty"

abbreviation insert :: "'a :: ccompare \<Rightarrow> 'a set_rbt \<Rightarrow> 'a set_rbt"
where "insert k \<equiv> RBT_Mapping2.insert k ()"

abbreviation remove :: "'a :: ccompare \<Rightarrow> 'a set_rbt \<Rightarrow> 'a set_rbt"
where "remove \<equiv> RBT_Mapping2.delete"

lift_definition bulkload :: "'a :: ccompare list \<Rightarrow> 'a set_rbt" is
  "rbt_comp_bulkload ccomp \<circ> map (\<lambda>x. (x, ()))"
by(auto 4 3 intro: linorder.rbt_bulkload_is_rbt ID_ccompare simp: rbt_comp_bulkload[OF ID_ccompare'])

abbreviation is_empty :: "'a :: ccompare set_rbt \<Rightarrow> bool"
where "is_empty \<equiv> RBT_Mapping2.is_empty"

abbreviation union :: "'a :: ccompare set_rbt \<Rightarrow> 'a set_rbt \<Rightarrow> 'a set_rbt"
where "union \<equiv> RBT_Mapping2.join (\<lambda>_ _. id)"

abbreviation inter :: "'a :: ccompare set_rbt \<Rightarrow> 'a set_rbt \<Rightarrow> 'a set_rbt"
where "inter \<equiv> RBT_Mapping2.meet (\<lambda>_ _. id)"

lift_definition inter_list :: "'a :: ccompare set_rbt \<Rightarrow> 'a list \<Rightarrow> 'a set_rbt" is
  "\<lambda>t xs. fold (\<lambda>k. rbt_comp_insert ccomp k ()) [x \<leftarrow> xs. rbt_comp_lookup ccomp t x \<noteq> None] RBT_Impl.Empty"
by(auto 4 3 intro: ID_ccompare linorder.is_rbt_fold_rbt_insert ord.Empty_is_rbt simp: rbt_comp_simps[OF ID_ccompare'])

lift_definition minus :: "'a :: ccompare set_rbt \<Rightarrow> 'a set_rbt \<Rightarrow> 'a set_rbt" is
  "rbt_comp_minus ccomp"
by(auto 4 3 intro: linorder.is_rbt_rbt_minus ID_ccompare simp: rbt_comp_minus[OF ID_ccompare'])

abbreviation filter :: "('a :: ccompare \<Rightarrow> bool) \<Rightarrow> 'a set_rbt \<Rightarrow> 'a set_rbt"
where "filter P \<equiv> RBT_Mapping2.filter (P \<circ> fst)"

lift_definition fold :: "('a :: ccompare \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a set_rbt \<Rightarrow> 'b \<Rightarrow> 'b" is "\<lambda>f. RBT_Impl.fold (\<lambda>a _. f a)" .

lift_definition fold1 :: "('a :: ccompare \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a set_rbt \<Rightarrow> 'a" is "RBT_Impl_fold1" .

lift_definition keys :: "'a :: ccompare set_rbt \<Rightarrow> 'a list" is "RBT_Impl.keys" .

abbreviation all :: "('a :: ccompare \<Rightarrow> bool) \<Rightarrow> 'a set_rbt \<Rightarrow> bool"
where "all P \<equiv> RBT_Mapping2.all (\<lambda>k _. P k)"

abbreviation ex :: "('a :: ccompare \<Rightarrow> bool) \<Rightarrow> 'a set_rbt \<Rightarrow> bool"
where "ex P \<equiv> RBT_Mapping2.ex (\<lambda>k _. P k)"

definition product :: "'a :: ccompare set_rbt \<Rightarrow> 'b :: ccompare set_rbt \<Rightarrow> ('a \<times> 'b) set_rbt"
where "product rbt1 rbt2 = RBT_Mapping2.product (\<lambda>_ _ _ _. ()) rbt1 rbt2"

abbreviation Id_on :: "'a :: ccompare set_rbt \<Rightarrow> ('a \<times> 'a) set_rbt"
where "Id_on \<equiv> RBT_Mapping2.diag"

abbreviation init :: "'a :: ccompare set_rbt \<Rightarrow> ('a, unit, 'a) rbt_generator_state"
where "init \<equiv> RBT_Mapping2.init"

subsection \<open>Properties\<close>

lemma member_empty [simp]:
  "member empty = (\<lambda>_. False)"
by(simp add: member_def empty_def Mapping_RBT_inverse ord.Empty_is_rbt ord.rbt_lookup.simps fun_eq_iff)

lemma fold_conv_fold_keys: "RBT_Set2.fold f rbt b = List.fold f (RBT_Set2.keys rbt) b"
by(simp add: RBT_Set2.fold_def RBT_Set2.keys_def RBT_Impl.fold_def RBT_Impl.keys_def fold_map o_def split_def)

lemma fold_conv_fold_keys':
  "fold f t = List.fold f (RBT_Impl.keys (RBT_Mapping2.impl_of t))"
by(simp add: fold.rep_eq RBT_Impl.fold_def RBT_Impl.keys_def fold_map o_def split_def)

lemma member_lookup [code]: "member t x \<longleftrightarrow> RBT_Mapping2.lookup t x = Some ()"
by transfer auto

lemma unfoldr_rbt_keys_generator:
  "list.unfoldr rbt_keys_generator (init t) = keys t"
by transfer(simp add: unfoldr_rbt_keys_generator)

lemma keys_eq_Nil_iff [simp]: "keys rbt = [] \<longleftrightarrow> rbt = empty"
by transfer(case_tac rbt, simp_all)

lemma fold1_conv_fold: "fold1 f rbt = List.fold f (tl (keys rbt)) (hd (keys rbt))"
by transfer(simp add: RBT_Impl_fold1_def)

context assumes ID_ccompare_neq_None: "ID CCOMPARE('a :: ccompare) \<noteq> None"
begin

lemma set_linorder: "class.linorder (cless_eq :: 'a \<Rightarrow> 'a \<Rightarrow> bool) cless"
using ID_ccompare_neq_None by(clarsimp)(rule ID_ccompare)

lemma ccomp_comparator: "comparator (ccomp :: 'a comparator)"
  using ID_ccompare_neq_None by(clarsimp)(rule ID_ccompare')

lemmas rbt_comps = rbt_comp_simps[OF ccomp_comparator] rbt_comp_minus[OF ccomp_comparator]

lemma member_RBT:
  "ord.is_rbt cless t \<Longrightarrow> member (Set_RBT t) (x :: 'a) \<longleftrightarrow> ord.rbt_lookup cless t x = Some ()"
by(auto simp add: member_def Mapping_RBT_inverse rbt_comps)

lemma member_impl_of:
  "ord.rbt_lookup cless (RBT_Mapping2.impl_of t) (x :: 'a) = Some () \<longleftrightarrow> member t x"
by transfer (auto simp: rbt_comps)

lemma member_insert [simp]:
  "member (insert x (t :: 'a set_rbt)) = (member t)(x := True)"
by transfer (simp add: fun_eq_iff linorder.rbt_lookup_rbt_insert[OF set_linorder] ID_ccompare_neq_None)

lemma member_fold_insert [simp]:
  "member (List.fold insert xs (t :: 'a set_rbt)) = (\<lambda>x. member t x \<or> x \<in> set xs)"
by(induct xs arbitrary: t) auto

lemma member_remove [simp]:
  "member (remove (x :: 'a) t) = (member t)(x := False)"
by transfer (simp add: linorder.rbt_lookup_rbt_delete[OF set_linorder] ID_ccompare_neq_None fun_eq_iff)

lemma member_bulkload [simp]:
  "member (bulkload xs) (x :: 'a) \<longleftrightarrow> x \<in> set xs"
by transfer (auto simp add: linorder.rbt_lookup_rbt_bulkload[OF set_linorder] rbt_comps map_of_map_Pair_const split: if_split_asm)

lemma member_conv_keys: "member t = (\<lambda>x :: 'a. x \<in> set (keys t))"
by(transfer)(simp add: ID_ccompare_neq_None linorder.rbt_lookup_keys[OF set_linorder] ord.is_rbt_rbt_sorted)

lemma is_empty_empty [simp]:
  "is_empty t \<longleftrightarrow> t = empty"
by transfer (simp split: rbt.split)

lemma RBT_lookup_empty [simp]:
  "ord.rbt_lookup cless (t :: ('a, unit) rbt) = Map.empty \<longleftrightarrow> t = RBT_Impl.Empty"
proof -
  interpret linorder "cless_eq :: 'a \<Rightarrow> 'a \<Rightarrow> bool" cless by(rule set_linorder)
  show ?thesis by(cases t)(auto simp add: fun_eq_iff)
qed

lemma member_empty_empty [simp]:
  "member t = (\<lambda>_. False) \<longleftrightarrow> (t :: 'a set_rbt) = empty"
by transfer(simp add: ID_ccompare_neq_None fun_eq_iff RBT_lookup_empty[symmetric])

lemma member_union [simp]:
  "member (union (t1 :: 'a set_rbt) t2) = (\<lambda>x. member t1 x \<or> member t2 x)"
by(auto simp add: member_lookup fun_eq_iff lookup_join[OF ID_ccompare_neq_None] split: option.split)

lemma member_minus [simp]:
  "member (minus (t1 :: 'a set_rbt) t2) = (\<lambda>x. member t1 x \<and> \<not> member t2 x)"
by(transfer)(auto simp add: ID_ccompare_neq_None fun_eq_iff rbt_comps linorder.rbt_lookup_rbt_minus[OF set_linorder] ord.is_rbt_rbt_sorted)

lemma member_inter [simp]:
  "member (inter (t1 :: 'a set_rbt) t2) = (\<lambda>x. member t1 x \<and> member t2 x)"
by(auto simp add: member_lookup fun_eq_iff lookup_meet[OF ID_ccompare_neq_None] split: option.split)

lemma member_inter_list [simp]:
  "member (inter_list (t :: 'a set_rbt) xs) = (\<lambda>x. member t x \<and> x \<in> set xs)"
by transfer(auto simp add: ID_ccompare_neq_None fun_eq_iff linorder.rbt_lookup_fold_rbt_insert[OF set_linorder] ord.Empty_is_rbt map_of_map_Pair_key ord.rbt_lookup.simps rel_option_iff split: if_split_asm option.split_asm)

lemma member_filter [simp]:
  "member (filter P (t :: 'a set_rbt)) = (\<lambda>x. member t x \<and> P x)"
by(simp add: member_lookup fun_eq_iff lookup_filter[OF ID_ccompare_neq_None] split: option.split)

lemma distinct_keys [simp]:
  "distinct (keys (rbt :: 'a set_rbt))"
by transfer(simp add: ID_ccompare_neq_None RBT_Impl.keys_def ord.is_rbt_rbt_sorted linorder.distinct_entries[OF set_linorder])

lemma all_conv_all_member:
  "all P t \<longleftrightarrow> (\<forall>x :: 'a. member t x \<longrightarrow> P x)"
by(simp add: member_lookup all_conv_all_lookup[OF ID_ccompare_neq_None])

lemma ex_conv_ex_member:
  "ex P t \<longleftrightarrow> (\<exists>x :: 'a. member t x \<and> P x)"
by(simp add: member_lookup ex_conv_ex_lookup[OF ID_ccompare_neq_None])

lemma finite_member: "finite (Collect (RBT_Set2.member (t :: 'a set_rbt)))"
by transfer (simp add: rbt_comps linorder.finite_dom_rbt_lookup[OF set_linorder])

lemma member_Id_on: "member (Id_on t) = (\<lambda>(k :: 'a, k'). k = k' \<and> member t k)"
by(simp add: member_lookup[abs_def] diag_lookup[OF ID_ccompare_neq_None] fun_eq_iff)

context assumes ID_ccompare_neq_None': "ID CCOMPARE('b :: ccompare) \<noteq> None"
begin

lemma set_linorder': "class.linorder (cless_eq :: 'b \<Rightarrow> 'b \<Rightarrow> bool) cless"
using ID_ccompare_neq_None' by(clarsimp)(rule ID_ccompare)

lemma member_product:
  "member (product rbt1 rbt2) = (\<lambda>ab :: 'a \<times> 'b. ab \<in> Collect (member rbt1) \<times> Collect (member rbt2))"
by(auto simp add: fun_eq_iff member_lookup product_def RBT_Mapping2.lookup_product ID_ccompare_neq_None ID_ccompare_neq_None' split: option.splits)

end

end

lemma sorted_RBT_Set_keys:
  "ID CCOMPARE('a :: ccompare) = Some c
  \<Longrightarrow> linorder.sorted (le_of_comp c) (RBT_Set2.keys rbt)"
by transfer(auto simp add: RBT_Set2.keys.rep_eq RBT_Impl.keys_def linorder.rbt_sorted_entries[OF ID_ccompare] ord.is_rbt_rbt_sorted)

context assumes ID_ccompare_neq_None: "ID CCOMPARE('a :: {ccompare, lattice}) \<noteq> None"
begin

lemma set_linorder2: "class.linorder (cless_eq :: 'a \<Rightarrow> 'a \<Rightarrow> bool) cless"
using ID_ccompare_neq_None by(clarsimp)(rule ID_ccompare)

end

lemma set_keys_Mapping_RBT: "set (keys (Mapping_RBT t)) = set (RBT_Impl.keys t)"
proof(cases t)
  case Empty thus ?thesis
    by(clarsimp simp add: Mapping_RBT_def keys.rep_eq is_ccompare_def Mapping_RBT'_inverse ord.is_rbt_def ord.rbt_sorted.simps)
next
  case (Branch c l k v r)
  show ?thesis
  proof(cases "is_ccompare TYPE('a) \<and> \<not> ord.is_rbt cless (Branch c l k v r)")
    case False thus ?thesis using Branch
      by(auto simp add: Mapping_RBT_def keys.rep_eq is_ccompare_def Mapping_RBT'_inverse simp del: not_None_eq)
  next
    case True
    thus ?thesis using Branch
      by(clarsimp simp add: Mapping_RBT_def keys.rep_eq is_ccompare_def Mapping_RBT'_inverse RBT_ext.linorder.is_rbt_fold_rbt_insert_impl[OF ID_ccompare] linorder.rbt_insert_is_rbt[OF ID_ccompare] ord.Empty_is_rbt)(subst linorder.rbt_lookup_keys[OF ID_ccompare, symmetric], assumption, auto simp add: linorder.rbt_sorted_fold_insert[OF ID_ccompare] RBT_ext.linorder.rbt_lookup_fold_rbt_insert_impl[OF ID_ccompare] RBT_ext.linorder.rbt_lookup_rbt_insert'[OF ID_ccompare] linorder.rbt_insert_rbt_sorted[OF ID_ccompare] ord.is_rbt_rbt_sorted ord.Empty_is_rbt dom_map_of_conv_image_fst RBT_Impl.keys_def ord.rbt_lookup.simps)
  qed
qed

hide_const (open) member empty insert remove bulkload union minus
  keys fold fold_rev filter all ex product Id_on init

end