theory TypeSchemes2
imports "../Nominal2"
begin

section {*** Type Schemes defined as a single nominal datatype ***}

atom_decl name

nominal_datatype ty =
  Var "name"
| Fun "ty" "ty"
and tys =
  All xs::"name fset" ty::"ty" binds (set+) xs in ty

thm ty_tys.distinct
thm ty_tys.induct
thm ty_tys.inducts
thm ty_tys.exhaust
thm ty_tys.strong_exhaust
thm ty_tys.fv_defs
thm ty_tys.bn_defs
thm ty_tys.perm_simps
thm ty_tys.eq_iff
thm ty_tys.fv_bn_eqvt
thm ty_tys.size_eqvt
thm ty_tys.supports
thm ty_tys.supp
thm ty_tys.fresh

fun
  lookup :: "(name \<times> ty) list \<Rightarrow> name \<Rightarrow> ty"
where
  "lookup [] Y = Var Y"
| "lookup ((X, T) # Ts) Y = (if X = Y then T else lookup Ts Y)"

lemma lookup_eqvt[eqvt]:
  shows "(p \<bullet> lookup Ts T) = lookup (p \<bullet> Ts) (p \<bullet> T)"
apply(induct Ts T rule: lookup.induct)
apply(simp_all)
done

lemma TEST1:
  assumes "x = Inl y"
  shows "(p \<bullet> Sum_Type.projl x) = Sum_Type.projl (p \<bullet> x)"
using assms by simp

lemma TEST2:
  assumes "x = Inr y"
  shows "(p \<bullet> Sum_Type.projr x) = Sum_Type.projr (p \<bullet> x)"
using assms by simp

lemma test:
  assumes a: "\<exists>y. f x = Inl y"
  shows "(p \<bullet> (Sum_Type.projl (f x))) = Sum_Type.projl ((p \<bullet> f) (p \<bullet> x))"
using a TEST1
by (metis eqvt_bound eqvt_lambda permute_eq_iff)

lemma test2:
  assumes a: "\<exists>y. f x = Inl y"
  shows "(p \<bullet> (Sum_Type.projl (f x))) = Sum_Type.projl (p \<bullet> (f x))"
using a
by clarsimp

nominal_function (default "case_sum (\<lambda>x. Inl undefined) (\<lambda>x. Inr undefined)")
    subst  :: "(name \<times> ty) list \<Rightarrow> ty \<Rightarrow> ty"
and substs :: "(name \<times> ty) list \<Rightarrow> tys \<Rightarrow> tys"
where
  "subst \<theta> (Var X) = lookup \<theta> X"
| "subst \<theta> (Fun T1 T2) = Fun (subst \<theta> T1) (subst \<theta> T2)"
| "fset (map_fset atom xs) \<sharp>* \<theta> \<Longrightarrow> substs \<theta> (All xs T) = All xs (subst \<theta> T)"
thm subst_substs_graph_def subst_substs_graph_aux_def
apply(simp add: subst_substs_graph_aux_def eqvt_def)
apply(rule TrueI)
apply (case_tac x)
apply simp apply clarify
apply (rule_tac y="b" in ty_tys.exhaust(1))
apply (auto)[1]
apply (auto)[1]
apply simp apply clarify
apply (rule_tac ya="b" and c="a" in ty_tys.strong_exhaust(2))
apply (auto)[1]
apply (auto)[5]
--"LAST GOAL"
apply (simp add: meta_eq_to_obj_eq[OF subst_def, symmetric, unfolded fun_eq_iff])
apply (subgoal_tac "eqvt_at (\<lambda>(l, r). subst l r) (\<theta>', T)")
apply (thin_tac "eqvt_at subst_substs_sumC (Inl (\<theta>', T))")
apply (thin_tac "eqvt_at subst_substs_sumC (Inl (\<theta>', Ta))")
prefer 2
apply (simp add: eqvt_at_def subst_def)
apply rule
apply (subst test2)
apply (simp add: subst_substs_sumC_def)
apply (simp add: THE_default_def)
apply (case_tac "Ex1 (subst_substs_graph (Inl (\<theta>', T)))")
prefer 2
apply simp
apply (simp add: the1_equality)
apply auto[1]
apply (erule_tac x="x" in allE)
apply simp
apply(cases rule: subst_substs_graph.cases)
apply assumption
apply (rule_tac x="lookup \<theta> X" in exI)
apply clarify
apply (rule the1_equality)
apply blast apply assumption
apply (rule_tac x="(Fun (Sum_Type.projl (subst_substs_sum (Inl (\<theta>, T1))))
                  (Sum_Type.projl (subst_substs_sum (Inl (\<theta>, T2)))))" in exI)
apply clarify
apply (rule the1_equality)
apply blast apply assumption
apply clarify
apply simp
--"-"
apply clarify
  apply (frule supp_eqvt_at)
  apply (simp add: finite_supp)
  apply (erule Abs_res_fcb)
  apply (simp add: Abs_fresh_iff)
  apply (simp add: Abs_fresh_iff)
  apply auto[1]
  apply (simp add: fresh_def fresh_star_def)
  apply (erule contra_subsetD)
  apply (simp add: supp_Pair)
  apply blast
  apply clarify
  apply (simp)
  apply (simp add: eqvt_at_def)
  apply (subst Abs_eq_iff)
  apply (rule_tac x="0::perm" in exI)
  apply (subgoal_tac "p \<bullet> \<theta>' = \<theta>'")
  apply (simp add: alphas fresh_star_zero)
  apply (subgoal_tac "\<And>x. x \<in> supp (subst \<theta>' (p \<bullet> T)) \<Longrightarrow> x \<in> p \<bullet> atom ` fset xs \<longleftrightarrow> x \<in> atom ` fset xsa")
  apply(simp)
  apply blast
  apply (subgoal_tac "x \<in> supp(p \<bullet> \<theta>', p \<bullet> T)")
  apply (simp add: supp_Pair eqvts eqvts_raw)
  apply auto[1]
  apply (subgoal_tac "(atom ` fset (p \<bullet> xs)) \<sharp>* \<theta>'")
  apply (simp add: fresh_star_def fresh_def)
  apply(drule_tac p1="p" in iffD2[OF fresh_star_permute_iff])
  apply (simp add: eqvts eqvts_raw)
  apply (simp add: fresh_star_def fresh_def)
  apply (simp (no_asm) only: supp_eqvt[symmetric] Pair_eqvt[symmetric])
  apply (subgoal_tac "p \<bullet> supp (subst \<theta>' T) \<subseteq> p \<bullet> supp (\<theta>', T)")
  apply (erule_tac subsetD)
  apply(simp only: supp_eqvt)
  apply(perm_simp)
  apply(drule_tac x="p" in spec)
  apply(simp)
  apply (metis permute_pure subset_eqvt)
  apply (rule perm_supp_eq)
  apply (simp add: fresh_def fresh_star_def)
  apply blast
  done

nominal_termination (eqvt) by lexicographic_order

text {* Some Tests about Alpha-Equality *}

lemma
  shows "All {|a, b|} (Fun (Var a) (Var b)) = All {|b, a|} (Fun (Var a) (Var b))"
  apply(simp add: Abs_eq_iff)
  apply(rule_tac x="0::perm" in exI)
  apply(simp add: alphas fresh_star_def ty_tys.supp supp_at_base)
  done

lemma
  shows "All {|a, b|} (Fun (Var a) (Var b)) = All {|a, b|} (Fun (Var b) (Var a))"
  apply(simp add: Abs_eq_iff)
  apply(rule_tac x="(atom a \<rightleftharpoons> atom b)" in exI)
  apply(simp add: alphas fresh_star_def supp_at_base ty_tys.supp)
  done

lemma
  shows "All {|a, b, c|} (Fun (Var a) (Var b)) = All {|a, b|} (Fun (Var a) (Var b))"
  apply(simp add: Abs_eq_iff)
  apply(rule_tac x="0::perm" in exI)
  apply(simp add: alphas fresh_star_def ty_tys.supp supp_at_base)
done

lemma
  assumes a: "a \<noteq> b"
  shows "\<not>(All {|a, b|} (Fun (Var a) (Var b)) = All {|c|} (Fun (Var c) (Var c)))"
  using a
  apply(simp add: Abs_eq_iff)
  apply(clarify)
  apply(simp add: alphas fresh_star_def ty_tys.supp supp_at_base)
  apply auto
  done

end


theory L4_Protocol
imports "../Common/Lib_Enum_toString" "HOL-Library.Word"
begin

section\<open>Transport Layer Protocols\<close>
type_synonym primitive_protocol = "8 word"

definition "ICMP \<equiv> 1 :: 8 word"
definition "TCP \<equiv> 6 :: 8 word"
definition "UDP \<equiv> 17 :: 8 word"
context begin (*let's not pollute the namespace too much*)
qualified definition "SCTP \<equiv> 132  :: 8 word"
qualified definition "IGMP \<equiv> 2 :: 8 word"
qualified definition "GRE \<equiv> 47 :: 8 word"
qualified definition "ESP \<equiv> 50 :: 8 word"
qualified definition "AH \<equiv> 51 :: 8 word"
qualified definition "IPv6ICMP \<equiv> 58 :: 8 word"
end
(* turn http://www.iana.org/assignments/protocol-numbers/protocol-numbers.xhtml into a separate file or so? *)

datatype protocol = ProtoAny | Proto "primitive_protocol"

fun match_proto :: "protocol \<Rightarrow> primitive_protocol \<Rightarrow> bool" where
  "match_proto ProtoAny _ \<longleftrightarrow> True" |
  "match_proto (Proto (p)) p_p \<longleftrightarrow> p_p = p"

  fun simple_proto_conjunct :: "protocol \<Rightarrow> protocol \<Rightarrow> protocol option" where
    "simple_proto_conjunct ProtoAny proto = Some proto" |
    "simple_proto_conjunct proto ProtoAny = Some proto" |
    "simple_proto_conjunct (Proto p1) (Proto p2) = (if p1 = p2 then Some (Proto p1) else None)"
  lemma simple_proto_conjunct_asimp[simp]: "simple_proto_conjunct proto ProtoAny = Some proto"
    by(cases proto) simp_all

  lemma simple_proto_conjunct_correct: "match_proto p1 pkt \<and> match_proto p2 pkt \<longleftrightarrow>
    (case simple_proto_conjunct p1 p2 of None \<Rightarrow> False | Some proto \<Rightarrow> match_proto proto pkt)"
    apply(cases p1)
     apply(simp_all)
    apply(cases p2)
     apply(simp_all)
    done

  lemma simple_proto_conjunct_Some: "simple_proto_conjunct p1 p2 = Some proto \<Longrightarrow>
    match_proto proto pkt \<longleftrightarrow> match_proto p1 pkt \<and> match_proto p2 pkt"
    using simple_proto_conjunct_correct by simp
  lemma simple_proto_conjunct_None: "simple_proto_conjunct p1 p2 = None \<Longrightarrow>
    \<not> (match_proto p1 pkt \<and> match_proto p2 pkt)"
    using simple_proto_conjunct_correct by simp

  lemma conjunctProtoD:
    "simple_proto_conjunct a (Proto b) = Some x \<Longrightarrow> x = Proto b \<and> (a = ProtoAny \<or> a = Proto b)"
  by(cases a) (simp_all split: if_splits)
  lemma conjunctProtoD2:
    "simple_proto_conjunct (Proto b) a = Some x \<Longrightarrow> x = Proto b \<and> (a = ProtoAny \<or> a = Proto b)"
  by(cases a) (simp_all split: if_splits)

  text\<open>Originally, there was a @{typ nat} in the protocol definition, allowing infinitely many protocols
        This was intended behavior. We want to prevent things such as @{term "\<not>TCP = UDP"}.
        So be careful with what you prove...\<close>
  lemma primitive_protocol_Ex_neq: "p = Proto pi \<Longrightarrow> \<exists>p'. p' \<noteq> pi" for pi
  proof
  	show "pi + 1 \<noteq> pi" by simp
  qed
  lemma protocol_Ex_neq: "\<exists>p'. Proto p' \<noteq> p"
    by(cases p) (simp_all add: primitive_protocol_Ex_neq)

section\<open>TCP flags\<close>
  datatype tcp_flag = TCP_SYN | TCP_ACK | TCP_FIN | TCP_RST | TCP_URG | TCP_PSH (*| TCP_ALL | TCP_NONE*)

  lemma UNIV_tcp_flag: "UNIV = {TCP_SYN, TCP_ACK, TCP_FIN, TCP_RST, TCP_URG, TCP_PSH}" using tcp_flag.exhaust by auto
  instance tcp_flag :: finite
  proof
    from UNIV_tcp_flag show "finite (UNIV:: tcp_flag set)" using finite.simps by auto
  qed
  instantiation "tcp_flag" :: enum
  begin
    definition "enum_tcp_flag = [TCP_SYN, TCP_ACK, TCP_FIN, TCP_RST, TCP_URG, TCP_PSH]"

    definition "enum_all_tcp_flag P \<longleftrightarrow> P TCP_SYN \<and> P TCP_ACK \<and> P TCP_FIN \<and> P TCP_RST \<and> P TCP_URG \<and> P TCP_PSH"

    definition "enum_ex_tcp_flag P \<longleftrightarrow> P TCP_SYN \<or> P TCP_ACK \<or> P TCP_FIN \<or> P TCP_RST \<or> P TCP_URG \<or> P TCP_PSH"
  instance proof
    show "UNIV = set (enum_class.enum :: tcp_flag list)"
      by(simp add: UNIV_tcp_flag enum_tcp_flag_def)
    next
    show "distinct (enum_class.enum :: tcp_flag list)"
      by(simp add: enum_tcp_flag_def)
    next
    show "\<And>P. (enum_class.enum_all :: (tcp_flag \<Rightarrow> bool) \<Rightarrow> bool) P = Ball UNIV P"
      by(simp add: UNIV_tcp_flag enum_all_tcp_flag_def)
    next
    show "\<And>P. (enum_class.enum_ex :: (tcp_flag \<Rightarrow> bool) \<Rightarrow> bool) P = Bex UNIV P"
      by(simp add: UNIV_tcp_flag enum_ex_tcp_flag_def)
  qed
  end

subsection\<open>TCP Flags to String\<close>
  fun tcp_flag_toString :: "tcp_flag \<Rightarrow> string" where
    "tcp_flag_toString TCP_SYN = ''TCP_SYN''" |
    "tcp_flag_toString TCP_ACK = ''TCP_ACK''" |
    "tcp_flag_toString TCP_FIN = ''TCP_FIN''" |
    "tcp_flag_toString TCP_RST = ''TCP_RST''" |
    "tcp_flag_toString TCP_URG = ''TCP_URG''" |
    "tcp_flag_toString TCP_PSH = ''TCP_PSH''"

  definition ipt_tcp_flags_toString :: "tcp_flag set \<Rightarrow> char list" where
    "ipt_tcp_flags_toString flags \<equiv> list_toString tcp_flag_toString (enum_set_to_list flags)"

  lemma "ipt_tcp_flags_toString {TCP_SYN,TCP_SYN,TCP_ACK} = ''[TCP_SYN, TCP_ACK]''" by eval

end


section \<open>Terms with explicit pattern matching\<close>

theory Pterm
imports
  "../Utils/Compiler_Utils"
  Consts
  Sterm \<comment> \<open>Inclusion of this theory might seem a bit strange. Indeed, it is only for technical
    reasons: to allow for a \<^theory_text>\<open>quickcheck\<close> setup.\<close>
begin

datatype pterm =
  Pconst name |
  Pvar name |
  Pabs "(term \<times> pterm) fset" |
  Papp pterm pterm (infixl "$\<^sub>p" 70)

primrec sterm_to_pterm :: "sterm \<Rightarrow> pterm" where
"sterm_to_pterm (Sconst name) = Pconst name" |
"sterm_to_pterm (Svar name) = Pvar name" |
"sterm_to_pterm (t $\<^sub>s u) = sterm_to_pterm t $\<^sub>p sterm_to_pterm u" |
"sterm_to_pterm (Sabs cs) = Pabs (fset_of_list (map (map_prod id sterm_to_pterm) cs))"

quickcheck_generator pterm
  \<comment> \<open>will print some fishy ``constructor'' names, but at least it works\<close>
  constructors: sterm_to_pterm

lemma sterm_to_pterm_total:
  obtains t' where "t = sterm_to_pterm t'"
proof (induction t arbitrary: thesis)
  case (Pconst x)
  then show ?case
    by (metis sterm_to_pterm.simps)
next
  case (Pvar x)
  then show ?case
    by (metis sterm_to_pterm.simps)
next
  case (Pabs cs)
  from Pabs.IH obtain cs' where "cs = fset_of_list (map (map_prod id sterm_to_pterm) cs')"
    apply atomize_elim
    proof (induction cs)
      case empty
      show ?case
        apply (rule exI[where x = "[]"])
        by simp
    next
      case (insert c cs)
      obtain pat rhs where "c = (pat, rhs)" by (cases c) auto

      have "\<exists>cs'. cs = fset_of_list (map (map_prod id sterm_to_pterm) cs')"
        apply (rule insert)
        using insert.prems unfolding finsert.rep_eq
        by blast
      then obtain cs' where "cs = fset_of_list (map (map_prod id sterm_to_pterm) cs')"
        by blast

      obtain rhs' where "rhs = sterm_to_pterm rhs'"
        apply (rule insert.prems[of "(pat, rhs)" rhs])
        unfolding \<open>c = _\<close> by simp+

      show ?case
        apply (rule exI[where x = "(pat, rhs') # cs'"])
        unfolding \<open>c = _\<close> \<open>cs = _\<close> \<open>rhs = _\<close>
        by (simp add: id_def)
    qed
  hence "Pabs cs = sterm_to_pterm (Sabs cs')"
    by simp
  then show ?case
    using Pabs by metis
