theory Bottom_Up_Computation_Heap
  imports "../state_monad/Bottom_Up_Computation" "../heap_monad/DP_CRelVH"
begin

definition (in iterator_defs)
  "iter_heap f \<equiv>
    wfrec
      {(nxt x, x) | x. cnt x}
      (\<lambda> rec x. if cnt x then do {f x; rec (nxt x)} else return ())"

lemma (in iterator) iter_heap_unfold:
  "iter_heap f x = (if cnt x then do {f x; iter_heap f (nxt x)} else return ())"
  unfolding iter_heap_def
  by (simp add: wfrec_fixpoint[OF iterator.wellfounded,OF iterator.intro,OF terminating] adm_wf_def)

locale dp_consistency_iterator_heap =
  dp_consistency_heap P update lookup dp + iterator cnt nxt sizef
  for lookup :: "'a \<Rightarrow> ('c option) Heap" and update and P dp
    and cnt :: "'a \<Rightarrow> bool" and nxt and sizef
begin

context
  includes lifting_syntax
begin

term iter_heap

term crel_vs

lemma crel_vs_iterate_state:
  "crel_vs (=) () (iter_heap f x)" if "((=) ===> crel_vs R) g f"
  using wellfounded
proof induction
  case (less x)
  have unit_expand: "() = (\<lambda> a f. f a) () (\<lambda> _. ())" ..
  from less show ?case
    by (subst iter_heap_unfold)
       (auto intro:
          bind_transfer[unfolded rel_fun_def, rule_format, unfolded unit_expand]
          crel_vs_return_ext[unfolded Transfer.Rel_def] that[unfolded rel_fun_def, rule_format]
       )
qed

lemma crel_vs_bind_ignore:
  "crel_vs R a (do {d; b})" if "crel_vs R a b" "crel_vs S c d"
proof -
  have unit_expand: "a = (\<lambda> a f. f a) () (\<lambda> _. a)" ..
  show ?thesis
    by (subst unit_expand)
       (rule bind_transfer[unfolded rel_fun_def, rule_format, unfolded unit_expand] that)+
qed

lemma crel_vs_iter_and_compute:
  assumes "((=) ===> crel_vs R) g f"
  shows "crel_vs R (g x) (do {iter_heap f y; f x})"
  by (rule
        crel_vs_bind_ignore crel_vs_iterate_state HOL.refl
        assms[unfolded rel_fun_def, rule_format] assms
     )+

lemma consistent_DP_iter_and_compute:
  assumes "consistentDP f"
  shows "consistentDP (\<lambda> x. do {iter_heap f y; f x})"
  apply (rule consistentDP_intro)
  using assms unfolding consistentDP_def Rel_def
  by (rule crel_vs_iter_and_compute)

end (* Lifting Syntax *)

end (* DP Consistency Iterator Heap *)

end (* Theory *)


section {* Soundness Theorems *}

theory Wasm_Soundness imports Main Wasm_Properties begin

theorem preservation:
  assumes "\<turnstile>_i s;vs;es : ts"
          "\<lparr>s;vs;es\<rparr> \<leadsto>_i \<lparr>s';vs';es'\<rparr>"
  shows "\<turnstile>_i s';vs';es' : ts"
proof -
  have "store_typing s" "s\<bullet>None \<tturnstile>_i vs;es : ts"
    using assms(1) config_typing.simps
    by blast+
  hence "store_typing s'" "s'\<bullet>None \<tturnstile>_i vs';es' : ts"
    using assms(2)
          store_preserved
          types_preserved_e
    by blast+
  thus ?thesis
    using config_typing.intros
    by blast
qed

theorem progress:
  assumes "\<turnstile>_i s;vs;es : ts"
  shows "const_list es \<or> es = [Trap] \<or> (\<exists>a s' vs' es'. \<lparr>s;vs;es\<rparr> \<leadsto>_i \<lparr>s';vs';es'\<rparr>)"
proof -
  have "store_typing s" "s\<bullet>None \<tturnstile>_i vs;es : ts"
    using assms config_typing.simps
    by blast+
  thus ?thesis
    using progress_e3
    by blast
qed

end


theory Coll_Test
imports
  Collections.Refine_Dflt
  Succ_Graph
begin

declare [[autoref_trace_failed_id]]

context begin interpretation autoref_syn .

schematic_goal "(?c::?'c,
  RETURN (({(1::nat,2::nat),(3,4)}):::(\<langle>\<langle>nat_rel,nat_rel\<rangle>prod_rel\<rangle>(map2set_rel (ahm_rel ?bhc))) )
)\<in>?R"
  apply autoref_monadic
  done

term dflt_ahs_rel

schematic_goal "(?c::?'c, \<lambda>(a::'a::hashable) (b::'a::hashable).
  ({(a,b)}:::\<langle>?Rk::(?'b::hashable\<times>_) set\<rangle>dflt_ahs_rel)
)\<in>?R"
  apply (autoref (keep_goal))
  done

subsection "Foreach-Loops"
schematic_goal "(?c::?'c,
  FOREACH {1,2,3::nat} (\<lambda>i s. RETURN (i+s)) 0
)\<in>?R"
  apply autoref_monadic
  done

schematic_goal "(?c::?'c,
  FOREACH (map_to_set [1::nat\<mapsto>True, 2\<mapsto>False]) (\<lambda>(k,v) s. RETURN (k+s)) 0
)\<in>?R"
  apply autoref_monadic
  done

(* TODO: generic algorithm for bounded hash code of sets! *)
schematic_goal "(?c::?'c,
  FOREACH
    (map_to_set ([{1::nat}\<mapsto>True, {2}\<mapsto>False]:::\<langle>\<langle>nat_rel\<rangle>dflt_rs_rel,bool_rel\<rangle>(rbt_map_rel ?cmp)))
    (\<lambda>(k,v) s. RETURN (v\<and>s)) False
)\<in>?R"
  apply autoref_monadic
  done

subsection "Array Hash Map Tests"

schematic_goal
  "(?f::?'c, \<lambda>m. (m)(1::nat\<mapsto>2::nat)) \<in> ?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  "(?f::?'c, \<lambda>m. (m:::\<langle>Id,Id\<rangle>dflt_ahm_rel)(1::nat\<mapsto>2::nat)) \<in> ?R"
apply (autoref (keep_goal))
done

schematic_goal
  "(?f::?'c, Map.empty:::\<langle>Id,Id\<rangle>dflt_ahm_rel) \<in> ?R"
apply (autoref)
done

schematic_goal
  fixes mi m
  (* TODO: Obviously, we cannot override the tyREL-rule for
    "nat\<rightharpoonup>nat" with this: *)
  assumes [autoref_rules]: "(mi,m)\<in>\<langle>nat_rel,nat_rel\<rangle>dflt_ahm_rel"
  shows "(?f::?'c,
    RETURN (card (dom (m:::\<langle>nat_rel,nat_rel\<rangle>dflt_ahm_rel)))) \<in> ?R"
  apply (autoref_monadic)
  done

(* Optimizations *)

subsection "List Map Tests"

definition foo::"(nat\<rightharpoonup>nat) nres" where "foo \<equiv>
  do {
    let X = Map.empty;
    ASSERT (1 \<notin> dom X);
    RETURN (X(1 \<mapsto> 2))
  }"

schematic_goal list_map_update_dj_test:
  "(?f::?'c, foo ::: \<langle>\<langle>Id,Id\<rangle>list_map_rel\<rangle>nres_rel) \<in> ?R"
  unfolding foo_def
  apply autoref_monadic
  done

schematic_goal
  "(?f::?'c, [1::nat \<mapsto> 2::nat, 3\<mapsto>4] ::: \<langle>nat_rel,nat_rel\<rangle>list_map_rel) \<in> ?R"
  apply autoref
  done