next
  case (Papp t1 t2)
  then obtain t1' t2' where "t1 = sterm_to_pterm t1'" "t2 = sterm_to_pterm t2'"
    by metis
  then have "t1 $\<^sub>p t2 = sterm_to_pterm (t1' $\<^sub>s t2')"
    by simp
  with Papp show ?case
    by metis
qed

lemma pterm_induct[case_names Pconst Pvar Pabs Papp]:
  assumes "\<And>x. P (Pconst x)"
  assumes "\<And>x. P (Pvar x)"
  assumes "\<And>cs. (\<And>pat t. (pat, t) |\<in>| cs \<Longrightarrow> P t) \<Longrightarrow> P (Pabs cs)"
  assumes "\<And>t u. P t \<Longrightarrow> P u \<Longrightarrow> P (t $\<^sub>p u)"
  shows "P t"
proof (rule pterm.induct, goal_cases)
  case (3 cs)
  show ?case
    apply (rule assms)
    using 3
    apply (subst (asm) fmember.rep_eq[symmetric])
    by auto
qed fact+

instantiation pterm :: pre_term begin

definition app_pterm where
"app_pterm t u = t $\<^sub>p u"

fun unapp_pterm where
"unapp_pterm (t $\<^sub>p u) = Some (t, u)" |
"unapp_pterm _ = None"

definition const_pterm where
"const_pterm = Pconst"

fun unconst_pterm where
"unconst_pterm (Pconst name) = Some name" |
"unconst_pterm _ = None"

definition free_pterm where
"free_pterm = Pvar"

fun unfree_pterm where
"unfree_pterm (Pvar name) = Some name" |
"unfree_pterm _ = None"

function (sequential) subst_pterm where
"subst_pterm (Pvar s) env = (case fmlookup env s of Some t \<Rightarrow> t | None \<Rightarrow> Pvar s)" |
"subst_pterm (t\<^sub>1 $\<^sub>p t\<^sub>2) env = subst_pterm t\<^sub>1 env $\<^sub>p subst_pterm t\<^sub>2 env" |
"subst_pterm (Pabs cs) env = Pabs ((\<lambda>(pat, rhs). (pat, subst_pterm rhs (fmdrop_fset (frees pat) env))) |`| cs)" |
"subst_pterm t _ = t"
by pat_completeness auto

termination
proof (relation "measure (size \<circ> fst)", goal_cases)
  case 4
  then show ?case
    apply auto
    including fset.lifting apply transfer
    apply (rule le_imp_less_Suc)
    apply (rule sum_nat_le_single[where y = "(a, (b, size b))" for a b])
    by auto
qed auto

primrec consts_pterm :: "pterm \<Rightarrow> name fset" where
"consts_pterm (Pconst x) = {|x|}" |
"consts_pterm (t\<^sub>1 $\<^sub>p t\<^sub>2) = consts_pterm t\<^sub>1 |\<union>| consts_pterm t\<^sub>2" |
"consts_pterm (Pabs cs) = ffUnion (snd |`| map_prod id consts_pterm |`| cs)" |
"consts_pterm (Pvar _) = {||}"

primrec frees_pterm :: "pterm \<Rightarrow> name fset" where
"frees_pterm (Pvar x) = {|x|}" |
"frees_pterm (t\<^sub>1 $\<^sub>p t\<^sub>2) = frees_pterm t\<^sub>1 |\<union>| frees_pterm t\<^sub>2" |
"frees_pterm (Pabs cs) = ffUnion ((\<lambda>(pv, tv). tv - frees pv) |`| map_prod id frees_pterm |`| cs)" |
"frees_pterm (Pconst _) = {||}"

instance
by standard
   (auto
      simp: app_pterm_def const_pterm_def free_pterm_def
      elim: unapp_pterm.elims unconst_pterm.elims unfree_pterm.elims
      split: option.splits)

end

corollary subst_pabs_id:
  assumes "\<And>pat rhs. (pat, rhs) |\<in>| cs \<Longrightarrow> subst rhs (fmdrop_fset (frees pat) env) = rhs"
  shows "subst (Pabs cs) env = Pabs cs"
apply (subst subst_pterm.simps)
apply (rule arg_cong[where f = Pabs])
apply (rule fset_map_snd_id)
apply (rule assms)
apply (subst (asm) fmember.rep_eq[symmetric])
apply assumption
done

corollary frees_pabs_alt_def:
  "frees (Pabs cs) = ffUnion ((\<lambda>(pat, rhs). frees rhs - frees pat) |`| cs)"
apply simp
apply (rule arg_cong[where f = ffUnion])
apply (rule fset.map_cong[OF refl])
by auto

lemma sterm_to_pterm_frees[simp]: "frees (sterm_to_pterm t) = frees t"
proof (induction t)
  case (Sabs cs)
  show ?case
    apply simp
    apply (rule arg_cong[where f = ffUnion])
    apply (rule fimage_cong[OF refl])
    apply clarsimp
    apply (subst Sabs)
    by (auto simp: fset_of_list_elem snds.simps)
qed auto

lemma sterm_to_pterm_consts[simp]: "consts (sterm_to_pterm t) = consts t"
proof (induction t)
  case (Sabs cs)
  show ?case
    apply simp
    apply (rule arg_cong[where f = ffUnion])
    apply (rule fimage_cong[OF refl])
    apply clarsimp
    apply (subst Sabs)
    by (auto simp: fset_of_list_elem snds.simps)
qed auto

lemma subst_sterm_to_pterm:
  "subst (sterm_to_pterm t) (fmmap sterm_to_pterm env) = sterm_to_pterm (subst t env)"
proof (induction t arbitrary: env rule: sterm_induct)
  case (Sabs cs)
  show ?case
    apply simp
    apply (rule fset.map_cong0)
    apply (auto split: prod.splits)
    apply (rule Sabs)
    by (auto simp: fset_of_list.rep_eq)
qed (auto split: option.splits)

instantiation pterm :: "term" begin

definition abs_pred_pterm :: "(pterm \<Rightarrow> bool) \<Rightarrow> pterm \<Rightarrow> bool" where
[code del]: "abs_pred P t \<longleftrightarrow> (\<forall>cs. t = Pabs cs \<longrightarrow> (\<forall>pat t. (pat, t) |\<in>| cs \<longrightarrow> P t) \<longrightarrow> P t)"

context begin

private lemma abs_pred_trivI0: "P t \<Longrightarrow> abs_pred P (t::pterm)"
unfolding abs_pred_pterm_def by auto

instance proof (standard, goal_cases)
  case (1 P t)
  then show ?case
    by (induction t rule: pterm_induct)
       (auto simp: const_pterm_def free_pterm_def app_pterm_def abs_pred_pterm_def)