schematic_goal list_map_test:
  "(?f::?'c, RETURN (([1 \<mapsto> 2, 3::nat \<mapsto> 4::nat]
       :::\<langle>nat_rel,nat_rel\<rangle>list_map_rel) |`(-{1}))) \<in> ?R"
apply (autoref_monadic)
done
concrete_definition list_map_test uses list_map_test
value list_map_test

(* Why does this work:*)
schematic_goal
  "(?f::?'c, RETURN (card (dom ([1 \<mapsto> 2, 3::nat \<mapsto> 4::nat]
       :::\<langle>nat_rel,nat_rel\<rangle>list_map_rel)))) \<in> ?R"
apply (autoref_monadic)
done

(* But this doesn't? This is not specific to list_map;
   it doesn't work with dflt_rbt_rel either.*)
(*schematic_lemma
  "(?f::?'c, RETURN (dom ([1 \<mapsto> 2, 3::nat \<mapsto> 4::nat]
       :::\<langle>nat_rel,nat_rel\<rangle>list_map_rel))) \<in> ?R"
apply (autoref_monadic)
done*)

subsection "Array-Map Tests"

term "{1,2::nat} \<union> {3,4}"

schematic_goal array_set_test_code:
  "(?f::?'c, RETURN (({1,2::nat} \<union> {3,4}
       ::: \<langle>nat_rel\<rangle>iam_set_rel )))\<in>?R"
by (autoref_monadic (trace))

concrete_definition array_set_test uses array_set_test_code
print_theorems
value [nbe] array_set_test

schematic_goal
  "(?f::?'c, RETURN (({1} ::: \<langle>nat_rel\<rangle>dflt_rs_rel) = {}))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_goal
  "(?f::?'c, RETURN (card {1,2,3::nat}))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_goal
  "(?f::?'c, RETURN (\<forall>x\<in>{1,2,3::nat}. x<4))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_goal
  "(?f::?'c, RETURN (\<exists>x\<in>{1,2,3::nat}. x<4))\<in>?R"
apply (autoref_monadic (trace))
done

schematic_goal
  "(?f::?'c, RETURN (({1} ::: \<langle>nat_rel\<rangle>iam_set_rel) = {}))\<in>?R"
  apply (autoref_monadic (trace))
  done

schematic_goal
  assumes [autoref_rules]: "(f,f')\<in>nat_rel\<rightarrow>Rb"
  shows "(?f::?'c,f' 3)\<in>?R"
  by (autoref)

schematic_goal "(?f::?'c,
  RETURN (({1,2::nat} \<times> {3,4::nat}) ::: \<langle>\<langle>Id,Id\<rangle>prod_rel\<rangle>dflt_rs_rel)
)\<in>?R"
  by autoref_monadic

schematic_goal "(?f::?'c,
  RETURN ({1,2::nat} \<inter> ({3,4::nat}) ::: \<langle>Id\<rangle>list_set_rel)
)\<in>?R"
  by autoref_monadic

schematic_goal "(?f::?'c,
  RETURN ({1,2::nat} \<inter> ({3,4::nat}) ::: \<langle>Id\<rangle>dflt_rs_rel)
)\<in>?R"
  by autoref_monadic

schematic_goal "(?f::?'c,
  RETURN (card (dom ([ 1::nat \<mapsto> True, 2\<mapsto>False ] ::: \<langle>Id,Id\<rangle>dflt_rm_rel )))
)\<in>?R"
  by autoref_monadic

text \<open>A hairy case for the operator identification heuristics for maps:\<close>
schematic_goal
  shows "(?f::?'c,
  \<lambda>m (x::'a::linorder) (y::'b::linorder). case_option
    None
    (\<lambda>m'. m' y)
    (m x)
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal
  shows "(?f::?'c,
  \<lambda>m (x::'a::hashable) (y::'b::hashable). case_option
    None
    (\<lambda>m'. m' y)
    (m x)
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  shows "(?f::?'c,
  \<lambda>m (x::'a::hashable) (y::'b::linorder). case_option
    None
    (\<lambda>m'. m' y)
    (m (x:::Id))
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c,
  {1,2::'a::numeral} \<times> {3,4::'a}
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c,
  {1,2::'a::{numeral,hashable}} \<times> ({3,4::'a} ::: \<langle>Id\<rangle>dflt_ahs_rel)
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c,
  {1,2::nat} \<times> {3,4::nat}
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c,
  {1,2::nat} \<inter> {3,4::nat}
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c,
  RETURN (({1,2::nat} \<times> {3,4::nat}) ::: \<langle>\<langle>Id,Id\<rangle>prod_rel\<rangle>dflt_rs_rel)
)\<in>?R"
  by autoref_monadic

(* TODO: ty_REL hint is ignored. Reason: Seems to not properly work with GAs! *)
schematic_goal
  notes [autoref_tyrel] = ty_REL[where 'a = "(nat\<times>nat) set"
    and R="\<langle>\<langle>Id,Id\<rangle>prod_rel\<rangle>dflt_rs_rel"]
  shows "(?f::?'c,
    RETURN (({1,2::nat} \<times> {3,4::nat}))
  )\<in>?R"
  by autoref_monadic

(* TODO: Iterator optimization does not capture
    foldli ((map fst \<circ> rbt_to_list) x)
pattern!
*)

text \<open>We have an optimized version for add on red-black trees\<close>
schematic_goal "(?f::?'c,
  [ 1::nat \<mapsto> True, 2::nat \<mapsto> False ] ++ [ 3::nat \<mapsto> True, 4::nat \<mapsto> False ]
)\<in>?R"
  by (autoref (keep_goal))

text \<open>The optimized version is also transfered through the map2set converter\<close>
schematic_goal "(?f::?'c,
  {1,2::nat} \<union> {3,4}
)\<in>?R"
  by (autoref (keep_goal))

text \<open>For list-sets, the generic version is used\<close>
schematic_goal "(?f::?'c,
  {1,2::nat} \<union> {3,4} ::: \<langle>Id\<rangle>list_set_rel
)\<in>?R"
  by (autoref (keep_goal))

lemma is_refgoal: "(c,a)\<in>R \<Longrightarrow> (c,a)\<in>R" .

schematic_goal "(?f::?'c,
  ({{1::nat}:::\<langle>Id\<rangle> map2set_rel dflt_rm_rel} )
  \<union> ({{2,3,4,5,5,6,7,8,98,9,0}})
)\<in>?R"
  by (autoref (keep_goal))

text \<open>The next two lemmas demonstrate optimization: The insert-operation
  is translated by @{term "(#)"}\<close>
schematic_goal "(?f::?'c, {1,2,3,4::nat}:::\<langle>Id\<rangle>list_set_rel
  )\<in>?R"
  by (autoref (keep_goal))

schematic_goal
  "(?f::?'c, {{1},{2},{3},{4::nat}}:::\<langle>?R'::(?'d\<times>_) set\<rangle>list_set_rel
  )\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c,
  SPEC (\<lambda>x. x\<in>({1,2,3::nat}:::\<langle>Id\<rangle>dflt_rs_rel))
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal "(?f::?'c,
  \<lambda>s::nat set. {s} \<union> {{1,2,3}} = {{1}}
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal "(?f::?'c,
  \<forall>(k,v)\<in>map_to_set [1::nat\<mapsto>2::nat]. k>v
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c, do {
  let s = ({1,2,3::nat}:::\<langle>Id\<rangle>dflt_rs_rel);
  FOREACH s (\<lambda>n s. RETURN (n+s)) 0
}
)\<in>?R"
  by autoref_monadic

schematic_goal "(?f::?'c, do {
  let s = ({{1,2,3::nat}, {}, {1,2}});
  FOREACH s (\<lambda>n s. RETURN (n \<union> s)) {}
}
)\<in>?R"
  by (autoref_monadic)

schematic_goal "(?f::?'c,
  ({{1::nat}} )
  \<union> ({{2,3,4,5,5,6,7,8,98,9,0}})
)\<in>?R"
  by (autoref (keep_goal))

schematic_goal "(?f::?'c,
  SPEC (\<lambda>x. x\<in>({1,2,3::nat}))
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal "(?f::?'c,
  \<lambda>s::nat set. {s} \<union> {{1,2,3}} = {{1}}
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal "(?f::?'c,
  \<forall>(k,v)\<in>map_to_set [1::nat\<mapsto>2::nat]. k>v
)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal "(?f::?'c,
  [ 1::nat \<mapsto> [ 2::nat \<mapsto> 3::nat, 1::nat \<mapsto> 3::nat ] ]
)\<in>?R"
  apply (autoref (keep_goal))
  done

end

text \<open>Indirect Annotation\<close>
consts
  rel_set1 :: rel_name
  rel_set2 :: rel_name

context begin interpretation autoref_syn .

definition
  "algo \<equiv> ( {1,2,3::nat}::#rel_set1, {1,2,3::nat}::#rel_set2 )"

schematic_goal
  notes [autoref_rel_indirect] =
    REL_INDIRECT[of rel_set1 "\<langle>Rk\<rangle>list_set_rel" for Rk]
    REL_INDIRECT[of rel_set2 "\<langle>Rk\<rangle>dflt_rs_rel" for Rk]
  shows "(?f::?'c,algo) \<in> ?R"
  unfolding algo_def
  by (autoref)

schematic_goal
  notes [autoref_rel_indirect] =
    REL_INDIRECT[of rel_set1 "\<langle>Rk\<rangle>dflt_rs_rel" for Rk]
    REL_INDIRECT[of rel_set2 "\<langle>Rk\<rangle>dflt_rs_rel" for Rk]
  shows "(?f::?'c,algo) \<in> ?R"
  unfolding algo_def
  by (autoref)

text \<open>A witness of the red algorithm is a node on the stack and a path
  to this node\<close>
type_synonym 'v red_witness = "('v list \<times> 'v) option"
text \<open>Prepend node to red witness\<close>
fun prep_wit_red :: "'v \<Rightarrow> 'v red_witness \<Rightarrow> 'v red_witness" where
  "prep_wit_red v None = None"
| "prep_wit_red v (Some (p,u)) = Some (v#p,u)"

text \<open>
  Initial witness for node \<open>u\<close> with onstack successor \<open>v\<close>
\<close>
definition red_init_witness :: "'v \<Rightarrow> 'v \<Rightarrow> 'v red_witness" where
  "red_init_witness u v = Some ([u],v)"

definition red_dfs where
  "red_dfs E onstack V u \<equiv>
    REC\<^sub>T (\<lambda>D (V,u). do {
      let V=(insert u V);

      \<comment> \<open>Check whether we have a successor on stack\<close>
      brk \<leftarrow> FOREACH\<^sub>C (E``{u}) (\<lambda>brk. brk=None)
        (\<lambda>t _. if t\<in>onstack then RETURN (red_init_witness u t) else RETURN None)
        None;

      \<comment> \<open>Recurse for successors\<close>
      case brk of
        None \<Rightarrow>
          FOREACH\<^sub>C ((E``{u})) (\<lambda>(V,brk). brk=None)
            (\<lambda>t (V,_).
              if t\<notin>V then do {
                (V,brk) \<leftarrow> D (V,t);
                RETURN (V,prep_wit_red u brk)
              } else RETURN (V,None))
            (V,None)
      | _ \<Rightarrow> RETURN (V,brk)
    }) (V,u)
  "

abbreviation "i_red_witness \<equiv> \<langle>\<langle>\<langle>i_nat\<rangle>\<^sub>ii_list,i_nat\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_option"
lemma [autoref_itype]:
  "red_init_witness ::\<^sub>i i_nat \<rightarrow>\<^sub>i i_nat \<rightarrow>\<^sub>i i_red_witness"
  "prep_wit_red ::\<^sub>i i_nat \<rightarrow>\<^sub>i i_red_witness \<rightarrow>\<^sub>i i_red_witness"
  by auto

abbreviation "red_witness_rel \<equiv> \<langle>\<langle>\<langle>nat_rel\<rangle>list_rel,nat_rel\<rangle>prod_rel\<rangle>option_rel"

lemma [autoref_rules_raw]:
  "(red_init_witness,red_init_witness) \<in> nat_rel\<rightarrow>nat_rel\<rightarrow>red_witness_rel"
  "(prep_wit_red,prep_wit_red) \<in> nat_rel \<rightarrow> red_witness_rel \<rightarrow> red_witness_rel"
  by (auto)

(*schematic_lemma
  "(?f, RECT (\<lambda>D x. D x)) \<in> (?R::(?'c\<times>_) set)"
  apply (autoref (keep_goal))
  done*)

schematic_goal red_dfs_impl:
  notes [[goals_limit = 1]]
  fixes u'::"nat" and V'::"nat set"
  assumes [autoref_rules]:
    "(u,u')\<in>nat_rel"
    "(V,V')\<in>\<langle>nat_rel\<rangle>dflt_rs_rel"
    "(onstack,onstack')\<in>\<langle>nat_rel\<rangle>dflt_rs_rel"
    "(E,E')\<in>\<langle>nat_rel\<rangle>slg_rel"
  shows "(?f, red_dfs E' onstack' V' u') \<in> (?R::(?'c\<times>_) set)"
  apply -
  unfolding red_dfs_def
  apply (autoref_monadic (trace))
  done

concrete_definition red_dfs_impl for E onstack V u uses red_dfs_impl

prepare_code_thms red_dfs_impl_def

export_code red_dfs_impl checking SML

end
end


subsection \<open>Control-flow Semantics Theorems\<close>

theory IRStepThms
  imports
    IRStepObj
    TreeToGraphThms
begin

text \<open>
We prove that within the same graph, a configuration triple will always
transition to the same subsequent configuration. Therefore, our step semantics
is deterministic.
\<close>

(*
definition stepping_nodes :: "(IRNode \<Rightarrow> bool) set" where
  "stepping_nodes = {
    is_sequential_node,
    is_IfNode,
    is_AbstractEndNode,
    is_NewInstanceNode,
    is_LoadFieldNode,
    is_SignedDivNode,
    is_SignedRemNode,
    is_LoadFieldNode,
    is_StoreFieldNode
  }"

inductive_cases StepE[elim!]:\<^marker>\<open>tag invisible\<close>
  "g, p \<turnstile> (nid,m,h) \<rightarrow> next"

lemma stepping_nodes_distinct:
  assumes "sel \<in> stepping_nodes \<and> sel node"
  shows "\<forall> oth \<in> stepping_nodes - {sel} . \<not>(oth node)"
  using assms unfolding stepping_nodes_def sorry

proof (induction arbitrary: m h rule: step.induct)
  case (SequentialNode nid nid')
  have "is_sequential_node \<in> stepping_nodes" unfolding stepping_nodes_def by simp
  then have distinct: "\<forall> oth \<in> stepping_nodes - {is_sequential_node} . \<not>(oth (kind g nid))"
    using stepping_nodes_distinct SequentialNode(1) by auto
  obtain next' where "g, p \<turnstile> (nid, m, h) \<rightarrow> next'"
    using SequentialNode.hyps(1) step.SequentialNode
    by blast
  then have "next' = (nid', m, h)"
    apply (induct rule: step.induct) using SequentialNode sorry
  show ?case apply (rule allI) (*using step.cases*) apply (induction rule: step.induct)
    using distinct unfolding stepping_nodes_def
    using is_IfNode_def is_NewInstanceNode_def is_LoadFieldNode_def is_SignedDivNode_def is_SignedRemNode_def
    is_LoadFieldNode_def is_StoreFieldNode_def
    apply (rule stepping_nodes_distinct [where sel = is_sequential_node, where node = "kind g nid"])
  then show ?case apply (rule stepping_nodes_distinct [where sel = is_sequential_node, where node = "kind g nid"])?
next
  case (IfNode nid cond tb fb condE m val nid' h)
  then show ?case sorry
next
  case (EndNodes nid merge i phis inps inpsE m vs m' h)
  then show ?case sorry
next
  case (NewInstanceNode nid f obj nid' h' ref h m' m)
  then show ?case sorry
next
  case (LoadFieldNode nid f obj nid' objE m ref h v m')
  then show ?case sorry
next
  case (SignedDivNode nid x y zero sb nxt xe ye m v1 v2 v m' h)
  then show ?case sorry
next
  case (SignedRemNode nid x y zero sb nxt xe ye m v1 v2 v m' h)
  then show ?case sorry
next
  case (StaticLoadFieldNode nid f nid' h v m' m)
  then show ?case sorry
next
  case (StoreFieldNode nid f newval uu obj nid' newvalE objE m val ref h' h m')
  then show ?case sorry
next
  case (StaticStoreFieldNode nid f newval uv nid' newvalE m val h' h m')
  then show ?case sorry
qed
*)

subsubsection \<open>Control-flow Step is Deterministic\<close>

theorem stepDet:
   "(g, p \<turnstile> (nid,m,h) \<rightarrow> next) \<Longrightarrow>
   (\<forall> next'. ((g, p \<turnstile> (nid,m,h) \<rightarrow> next') \<longrightarrow> next = next'))"
proof (induction rule: "step.induct")
  case (SequentialNode nid "next" m h)
  have notif: "\<not>(is_IfNode (kind g nid))"
    using SequentialNode.hyps(1) is_sequential_node.simps
    by (metis is_IfNode_def)
  have notend: "\<not>(is_AbstractEndNode (kind g nid))"
    using SequentialNode.hyps(1) is_sequential_node.simps
    by (metis is_AbstractEndNode.simps is_EndNode.elims(2) is_LoopEndNode_def)
  have notnew: "\<not>(is_NewInstanceNode (kind g nid))"
    using SequentialNode.hyps(1) is_sequential_node.simps
    by (metis is_NewInstanceNode_def)
  have notload: "\<not>(is_LoadFieldNode (kind g nid))"
    using SequentialNode.hyps(1) is_sequential_node.simps
    by (metis is_LoadFieldNode_def)
  have notstore: "\<not>(is_StoreFieldNode (kind g nid))"
    using SequentialNode.hyps(1) is_sequential_node.simps
    by (metis is_StoreFieldNode_def)
  have notdivrem:  "\<not>(is_IntegerDivRemNode (kind g nid))"
    using SequentialNode.hyps(1) is_sequential_node.simps is_SignedDivNode_def is_SignedRemNode_def
    by (metis is_IntegerDivRemNode.simps)
  from notif notend notnew notload notstore notdivrem
  show ?case using SequentialNode step.cases
    by (smt (z3) IRNode.disc(1028) IRNode.disc(2270) IRNode.discI(31) Pair_inject is_sequential_node.simps(18) is_sequential_node.simps(43) is_sequential_node.simps(44))
next
  case (IfNode nid cond tb fb m val "next" h)
  then have notseq: "\<not>(is_sequential_node (kind g nid))"
    using is_sequential_node.simps is_AbstractMergeNode.simps
    by (simp add: IfNode.hyps(1))
  have notend: "\<not>(is_AbstractEndNode (kind g nid))"
    using is_AbstractEndNode.simps
    by (simp add: IfNode.hyps(1))
  have notdivrem: "\<not>(is_IntegerDivRemNode (kind g nid))"
    using is_AbstractEndNode.simps
    by (simp add: IfNode.hyps(1))
  from notseq notend notdivrem show ?case using IfNode repDet evalDet IRNode.distinct IRNode.inject(11) Pair_inject step.simps
    by (smt (z3) IRNode.distinct IRNode.inject(12) Pair_inject step.simps)
next
  case (EndNodes nid merge i phis inputs m vs m' h)
  have notseq: "\<not>(is_sequential_node (kind g nid))"
    using EndNodes.hyps(1) is_AbstractEndNode.simps is_sequential_node.simps
    by (metis is_EndNode.elims(2) is_LoopEndNode_def)
  have notif: "\<not>(is_IfNode (kind g nid))"
    using EndNodes.hyps(1) is_IfNode_def is_AbstractEndNode.elims
    by (metis IRNode.distinct_disc(1058) is_EndNode.simps(12))
  have notref: "\<not>(is_RefNode (kind g nid))"
    using EndNodes.hyps(1) is_sequential_node.simps
    using IRNode.disc(1899) IRNode.distinct(1473) is_AbstractEndNode.simps is_EndNode.elims(2) is_LoopEndNode_def is_RefNode_def
    by metis
  have notnew: "\<not>(is_NewInstanceNode (kind g nid))"
    using EndNodes.hyps(1) is_AbstractEndNode.simps
    using IRNode.distinct_disc(1442) is_EndNode.simps(29) is_NewInstanceNode_def
    by (metis IRNode.distinct_disc(1901) is_EndNode.simps(32))
  have notload: "\<not>(is_LoadFieldNode (kind g nid))"
    using EndNodes.hyps(1) is_AbstractEndNode.simps
    using is_LoadFieldNode_def
    by (metis IRNode.distinct_disc(1706) is_EndNode.simps(21))
  have notstore: "\<not>(is_StoreFieldNode (kind g nid))"
    using EndNodes.hyps(1) is_AbstractEndNode.simps is_StoreFieldNode_def
    by (metis IRNode.distinct_disc(1926) is_EndNode.simps(44))
  have notdivrem: "\<not>(is_IntegerDivRemNode (kind g nid))"
    using EndNodes.hyps(1) is_AbstractEndNode.simps is_SignedDivNode_def is_SignedRemNode_def
    using IRNode.distinct_disc(1498) IRNode.distinct_disc(1500) is_IntegerDivRemNode.simps is_EndNode.simps(36) is_EndNode.simps(37)
    by auto
  from notseq notif notref notnew notload notstore notdivrem
  show ?case using EndNodes repAllDet evalAllDet
    by (smt (z3) is_IfNode_def is_LoadFieldNode_def is_NewInstanceNode_def is_RefNode_def is_StoreFieldNode_def is_SignedDivNode_def is_SignedRemNode_def  Pair_inject is_IntegerDivRemNode.elims(3) step.cases)
next
  case (NewInstanceNode nid f obj nxt h' ref h m' m)
  then have notseq: "\<not>(is_sequential_node (kind g nid))"
    using is_sequential_node.simps is_AbstractMergeNode.simps
    by (simp add: NewInstanceNode.hyps(1))
  have notend: "\<not>(is_AbstractEndNode (kind g nid))"
    using is_AbstractMergeNode.simps
    by (simp add: NewInstanceNode.hyps(1))
  have notif: "\<not>(is_IfNode (kind g nid))"
    using is_AbstractMergeNode.simps
    by (simp add: NewInstanceNode.hyps(1))
  have notref: "\<not>(is_RefNode (kind g nid))"
    using is_AbstractMergeNode.simps
    by (simp add: NewInstanceNode.hyps(1))
  have notload: "\<not>(is_LoadFieldNode (kind g nid))"
    using is_AbstractMergeNode.simps
    by (simp add: NewInstanceNode.hyps(1))
  have notstore: "\<not>(is_StoreFieldNode (kind g nid))"
    using is_AbstractMergeNode.simps
    by (simp add: NewInstanceNode.hyps(1))
  have notdivrem:  "\<not>(is_IntegerDivRemNode (kind g nid))"
    using is_AbstractMergeNode.simps
    by (simp add: NewInstanceNode.hyps(1))
  from notseq notend notif notref notload notstore notdivrem
  show ?case using NewInstanceNode step.cases
    by (smt (z3) IRNode.disc(1028) IRNode.disc(2270) IRNode.discI(11) IRNode.distinct(2311) IRNode.distinct(2313) IRNode.inject(31) Pair_inject)
next
  case (LoadFieldNode nid f obj nxt m ref h v m')
  then have notseq: "\<not>(is_sequential_node (kind g nid))"
    using is_sequential_node.simps is_AbstractMergeNode.simps
    by (simp add: LoadFieldNode.hyps(1))
  have notend: "\<not>(is_AbstractEndNode (kind g nid))"
    using is_AbstractEndNode.simps
    by (simp add: LoadFieldNode.hyps(1))
  have notdivrem:  "\<not>(is_IntegerDivRemNode (kind g nid))"
    using is_AbstractEndNode.simps
    by (simp add: LoadFieldNode.hyps(1))
  from notseq notend notdivrem
  show ?case using LoadFieldNode step.cases repDet evalDet
    by (smt (z3) IRNode.distinct(1051) IRNode.distinct(1721) IRNode.distinct(1739) IRNode.distinct(1741) IRNode.distinct(1745) IRNode.inject(20) Pair_inject Value.inject(2) option.distinct(1) option.inject)
next
  case (StaticLoadFieldNode nid f nxt h v m' m)
  then have notseq: "\<not>(is_sequential_node (kind g nid))"
    using is_sequential_node.simps is_AbstractMergeNode.simps
    by (simp add: StaticLoadFieldNode.hyps(1))
  have notend: "\<not>(is_AbstractEndNode (kind g nid))"
    using is_AbstractEndNode.simps
    by (simp add: StaticLoadFieldNode.hyps(1))
  have notdivrem: "\<not>(is_IntegerDivRemNode (kind g nid))"
    by (simp add: StaticLoadFieldNode.hyps(1))
  from notseq notend notdivrem
  show ?case using StaticLoadFieldNode step.cases
    by (smt (z3) IRNode.distinct(1051) IRNode.distinct(1721) IRNode.distinct(1739) IRNode.distinct(1741) IRNode.distinct(1745) IRNode.inject(20) Pair_inject option.distinct(1))
next
  case (StoreFieldNode nid f newval uu obj nxt m val ref h' h m')
  then have notseq: "\<not>(is_sequential_node (kind g nid))"
    using is_sequential_node.simps is_AbstractMergeNode.simps
    by (simp add: StoreFieldNode.hyps(1))
  have notend: "\<not>(is_AbstractEndNode (kind g nid))"
    using is_AbstractEndNode.simps
    by (simp add: StoreFieldNode.hyps(1))
  have notdivrem: "\<not>(is_IntegerDivRemNode (kind g nid))"
    by (simp add: StoreFieldNode.hyps(1))
  from notseq notend notdivrem
  show ?case using StoreFieldNode step.cases repDet evalDet
    by (smt (z3) IRNode.distinct(1097) IRNode.distinct(1745) IRNode.distinct(2317) IRNode.distinct(2605) IRNode.distinct(2627) IRNode.inject(43) Pair_inject Value.inject(2) option.distinct(1) option.inject)
next
  case (StaticStoreFieldNode nid f newval uv nxt m val h' h m')
  then have notseq: "\<not>(is_sequential_node (kind g nid))"
    using is_sequential_node.simps is_AbstractMergeNode.simps
    by (simp add: StaticStoreFieldNode.hyps(1))
  have notend: "\<not>(is_AbstractEndNode (kind g nid))"
    using is_AbstractEndNode.simps
    by (simp add: StaticStoreFieldNode.hyps(1))
  have notdivrem: "\<not>(is_IntegerDivRemNode (kind g nid))"
    by (simp add: StaticStoreFieldNode.hyps(1))
  from notseq notend notdivrem
  show ?case using StoreFieldNode step.cases repDet evalDet
    by (smt (z3) IRNode.distinct(1097) IRNode.distinct(1745) IRNode.distinct(2317) IRNode.distinct(2605) IRNode.distinct(2627) IRNode.inject(43) Pair_inject StaticStoreFieldNode.hyps(1) StaticStoreFieldNode.hyps(2) StaticStoreFieldNode.hyps(3) StaticStoreFieldNode.hyps(4) StaticStoreFieldNode.hyps(5) option.distinct(1))
next
  case (SignedDivNode nid x y zero sb nxt m v1 v2 v m' h)
  then have notseq: "\<not>(is_sequential_node (kind g nid))"
    using is_sequential_node.simps is_AbstractMergeNode.simps
    by (simp add: SignedDivNode.hyps(1))
  have notend: "\<not>(is_AbstractEndNode (kind g nid))"
    using is_AbstractEndNode.simps
    by (simp add: SignedDivNode.hyps(1))
  from notseq notend
  show ?case using SignedDivNode step.cases repDet evalDet
    by (smt (z3) IRNode.distinct(1091) IRNode.distinct(1739) IRNode.distinct(2311) IRNode.distinct(2601) IRNode.distinct(2605) IRNode.inject(40) Pair_inject)
next
  case (SignedRemNode nid x y zero sb nxt m v1 v2 v m' h)
  then have notseq: "\<not>(is_sequential_node (kind g nid))"
    using is_sequential_node.simps is_AbstractMergeNode.simps
    by (simp add: SignedRemNode.hyps(1))
  have notend: "\<not>(is_AbstractEndNode (kind g nid))"
    using is_AbstractEndNode.simps
    by (simp add: SignedRemNode.hyps(1))
  from notseq notend
  show ?case using SignedRemNode step.cases repDet evalDet
    by (smt (z3) IRNode.distinct(1093) IRNode.distinct(1741) IRNode.distinct(2313) IRNode.distinct(2601) IRNode.distinct(2627) IRNode.inject(41) Pair_inject)
qed

lemma stepRefNode:
  "\<lbrakk>kind g nid = RefNode nid'\<rbrakk> \<Longrightarrow> g, p \<turnstile> (nid,m,h) \<rightarrow> (nid',m,h)"
  using SequentialNode
  by (metis IRNodes.successors_of_RefNode is_sequential_node.simps(7) nth_Cons_0)

lemma IfNodeStepCases:
  assumes "kind g nid = IfNode cond tb fb"
  assumes "g \<turnstile> cond \<simeq> condE"
  assumes "[m, p] \<turnstile> condE \<mapsto> v"
  assumes "g, p \<turnstile> (nid, m, h) \<rightarrow> (nid', m, h)"
  shows "nid' \<in> {tb, fb}"
  using step.IfNode repDet stepDet assms
  by (metis insert_iff old.prod.inject)

lemma IfNodeSeq:
  shows "kind g nid = IfNode cond tb fb \<longrightarrow> \<not>(is_sequential_node (kind g nid))"
  unfolding is_sequential_node.simps
  using is_sequential_node.simps(18) by presburger

lemma IfNodeCond:
  assumes "kind g nid = IfNode cond tb fb"
  assumes "g, p \<turnstile> (nid, m, h) \<rightarrow> (nid', m, h)"
  shows "\<exists> condE v. ((g \<turnstile> cond \<simeq> condE) \<and> ([m, p] \<turnstile> condE \<mapsto> v))"
  using assms(2,1) by (induct "(nid,m,h)" "(nid',m,h)" rule: step.induct; auto)

lemma step_in_ids:
  assumes "g, p \<turnstile> (nid, m, h) \<rightarrow> (nid', m', h')"
  shows "nid \<in> ids g"
  using assms apply (induct "(nid, m, h)" "(nid', m', h')" rule: step.induct)
  using is_sequential_node.simps(45) not_in_g
  apply simp
  apply (metis is_sequential_node.simps(53))
  using ids_some
  using IRNode.distinct(1113) apply presburger
  using EndNodes(1) is_AbstractEndNode.simps is_EndNode.simps(45) ids_some
  apply (metis IRNode.disc(1218) is_EndNode.simps(52))
  by simp+

end


(*  Title:      HOL/Auth/Shared.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Theory of Shared Keys (common to all symmetric-key protocols)

Shared, long-term keys; initial states of agents
*)

theory Shared
imports Event All_Symmetric
begin

consts
  shrK    :: "agent => key"  (*symmetric keys*)

specification (shrK)
  inj_shrK: "inj shrK"
  \<comment>\<open>No two agents have the same long-term key\<close>
   apply (rule exI [of _ "case_agent 0 (\<lambda>n. n + 2) 1"])
   apply (simp add: inj_on_def split: agent.split)
   done

text\<open>Server knows all long-term keys; other agents know only their own\<close>

overloading
  initState \<equiv> initState
begin

primrec initState where
  initState_Server:  "initState Server     = Key ` range shrK"