next
  (* FIXME proving 2, 3 and 4 via sterm probably requires lifting setup *)
  (* lifting setup requires a consistent ordering without assumptions! *)
  (* but: other parts (in Eq_Logic_PM_Seq) require a key-ordering that only works with assumptions *)
  (* solution: don't try to abstract over the ordering *)

  case (2 t)
  show ?case
    unfolding abs_pred_pterm_def
    apply clarify
    apply (rule subst_pabs_id)
    by blast
next
  case (3 x t)
  show ?case
    unfolding abs_pred_pterm_def
    apply clarsimp
    apply (rule fset.map_cong0)
    apply (rename_tac c)
    apply (case_tac c; hypsubst_thin)
    apply simp
    subgoal for cs env pat rhs
      apply (cases "x |\<in>| frees pat")
      subgoal
        apply (rule arg_cong[where f = "subst rhs"])
        by (auto intro: fmap_ext)
      subgoal premises prems[rule_format]
        apply (subst (2) prems(1)[symmetric, where pat = pat])
        subgoal
          by (subst fmember.rep_eq) fact
        subgoal
          using prems unfolding ffUnion_alt_def
          by (auto simp: fmember.rep_eq fset_of_list.rep_eq elim!: fBallE)
        subgoal
          apply (rule arg_cong[where f = "subst rhs"])
          by (auto intro: fmap_ext)
        done
      done
    done
next
  case (4 t)
  show ?case
    unfolding abs_pred_pterm_def
    apply clarsimp
    apply (rule fset.map_cong0)
    apply clarsimp
    subgoal premises prems[rule_format] for cs env\<^sub>1 env\<^sub>2 a b
      apply (rule prems(2)[unfolded fmember.rep_eq, OF prems(5)])
      using prems unfolding fdisjnt_alt_def by auto
    done
next
  case 5
  show ?case
    proof (rule abs_pred_trivI0, clarify)
      fix t :: pterm
      fix env :: "(name, pterm) fmap"

      obtain t' where "t = sterm_to_pterm t'"
        by (rule sterm_to_pterm_total)
      obtain env' where "env = fmmap sterm_to_pterm env'"
        by (metis fmmap_total sterm_to_pterm_total)

      show "frees (subst t env) = frees t - fmdom env" if "fmpred (\<lambda>_. closed) env"
        unfolding \<open>t = _\<close> \<open>env = _\<close>
        apply simp
        apply (subst subst_sterm_to_pterm)
        apply simp
        apply (rule subst_frees)
        using that unfolding \<open>env = _\<close>
        apply simp
        apply (rule fmpred_mono_strong; assumption?)
        unfolding closed_except_def by simp
    qed
next
  case 6
  show ?case
    proof (rule abs_pred_trivI0, clarify)
      fix t :: pterm
      fix env :: "(name, pterm) fmap"

      obtain t' where "t = sterm_to_pterm t'"
        by (rule sterm_to_pterm_total)
      obtain env' where "env = fmmap sterm_to_pterm env'"
        by (metis fmmap_total sterm_to_pterm_total)

      show "consts (subst t env) = consts t |\<union>| ffUnion (consts |`| fmimage env (frees t))"
        unfolding \<open>t = _\<close> \<open>env = _\<close>
        apply simp
        apply (subst comp_def)
        apply simp
        apply (subst subst_sterm_to_pterm)
        apply simp
        apply (rule subst_consts')
        done
    qed
qed (rule abs_pred_trivI0)

end

end

lemma no_abs_abs[simp]: "\<not> no_abs (Pabs cs)"
by (subst no_abs.simps) (auto simp: term_cases_def)

lemma sterm_to_pterm:
  assumes "no_abs t"
  shows "sterm_to_pterm t = convert_term t"
using assms proof induction
  case (free name)
  show ?case
    apply simp
    apply (simp add: free_sterm_def free_pterm_def)
    done
next
  case (const name)
  show ?case
    apply simp
    apply (simp add: const_sterm_def const_pterm_def)
    done
next
  case (app t\<^sub>1 t\<^sub>2)
  then show ?case
    apply simp
    apply (simp add: app_sterm_def app_pterm_def)
    done
qed

abbreviation Pabs_single ("\<Lambda>\<^sub>p _. _" [0, 50] 50) where
"Pabs_single x rhs \<equiv> Pabs {| (Free x, rhs) |}"

lemma closed_except_simps:
  "closed_except (Pvar x) S \<longleftrightarrow> x |\<in>| S"
  "closed_except (t\<^sub>1 $\<^sub>p t\<^sub>2) S \<longleftrightarrow> closed_except t\<^sub>1 S \<and> closed_except t\<^sub>2 S"
  "closed_except (Pabs cs) S \<longleftrightarrow> fBall cs (\<lambda>(pat, t). closed_except t (S |\<union>| frees pat))"
  "closed_except (Pconst name) S \<longleftrightarrow> True"
proof goal_cases
  case 3
  show ?case
    proof (standard, goal_cases)
      case 1
      then show ?case
        apply (auto simp: ffUnion_alt_def closed_except_def)
        apply (drule ffUnion_least_rev)
        apply auto
        by (smt case_prod_conv fBall_alt_def fminus_iff fset_rev_mp id_apply map_prod_simp)
    next
      case 2
      then show ?case
        by (fastforce simp: ffUnion_alt_def closed_except_def)
    qed
qed (auto simp: ffUnion_alt_def closed_except_def)

instantiation pterm :: pre_strong_term  begin

function (sequential) wellformed_pterm :: "pterm \<Rightarrow> bool" where
"wellformed_pterm (t\<^sub>1 $\<^sub>p t\<^sub>2) \<longleftrightarrow> wellformed_pterm t\<^sub>1 \<and> wellformed_pterm t\<^sub>2" |
"wellformed_pterm (Pabs cs) \<longleftrightarrow> fBall cs (\<lambda>(pat, t). linear pat \<and> wellformed_pterm t) \<and> is_fmap cs \<and> pattern_compatibles cs \<and> cs \<noteq> {||}" |
"wellformed_pterm _ \<longleftrightarrow> True"
by pat_completeness auto

termination
proof (relation "measure size", goal_cases)
  case 4
  then show ?case
    apply auto
    including fset.lifting apply transfer
    apply (rule le_imp_less_Suc)
    apply (rule sum_nat_le_single[where y = "(a, (b, size b))" for a b])
    by auto
qed auto

primrec all_frees_pterm :: "pterm \<Rightarrow> name fset" where
"all_frees_pterm (Pvar x) = {|x|}" |
"all_frees_pterm (t\<^sub>1 $\<^sub>p t\<^sub>2) = all_frees_pterm t\<^sub>1 |\<union>| all_frees_pterm t\<^sub>2" |
"all_frees_pterm (Pabs cs) = ffUnion ((\<lambda>(P, T). P |\<union>| T) |`| map_prod frees all_frees_pterm |`| cs)" |
"all_frees_pterm (Pconst _) = {||}"

instance
by standard (auto simp: const_pterm_def free_pterm_def app_pterm_def)

end

lemma sterm_to_pterm_all_frees[simp]: "all_frees (sterm_to_pterm t) = all_frees t"
proof (induction t)
  case (Sabs cs)
  show ?case
    apply simp
    apply (rule arg_cong[where f = ffUnion])
    apply (rule fimage_cong[OF refl])
    apply clarsimp
    apply (subst Sabs)
    by (auto simp: fset_of_list_elem snds.simps)
qed auto

instance pterm :: strong_term proof (standard, goal_cases)
  case (1 t)
  obtain t' where "t = sterm_to_pterm t'"
    by (metis sterm_to_pterm_total)
  show ?case
    apply (rule abs_pred_trivI)
    unfolding \<open>t = _\<close> sterm_to_pterm_all_frees sterm_to_pterm_frees
    by (rule frees_all_frees)
next
  case (2 t)
  show ?case
    unfolding abs_pred_pterm_def
    apply (intro allI impI)
    apply (simp add: case_prod_twice, intro conjI)
    subgoal by blast
    subgoal by (auto intro: is_fmap_image)
    subgoal
      unfolding fpairwise_image fpairwise_alt_def
      by (auto elim!: fBallE)
    done
qed

lemma wellformed_PabsI:
  assumes "is_fmap cs" "pattern_compatibles cs" "cs \<noteq> {||}"
  assumes "\<And>pat t. (pat, t) |\<in>| cs \<Longrightarrow> linear pat"
  assumes "\<And>pat t. (pat, t) |\<in>| cs \<Longrightarrow> wellformed t"
  shows "wellformed (Pabs cs)"
using assms by auto

corollary subst_closed_pabs:
  assumes "(pat, rhs) |\<in>| cs" "closed (Pabs cs)"
  shows "subst rhs (fmdrop_fset (frees pat) env) = rhs"
using assms by (subst subst_closed_except_id) (auto simp: fdisjnt_alt_def closed_except_simps)

lemma (in constants) shadows_consts_pterm_simps[simp]:
  "shadows_consts (t\<^sub>1 $\<^sub>p t\<^sub>2) \<longleftrightarrow> shadows_consts t\<^sub>1 \<or> shadows_consts t\<^sub>2"
  "shadows_consts (Pvar name) \<longleftrightarrow> name |\<in>| all_consts"
  "shadows_consts (Pabs cs) \<longleftrightarrow> fBex cs (\<lambda>(pat, t). shadows_consts pat \<or> shadows_consts t)"
  "shadows_consts (Pconst name) \<longleftrightarrow> False"
proof goal_cases
  case 3

  (* FIXME duplicated from Sterm *)
  show ?case
    unfolding shadows_consts_def
    apply rule
    subgoal
      by (force simp: ffUnion_alt_def fset_of_list_elem fdisjnt_alt_def elim!: ballE)
    subgoal
      apply (auto simp: fset_of_list_elem fdisjnt_alt_def)
      by (auto simp: fset_eq_empty_iff ffUnion_alt_def fset_of_list_elem elim!: allE fBallE)
    done
qed (auto simp: shadows_consts_def fdisjnt_alt_def)

end


theory TheoremD8
imports TheoremD7
begin

context LocalLexing begin

lemma wellformed_tokens_empty_path[simp]: "wellformed_tokens []"
  by (simp add: wellformed_tokens_def)

lemma Init_subset_Gen: "Init \<subseteq> Gen (\<P> 0 0)"
  apply (subst \<P>_0_0_Gen)
  apply (auto simp add: Init_def)
  apply (rule_tac x="[]" in exI)
  apply (simp add: is_derivation_def)
  done

lemma \<J>_0_0_subset_Gen: "\<J> 0 0 \<subseteq> Gen (\<P> 0 0)"
  apply (simp only: \<J>.simps)
  apply (rule_tac thmD5)
  apply (rule Init_subset_Gen)
  by auto

lemma inc_dot_rule[simp]: "item_rule (inc_dot d x) = item_rule x"
  by (simp add: inc_dot_def)

lemma init_item_rule[simp]: "item_rule (init_item r k) = r"
  by (simp add: init_item_def)

lemma item_dot_is_\<alpha>_length: "wellformed_item x \<Longrightarrow> item_dot x = length (item_\<alpha> x)"
  apply (simp add: item_\<alpha>_def)
  by (simp add: min_absorb2 wellformed_item_def)

lemma Gen_subset_\<J>_0_0_helper:
  assumes "wellformed_item x"
  assumes "item_origin x = 0"
  assumes "item_end x = 0"
  assumes "derives (item_\<alpha> x) []"
  assumes "is_derivation (item_nonterminal x # \<gamma>)"
  shows "x \<in> \<pi> 0 {} Init"
proof -
  let ?y = "init_item (item_nonterminal x, item_rhs x) 0"
  have y_dom: "?y \<in> \<pi> 0 {} Init"
    apply (rule_tac thmD7)
    using assms apply auto
    using is_nonterminal_item_nonterminal apply blast
    by (simp add: item_nonterminal_def item_rhs_def wellformed_item_def)
  let ?x = "inc_dot (length (item_\<alpha> x)) ?y"
  have x1: "item_rule x = item_rule ?x"
    apply (simp)
    by (simp add: item_nonterminal_def item_rhs_def)
  have x2: "item_dot x = item_dot ?x"
    apply simp
    by (simp add: assms(1) item_dot_is_\<alpha>_length)
  have x3: "item_origin x = item_origin ?x"
    using assms by auto
  have x4: "item_end x = item_end ?x"
    using assms by auto
  from x1 x2 x3 x4 have x_is_inc: "x = ?x" using item.expand by blast
  have wellformed_item_y: "wellformed_item ?y"
    using assms(1) item_nonterminal_def item_rhs_def wellformed_item_def by auto
  have "x \<in> \<pi> 0 {} {?y}"
    apply (subst x_is_inc)
    apply (rule_tac thmD6)
    apply (simp add: wellformed_item_y)
    apply (simp add: item_rhs_split)
    apply simp
    using assms apply simp
    done
  with y_dom show ?thesis
    using \<pi>_subset_elem_trans empty_subsetI insert_subset by blast
qed

lemma Gen_subset_\<J>_0_0: "Gen (\<P> 0 0) \<subseteq> \<J> 0 0"
  apply (subst \<P>_0_0_Gen)
  apply auto
  using Gen_subset_\<J>_0_0_helper by blast

theorem thmD8: "\<J> 0 0 = Gen (\<P> 0 0)"
  using Gen_subset_\<J>_0_0 \<J>_0_0_subset_Gen by blast

end

end


section {* WebAssembly Base Definitions *}

theory Wasm_Base_Defs imports Wasm_Ast Wasm_Type_Abs begin

instantiation i32 :: wasm_int begin
  lift_definition nat_of_int :: "i32 \<Rightarrow> nat" is "unat" .
  lift_definition int_of_nat :: "nat \<Rightarrow> i32" is "of_nat" .
instance ..

end
instantiation i64 :: wasm_int begin instance .. end
instantiation f32 :: wasm_float begin instance .. end
instantiation f64 :: wasm_float begin instance .. end

consts
  (* inter-type conversions *)
  (* float to i32 *)
  ui32_trunc_f32 :: "f32 \<Rightarrow> i32 option"
  si32_trunc_f32 :: "f32 \<Rightarrow> i32 option"
  ui32_trunc_f64 :: "f64 \<Rightarrow> i32 option"
  si32_trunc_f64 :: "f64 \<Rightarrow> i32 option"
  (* float to i64 *)
  ui64_trunc_f32 :: "f32 \<Rightarrow> i64 option"
  si64_trunc_f32 :: "f32 \<Rightarrow> i64 option"
  ui64_trunc_f64 :: "f64 \<Rightarrow> i64 option"
  si64_trunc_f64 :: "f64 \<Rightarrow> i64 option"
  (* int to f32 *)
  f32_convert_ui32 :: "i32 \<Rightarrow> f32"
  f32_convert_si32 :: "i32 \<Rightarrow> f32"
  f32_convert_ui64 :: "i64 \<Rightarrow> f32"
  f32_convert_si64 :: "i64 \<Rightarrow> f32"
  (* int to f64 *)
  f64_convert_ui32 :: "i32 \<Rightarrow> f64"
  f64_convert_si32 :: "i32 \<Rightarrow> f64"
  f64_convert_ui64 :: "i64 \<Rightarrow> f64"
  f64_convert_si64 :: "i64 \<Rightarrow> f64"
  (* intra-{int/float} conversions *)
  wasm_wrap :: "i64 \<Rightarrow> i32"
  wasm_extend_u :: "i32 \<Rightarrow> i64"
  wasm_extend_s :: "i32 \<Rightarrow> i64"
  wasm_demote :: "f64 \<Rightarrow> f32"
  wasm_promote :: "f32 \<Rightarrow> f64"
  (* boolean encoding *)
  serialise_i32 :: "i32 \<Rightarrow> bytes"
  serialise_i64 :: "i64 \<Rightarrow> bytes"
  serialise_f32 :: "f32 \<Rightarrow> bytes"
  serialise_f64 :: "f64 \<Rightarrow> bytes"
  wasm_bool :: "bool \<Rightarrow> i32"
  int32_minus_one :: i32

  (* memory *)
definition mem_size :: "mem \<Rightarrow> nat" where
  "mem_size m = (mem_length m) div Ki64"

abbreviation "mem_agree m \<equiv> pred_option ((\<le>) (mem_size m)) (mem_max m)"

definition mem_grow :: "mem \<Rightarrow> nat \<Rightarrow> mem option" where
  "mem_grow m n = (let len = (mem_size m) + n in
                   if (len \<le> 2^16 \<and> pred_option (\<lambda>max. len \<le> max) (mem_max m))
                    then Some (mem_append m (bytes_replicate (n * Ki64) 0))
                    else None)"

definition load :: "mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> nat \<Rightarrow> bytes option" where
  "load m n off l = (if (mem_length m \<ge> (n+off+l))
                       then Some (read_bytes m (n+off) l)
                       else None)"