| initState_Friend:  "initState (Friend i) = {Key (shrK (Friend i))}"
| initState_Spy:     "initState Spy        = Key`shrK`bad"

end

subsection\<open>Basic properties of shrK\<close>

(*Injectiveness: Agents' long-term keys are distinct.*)
lemmas shrK_injective = inj_shrK [THEN inj_eq]
declare shrK_injective [iff]

lemma invKey_K [simp]: "invKey K = K"
apply (insert isSym_keys)
apply (simp add: symKeys_def)
done

lemma analz_Decrypt' [dest]:
     "[| Crypt K X \<in> analz H;  Key K  \<in> analz H |] ==> X \<in> analz H"
by auto

text\<open>Now cancel the \<open>dest\<close> attribute given to
 \<open>analz.Decrypt\<close> in its declaration.\<close>
declare analz.Decrypt [rule del]

text\<open>Rewrites should not refer to  @{term "initState(Friend i)"} because
  that expression is not in normal form.\<close>

lemma keysFor_parts_initState [simp]: "keysFor (parts (initState C)) = {}"
apply (unfold keysFor_def)
apply (induct_tac "C", auto)
done

(*Specialized to shared-key model: no @{term invKey}*)
lemma keysFor_parts_insert:
     "[| K \<in> keysFor (parts (insert X G));  X \<in> synth (analz H) |]
      ==> K \<in> keysFor (parts (G \<union> H)) | Key K \<in> parts H"
by (metis invKey_K keysFor_parts_insert)

lemma Crypt_imp_keysFor: "Crypt K X \<in> H ==> K \<in> keysFor H"
by (metis Crypt_imp_invKey_keysFor invKey_K)

subsection\<open>Function "knows"\<close>

(*Spy sees shared keys of agents!*)
lemma Spy_knows_Spy_bad [intro!]: "A: bad ==> Key (shrK A) \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split: event.split)
done

(*For case analysis on whether or not an agent is compromised*)
lemma Crypt_Spy_analz_bad: "[| Crypt (shrK A) X \<in> analz (knows Spy evs);  A: bad |]
      ==> X \<in> analz (knows Spy evs)"
by (metis Spy_knows_Spy_bad analz.Inj analz_Decrypt')

(** Fresh keys never clash with long-term shared keys **)

(*Agents see their own shared keys!*)
lemma shrK_in_initState [iff]: "Key (shrK A) \<in> initState A"
by (induct_tac "A", auto)

lemma shrK_in_used [iff]: "Key (shrK A) \<in> used evs"
by (rule initState_into_used, blast)

(*Used in parts_induct_tac and analz_Fake_tac to distinguish session keys
  from long-term shared keys*)
lemma Key_not_used [simp]: "Key K \<notin> used evs ==> K \<notin> range shrK"
by blast

lemma shrK_neq [simp]: "Key K \<notin> used evs ==> shrK B \<noteq> K"
by blast

lemmas shrK_sym_neq = shrK_neq [THEN not_sym]
declare shrK_sym_neq [simp]

subsection\<open>Fresh nonces\<close>

lemma Nonce_notin_initState [iff]: "Nonce N \<notin> parts (initState B)"
by (induct_tac "B", auto)

lemma Nonce_notin_used_empty [simp]: "Nonce N \<notin> used []"
by (simp add: used_Nil)

subsection\<open>Supply fresh nonces for possibility theorems.\<close>

(*In any trace, there is an upper bound N on the greatest nonce in use.*)
lemma Nonce_supply_lemma: "\<exists>N. ALL n. N<=n --> Nonce n \<notin> used evs"
apply (induct_tac "evs")
apply (rule_tac x = 0 in exI)
apply (simp_all (no_asm_simp) add: used_Cons split: event.split)
apply (metis le_sup_iff msg_Nonce_supply)
done

lemma Nonce_supply1: "\<exists>N. Nonce N \<notin> used evs"
by (metis Nonce_supply_lemma order_eq_iff)

lemma Nonce_supply2: "\<exists>N N'. Nonce N \<notin> used evs & Nonce N' \<notin> used evs' & N \<noteq> N'"
apply (cut_tac evs = evs in Nonce_supply_lemma)
apply (cut_tac evs = "evs'" in Nonce_supply_lemma, clarify)
apply (metis Suc_n_not_le_n nat_le_linear)
done

lemma Nonce_supply3: "\<exists>N N' N''. Nonce N \<notin> used evs & Nonce N' \<notin> used evs' &
                    Nonce N'' \<notin> used evs'' & N \<noteq> N' & N' \<noteq> N'' & N \<noteq> N''"
apply (cut_tac evs = evs in Nonce_supply_lemma)
apply (cut_tac evs = "evs'" in Nonce_supply_lemma)
apply (cut_tac evs = "evs''" in Nonce_supply_lemma, clarify)
apply (rule_tac x = N in exI)
apply (rule_tac x = "Suc (N+Na)" in exI)
apply (rule_tac x = "Suc (Suc (N+Na+Nb))" in exI)
apply (simp (no_asm_simp) add: less_not_refl3 le_add1 le_add2 less_Suc_eq_le)
done

lemma Nonce_supply: "Nonce (@ N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule Nonce_supply_lemma [THEN exE])
apply (rule someI, blast)
done

text\<open>Unlike the corresponding property of nonces, we cannot prove
    @{term "finite KK ==> \<exists>K. K \<notin> KK & Key K \<notin> used evs"}.
    We have infinitely many agents and there is nothing to stop their
    long-term keys from exhausting all the natural numbers.  Instead,
    possibility theorems must assume the existence of a few keys.\<close>

subsection\<open>Specialized Rewriting for Theorems About @{term analz} and Image\<close>

lemma subset_Compl_range: "A <= - (range shrK) ==> shrK x \<notin> A"
by blast

lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} \<union> H"
by blast

lemma insert_Key_image: "insert (Key K) (Key`KK \<union> C) = Key`(insert K KK) \<union> C"
by blast

(** Reverse the normal simplification of "image" to build up (not break down)
    the set of keys.  Use analz_insert_eq with (Un_upper2 RS analz_mono) to
    erase occurrences of forwarded message components (X). **)

lemmas analz_image_freshK_simps =
       simp_thms mem_simps \<comment>\<open>these two allow its use with \<open>only:\<close>\<close>
       disj_comms
       image_insert [THEN sym] image_Un [THEN sym] empty_subsetI insert_subset
       analz_insert_eq Un_upper2 [THEN analz_mono, THEN [2] rev_subsetD]
       insert_Key_singleton subset_Compl_range
       Key_not_used insert_Key_image Un_assoc [THEN sym]

(*Lemma for the trivial direction of the if-and-only-if*)
lemma analz_image_freshK_lemma:
     "(Key K \<in> analz (Key`nE \<union> H)) --> (K \<in> nE | Key K \<in> analz H)  ==>
         (Key K \<in> analz (Key`nE \<union> H)) = (K \<in> nE | Key K \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsection\<open>Tactics for possibility theorems\<close>

ML
\<open>
structure Shared =
struct

(*Omitting used_Says makes the tactic much faster: it leaves expressions
    such as  Nonce ?N \<notin> used evs that match Nonce_supply*)
fun possibility_tac ctxt =
   (REPEAT
    (ALLGOALS (simp_tac (ctxt
          delsimps [@{thm used_Says}, @{thm used_Notes}, @{thm used_Gets}]
          setSolver safe_solver))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac ctxt [refl, conjI, @{thm Nonce_supply}])))

(*For harder protocols (such as Recur) where we have to set up some
  nonces and keys initially*)
fun basic_possibility_tac ctxt =
    REPEAT
    (ALLGOALS (asm_simp_tac (ctxt setSolver safe_solver))
     THEN
     REPEAT_FIRST (resolve_tac ctxt [refl, conjI]))

val analz_image_freshK_ss =
  simpset_of
   (@{context} delsimps [image_insert, image_Un]
      delsimps [@{thm imp_disjL}]    (*reduces blow-up*)
      addsimps @{thms analz_image_freshK_simps})

end
\<close>

(*Lets blast_tac perform this step without needing the simplifier*)
lemma invKey_shrK_iff [iff]:
     "(Key (invKey K) \<in> X) = (Key K \<in> X)"
by auto

(*Specialized methods*)

method_setup analz_freshK = \<open>
    Scan.succeed (fn ctxt =>
     (SIMPLE_METHOD
      (EVERY [REPEAT_FIRST (resolve_tac ctxt [allI, ballI, impI]),
          REPEAT_FIRST (resolve_tac ctxt @{thms analz_image_freshK_lemma}),
          ALLGOALS (asm_simp_tac (put_simpset Shared.analz_image_freshK_ss ctxt))])))\<close>
    "for proving the Session Key Compromise theorem"

method_setup possibility = \<open>
    Scan.succeed (fn ctxt => SIMPLE_METHOD (Shared.possibility_tac ctxt))\<close>
    "for proving possibility theorems"

method_setup basic_possibility = \<open>
    Scan.succeed (fn ctxt => SIMPLE_METHOD (Shared.basic_possibility_tac ctxt))\<close>
    "for proving possibility theorems"

lemma knows_subset_knows_Cons: "knows A evs <= knows A (e # evs)"
by (cases e) (auto simp: knows_Cons)

end


theory Lambda imports "../Nominal2" begin

atom_decl name

nominal_datatype lam =
  Var "name"
| App "lam" "lam"
| Lam x::"name" l::"lam"  binds x in l ("Lam [_]. _" [100, 100] 100)

nominal_function lookup where
  "lookup (n :: name) m [] \<longleftrightarrow> (n = m)"
| "lookup n m ((hn, hm) # t) \<longleftrightarrow>
     (n, m) = (hn, hm) \<or> (n \<noteq> hn \<and> m \<noteq> hm \<and> lookup n m t)"
  apply (simp add: eqvt_def lookup_graph_def)
  apply (rule, perm_simp, rule, rule)
  by pat_completeness auto

nominal_termination (eqvt) by lexicographic_order

nominal_function lam2_rec where
  "lam2_rec faa fll xs (Var n) (Var m) = lookup n m xs"
| "lam2_rec faa fll xs (Var n) (App l r) = False"
| "lam2_rec faa fll xs (Var n) (Lam [x]. t) = False"
| "lam2_rec faa fll xs (App l r) (Var n) = False"
| "lam2_rec faa fll xs (App l1 r1) (App l2 r2) = faa l1 r1 l2 r2"
| "lam2_rec faa fll xs (App l r) (Lam [x]. t) = False"
| "lam2_rec faa fll xs (Lam [x]. t) (Var n) = False"
| "lam2_rec faa fll xs (Lam [x]. t) (App l1 r1) = False"
| "(atom x \<sharp> (xs, Lam [y]. s) \<and> atom y \<sharp> (x, xs, Lam [x]. t) \<and>
     (\<forall>x' y' t' s'. atom x' \<sharp> (xs, Lam [y']. s') \<longrightarrow> atom y' \<sharp> (x', xs, Lam [x']. t') \<longrightarrow> Lam [x]. t = Lam [x']. t' \<longrightarrow> Lam [y]. s = Lam [y']. s'
        \<longrightarrow> fll x t y s = fll x' t' y' s')) \<Longrightarrow>
     lam2_rec faa fll xs (Lam [x]. t) (Lam [y]. s) = fll x t y s"
| "(atom x \<sharp> (xs, Lam [y]. s) \<and> atom y \<sharp> (x, xs, Lam [x]. t) \<and>
     \<not>(\<forall>x' y' t' s'. atom x' \<sharp> (xs, Lam [y']. s') \<longrightarrow> atom y' \<sharp> (x', xs, Lam [x']. t') \<longrightarrow> Lam [x]. t = Lam [x']. t' \<longrightarrow> Lam [y]. s = Lam [y']. s'
        \<longrightarrow> fll x t y s = fll x' t' y' s')) \<Longrightarrow>
     lam2_rec faa fll xs (Lam [x]. t) (Lam [y]. s) = False"
  apply (simp add: eqvt_def lam2_rec_graph_def)
  apply (rule, perm_simp, rule, rule)
  apply (case_tac x)
  apply (rule_tac y="d" and c="(c, e)" in lam.strong_exhaust)
  apply (rule_tac y="e" and c="(c, d)" in lam.strong_exhaust)
  apply simp_all[3]  apply (metis, metis, metis)
  apply (rule_tac y="e" and c="(c, d)" in lam.strong_exhaust)
  apply simp_all[3]  apply (metis, metis, metis)
  apply (rule_tac y="e" and c="(name, c, d)" in lam.strong_exhaust)
  apply simp_all[2]  apply (metis, metis)
  unfolding fresh_star_def
  apply (thin_tac "\<And>faa fll xs n m. x = (faa, fll, xs, Var n, Var m) \<Longrightarrow> P")
  apply (thin_tac "\<And>faa fll xs n l r. x = (faa, fll, xs, Var n, App l r) \<Longrightarrow> P")
  apply (thin_tac "\<And>faa fll xs n xa t. x = (faa, fll, xs, Var n, Lam [xa]. t) \<Longrightarrow> P")
  apply (thin_tac "\<And>faa fll xs l1 r1 l2 r2. x = (faa, fll, xs, App l1 r1, App l2 r2) \<Longrightarrow> P")
  apply (thin_tac "\<And>faa fll xs l r n. x = (faa, fll, xs, App l r, Var n) \<Longrightarrow> P")
  apply (thin_tac "\<And>faa fll xs l r xa t. x = (faa, fll, xs, App l r, Lam [xa]. t) \<Longrightarrow> P")
  apply (thin_tac "\<And>faa fll xs xa t n. x = (faa, fll, xs, Lam [xa]. t, Var n) \<Longrightarrow> P")
  apply (thin_tac "\<And>faa fll xs xa t l1 r1. x = (faa, fll, xs, Lam [xa]. t, App l1 r1) \<Longrightarrow> P")
  apply (drule_tac x="name" in meta_spec)+
  apply (drule_tac x="c" in meta_spec)+
  apply (drule_tac x="namea" in meta_spec)+
  apply (drule_tac x="lama" in meta_spec)
  apply (drule_tac x="lama" in meta_spec)
  apply (drule_tac x="lam" in meta_spec)+
  apply (drule_tac x="b" in meta_spec)+
  apply (drule_tac x="a" in meta_spec)+
  apply (case_tac "(\<forall>x' y' t' s'. atom x' \<sharp> (c, Lam [y']. s') \<longrightarrow>
             atom y' \<sharp> (x', c, Lam [x']. t') \<longrightarrow> Lam [name]. lam = Lam [x']. t' \<longrightarrow>
             Lam [namea]. lama = Lam [y']. s' \<longrightarrow> b name lam namea lama = b x' t' y' s')")
  apply clarify
  apply (simp)
  apply (simp only: fresh_Pair_elim)
  apply blast
  apply (simp_all)[53]
  apply clarify
  apply metis
  apply simp
  done

nominal_termination (eqvt) by lexicographic_order

lemma lam_rec2_cong[fundef_cong]:
  "(\<And>s1 s2 s3 s4. l = App s1 s2 \<Longrightarrow> l2 = App s3 s4  \<Longrightarrow> faa s1 s2 s3 s4 = faa' s1 s2 s3 s4) \<Longrightarrow>
   (\<And>n t n' t'. l = Lam [n]. t \<Longrightarrow> l2 = Lam [n']. t' \<Longrightarrow> fll n t n' t' = fll' n t n' t') \<Longrightarrow>
  lam2_rec faa fll xs l l2 = lam2_rec faa' fll' xs l l2"
  apply (rule_tac y="l" and c="(xs, l2)" in lam.strong_exhaust)
  apply (rule_tac y="l2" and c="(xs, l)" in lam.strong_exhaust) apply auto[3]
  apply (rule_tac y="l2" and c="(xs, l)" in lam.strong_exhaust) apply auto[3]
  apply (rule_tac y="l2" and c="(name, xs, l)" in lam.strong_exhaust)
  apply auto[2]
  apply clarify
  apply (case_tac "(\<forall>x' y' t' s'. atom x' \<sharp> (xs, Lam [y']. s') \<longrightarrow>
    atom y' \<sharp> (x', xs, Lam [x']. t') \<longrightarrow> Lam [name]. lam = Lam [x']. t' \<longrightarrow>
    Lam [namea]. lama = Lam [y']. s' \<longrightarrow> fll name lam namea lama = fll x' t' y' s')")
  unfolding fresh_star_def
  apply (subst lam2_rec.simps) apply simp
  apply (subst lam2_rec.simps) apply simp
  apply metis
  apply (subst lam2_rec.simps(10)) apply (simp add: fresh_star_def)
  apply (subst lam2_rec.simps(10)) apply (simp_all add: fresh_star_def)
  done

nominal_function aux :: "lam \<Rightarrow> lam \<Rightarrow> (name \<times> name) list \<Rightarrow> bool"
  where
[simp del]: "aux l r xs = lam2_rec
  (%t1 t2 t3 t4. (aux t1 t3 xs) \<and> (aux t2 t4 xs))
  (%x t y s. aux t s ((x, y) # xs)) xs l r"
  unfolding eqvt_def aux_graph_def
  apply (rule, perm_simp, rule, rule)
  by pat_completeness auto

nominal_termination (eqvt)
  by (relation "measure (\<lambda>(l, r, xs). size l + size r)") simp_all

lemma aux_simps[simp]:
  "aux (Var x) (Var y) xs = lookup x y xs"
  "aux (App t1 t2) (App s1 s2) xs = (aux t1 s1 xs \<and> aux t2 s2 xs)"
  "aux (Var x) (App t1 t2) xs = False"
  "aux (Var x) (Lam [y].t) xs = False"
  "aux (App t1 t2) (Var x) xs = False"
  "aux (App t1 t2) (Lam [x].t) xs = False"
  "aux (Lam [x].t) (Var y) xs = False"
  "aux (Lam [x].t) (App t1 t2) xs = False"
  "\<lbrakk>atom x \<sharp> (s, xs); atom y \<sharp> (x, t, xs)\<rbrakk> \<Longrightarrow> aux (Lam [x].t) (Lam [y].s) xs = aux t s ((x, y) # xs)"
  apply (subst aux.simps, simp)
  apply (subst aux.simps, simp)
  apply (subst aux.simps, simp)
  apply (subst aux.simps, simp)
  apply (subst aux.simps, simp)
  apply (subst aux.simps, simp)
  apply (subst aux.simps, simp)
  apply (subst aux.simps, simp)
  apply (subst aux.simps)
  apply (subst lam2_rec.simps)
  apply (rule, simp add: lam.fresh)
  apply (rule, simp add: lam.fresh)
  apply (intro allI impI)
  apply (rule_tac x="(x, x', y, y', t, t', s, s', xs)" and ?'a="name" in obtain_fresh)
  apply (rule_tac x="(a, x, x', y, y', t, t', s, s', xs)" and ?'a="name" in obtain_fresh)
  apply (rule_tac s="aux ((atom x \<rightleftharpoons> atom a) \<bullet> t) s ((a, y) # xs)" in trans)
  apply (rule_tac s="(atom x \<rightleftharpoons> atom a) \<bullet> aux t s ((x, y) # xs)" in trans)
  apply (rule permute_pure[symmetric])
  apply (simp add: eqvts swap_fresh_fresh)
  apply (simp add: lam.fresh fresh_at_base fresh_Pair_elim)
  apply (rename_tac b)
  apply (rule_tac s="aux ((atom x \<rightleftharpoons> atom a) \<bullet> t) ((atom y \<rightleftharpoons> atom b) \<bullet> s) ((a, b) # xs)" in trans)
  apply (rule_tac s="(atom y \<rightleftharpoons> atom b) \<bullet> aux ((atom x \<rightleftharpoons> atom a) \<bullet> t) s ((a, y) # xs)" in trans)
  apply (rule permute_pure[symmetric])
  apply (simp add: eqvts swap_fresh_fresh)
  apply (simp add: lam.fresh fresh_at_base fresh_Pair_elim)
  apply (subst permute_eqvt)
  apply (simp add: eqvts swap_fresh_fresh)
  apply (rule sym)
  apply (rule_tac s="aux ((atom x' \<rightleftharpoons> atom a) \<bullet> t') s' ((a, y') # xs)" in trans)
  apply (rule_tac s="(atom x' \<rightleftharpoons> atom a) \<bullet> aux t' s' ((x', y') # xs)" in trans)
  apply (rule permute_pure[symmetric])
  apply (simp add: eqvts swap_fresh_fresh)
  apply (simp add: lam.fresh fresh_at_base fresh_Pair_elim swap_fresh_fresh)
  apply (rule_tac s="aux ((atom x' \<rightleftharpoons> atom a) \<bullet> t') ((atom y' \<rightleftharpoons> atom b) \<bullet> s') ((a, b) # xs)" in trans)
  apply (rule_tac s="(atom y' \<rightleftharpoons> atom b) \<bullet> aux ((atom x' \<rightleftharpoons> atom a) \<bullet> t') s' ((a, y') # xs)" in trans)
  apply (rule permute_pure[symmetric])
  apply (simp add: eqvts swap_fresh_fresh)
  apply (simp add: lam.fresh fresh_at_base fresh_Pair_elim swap_fresh_fresh)
  apply (subst permute_eqvt)
  apply (simp add: eqvts swap_fresh_fresh)
  apply (subgoal_tac "(atom x' \<rightleftharpoons> atom a) \<bullet> t' = (atom x \<rightleftharpoons> atom a) \<bullet> t")
  apply (subgoal_tac "(atom y' \<rightleftharpoons> atom b) \<bullet> s' = (atom y \<rightleftharpoons> atom b) \<bullet> s")
  apply simp
  apply (subgoal_tac "Lam [y]. s = Lam [b]. ((atom y \<rightleftharpoons> atom b) \<bullet> s)")
  apply (subgoal_tac "Lam [y']. s' = Lam [b]. ((atom y' \<rightleftharpoons> atom b) \<bullet> s')")
  apply (auto simp add: fresh_Pair_elim Abs1_eq_iff)[1]
  apply (rule sym)
  apply (simp add: Abs1_eq_iff fresh_Pair_elim fresh_at_base swap_commute)
  apply (rule sym)
  apply (simp add: Abs1_eq_iff fresh_Pair_elim fresh_at_base swap_commute)
  apply (subgoal_tac "Lam [x]. t = Lam [a]. ((atom x \<rightleftharpoons> atom a) \<bullet> t)")
  apply (subgoal_tac "Lam [x']. t' = Lam [a]. ((atom x' \<rightleftharpoons> atom a) \<bullet> t')")
  apply (auto simp add: fresh_Pair_elim Abs1_eq_iff)[1]
  apply (rule sym)
  apply (simp add: Abs1_eq_iff fresh_Pair_elim fresh_at_base swap_commute)
  apply (rule sym)
  apply (simp add: Abs1_eq_iff fresh_Pair_elim fresh_at_base swap_commute)
  apply (rule refl)
  done

lemma aux_induct:  "\<lbrakk>\<And>xs n m. P xs (Var n) (Var m); \<And>xs n l r. P xs (Var n) (App l r);
 \<And>xs n x t. P xs (Var n) (Lam [x]. t);
 \<And>xs l r n. P xs (App l r) (Var n);
 (\<And>xs l1 r1 l2 r2. P xs l1 l2 \<Longrightarrow> P xs r1 r2 \<Longrightarrow> P xs (App l1 r1) (App l2 r2));
 \<And>xs l r x t. P xs (App l r) (Lam [x]. t);
 \<And>xs x t n. P xs (Lam [x]. t) (Var n);
 \<And>xs x t l1 r1. P xs (Lam [x]. t) (App l1 r1);
 \<And>x xs y s t.
    atom x \<sharp> (xs, Lam [y]. s) \<and>
    atom y \<sharp> (x, xs, Lam [x]. t) \<Longrightarrow> P ((x, y) # xs) t s \<Longrightarrow> P xs (Lam [x]. t) (Lam [y]. s)\<rbrakk>
\<Longrightarrow> P (a :: (name \<times> name) list) b c"
  apply (induction_schema)
  apply (rule_tac y="b" and c="(a, c)" in lam.strong_exhaust)
  apply (rule_tac y="c" and c="(name, a, b)" in lam.strong_exhaust)
  apply simp_all[3] apply (metis)
  apply (rule_tac y="c" and c="(name, a, b)" in lam.strong_exhaust)
  apply simp_all[3] apply (metis, metis, metis)
  apply (rule_tac y="c" and c="(name, a, b)" in lam.strong_exhaust)
  apply simp_all[3] apply (metis)
  apply (simp add: fresh_star_def)
  apply metis
  apply lexicographic_order
  done

nominal_function swapequal :: "lam \<Rightarrow> lam \<Rightarrow> (name \<times> name) list \<Rightarrow> bool" where
  "swapequal l r [] \<longleftrightarrow> l = r"
| "atom x \<sharp> (l, r, hl, hr, t) \<Longrightarrow>
    swapequal l r ((hl, hr) # t) \<longleftrightarrow> swapequal ((hl \<leftrightarrow> x) \<bullet> l) ((hr \<leftrightarrow> x) \<bullet> r) t"
  unfolding eqvt_def swapequal_graph_def
  apply (rule, perm_simp, rule, rule TrueI)
  apply (case_tac x)
  apply (case_tac c)
  apply metis
  apply (case_tac aa)
  apply (rename_tac l r lst h t hl hr)
  apply (rule_tac x="(l, r, hl, hr, t)" and ?'a="name" in obtain_fresh)
  apply simp
  apply simp
  apply simp
  apply clarify
  apply (rule_tac s="(x \<leftrightarrow> xa) \<bullet> swapequal_sumC ((hla \<leftrightarrow> x) \<bullet> la, (hra \<leftrightarrow> x) \<bullet> ra, ta)" in trans)
  apply (simp only: permute_pure)
  apply (simp add: eqvt_at_def fresh_Pair_elim)
  apply (simp add: flip_fresh_fresh)
  apply (subgoal_tac "(x \<leftrightarrow> xa) \<bullet> (hla \<leftrightarrow> x) \<bullet> la = (hla \<leftrightarrow> xa) \<bullet> la")
  apply (subgoal_tac "(x \<leftrightarrow> xa) \<bullet> (hra \<leftrightarrow> x) \<bullet> ra = (hra \<leftrightarrow> xa) \<bullet> ra")
  apply simp
  apply (subst permute_eqvt)
  apply (simp add: flip_fresh_fresh flip_eqvt)
  apply (subst permute_eqvt)
  apply (simp add: flip_fresh_fresh flip_eqvt)
  done

nominal_termination (eqvt) by lexicographic_order

lemma var_eq_swapequal: "atom ab \<sharp> xs \<Longrightarrow> swapequal (Var ab) (Var ab) xs"
  apply (induct xs)
  apply simp
  apply (case_tac a)
  apply (simp add: fresh_Cons)
  apply (rule_tac x="(ab, aa, b, xs)" and ?'a="name" in obtain_fresh)
  apply (subst swapequal.simps)
  apply (simp add: fresh_Pair lam.fresh)
  apply (simp add: fresh_Pair_elim)
  by (metis flip_at_base_simps(3) fresh_Pair fresh_at_base(2))

lemma var_neq_swapequal:
  "atom ab \<sharp> xs \<Longrightarrow> ab \<noteq> m \<Longrightarrow> \<not> swapequal (Var ab) (Var m) xs"
  "atom ab \<sharp> xs \<Longrightarrow> ab \<noteq> m \<Longrightarrow> \<not> swapequal (Var m) (Var ab) xs"
  apply (induct xs arbitrary: m)
  apply simp_all[2]
  apply (case_tac [!] a)
  apply (simp_all add: fresh_Cons)
  apply (rule_tac [!] x="(ab, aa, b, m, xs)" and ?'a="name" in obtain_fresh)
  apply (subst swapequal.simps)
  apply (auto simp add: fresh_Pair lam.fresh)[1]
  apply (elim conjE)
  apply (simp add: fresh_Pair_elim fresh_at_base permute_flip_at)
  apply (subst swapequal.simps)
  apply (auto simp add: fresh_Pair lam.fresh)[1]
  apply (elim conjE)
  apply (simp add: fresh_Pair_elim fresh_at_base permute_flip_at)
  done

lemma lookup_swapequal: "lookup n m xs = swapequal (Var n) (Var m) xs"
  apply (induct xs arbitrary: m n)
  apply simp
  apply (case_tac a)
  apply (rule_tac x="(n, m, aa, b, xs)" and ?'a="name" in obtain_fresh)
  apply simp
  apply (subst swapequal.simps)
  apply (simp add: fresh_Pair lam.fresh fresh_Nil)
  by (metis (hide_lams, mono_tags) flip_at_base_simps(3) flip_at_simps(1) fresh_Pair fresh_at_base(2) lam.perm_simps(1) var_eq_swapequal var_neq_swapequal(1) var_neq_swapequal(2))

lemma swapequal_reorder: "
  a \<noteq> x \<Longrightarrow> a \<noteq> y \<Longrightarrow> b \<noteq> x \<Longrightarrow> b \<noteq> y \<Longrightarrow>
  swapequal t s ((x, y) # (a, b) # xs) = swapequal t s ((a, b) # (x, y) # xs)"
  apply (rule_tac x="(a, b, x, y, t, s, xs)" and ?'a="name" in obtain_fresh)
  apply (rule_tac x="(a, b, x, y, t, s, xs, aa)" and ?'a="name" in obtain_fresh)
  apply (rename_tac f g)
  apply (simp add: fresh_Pair_elim fresh_at_base)
  apply (subst swapequal.simps)
  apply (auto simp add: fresh_Pair fresh_Cons fresh_at_base)[1]
  apply (subgoal_tac "(x \<leftrightarrow> f) \<bullet> atom g \<sharp> t")
  apply (subst swapequal.simps)
  apply (simp add: fresh_Pair fresh_Cons fresh_permute_left)
  apply rule apply assumption
  apply (simp add: flip_at_base_simps fresh_at_base flip_def)
  apply (subst swapequal.simps)
  apply (simp add: fresh_Pair fresh_Cons fresh_at_base)
  apply rule apply (rotate_tac 12)
  apply assumption
  apply (simp add: fresh_Pair fresh_Cons fresh_at_base)
  apply (subst swapequal.simps)
  apply (simp add: fresh_Pair fresh_Cons fresh_at_base fresh_permute_left)
  apply (subgoal_tac "(a \<leftrightarrow> g) \<bullet> atom f \<sharp> t")
  apply rule apply assumption
  apply (simp add: flip_at_base_simps fresh_at_base flip_def)
  apply (simp add: flip_at_base_simps fresh_at_base flip_def)
  apply (subgoal_tac "(a \<leftrightarrow> g) \<bullet> (x \<leftrightarrow> f) \<bullet> t = (x \<leftrightarrow> f) \<bullet> (a \<leftrightarrow> g) \<bullet> t")
  apply (subgoal_tac "(b \<leftrightarrow> g) \<bullet> (y \<leftrightarrow> f) \<bullet> s = (y \<leftrightarrow> f) \<bullet> (b \<leftrightarrow> g) \<bullet> s")
  apply simp
  apply (subst permute_eqvt) apply (simp add: flip_eqvt)
  apply (subst permute_eqvt) apply (simp add: flip_eqvt)
  apply (simp add: flip_at_base_simps fresh_at_base flip_def)
  done

lemma swapequal_lambda:
  assumes "distinct xs \<and> atom x \<sharp> xs \<and> atom y \<sharp> xs"
  shows "swapequal (Lam [x]. t) (Lam [y]. s) xs = swapequal t s ((x, y) # xs)"
  using assms
  apply (induct xs arbitrary: t s x y)
  apply (rule_tac x="(x, y, t, s)" and ?'a="name" in obtain_fresh)
  apply (simp add: fresh_Pair_elim fresh_Nil)
  apply (subst swapequal.simps)
  apply (simp add: fresh_Pair fresh_Nil)
  apply auto[1]
  apply simp
  apply (subgoal_tac "[[atom x]]lst. t = [[atom a]]lst. ((x \<leftrightarrow> a) \<bullet> t)")
  apply (subgoal_tac "[[atom y]]lst. s = [[atom a]]lst. ((y \<leftrightarrow> a) \<bullet> s)")
  apply simp
  apply (simp add: Abs1_eq_iff)
  apply (auto simp add: Abs1_eq_iff flip_def fresh_at_base)[2]
  apply (simp add: fresh_permute_left)
  apply (simp add: fresh_permute_left)
  apply clarify
  apply (simp add: fresh_Cons fresh_Pair fresh_at_base)
  apply clarify
  apply (simp add: swapequal_reorder)
  apply (rule_tac x="(x, y, t, s, a, b, xs)" and ?'a="name" in obtain_fresh)
  apply (rename_tac f)
  apply (subst (2) swapequal.simps)
  apply (auto simp add: lam.fresh fresh_Pair fresh_at_base fresh_Cons)[1]
  apply (subst swapequal.simps)
  apply (auto simp add: lam.fresh fresh_Pair fresh_at_base fresh_Cons)[1]
  apply (simp add: flip_def fresh_Pair_elim fresh_at_base)
  done

lemma distinct_swapequal: "\<forall>p q. p \<bullet> l \<noteq> q \<bullet> r \<Longrightarrow> \<not>swapequal l r xs"
  apply (induct xs rule:swapequal.induct)
  apply auto[1]
  apply (simp add: fresh_Pair_elim)
  apply (subgoal_tac "\<forall>(p\<Colon>perm) q\<Colon>perm. p \<bullet> (hl \<leftrightarrow> x) \<bullet> l \<noteq> q \<bullet> (hr \<leftrightarrow> x) \<bullet> r")
  apply simp
  apply (intro allI)
  apply (drule_tac x="p + (hl \<leftrightarrow> x)" in spec)
  apply (drule_tac x="q + (hr \<leftrightarrow> x)" in spec)
  apply simp
  done

lemma swapequal_app: "(swapequal l1 l2 xs \<and> swapequal r1 r2 xs) = swapequal (App l1 r1) (App l2 r2) xs"
  apply (induct xs arbitrary: l1 l2 r1 r2)
  apply simp
  apply (case_tac a)
  apply simp
  apply (rule_tac x="(l1, l2, r1, r2, aa, b, xs)" and ?'a="name" in obtain_fresh)
  apply (simp add: fresh_Pair_elim)
  apply (subst swapequal.simps) apply (auto simp add: fresh_Pair)[1]
  apply (subst swapequal.simps) apply (auto simp add: fresh_Pair lam.fresh)
  done

lemma [simp]:
  "atom x \<sharp> xs \<Longrightarrow> x \<notin> fst ` set xs"
  "atom x \<sharp> xs \<Longrightarrow> x \<notin> snd ` set xs"
  apply (induct xs)
  apply simp_all
  apply (case_tac [!] a)
  apply (simp_all add: fresh_Cons fresh_Pair fresh_at_base)
  done

lemma aux_alphaish:
  assumes "distinct (map fst xs @ map snd xs)"
  shows "aux x y xs \<longleftrightarrow> swapequal x y xs"
  using assms
  apply (induct xs x y rule: aux_induct)
  apply (simp add: lookup_swapequal)
  apply (simp, rule distinct_swapequal, simp)+
  apply (simp add: swapequal_app)
  apply (simp, rule distinct_swapequal, simp)+
  apply (simp add: fresh_Pair_elim lam.fresh fresh_at_base conjE)
  apply (elim conjE)
  apply (simp add: fresh_Pair_elim lam.fresh fresh_at_base)
  apply (subgoal_tac "x \<notin> fst ` set xs \<and>
        x \<notin> snd ` set xs \<and> y \<notin> snd ` set xs \<and> y \<notin> fst ` set xs")
  apply (subst swapequal_lambda)
  apply auto[2]
  apply simp
  done

lemma aux_is_alpha:
  "aux x y [] \<longleftrightarrow> (x = y)"
  by (simp_all add: supp_Nil aux_alphaish)

end