definition sign_extend :: "sx \<Rightarrow> nat \<Rightarrow> bytes \<Rightarrow> bytes" where
  "sign_extend sx l bytes = (let msb = msb (msbyte bytes) in
                          let byte = (case sx of U \<Rightarrow> 0 | S \<Rightarrow> if msb then -1 else 0) in
                          bytes_takefill byte l bytes)"

definition load_packed :: "sx \<Rightarrow> mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bytes option" where
  "load_packed sx m n off lp l = map_option (sign_extend sx l) (load m n off lp)"

definition store :: "mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> bytes \<Rightarrow> nat \<Rightarrow> mem option" where
  "store m n off bs l = (if (mem_length m \<ge> (n+off+l))
                          then Some (write_bytes m (n+off) (bytes_takefill 0 l bs))
                          else None)"

definition store_packed :: "mem \<Rightarrow> nat \<Rightarrow> off \<Rightarrow> bytes \<Rightarrow> nat \<Rightarrow> mem option" where
  "store_packed = store"

consts
  wasm_deserialise :: "bytes \<Rightarrow> t \<Rightarrow> v"
  (* host *)
  host_apply :: "s \<Rightarrow> tf \<Rightarrow> host \<Rightarrow> v list \<Rightarrow> host_state \<Rightarrow> (s \<times> v list) option"

definition typeof :: " v \<Rightarrow> t" where
  "typeof v = (case v of
                 ConstInt32 _ \<Rightarrow> T_i32
               | ConstInt64 _ \<Rightarrow> T_i64
               | ConstFloat32 _ \<Rightarrow> T_f32
               | ConstFloat64 _ \<Rightarrow> T_f64)"

definition option_projl :: "('a \<times> 'b) option \<Rightarrow> 'a option" where
  "option_projl x = map_option fst x"

definition option_projr :: "('a \<times> 'b) option \<Rightarrow> 'b option" where
  "option_projr x = map_option snd x"

definition t_length :: "t \<Rightarrow> nat" where
 "t_length t = (case t of
                  T_i32 \<Rightarrow> 4
                | T_i64 \<Rightarrow> 8
                | T_f32 \<Rightarrow> 4
                | T_f64 \<Rightarrow> 8)"

definition tp_length :: "tp \<Rightarrow> nat" where
 "tp_length tp = (case tp of
                 Tp_i8 \<Rightarrow> 1
               | Tp_i16 \<Rightarrow> 2
               | Tp_i32 \<Rightarrow> 4)"

definition is_int_t :: "t \<Rightarrow> bool" where
 "is_int_t t = (case t of
                  T_i32 \<Rightarrow> True
                | T_i64 \<Rightarrow> True
                | T_f32 \<Rightarrow> False
                | T_f64 \<Rightarrow> False)"

definition is_float_t :: "t \<Rightarrow> bool" where
 "is_float_t t = (case t of
                    T_i32 \<Rightarrow> False
                  | T_i64 \<Rightarrow> False
                  | T_f32 \<Rightarrow> True
                  | T_f64 \<Rightarrow> True)"

definition is_mut :: "tg \<Rightarrow> bool" where
  "is_mut tg = (tg_mut tg = T_mut)"

definition unop_t_agree :: "unop \<Rightarrow> t \<Rightarrow> bool" where
  "unop_t_agree unop t =
     (case unop of
        Unop_i _ \<Rightarrow> is_int_t t
      | Unop_f _ \<Rightarrow> is_float_t t)"

definition binop_t_agree :: "binop \<Rightarrow> t \<Rightarrow> bool" where
  "binop_t_agree binop t =
     (case binop of
        Binop_i _ \<Rightarrow> is_int_t t
      | Binop_f _ \<Rightarrow> is_float_t t)"

definition relop_t_agree :: "relop \<Rightarrow> t \<Rightarrow> bool" where
  "relop_t_agree relop t =
     (case relop of
        Relop_i _ \<Rightarrow> is_int_t t
      | Relop_f _ \<Rightarrow> is_float_t t)"

definition app_unop_i :: "unop_i \<Rightarrow> 'i::wasm_int \<Rightarrow> 'i::wasm_int" where
  "app_unop_i iop c =
     (case iop of
     Ctz \<Rightarrow> int_ctz c
   | Clz \<Rightarrow> int_clz c
   | Popcnt \<Rightarrow> int_popcnt c)"

definition app_unop_i_v :: "unop_i \<Rightarrow> v \<Rightarrow> v" where
  "app_unop_i_v iop v =
    (case v of
       (ConstInt32 c) \<Rightarrow> ConstInt32 (app_unop_i iop c)
     | (ConstInt64 c) \<Rightarrow> ConstInt64 (app_unop_i iop c)
     | v' \<Rightarrow> v')"

definition app_unop_f :: "unop_f \<Rightarrow> 'f::wasm_float \<Rightarrow> 'f::wasm_float" where
  "app_unop_f fop c =
                 (case fop of
                    Neg \<Rightarrow> float_neg c
                  | Abs \<Rightarrow> float_abs c
                  | Ceil \<Rightarrow> float_ceil c
                  | Floor \<Rightarrow> float_floor c
                  | Trunc \<Rightarrow> float_trunc c
                  | Nearest \<Rightarrow> float_nearest c
                  | Sqrt \<Rightarrow> float_sqrt c)"

definition app_unop_f_v :: "unop_f \<Rightarrow> v \<Rightarrow> v" where
  "app_unop_f_v fop v =
    (case v of
       (ConstFloat32 c) \<Rightarrow> ConstFloat32 (app_unop_f fop c)
     | (ConstFloat64 c) \<Rightarrow> ConstFloat64 (app_unop_f fop c)
     | v' \<Rightarrow> v')"

definition app_unop :: "unop \<Rightarrow> v \<Rightarrow> v" where
  "app_unop uop v =
    (case uop of
       Unop_i iop \<Rightarrow> app_unop_i_v iop v
     | Unop_f fop \<Rightarrow> app_unop_f_v fop v)"

definition app_binop_i :: "binop_i \<Rightarrow> 'i::wasm_int \<Rightarrow> 'i::wasm_int \<Rightarrow> ('i::wasm_int) option" where
  "app_binop_i iop c1 c2 = (case iop of
                              Add \<Rightarrow> Some (int_add c1 c2)
                            | Sub \<Rightarrow> Some (int_sub c1 c2)
                            | Mul \<Rightarrow> Some (int_mul c1 c2)
                            | Div U \<Rightarrow> int_div_u c1 c2
                            | Div S \<Rightarrow> int_div_s c1 c2
                            | Rem U \<Rightarrow> int_rem_u c1 c2
                            | Rem S \<Rightarrow> int_rem_s c1 c2
                            | And \<Rightarrow> Some (int_and c1 c2)
                            | Or \<Rightarrow> Some (int_or c1 c2)
                            | Xor \<Rightarrow> Some (int_xor c1 c2)
                            | Shl \<Rightarrow> Some (int_shl c1 c2)
                            | Shr U \<Rightarrow> Some (int_shr_u c1 c2)
                            | Shr S \<Rightarrow> Some (int_shr_s c1 c2)
                            | Rotl \<Rightarrow> Some (int_rotl c1 c2)
                            | Rotr \<Rightarrow> Some (int_rotr c1 c2))"

definition app_binop_i_v :: "binop_i \<Rightarrow> v \<Rightarrow> v \<Rightarrow> v option" where
  "app_binop_i_v iop v1 v2 =
    (case (v1,v2) of
       ((ConstInt32 c1), (ConstInt32 c2)) \<Rightarrow> map_option ConstInt32 (app_binop_i iop c1 c2)
     | ((ConstInt64 c1), (ConstInt64 c2)) \<Rightarrow> map_option ConstInt64 (app_binop_i iop c1 c2)
     | _ \<Rightarrow> None)"

definition app_binop_f :: "binop_f \<Rightarrow> 'f::wasm_float \<Rightarrow> 'f::wasm_float \<Rightarrow> ('f::wasm_float) option" where
  "app_binop_f fop c1 c2 = (case fop of
                              Addf \<Rightarrow> Some (float_add c1 c2)
                            | Subf \<Rightarrow> Some (float_sub c1 c2)
                            | Mulf \<Rightarrow> Some (float_mul c1 c2)
                            | Divf \<Rightarrow> Some (float_div c1 c2)
                            | Min \<Rightarrow> Some (float_min c1 c2)
                            | Max \<Rightarrow> Some (float_max c1 c2)
                            | Copysign \<Rightarrow> Some (float_copysign c1 c2))"

definition app_binop_f_v :: "binop_f \<Rightarrow> v \<Rightarrow> v \<Rightarrow> v option" where
  "app_binop_f_v fop v1 v2 =
    (case (v1,v2) of
       ((ConstFloat32 c1), (ConstFloat32 c2)) \<Rightarrow> map_option ConstFloat32 (app_binop_f fop c1 c2)
     | ((ConstFloat64 c1), (ConstFloat64 c2)) \<Rightarrow> map_option ConstFloat64 (app_binop_f fop c1 c2)
     | _ \<Rightarrow> None)"

definition app_binop :: "binop \<Rightarrow> v \<Rightarrow> v \<Rightarrow> v option" where
  "app_binop bop v1 v2 =
    (case bop of
       Binop_i iop \<Rightarrow> app_binop_i_v iop v1 v2
     | Binop_f fop \<Rightarrow> app_binop_f_v fop v1 v2)"

definition app_testop_i :: "testop \<Rightarrow> 'i::wasm_int \<Rightarrow> bool" where
  "app_testop_i testop c = (case testop of Eqz \<Rightarrow> int_eqz c)"

definition app_testop :: "testop \<Rightarrow> v \<Rightarrow> v" where
  "app_testop op v =
    (case v of
       ConstInt32 c \<Rightarrow> ConstInt32 (wasm_bool (app_testop_i op c))
     | ConstInt64 c \<Rightarrow> ConstInt32 (wasm_bool (app_testop_i op c))
     | _ \<Rightarrow> ConstInt32 0)"

definition app_relop_i :: "relop_i \<Rightarrow> 'i::wasm_int \<Rightarrow> 'i::wasm_int \<Rightarrow> bool" where
  "app_relop_i rop c1 c2 = (case rop of
                              Eq \<Rightarrow> int_eq c1 c2
                            | Ne \<Rightarrow> int_ne c1 c2
                            | Lt U \<Rightarrow> int_lt_u c1 c2
                            | Lt S \<Rightarrow> int_lt_s c1 c2
                            | Gt U \<Rightarrow> int_gt_u c1 c2
                            | Gt S \<Rightarrow> int_gt_s c1 c2
                            | Le U \<Rightarrow> int_le_u c1 c2
                            | Le S \<Rightarrow> int_le_s c1 c2
                            | Ge U \<Rightarrow> int_ge_u c1 c2
                            | Ge S \<Rightarrow> int_ge_s c1 c2)"

definition app_relop_i_v :: "relop_i \<Rightarrow> v \<Rightarrow> v \<Rightarrow> v" where
  "app_relop_i_v iop v1 v2 =
    (case (v1,v2) of
       ((ConstInt32 c1), (ConstInt32 c2)) \<Rightarrow> ConstInt32 (wasm_bool (app_relop_i iop c1 c2))
     | ((ConstInt64 c1), (ConstInt64 c2)) \<Rightarrow> ConstInt32 (wasm_bool (app_relop_i iop c1 c2))
     | _ \<Rightarrow> ConstInt32 0)"

definition app_relop_f :: "relop_f \<Rightarrow> 'f::wasm_float \<Rightarrow> 'f::wasm_float \<Rightarrow> bool" where
  "app_relop_f rop c1 c2 = (case rop of
                              Eqf \<Rightarrow> float_eq c1 c2
                            | Nef \<Rightarrow> float_ne c1 c2
                            | Ltf \<Rightarrow> float_lt c1 c2
                            | Gtf \<Rightarrow> float_gt c1 c2
                            | Lef \<Rightarrow> float_le c1 c2
                            | Gef \<Rightarrow> float_ge c1 c2)"

definition app_relop_f_v :: "relop_f \<Rightarrow> v \<Rightarrow> v \<Rightarrow> v" where
  "app_relop_f_v fop v1 v2 =
    (case (v1,v2) of
       ((ConstFloat32 c1), (ConstFloat32 c2)) \<Rightarrow> ConstInt32 (wasm_bool (app_relop_f fop c1 c2))
     | ((ConstFloat64 c1), (ConstFloat64 c2)) \<Rightarrow> ConstInt32 (wasm_bool (app_relop_f fop c1 c2))
     | _ \<Rightarrow> ConstInt32 0)"

definition app_relop :: "relop \<Rightarrow> v \<Rightarrow> v \<Rightarrow> v" where
  "app_relop rop v1 v2 =
    (case rop of
       Relop_i iop \<Rightarrow> app_relop_i_v iop v1 v2
     | Relop_f fop \<Rightarrow> app_relop_f_v fop v1 v2)"

definition types_agree :: "t \<Rightarrow> v \<Rightarrow> bool" where
  "types_agree t v = (typeof v = t)"

definition cl_type :: "cl \<Rightarrow> tf" where
  "cl_type cl = (case cl of Func_native _ tf _ _ \<Rightarrow> tf | Func_host tf _ \<Rightarrow> tf)"

definition rglob_is_mut :: "global \<Rightarrow> bool" where
  "rglob_is_mut g = (g_mut g = T_mut)"

definition stypes :: "s \<Rightarrow> inst \<Rightarrow> nat \<Rightarrow> tf" where
  "stypes s i j = ((types i)!j)"

definition sfunc_ind :: "s \<Rightarrow> inst \<Rightarrow> nat \<Rightarrow> nat" where
  "sfunc_ind s i j = ((inst.funcs i)!j)"

definition sfunc :: "s \<Rightarrow> inst \<Rightarrow> nat \<Rightarrow> cl" where
  "sfunc s i j = (funcs s)!(sfunc_ind s i j)"

definition sglob_ind :: "s \<Rightarrow> inst \<Rightarrow> nat \<Rightarrow> nat" where
  "sglob_ind s i j = ((inst.globs i)!j)"

definition sglob :: "s \<Rightarrow> inst \<Rightarrow> nat \<Rightarrow> global" where
  "sglob s i j = (globs s)!(sglob_ind s i j)"

definition sglob_val :: "s \<Rightarrow> inst \<Rightarrow> nat \<Rightarrow> v" where
  "sglob_val s i j = g_val (sglob s i j)"

definition smem_ind :: "s \<Rightarrow> inst \<Rightarrow> nat option" where
  "smem_ind s i = (case (inst.mems i) of (n#_) \<Rightarrow> Some n | [] \<Rightarrow> None)"

definition stab_s :: "s \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> cl option" where
  "stab_s s i j = (let stabinst = fst ((tabs s)!i) in
                   (if ((length stabinst) > j) then
                      case (stabinst!j) of
                        Some i_cl \<Rightarrow> if ((length (funcs s)) > i_cl) then
                                       Some ((funcs s)!i_cl)
                                     else None
                      | None \<Rightarrow> None
                    else None))"

definition stab :: "s \<Rightarrow> inst \<Rightarrow> nat \<Rightarrow> cl option" where
  "stab s i j = (case (inst.tabs i) of (k#_) => stab_s s k j | [] => None)"

definition supdate_glob_s :: "s \<Rightarrow> nat \<Rightarrow> v \<Rightarrow> s" where
  "supdate_glob_s s k v = s\<lparr>globs := (globs s)[k:=((globs s)!k)\<lparr>g_val := v\<rparr>]\<rparr>"

definition supdate_glob :: "s \<Rightarrow> inst \<Rightarrow> nat \<Rightarrow> v \<Rightarrow> s" where
  "supdate_glob s i j v = (let k = sglob_ind s i j in supdate_glob_s s k v)"

definition is_const :: "e \<Rightarrow> bool" where
  "is_const e = (case e of Basic (C _) \<Rightarrow> True | _ \<Rightarrow> False)"

definition const_list :: "e list \<Rightarrow> bool" where
  "const_list xs = list_all is_const xs"

definition tab_extension :: "tabinst \<Rightarrow> tabinst \<Rightarrow> bool" where
  "tab_extension t1 t2 \<equiv> tab_size t1 \<le> tab_size t2 \<and>
                         (tab_max t1) = (tab_max t2)"

definition mem_extension :: "mem \<Rightarrow> mem \<Rightarrow> bool" where
  "mem_extension m1 m2 \<equiv> mem_size m1 \<le> mem_size m2 \<and>
                         (mem_max m1) = (mem_max m2)"

definition global_extension :: "global \<Rightarrow> global \<Rightarrow> bool" where
  "global_extension g1 g2 \<equiv> (g_mut g1 = g_mut g2) \<and> (typeof (g_val g1) = typeof (g_val g2)) \<and> (g_mut g1 = T_immut \<longrightarrow> g_val g1 = g_val g2)"

inductive store_extension :: "s \<Rightarrow> s \<Rightarrow> bool" where
"\<lbrakk>fs = fs'; list_all2 tab_extension tclss tclss'; list_all2 mem_extension bss bss'; list_all2 global_extension gs gs'\<rbrakk>
  \<Longrightarrow> store_extension \<lparr>s.funcs = fs, s.tabs = tclss, s.mems = bss, s.globs = gs\<rparr>
                       \<lparr>s.funcs = fs'@fs'', s.tabs = tclss'@tclss'', s.mems = bss'@bss'', s.globs = gs'@gs''\<rparr>"

abbreviation to_e_list :: "b_e list \<Rightarrow> e list" ("$* _" 60) where
  "to_e_list b_es \<equiv> map Basic b_es"

abbreviation v_to_e_list :: "v list \<Rightarrow> e list" ("$$* _" 60) where
  "v_to_e_list ves \<equiv> map (\<lambda>v. $C v) ves"

  (* Lfilled depth thing-to-fill fill-with result *)
inductive Lfilled :: "nat \<Rightarrow> Lholed \<Rightarrow> e list \<Rightarrow> e list \<Rightarrow> bool" where
  (* "Lfill (LBase vs es') es = vs @ es @ es'" *)
  L0:"\<lbrakk>const_list vs; lholed = (LBase vs es')\<rbrakk> \<Longrightarrow> Lfilled 0 lholed es (vs @ es @ es')"
  (* "Lfill (LRec vs ts es' l es'') es = vs @ [Label ts es' (Lfill l es)] @ es''" *)
| LN:"\<lbrakk>const_list vs; lholed = (LRec vs n es' l es''); Lfilled k l es lfilledk\<rbrakk> \<Longrightarrow> Lfilled (k+1) lholed es (vs @ [Label n es' lfilledk] @ es'')"

  (* Lfilled depth thing-to-fill fill-with result *)
inductive Lfilled_exact :: "nat \<Rightarrow> Lholed \<Rightarrow> e list \<Rightarrow> e list \<Rightarrow> bool" where
  (* "Lfill (LBase vs es') es = vs @ es @ es'" *)
  L0:"\<lbrakk>lholed = (LBase [] [])\<rbrakk> \<Longrightarrow> Lfilled_exact 0 lholed es es"
  (* "Lfill (LRec vs ts es' l es'') es = vs @ [Label ts es' (Lfill l es)] @ es''" *)
| LN:"\<lbrakk>const_list vs; lholed = (LRec vs n es' l es''); Lfilled_exact k l es lfilledk\<rbrakk> \<Longrightarrow> Lfilled_exact (k+1) lholed es (vs @ [Label n es' lfilledk] @ es'')"

definition load_store_t_bounds :: "a \<Rightarrow> tp option \<Rightarrow> t \<Rightarrow> bool" where
  "load_store_t_bounds a tp t = (case tp of
                                   None \<Rightarrow> 2^a \<le> t_length t
                                 | Some tp \<Rightarrow> 2^a \<le> tp_length tp \<and> tp_length tp < t_length t \<and>  is_int_t t)"

definition cvt_i32 :: "sx option \<Rightarrow> v \<Rightarrow> i32 option" where
  "cvt_i32 sx v = (case v of
                   ConstInt32 c \<Rightarrow> None
                 | ConstInt64 c \<Rightarrow> Some (wasm_wrap c)
                 | ConstFloat32 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui32_trunc_f32 c
                                      | Some S \<Rightarrow> si32_trunc_f32 c
                                      | None \<Rightarrow> None)
                 | ConstFloat64 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui32_trunc_f64 c
                                      | Some S \<Rightarrow> si32_trunc_f64 c
                                      | None \<Rightarrow> None))"

definition cvt_i64 :: "sx option \<Rightarrow> v \<Rightarrow> i64 option" where
  "cvt_i64 sx v = (case v of
                   ConstInt32 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> Some (wasm_extend_u c)
                                      | Some S \<Rightarrow> Some (wasm_extend_s c)
                                      | None \<Rightarrow> None)
                 | ConstInt64 c \<Rightarrow> None
                 | ConstFloat32 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui64_trunc_f32 c
                                      | Some S \<Rightarrow> si64_trunc_f32 c
                                      | None \<Rightarrow> None)
                 | ConstFloat64 c \<Rightarrow> (case sx of
                                        Some U \<Rightarrow> ui64_trunc_f64 c
                                      | Some S \<Rightarrow> si64_trunc_f64 c
                                      | None \<Rightarrow> None))"

definition cvt_f32 :: "sx option \<Rightarrow> v \<Rightarrow> f32 option" where
  "cvt_f32 sx v = (case v of
                   ConstInt32 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f32_convert_ui32 c)
                                    | Some S \<Rightarrow> Some (f32_convert_si32 c)
                                    | _ \<Rightarrow> None)
                 | ConstInt64 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f32_convert_ui64 c)
                                    | Some S \<Rightarrow> Some (f32_convert_si64 c)
                                    | _ \<Rightarrow> None)
                 | ConstFloat32 c \<Rightarrow> None
                 | ConstFloat64 c \<Rightarrow> Some (wasm_demote c))"

definition cvt_f64 :: "sx option \<Rightarrow> v \<Rightarrow> f64 option" where
  "cvt_f64 sx v = (case v of
                   ConstInt32 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f64_convert_ui32 c)
                                    | Some S \<Rightarrow> Some (f64_convert_si32 c)
                                    | _ \<Rightarrow> None)
                 | ConstInt64 c \<Rightarrow> (case sx of
                                      Some U \<Rightarrow> Some (f64_convert_ui64 c)
                                    | Some S \<Rightarrow> Some (f64_convert_si64 c)
                                    | _ \<Rightarrow> None)
                 | ConstFloat32 c \<Rightarrow> Some (wasm_promote c)
                 | ConstFloat64 c \<Rightarrow> None)"

definition cvt :: "t \<Rightarrow> sx option \<Rightarrow> v \<Rightarrow> v option" where
  "cvt t sx v = (case t of
                 T_i32 \<Rightarrow> (case (cvt_i32 sx v) of Some c \<Rightarrow> Some (ConstInt32 c) | None \<Rightarrow> None)
               | T_i64 \<Rightarrow> (case (cvt_i64 sx v) of Some c \<Rightarrow> Some (ConstInt64 c) | None \<Rightarrow> None)
               | T_f32 \<Rightarrow> (case (cvt_f32 sx v) of Some c \<Rightarrow> Some (ConstFloat32 c) | None \<Rightarrow> None)
               | T_f64 \<Rightarrow> (case (cvt_f64 sx v) of Some c \<Rightarrow> Some (ConstFloat64 c) | None \<Rightarrow> None))"

definition bits :: "v \<Rightarrow> bytes" where
  "bits v = (case v of
               ConstInt32 c \<Rightarrow> (serialise_i32 c)
             | ConstInt64 c \<Rightarrow> (serialise_i64 c)
             | ConstFloat32 c \<Rightarrow> (serialise_f32 c)
             | ConstFloat64 c \<Rightarrow> (serialise_f64 c))"

definition bitzero :: "t \<Rightarrow> v" where
  "bitzero t = (case t of
                T_i32 \<Rightarrow> ConstInt32 0
              | T_i64 \<Rightarrow> ConstInt64 0
              | T_f32 \<Rightarrow> ConstFloat32 0
              | T_f64 \<Rightarrow> ConstFloat64 0)"

definition n_zeros :: "t list \<Rightarrow> v list" where
  "n_zeros ts = (map (\<lambda>t. bitzero t) ts)"

lemma is_int_t_exists:
  assumes "is_int_t t"
  shows "t = T_i32 \<or> t = T_i64"
  using assms
  by (cases t) (auto simp add: is_int_t_def)

lemma is_float_t_exists:
  assumes "is_float_t t"
  shows "t = T_f32 \<or> t = T_f64"
  using assms
  by (cases t) (auto simp add: is_float_t_def)

lemma int_float_disjoint: "is_int_t t = -(is_float_t t)"
  by simp (metis is_float_t_def is_int_t_def t.exhaust t.simps(13-16))

lemma stab_unfold:
  assumes "stab s i j = Some cl"
  shows "\<exists>k ks i_cl. inst.tabs i = k#ks \<and>
                     length (fst ((tabs s)!k)) > j \<and>
                     (fst ((tabs s)!k))!j = Some i_cl \<and>
                     length (funcs s) > i_cl \<and>
                     (funcs s)!i_cl = cl"
  using assms
  unfolding stab_def stab_s_def
  by (simp add: Let_def split: list.splits if_splits option.splits)

lemma inj_basic: "inj Basic"
  by (meson e.inject(1) injI)

lemma inj_basic_econst: "inj (\<lambda>v. $C v)"
  by (meson b_e.inject(16) e.inject(1) injI)

lemma to_e_list_1:"[$ a] = $* [a]"
  by simp

lemma to_e_list_2:"[$ a, $ b] = $* [a, b]"
  by simp

lemma to_e_list_3:"[$ a, $ b, $ c] = $* [a, b, c]"
  by simp

lemma v_exists_b_e:"\<exists>ves. ($$*vs) = ($*ves)"
proof (induction vs)
  case (Cons a vs)
  thus ?case
  by (metis list.simps(9))
qed auto

lemma Lfilled_exact_imp_Lfilled:
  assumes "Lfilled_exact n lholed es LI"
  shows "Lfilled n lholed es LI"
  using assms
proof (induction rule: Lfilled_exact.induct)
  case (L0 lholed es)
  thus ?case
    using const_list_def Lfilled.intros(1)
    by fastforce
next
  case (LN vs lholed n es' l es'' k es lfilledk)
  thus ?case
    using Lfilled.intros(2)
    by fastforce
qed

lemma Lfilled_exact_app_imp_exists_Lfilled:
  assumes "const_list ves"
          "Lfilled_exact n lholed (ves@es) LI"
  shows "\<exists>lholed'. Lfilled n lholed' es LI"
  using assms(2,1)
proof (induction "(ves@es)" LI rule: Lfilled_exact.induct)
  case (L0 lholed)
  show ?case
    using Lfilled.intros(1)[OF L0(2), of _ "[]"]
    by fastforce
next
  case (LN vs lholed n es' l es'' k lfilledk)
  thus ?case
    using Lfilled.intros(2)
    by fastforce
qed

lemma Lfilled_imp_exists_Lfilled_exact:
  assumes "Lfilled n lholed es LI"
  shows "\<exists>lholed' ves es_c. const_list ves \<and> Lfilled_exact n lholed' (ves@es@es_c) LI"
  using assms Lfilled_exact.intros
  by (induction rule: Lfilled.induct) fastforce+

lemma n_zeros_typeof:
  "n_zeros ts = vs \<Longrightarrow> (ts = map typeof vs)"
proof (induction ts arbitrary: vs)
  case Nil
  thus ?case
    unfolding n_zeros_def
    by simp
next
  case (Cons t ts)
  obtain vs' where "n_zeros ts = vs'"
    using n_zeros_def
    by blast
  moreover
  have "typeof (bitzero t) = t"
    unfolding typeof_def bitzero_def
    by (cases t, simp_all)
  ultimately
  show ?case
    using Cons
    unfolding n_zeros_def
    by auto
qed

end


section {* Proof of the agreement property of AbstractMultiPaxos. *}

theory AbstractMultiPaxosR1Correctness
imports AbstractMultiPaxosR1 IOA_Automation
  BallotArrayProperties
begin

locale ampr1_proof = IOA + quorums quorums + ampr1_ioa quorums for
     quorums :: "'a set set" +
  fixes the_ioa :: "(('v, 'a, 'l) ampr1_state, 'v paxos_action) ioa"
  defines "the_ioa \<equiv> ioa"
begin

interpretation dsa_p:dsa_properties quorums ballot vote for ballot :: "'a \<Rightarrow> bal"
  and vote :: "'a \<Rightarrow> nat \<Rightarrow> 'v option"
  by (unfold_locales)

subsection {* Automation setup *}

lemmas ioa_defs =
   is_trans_def actions_def trans_def start_def start_s_def
   externals_def ioa_def asig_def the_ioa_def

declare propose_def[simp] join_ballot_def[simp] do_vote_def[simp] suggest_def[simp]
  learn_def[simp] Let_def[simp] if_splits[split] acquire_leadership_def[simp]
  join_started_ballot_def[simp]

named_theorems inv_defs

(*  Nitpick config:
nitpick[no_assms, show_consts, verbose, card 'a = 3, card 'v = 2, card nat = 2, card "'v option" = 3, card "nat option" = 3,
    card "('v \<times> nat) option" = 5, card "'v \<times> nat" = 4, card unit = 1, card "('v, 'a) ampr1_state" = 32]
*)

method rm_trans_rel_assm =
  (match premises in P[thin]:"trans_rel ?x ?y ?z" \<Rightarrow> \<open>-\<close>)

lemma is_trans_simp[simp]:
  "s \<midarrow>a\<midarrow>the_ioa\<longrightarrow> t = trans_rel s a t"
  by (simp add:is_trans_def the_ioa_def ioa_def trans_def)

method my_fail for msg::"char list" = (print_term msg; fail)

text {* If any of m1, m2, or m3 fail, then the whole method fails. *}
method inv_cases methods m1 m2 m3 uses invs declares inv_defs =
  (rule invariantI; (
      ((match premises in "?s \<in> ioa.start ?ioa" \<Rightarrow> \<open>-\<close>); m1 )
    | ((instantiate_invs_2 invs:invs | my_fail "''instantiation failed''");
        (m2 | my_fail "''method 2 failed''"); simp only:is_trans_simp;
          ((induct_tac rule:trans_cases | my_fail "''case analysis failed''"), simp?); rm_trans_rel_assm; m3)
        ) )

method force_inv uses invs declares inv_defs =
  inv_cases \<open>(force simp add:inv_defs ioa_defs)?\<close> \<open>-\<close> \<open>(force simp add:inv_defs split:option.splits)?\<close>
  invs:invs inv_defs:inv_defs

method simp_inv uses invs declares inv_defs =
  inv_cases \<open>simp add:inv_defs ioa_defs\<close> \<open>-\<close> \<open>(simp add:inv_defs split:option.splits; fail)?\<close>
  invs:invs inv_defs:inv_defs

subsection {* Invariants *}

definition inv3 where inv3_def[inv_defs]:
  -- {* acceptors only vote for the suggestion. *}
  "inv3 s \<equiv> \<forall> i a b . let v = vote s a i b in v \<noteq> None \<longrightarrow> v = suggestion s i b"

context begin
  -- {* Proof of @{term inv3} *}

private definition inv1 where inv1_def[inv_defs]:
  "inv1 s \<equiv> \<forall> b . inst_status s b \<noteq> None \<longrightarrow> ballot s (leader b) \<ge> b"

private lemma inv1: "invariant the_ioa inv1" by (force_inv)

private definition inv2 where inv2_def[inv_defs]:
  "inv2 s \<equiv> \<forall> a b i . leader b = a \<and> (ballot s a < b \<or> (ballot s a = b \<and> inst_status s b = None))
    \<longrightarrow> suggestion s i b = None"

private lemma inv2: "invariant the_ioa inv2"
  apply (simp_inv invs:inv1)
   apply (simp add:ioa_defs inv_defs; case_tac s; case_tac t; force split:option.splits)
  apply (simp add:ioa_defs inv_defs; case_tac s; case_tac t; simp) by (metis fun_upd_apply)

lemma inv3: "invariant the_ioa inv3"
  apply (simp_inv invs:inv2)
   apply (simp add:ioa_defs inv_defs; case_tac s; case_tac t; force)
  apply (simp add:ioa_defs inv_defs; case_tac s; case_tac t; auto split:option.splits)
  by (metis fun_upd_apply option.distinct(1))

end

definition conservative where
  "conservative s \<equiv>  \<forall> i . ballot_array.conservative_array (flip (vote s) i)"

lemma conservative: "invariant the_ioa conservative"
proof -
  have "\<And> s . inv3 s \<Longrightarrow> conservative s"
    apply (simp add:inv_defs ballot_array.conservative_def ballot_array.conservative_array_def
       conservative_def split:option.splits) by (metis option.inject)
  with inv3 show ?thesis  using IOA.invariant_def by blast
qed

definition safe_at where "safe_at s i \<equiv> dsa.safe_at (ballot s) (flip (vote s) i)"

lemma safe_mono:
  -- {* @{term safe_at} is monotonic. A key lemma to simplify invariant proofs. *}
  assumes "s \<midarrow>a\<midarrow>the_ioa\<longrightarrow> t" and "safe_at s i v b"
  shows "safe_at t i v b"
proof -
  have "is_prefix (ballot s) (ballot t) (flip (vote s) i) (flip (vote t) i)" using \<open>s \<midarrow>a\<midarrow>the_ioa\<longrightarrow> t\<close>
    by (simp add:inv_defs ioa_defs; induct_tac rule:trans_cases, auto simp add:is_prefix_def inv_defs split:option.split_asm)
  thus ?thesis
  using assms ballot_array_prefix.safe_at_mono unfolding safe_at_def
  by (metis ballot_array_prefix_axioms_def ballot_array_prefix_def quorums_axioms)
qed

method insert_safe_mono =
  match premises in P:"?s \<midarrow>?a\<midarrow>the_ioa\<longrightarrow> ?t" \<Rightarrow> \<open>insert safe_mono[OF P]\<close>
method inv_cases_3 uses invs declares inv_defs =
  inv_cases \<open>-\<close> \<open>insert_safe_mono\<close> \<open>-\<close> invs:invs inv_defs:inv_defs

definition safe where "safe s \<equiv> \<forall> a i b . case vote s a i b of Some v \<Rightarrow> safe_at s i v b | _ \<Rightarrow> True"

definition inv4 where inv4_def[inv_defs]:"inv4 s \<equiv> \<forall> i b .
  case suggestion s i b of Some v \<Rightarrow>
    (case inst_status s b of Some f \<Rightarrow>
      (case f i of None \<Rightarrow> True | Some w \<Rightarrow> v = w)
    | None \<Rightarrow> False)
  | None \<Rightarrow> True"

lemma inv4:"invariant the_ioa inv4"
  apply (simp_inv; (simp add:ioa_defs inv_defs; case_tac s; case_tac t; clarify; simp split:option.splits))
      apply (metis option.collapse option.distinct(1))
     apply (metis option.collapse option.distinct(1))
    apply (metis option.collapse option.distinct(1))
   apply auto
      apply fastforce
     apply (metis option.collapse option.distinct(1))
    apply (metis fun_upd_apply option.distinct(1) option.inject)
    apply (metis fun_upd_apply option.distinct(1))
   apply (metis fun_upd_apply)
  by (metis option.collapse option.distinct(1))

definition inst_status_inv where inst_status_inv_def[inv_defs]:
  "inst_status_inv s \<equiv> (\<forall> b . case inst_status s b of Some f \<Rightarrow>
    (\<forall> i . case f i of Some v \<Rightarrow> safe_at s i v b | None \<Rightarrow> (\<forall> v . safe_at s i v b))
    | None \<Rightarrow> True)"

definition the_inv where the_inv_def[inv_defs]: "the_inv s \<equiv>
  safe s  \<and> inst_status_inv s"

context begin
  --{* Proof of @{term the_inv} *}

private
definition inv5 where inv5_def[inv_defs]:"inv5 s \<equiv> \<forall> a b f i . onebs s a b = Some f
      \<longrightarrow> f i = dsa.acc_max (flip (vote s) i) a b \<and> ballot s a \<ge> b"

private
lemma inv5:"invariant the_ioa inv5"
  -- {* The @{term do_vote} case necessitates to show that the value of @{term dsa.acc_max} dose not change as a result of the vote.  *}
  apply (force_inv inv_defs:inv5_def)
  subgoal premises prems for s t _ a2 i2 v unfolding inv5_def
      -- {* the @{term do_vote} case *}
  proof (clarify, rule conjI)
    fix a b f i
    assume "onebs t a b = Some f"
    hence "onebs s a b = Some f" using \<open>do_vote a2 i2 v s t\<close> unfolding do_vote_def by auto
    hence "f i = dsa.acc_max (flip (vote s) i) a b" and "b \<le> ballot s a" using \<open>inv5 s\<close> unfolding inv5_def by auto
    have "dsa.acc_max (flip (vote t) i) a b = dsa.acc_max (flip (vote s) i) a b"
    proof -
      from \<open>b \<le> ballot s a\<close> have "\<And> b' . b' < b \<Longrightarrow> flip (vote s) i a b' = flip (vote t) i a b'" using  \<open>do_vote a2 i2 v s t\<close>
        unfolding do_vote_def by auto
      hence "{(v, ba). ba < b \<and> flip (vote s) i a ba = Some v} = {(v, ba). ba < b \<and> flip (vote t) i a ba = Some v}" by metis
      thus ?thesis unfolding dsa.acc_max_def dsa.a_votes_def by auto
    qed
    with \<open>f i = dsa.acc_max (flip (vote s) i) a b\<close> show "f i = dsa.acc_max (flip (vote t) i) a b" by auto
    from \<open>b \<le> ballot s a\<close> and \<open>do_vote a2 i2 v s t\<close> show "b \<le> ballot t a" unfolding do_vote_def by auto
  qed
  done

lemma the_inv:"invariant the_ioa the_inv"
  apply (inv_cases_3 invs:inv4 conservative inv5)
        apply (simp add:ioa_defs inv_defs safe_def ballot_array.safe_def safe_at_def dsa_p.safe_at_0)
       apply (simp add:ioa_defs inv_defs safe_def split:option.splits)
       apply (metis option.distinct(1))
      apply (simp add:inv_defs split:option.splits)
  subgoal premises prems for s t _ a b (* join_ballot *)
  proof (auto simp add:the_inv_def)
    from \<open>join_ballot a b s t\<close> have 1:"inst_status t = inst_status s" and 2:"vote t = vote s" by auto
    note mono = \<open>(\<And>i v b. safe_at s i v b \<Longrightarrow> safe_at t i v b)\<close>
    show "safe t" using \<open>the_inv s\<close>  2 mono
      by (auto simp add:safe_def ballot_array.safe_def safe_at_def inv_defs split:option.splits)
    show "inst_status_inv t" using 1 2 mono \<open>the_inv s\<close>
      by (force simp add:inv_defs split:option.splits)
  qed
  subgoal premises prems for s t _ a i v (* do_vote *)
  proof (auto simp add:the_inv_def)
    note mono = \<open>(\<And>i v b. safe_at s i v b \<Longrightarrow> safe_at t i v b)\<close>
    have 1:"\<And> i b v . suggestion s i b = Some v \<Longrightarrow> safe_at s i v b" using \<open>the_inv s\<close> \<open>inv4 s\<close>
      by (fastforce simp add:safe_def inv_defs split:option.splits)
    show "safe t" using \<open>the_inv s\<close> mono \<open>do_vote a i v s t \<close> 1
      by (auto simp add:safe_def inv_defs split:option.splits)
    show "inst_status_inv t" using \<open>the_inv s\<close> mono \<open>do_vote a i v s t \<close>
      apply (cases s, cases t, auto simp add: inv_defs safe_def split!:option.splits)
      by (metis option.distinct(1))
  qed
  subgoal for s t _ _ _ _ _ (* suggest *)
    apply (cases s, cases t, auto simp add: inv_defs safe_def split:option.splits)[1]
    apply (metis option.distinct(1))
    done
  subgoal premises prems for s t _ a q (* acquire_leadership *)
  proof (auto simp add:the_inv_def)
    note mono = \<open>(\<And>i v b. safe_at s i v b \<Longrightarrow> safe_at t i v b)\<close>
    show "safe t" using \<open>acquire_leadership a q s t\<close> \<open>the_inv s\<close> mono
      by (auto simp add:safe_def inv_defs split:option.splits)
    show "inst_status_inv t"
    proof -
      let ?b = "ballot s a"
      from \<open>acquire_leadership a q s t\<close> have "joined s q ?b" and \<open>q\<in> quorums\<close> by (auto simp add:safe_def inv_defs split:option.splits)
      from \<open>the_inv s\<close> have "safe s" by (simp add: the_inv_def)

      text {* First we show that @{term max_vote} is the max over @{term dsa.acc_max}
        (i.e. @{term dsa.max_quorum_votes} *}
      have 1:"max_vote s i ?b q = dsa.max_quorum_votes (flip (vote s) i) q ?b" for i
      proof -
        have "(the (onebs s a ?b)) i = dsa.acc_max (flip (vote s) i) a ?b" if "a \<in> q" for a i
          using \<open>inv5 s\<close> \<open>joined s q ?b\<close> that by (simp add: ampr1_ioa.joined_def inv5_def)
        thus ?thesis by (auto simp add:max_vote_def dsa.max_quorum_votes_def)
      qed
      have 2:"ballot s a \<ge> ?b" if "a \<in> q" for a using \<open>joined s q ?b\<close> \<open>inv5 s\<close> that by (auto simp add:inv5_def joined_def)

      text {* Then we show that a suggestion is @{term dsa.proved_safe_at}, and that everything is
        safe if there is no suggestion *}
      let ?proved="\<lambda> i . dsa.proved_safe_at (ballot s) (flip (vote s) i) q ?b"
      have 3:"case sugg s i ?b q of Some v \<Rightarrow> ?proved i v | None \<Rightarrow> (\<forall> v . ?proved i v)" for i
      proof (cases "sugg s i ?b q")
        case None
        hence "dsa.max_quorum_votes (flip (vote s) i) q ?b = {}" unfolding sugg_def
            \<open>max_vote s i ?b q = dsa.max_quorum_votes (flip (vote s) i) q ?b\<close> by auto
        thus ?thesis using 2 \<open>q \<in> quorums\<close> None unfolding dsa.proved_safe_at_def joined_def by auto
      next
        case (Some v)
          -- {* Here the difficulty lies in the use of @{term the_elem} in @{thm sugg_def} *}
        obtain x where "dsa.max_quorum_votes (flip (vote s) i) q ?b = {x}"
        proof -
          from Some have "max_vote s i ?b q \<noteq> {}" unfolding sugg_def by auto
          moreover
          note \<open>max_vote s i ?b q = dsa.max_quorum_votes (flip (vote s) i) q ?b\<close>  and \<open>conservative s\<close>
          moreover note dsa_p.max_vote_e_or_singleton
          ultimately show ?thesis using that unfolding conservative_def by (metis \<open>q \<in> quorums\<close>)
        qed
        moreover
        have "v = (the_elem (fst ` (dsa.max_quorum_votes (flip (vote s) i) q ?b)))" using Some \<open>joined s q ?b\<close> 1
          by (auto simp add: sugg_def)
        ultimately show ?thesis using \<open>q\<in>quorums\<close> \<open>joined s q ?b\<close> 1 2 Some
          unfolding dsa.proved_safe_at_def by auto
      qed

      text {* Finally we conclude using lemma @{thm dsa_p.proved_safe_at_imp_safe_at} *}

      obtain f where 6:"f = (\<lambda> i . sugg s i ?b q)" and 7:"inst_status t (ballot s a) = Some f" using \<open>acquire_leadership a q s t\<close>
        using \<open>acquire_leadership a q s t\<close> by simp
      have 8:"case f i of Some v \<Rightarrow> safe_at s i v ?b | None \<Rightarrow> safe_at s i v ?b" for i v
      proof (cases "f i")
        case None
        with \<open>acquire_leadership a q s t\<close> 6 have "sugg s i ?b q = None" by auto
        with 3 have "dsa.proved_safe_at (ballot s) (flip (vote s) i) q ?b v" by (metis (mono_tags) option.simps(4))
        thus ?thesis using \<open>conservative s\<close> \<open>q\<in>quorums\<close> dsa_p.proved_safe_at_imp_safe_at None
          apply (auto simp add:safe_def safe_at_def conservative_def split:option.splits)
          apply (metis (full_types) ampr1_proof.safe_at_def ampr1_proof.safe_def ampr1_proof_axioms dsa.safe_def \<open>safe s\<close>)
          done
      next
        case (Some w)
        from Some 6 have 7:"sugg s i ?b q = Some w" by auto
        hence "dsa.proved_safe_at (ballot s) (flip (vote s) i) q ?b w" using "3" by (metis option.simps(5))
        with \<open>safe s\<close> and \<open>conservative s\<close> show ?thesis using Some \<open>q\<in>quorums\<close> dsa_p.proved_safe_at_imp_safe_at
          by (auto simp add:safe_def safe_at_def conservative_def ballot_array.safe_def inv_defs split!:option.splits)
      qed
      from 7 8 show ?thesis using \<open>the_inv s\<close> \<open>acquire_leadership a q s t\<close> mono
        apply (simp add: inv_defs split:option.splits)
        by (smt option.case_eq_if option.distinct(1) option.sel)
    qed
  qed
  apply (simp add:ioa_defs inv_defs safe_def split:option.splits; metis option.distinct(1))
  done

end

definition inv7 where inv7_def[inv_defs]:
  "inv7 s \<equiv> \<forall> i . ballot_array.safe quorums (ballot s) (flip (vote s) i)"

lemma inv7:"invariant the_ioa inv7"
proof -
  { fix s
    assume "the_inv s" and "inv3 s" and "inv4 s"
    hence "flip (vote s) i a b = Some v \<longrightarrow> safe_at s i v b" for a i b v  apply (simp add:inv_defs) by (metis (no_types) option.simps(5) safe_def)
    hence "inv7 s"   by (simp add:ballot_array.safe_def safe_at_def inv7_def split:option.splits) }
  thus ?thesis by (smt IOA.invariant_def inv4 inv3 the_inv)
qed

context begin
-- {* Is this stuff needed? *}

private
definition inv6 where
  inv6_def[inv_defs]:"inv6 s \<equiv> \<forall> i a b . ballot s a < b \<longrightarrow> flip (vote s) i a b = None"

private
lemma  inv6:"invariant the_ioa inv6"
by (force_inv)

end

end

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
                 Philipp Meyer <meyerphi@in.tum.de>
*)
header {* \isaheader {The hashable Typeclass} *}
theory HashCode
imports
  "../../Native_Word/Uint32"
  "Code_Target_ICF"
begin

text_raw {*\label{thy:HashCode}*}

text {*
  In this theory a typeclass of hashable types is established.
  For hashable types, there is a function @{text hashcode}, that
  maps any entity of this type to an unsigned 32 bit word value.

  This theory defines the hashable typeclass and provides instantiations
  for a couple of standard types.
*}

type_synonym
  hashcode = "uint32"

definition "nat_of_hashcode \<equiv> nat_of_uint32"
definition "int_of_hashcode \<equiv> int_of_uint32"
definition "integer_of_hashcode \<equiv> integer_of_uint32"

class hashable =
  fixes hashcode :: "'a \<Rightarrow> hashcode"
  and def_hashmap_size :: "'a itself \<Rightarrow> nat"
  assumes def_hashmap_size: "1 < def_hashmap_size TYPE('a)"
begin
  definition bounded_hashcode :: "uint32 \<Rightarrow> 'a \<Rightarrow> uint32" where
    "bounded_hashcode n x = (hashcode x) mod n"

  lemma bounded_hashcode_bounds: "1 < n \<Longrightarrow> bounded_hashcode n a < n"
    unfolding bounded_hashcode_def
    by (transfer, simp add: word_less_def uint_mod)

  definition bounded_hashcode_nat :: "nat \<Rightarrow> 'a \<Rightarrow> nat" where
    "bounded_hashcode_nat n x = nat_of_hashcode (hashcode x) mod n"

  lemma bounded_hashcode_nat_bounds: "1 < n \<Longrightarrow> bounded_hashcode_nat n a < n"
    unfolding bounded_hashcode_nat_def
    by transfer simp
end

instantiation unit :: hashable
begin
  definition [simp]: "hashcode (u :: unit) = 0"
  definition "def_hashmap_size = (\<lambda>_ :: unit itself. 2)"
  instance
    by (intro_classes)(simp_all add: def_hashmap_size_unit_def)
end

instantiation bool :: hashable
begin
  definition [simp]: "hashcode (b :: bool) = (if b then 1 else 0)"
  definition "def_hashmap_size = (\<lambda>_ :: bool itself. 2)"
  instance by (intro_classes)(simp_all add: def_hashmap_size_bool_def)
end

instantiation "int" :: hashable
begin
  definition [simp]: "hashcode (i :: int) = uint32_of_int i"
  definition "def_hashmap_size = (\<lambda>_ :: int itself. 16)"
  instance by(intro_classes)(simp_all add: def_hashmap_size_int_def)
end

instantiation "integer" :: hashable
begin
  definition [simp]: "hashcode (i :: integer) = Uint32 i"
  definition "def_hashmap_size = (\<lambda>_ :: integer itself. 16)"
  instance by(intro_classes)(simp_all add: def_hashmap_size_integer_def)
end

instantiation "nat" :: hashable
begin
  definition [simp]: "hashcode (n :: nat) = uint32_of_int (int n)"
  definition "def_hashmap_size = (\<lambda>_ :: nat itself. 16)"
  instance by(intro_classes)(simp_all add: def_hashmap_size_nat_def)
end

instantiation "nibble" :: hashable
begin
  definition [simp]: "hashcode (c :: nibble) = uint32_of_int (int (nat_of_nibble c))"
  definition "def_hashmap_size = (\<lambda>_ :: nibble itself. 16)"
  instance by(intro_classes)(simp_all add: def_hashmap_size_nibble_def)
end

instantiation char :: hashable
begin
  definition [simp]: "hashcode (c :: char) == uint32_of_int (int (nat_of_char c))"
  definition "def_hashmap_size = (\<lambda>_ :: char itself. 32)"
  instance by(intro_classes)(simp_all add: def_hashmap_size_char_def)
end

instantiation prod :: (hashable, hashable) hashable
begin
  definition "hashcode x == (hashcode (fst x) * 33 + hashcode (snd x))"
  definition "def_hashmap_size = (\<lambda>_ :: ('a \<times> 'b) itself. def_hashmap_size TYPE('a) + def_hashmap_size TYPE('b))"
  instance using def_hashmap_size[where ?'a="'a"] def_hashmap_size[where ?'a="'b"]
    by(intro_classes)(simp_all add: def_hashmap_size_prod_def)
end

instantiation sum :: (hashable, hashable) hashable
begin
  definition "hashcode x == (case x of Inl a \<Rightarrow> 2 * hashcode a | Inr b \<Rightarrow> 2 * hashcode b + 1)"
  definition "def_hashmap_size = (\<lambda>_ :: ('a + 'b) itself. def_hashmap_size TYPE('a) + def_hashmap_size TYPE('b))"
  instance using def_hashmap_size[where ?'a="'a"] def_hashmap_size[where ?'a="'b"]
    by(intro_classes)(simp_all add: bounded_hashcode_bounds def_hashmap_size_sum_def split: sum.split)
end

instantiation list :: (hashable) hashable
begin
  definition "hashcode = foldl (\<lambda>h x. h * 33 + hashcode x) 5381"
  definition "def_hashmap_size = (\<lambda>_ :: 'a list itself. 2 * def_hashmap_size TYPE('a))"
  instance
  proof
    from def_hashmap_size[where ?'a = "'a"]
    show "1 < def_hashmap_size TYPE('a list)"
      by(simp add: def_hashmap_size_list_def)
  qed
end

instantiation option :: (hashable) hashable
begin
  definition "hashcode opt = (case opt of None \<Rightarrow> 0 | Some a \<Rightarrow> hashcode a + 1)"
  definition "def_hashmap_size = (\<lambda>_ :: 'a option itself. def_hashmap_size TYPE('a) + 1)"
  instance using def_hashmap_size[where ?'a = "'a"]
    by(intro_classes)(simp_all add: def_hashmap_size_option_def split: option.split)
end

lemma hashcode_option_simps [simp]:
  "hashcode None = 0"
  "hashcode (Some a) = 1 + hashcode a"
  by(simp_all add: hashcode_option_def)

lemma bounded_hashcode_option_simps [simp]:
  "bounded_hashcode n None = 0"
  "bounded_hashcode n (Some a) = (hashcode a + 1) mod n"
  apply (simp_all add: bounded_hashcode_def, transfer, simp_all add: word_mod_def)
  apply (simp_all add: algebra_simps)
  done

(*
lemma bounded_hashcode_option_simps [simp]:
  "bounded_hashcode n None = 0"
  "bounded_hashcode n (Some a) = (bounded_hashcode n a + 1) mod n"
  apply (simp_all add: bounded_hashcode_def, transfer, simp_all add: word_mod_def)
  apply (simp_all add: algebra_simps mod_add_right_eq)
*)

hide_type (open) word

end


theory compare
  imports Main
    "/Volumes/Setup/Isabelle/Isabelle-Code/September/libs_functions"
begin

lemma distrib_simps:
"P \<and> (Q \<or> R) \<longleftrightarrow> P \<and> Q \<or> P \<and> R"
  by blast

lemma not_ex: "(\<not>(\<exists>x. P(x))) \<longleftrightarrow> (\<forall>x. \<not>P(x))"
  by simp

lemma all_comm: "(\<forall>x y. P(x ,y)) \<longleftrightarrow> (\<forall>y x . P(x ,y))"
  by blast

definition trig_list :: "(string * string list) list" where
"trig_list = [(''1'', [''1'',''2'']),(''2'', [''1'',''2''])]"

definition sync_list :: "(string * string list) list" where
"sync_list = [(''4'', [''1'',''2'']),(''5'', [''1'',''2''])]"

value "Connector"
(*BIP*)
value "((\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. \<exists>trig_list\<in>set(snd connector).(P ((fst sync),(snd sync)) \<longrightarrow>
      (( \<exists>trig\<in>set trig_list.\<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
       ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1),(snd s_elm_1))
      )
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1)))))"

(*JavaBIP*)
value "((\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. (P ((fst sync), (snd sync)) \<longrightarrow>
      ((\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
      \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q ((fst t_elm), h)) ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1), (snd s_elm_1))
      \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P ((fst s_elm_1), l)))
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1)))))"
(*
notepad
begin
  have "(\<not>(\<exists>x. P(x))) \<longleftrightarrow> (\<forall>x. \<not>P(x))"
  proof (rule classical)
    assume "\<not> ?thesis"
    then show ?thesis
      by blast
  qed
end

lemma "((
((\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. \<exists>trig_list\<in>set(snd connector).(P ((fst sync),(snd sync)) \<longrightarrow>
      (( \<exists>trig\<in>set trig_list.\<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
       ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1),(snd s_elm_1))
      )
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1)))))
)
\<longleftrightarrow>
(
(\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. (P ((fst sync), (snd sync)) \<longrightarrow>
      ((\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
      \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q ((fst t_elm), h)) ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1), (snd s_elm_1))
      \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P ((fst s_elm_1), l)))
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1))))
))"
proof(rule ccontr)
  assume "\<not> ((
((\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. \<exists>trig_list\<in>set(snd connector).(P ((fst sync),(snd sync)) \<longrightarrow>
      (( \<exists>trig\<in>set trig_list.\<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
       ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1),(snd s_elm_1))
      )
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1)))))
)
\<longleftrightarrow>
(
(\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. (P ((fst sync), (snd sync)) \<longrightarrow>
      ((\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
      \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q ((fst t_elm), h)) ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1), (snd s_elm_1))
      \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P ((fst s_elm_1), l)))
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1))))
))"
  then show False
    sledgehammer
  qed

notepad
begin
  have "((
((\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. \<exists>trig_list\<in>set(snd connector).(P ((fst sync),(snd sync)) \<longrightarrow>
      (( \<exists>trig\<in>set trig_list.\<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
       ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1),(snd s_elm_1))
      )
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1)))))
)
\<longleftrightarrow>
(
(\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. (P ((fst sync), (snd sync)) \<longrightarrow>
      ((\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
      \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q ((fst t_elm), h)) ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1), (snd s_elm_1))
      \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P ((fst s_elm_1), l)))
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1))))
))"
  proof (rule ccontr)
    assume "\<not> ((
((\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. \<exists>trig_list\<in>set(snd connector).(P ((fst sync),(snd sync)) \<longrightarrow>
      (( \<exists>trig\<in>set trig_list.\<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
       ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1),(snd s_elm_1))
      )
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1)))))
)
\<longleftrightarrow>
(
(\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. (P ((fst sync), (snd sync)) \<longrightarrow>
      ((\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
      \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q ((fst t_elm), h)) ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1), (snd s_elm_1))
      \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P ((fst s_elm_1), l)))
    )
))\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1))))
))"
    then show False nitpick [card string = 2, dont_box]
  qed
end
*)

(*--------------------------*)
lemma test_1: "
((\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P ((fst t), l) \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P ((fst t), l1))))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q ((fst k), h) \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q ((fst k), h1))))) \<Longrightarrow>
\<not>(
((\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. \<exists>trig_list\<in>set(snd connector).(P ((fst sync),(snd sync)) \<longrightarrow>
      (( \<exists>trig\<in>set trig_list.\<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
       ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1),(snd s_elm_1))
      )
    )
))
)
\<longleftrightarrow>
(
(\<forall>connector\<in>set Connector.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. (P ((fst sync), (snd sync)) \<longrightarrow>
      ((\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q ((fst t_elm), (snd t_elm))
      \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q ((fst t_elm), h)) ))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P ((fst s_elm_1), (snd s_elm_1))
      \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P ((fst s_elm_1), l)))
    )
))
))
"
  unfolding test_synchron_def test_triggers_def Connector_def
  using for_synchron for_trigger
  nitpick

end


(*
    File:        LTermDef.thy
    Time-stamp:  <2020-06-22T04:24:12Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory LTermDef imports ZF.Sum Nth OccGraft LVariable begin

consts
  LTerm :: i
  LTag :: i

datatype
  LTerm = LVar ( "x: LVariable" )
        | LLam ( "x: LVariable", "M: LTerm")
        | LApp ( "M: LTerm", "N: LTerm")

datatype
  LTag = TLVar ( "x: LVariable" )
       | TLLam ( "x: LVariable" )
       | TLApp

definition LArity :: "i=>i" where
"LArity(T) == LTag_case(%x. 0, %x. 1, 2, T)"

definition LTerm_cons :: "[i, i]=>i" where
"LTerm_cons(T, l) == LTag_case(%x. LVar(x),
                               %x. LLam(x, nth(0, l)),
                               LApp(nth(0, l), nth(1, l)), T)"

definition LOcc :: "i=>i" where
  "LOcc(M) == LTerm_rec(
            %x. Occ_cons(TLVar(x), []),
            %x N r. Occ_cons(TLLam(x), [r]),
            %M N rm rn. Occ_cons(TLApp, [rm, rn]), M)"

definition LOccinv :: "i=>i" where
"LOccinv(x) == THE M. M: LTerm & x = LOcc(M)"

definition LSub :: "i=>i" where
"LSub(M) == {<l, LOccinv(Occ_Subtree(l, LOcc(M)))>. <l, T>: LOcc(M)}"

definition Lsubterm :: "[i, i]=>i" where
"Lsubterm(M, l) == THE N. <l, N>: LSub(M)"

definition Lgraft :: "[i, i, i]=>i" where
"Lgraft(x, W, y) == LOccinv(Occ_Graft(LOcc(x), W, LOcc(y)))"

lemma LTerm_rec_type:
  assumes "M: LTerm"
  and "!!x. [| x: LVariable |] ==> c(x): C(LVar(x))"
  and "!!x M r. [| x:LVariable;  M: LTerm;  r: C(M) |] ==>
                   h(x,M,r): C(LLam(x,M))"
  and "!!x M N rm rn. [| M: LTerm;  N: LTerm;
         rm: C(M); rn: C(N) |] ==> k(M,N,rm,rn): C(LApp(M,N))"
  shows "LTerm_rec(c,h,k,M) : C(M)"
apply (rule assms(1) [THEN LTerm.induct])
apply (simp_all add: assms)
done

lemma LTerm_cons_eqns:
  "LTerm_cons(TLVar(x), []) = LVar(x)"
  "LTerm_cons(TLLam(x), [M]) = LLam(x, M)"
  "LTerm_cons(TLApp, [M, N]) = LApp(M, N)"
apply (simp_all add: LTerm_cons_def)
done

lemma LArity_eqns:
  "LArity(TLVar(x)) = 0"
  "LArity(TLLam(x)) = 1"
  "LArity(TLApp) = 2"
apply (simp_all add: LArity_def)
done

lemma LOcc_eqns:
  "LOcc(LVar(x)) = Occ_cons(TLVar(x), [])"
  "LOcc(LLam(x, M)) = Occ_cons(TLLam(x), [LOcc(M)])"
  "LOcc(LApp(M, N)) = Occ_cons(TLApp, [LOcc(M), LOcc(N)])"
apply (simp_all add: LOcc_def)
done

lemma LTerm_Term_cons_intrs:
  "x: LVariable ==> LTerm_cons(TLVar(x), []): LTerm"
  "[| x: LVariable;  M: LTerm |] ==> LTerm_cons(TLLam(x), [M]): LTerm"
  "[| M: LTerm; N: LTerm |] ==> LTerm_cons(TLApp, [M, N]): LTerm"
apply (simp_all add: LTerm_cons_eqns)
apply (assumption | rule LTerm.intros)+
done

lemma LArity_type:
  "T: LTag ==> LArity(T): nat"
apply (erule LTag.cases)
apply (simp_all add: LArity_eqns)
done

lemma LTerm_Occ_cons_cond:
  "Occ_cons_cond(LTerm, LOcc, LTag, LArity)"
apply (rule Occ_cons_condI)
apply (elim LTag.cases)
apply (simp_all add: LArity_eqns)
apply (elim LTag.cases)
apply (simp_all add: LArity_eqns)

apply (rule bexI)
apply (rule LOcc_eqns)
apply (typecheck add: LTerm.intros)

apply (elim bexE conjE)
apply (erule nth_0E)
apply assumption
apply simp
apply simp
apply (rule bexI)
apply (rule LOcc_eqns)
apply (typecheck add: LTerm.intros)

apply (elim bexE conjE)
apply (erule nth_0E)
apply assumption
apply simp
apply simp
apply (erule nth_0E)
apply assumption
apply simp
apply simp
apply (rule bexI)
apply (rule LOcc_eqns)
apply (typecheck add: LTerm.intros)
done

lemma LTerm_Occ_ind_cond:
  "Occ_ind_cond(LTerm, LOcc, LTag, LArity, LTerm_cons)"
apply (rule Occ_ind_condI)
apply (erule LTerm.induct)

apply (drule bspec)
apply (drule_tac [2] bspec)
apply (drule_tac [3] mp)
apply (erule_tac [4] LTerm_cons_eqns [THEN subst])
apply (typecheck add: LTag.intros)
apply (simp add: LTerm_cons_eqns LArity_eqns LOcc_eqns)
apply (typecheck add: LTerm.intros)

apply (drule bspec)
apply (drule_tac [2] bspec)
apply (drule_tac [3] mp)
apply (erule_tac [4] LTerm_cons_eqns [THEN subst])
apply (typecheck add: LTag.intros)
apply (simp add: LTerm_cons_eqns LArity_eqns LOcc_eqns)
apply (typecheck add: LTerm.intros)

apply (drule bspec)
apply (drule_tac [2] bspec)
apply (drule_tac [3] mp)
apply (erule_tac [4] LTerm_cons_eqns [THEN subst])
apply (typecheck add: LTag.intros)
apply (simp add: LTerm_cons_eqns LArity_eqns LOcc_eqns)
apply (typecheck add: LTerm.intros)

done

lemma LTerm_Term_cons_inj_cond:
  "Term_cons_inj_cond(LTerm, LTag, LArity, LTerm_cons)"
apply (rule Term_cons_inj_condI)
apply (rule iffI)
apply (elim LTag.cases)
prefer 10
apply (elim LTag.cases)
apply (simp_all add: LTerm_cons_def LArity_def)
done

lemmas LTerm_Term_cons_typechecks = (* nth_typechecks *)
    LTerm_Term_cons_intrs LTag.intros
    LArity_type Occ_ind_cond_Occ_domain [OF LTerm_Occ_ind_cond]
    Occ_ind_cond_Occ_in_Occ_range [OF LTerm_Occ_ind_cond]
    PowI succI1 succI2

declare LTerm_Term_cons_typechecks [TC]

lemmas LTerm_Term_cons_simps = LArity_eqns (* LTerm_cons_eqns [THEN sym] *)

declare LTerm_Term_cons_simps [simp]

lemmas LTerm_cons_eqns_sym = LTerm_cons_eqns [THEN sym]

end