theory "HSem-Equivalences"
imports HSem HSemUpd
begin
lemma disjoint_join_is_update:
  assumes "fdom \<rho>1 = d1"
  assumes "fdom \<rho>2 = d2"
  assumes "d1 \<inter> d2 = {}"
  shows "\<rho>1\<^bsub>[d1 \<union> d2]\<^esub> \<squnion> \<rho>2\<^bsub>[d1 \<union> d2]\<^esub> = \<rho>1 f++ \<rho>2"
proof-
  have disjoint: "fdom \<rho>1 \<inter> fdom \<rho>2 = {}" using assms by auto

  have compat[simp]: "compatible (\<rho>1\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub>) (\<rho>2\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub>)"
  proof (rule compatible_fmapI)
    show "fdom (\<rho>1\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub>) = fdom (\<rho>2\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub>)"
      by simp
    fix x
    assume "x \<in> fdom (\<rho>1\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub>)"
    hence "(x \<in> fdom \<rho>1 \<and> x \<notin> fdom \<rho>2) \<or> (x \<in> fdom \<rho>2 \<and> x \<notin> fdom \<rho>1)" using disjoint by auto
    thus "compatible (\<rho>1\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub> f! x) (\<rho>2\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub> f! x)"
      by auto
  qed

  have "\<rho>1 f++ \<rho>2 = \<rho>1\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub> \<squnion> \<rho>2\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub>"
  proof
    show "fdom (\<rho>1 f++ \<rho>2) = fdom (\<rho>1\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub> \<squnion> \<rho>2\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub>)"
      by simp
  next
    fix x
    assume "x \<in> fdom (\<rho>1 f++ \<rho>2)"
    hence "(x \<in> fdom \<rho>1 \<and> x \<notin> fdom \<rho>2) \<or> (x \<in> fdom \<rho>2 \<and> x \<notin> fdom \<rho>1)" using disjoint by auto
    thus "\<rho>1 f++ \<rho>2 f! x = \<rho>1\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub> \<squnion> \<rho>2\<^bsub>[fdom \<rho>1 \<union> fdom \<rho>2]\<^esub> f! x"
      by auto
  qed
  thus ?thesis using assms by simp
qed

theorem heap_update_join:
  assumes disjoint: "fdom \<rho> \<inter> heapVars \<Gamma> = {}"
  assumes exp_eq: "\<And> e. e \<in> snd ` set \<Gamma> \<Longrightarrow> ESem1 e = ESem2 e"
  shows "HSemUpd.has_ESem.HSem ESem1 \<Gamma> \<cdot> \<rho> = HSem.has_ESem.HSem ESem2 \<Gamma> \<rho>"
proof-
  interpret Upd: has_ESem ESem1.
  interpret HSem:has_ESem ESem2.

  have cond: "fix_join_cond (\<rho>\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>)
                        (\<lambda> \<rho>' . heapToEnv \<Gamma> (\<lambda>e. ESem2 e \<rho>')\<^bsub>[fdom \<rho> \<union> heapVars \<Gamma>]\<^esub>)"
    by (rule HSem.disjoint_is_HSem_cond[OF disjoint])

  have heapToEnv_eq: "\<And> \<rho>. heapToEnv \<Gamma> (\<lambda>e. ESem1 e \<rho>) = heapToEnv \<Gamma> (\<lambda>e. ESem2 e \<rho>)"
    by (rule heapToEnv_cong[OF refl exp_eq])

  show ?thesis
    unfolding Upd.UHSem_def' HSem.HSem_def'[OF cond]
    apply (simp add: bottom_of_fjc to_bot_fmap_def)
    apply (rule fix_on_cong[OF Upd.fix_on_cond_UHSem])
    apply (simp add: heapToEnv_eq)
    apply (rule disjoint_join_is_update[OF refl _ disjoint, symmetric])
    apply simp
    done
qed

context has_cont_ESem
begin
  lemma replace_upd: "UHSem \<Gamma> \<rho> = HSem \<Gamma> (\<rho> f|` (- heapVars \<Gamma>))"
  proof-
    have "UHSem \<Gamma> \<rho> = UHSem \<Gamma> (\<rho> f|` (- heapVars \<Gamma>))"
      by (metis UHSem_Nil UHSem_restr Un_iff all_not_in_conv diff_eq fdom_UHSem fdom_fmap_restr fmap_restr_UHSem_noop fmap_restr_fmap_restr inf_bot_right)
    also have "\<dots> = HSem \<Gamma> (\<rho> f|` (- heapVars \<Gamma>))"
      by (rule heap_update_join[OF _ ESem_cont ESem_cont refl]) auto
    finally
    show ?thesis.
  qed

  lemmas iterative_HSem'_cond_join = iterative_UHSem'_cond[unfolded replace_upd]
  thm trans[OF iterative_UHSem iterative_UHSem', unfolded replace_upd]
  thm iterative_UHSem [unfolded replace_upd]
  lemmas iterative_HSem_join       = iterative_UHSem [unfolded replace_upd]
  lemmas iterative_HSem'_join      = iterative_UHSem'[unfolded replace_upd]
end

end


theory SINVAR_NoRefl
imports "../TopoS_Helper"
begin

subsection {* SecurityInvariant NoRefl *}

text{*Hosts are not allowed to communicate with themselves.*}

text {* This can be used to effectively lift hosts to roles.
        Just list all roles that are allowed to communicate with themselves.
        Otherwise, communication between hosts of the same role (group) is prohibited.
        Useful in conjunction with the security gateway. *}

datatype node_config = NoRefl | Refl

definition default_node_properties :: "node_config"
  where  "default_node_properties = NoRefl"

fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (s, r) \<in> edges G. s = r \<longrightarrow> nP s = Refl)"

fun verify_globals :: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> 'b \<Rightarrow> bool" where
  "verify_globals _ _ _ = True"

definition receiver_violation :: "bool" where "receiver_violation = False"

subsubsection {*Preliminaries*}

 lemma NoRfl_ENRsr: "SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_sr sinvar (\<lambda> nP\<^sub>s s nP\<^sub>r r. s = r \<longrightarrow> nP\<^sub>s = Refl)"
    by(simp add: SecurityInvariant_withOffendingFlows.sinvar_all_edges_normal_form_sr_def)

  definition NoRefl_offending_set:: "'v graph \<Rightarrow> ('v \<Rightarrow> node_config) \<Rightarrow> ('v \<times> 'v) set set" where
  "NoRefl_offending_set G nP = (if sinvar G nP then
      {}
     else
      { {e \<in> edges G. case e of (e1,e2) \<Rightarrow> e1 = e2 \<and> nP e1 = NoRefl} })"

 thm SecurityInvariant_withOffendingFlows.ENFsr_offending_set[OF NoRfl_ENRsr]

  lemma NoRefl_offending_set: "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = NoRefl_offending_set"
    apply(simp only: fun_eq_iff NoRefl_offending_set_def)
    apply(rule allI)+
    apply(rename_tac G nP)
    apply(simp only: SecurityInvariant_withOffendingFlows.ENFsr_offending_set[OF NoRfl_ENRsr])
    apply(case_tac "sinvar G nP")
     apply(simp)
    apply(simp)
    apply(rule)
     apply(rule)
     apply(clarsimp)
     using node_config.exhaust apply blast
    apply(rule)
    apply(rule)
    apply(clarsimp)
   done

interpretation NoRefl: SecurityInvariant_ACS
where default_node_properties = default_node_properties
and sinvar = sinvar
and verify_globals = verify_globals
where "SecurityInvariant_withOffendingFlows.set_offending_flows sinvar = NoRefl_offending_set"
  unfolding default_node_properties_def
  apply unfold_locales
    apply(rule ballI)
    apply(frule SINVAR_NoRefl.offending_notevalD)
    apply(simp only: SecurityInvariant_withOffendingFlows.ENFsr_offending_set[OF NoRfl_ENRsr])
    apply fastforce
   apply(erule default_uniqueness_by_counterexample_ACS)
   apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
   apply (simp add:graph_ops)
   apply (simp split: split_split_asm split_split)
   apply(rule_tac x="\<lparr> nodes={vertex_1}, edges = {(vertex_1,vertex_1)} \<rparr>" in exI, simp)
   apply(rule conjI)
    apply(simp add: valid_graph_def)
   apply(case_tac otherbot, simp_all)
   apply(rule_tac x="(\<lambda> x. NoRefl)(vertex_1 := NoRefl, vertex_2 := NoRefl)" in exI, simp)
   apply(rule_tac x="{(vertex_1,vertex_1)}" in exI, simp)
  apply(fact NoRefl_offending_set)
  done

  lemma TopoS_NoRefl: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_fact (open) sinvar_mono
hide_const (open) sinvar verify_globals receiver_violation default_node_properties

end


(*  Title:      HOL/HOLCF/IOA/meta_theory/Compositionality.thy
    Author:     Olaf Müller
*)

section {* Compositionality of I/O automata *}
theory Compositionality
imports CompoTraces
begin

lemma compatibility_consequence3: "[|eA --> A ; eB & ~eA --> ~A|] ==> (eA | eB) --> A=eA"
apply auto
done

lemma Filter_actAisFilter_extA:
"!! A B. [| compatible A B; Forall (%a. a: ext A | a: ext B) tr |] ==>
            Filter (%a. a: act A)$tr= Filter (%a. a: ext A)$tr"
apply (rule ForallPFilterQR)
(* i.e.: [| (! x. P x --> (Q x = R x)) ; Forall P tr |] ==> Filter Q$tr = Filter R$tr *)
prefer 2 apply (assumption)
apply (rule compatibility_consequence3)
apply (simp_all add: ext_is_act ext1_ext2_is_not_act1)
done

(* the next two theorems are only necessary, as there is no theorem ext (A||B) = ext (B||A) *)

lemma compatibility_consequence4: "[|eA --> A ; eB & ~eA --> ~A|] ==> (eB | eA) --> A=eA"
apply auto
done

lemma Filter_actAisFilter_extA2: "[| compatible A B; Forall (%a. a: ext B | a: ext A) tr |] ==>
            Filter (%a. a: act A)$tr= Filter (%a. a: ext A)$tr"
apply (rule ForallPFilterQR)
prefer 2 apply (assumption)
apply (rule compatibility_consequence4)
apply (simp_all add: ext_is_act ext1_ext2_is_not_act1)
done

subsection " Main Compositionality Theorem "

lemma compositionality: "[| is_trans_of A1; is_trans_of A2; is_trans_of B1; is_trans_of B2;
             is_asig_of A1; is_asig_of A2;
             is_asig_of B1; is_asig_of B2;
             compatible A1 B1; compatible A2 B2;
             A1 =<| A2;
             B1 =<| B2 |]
         ==> (A1 || B1) =<| (A2 || B2)"
apply (simp add: is_asig_of_def)
apply (frule_tac A1 = "A1" in compat_commute [THEN iffD1])
apply (frule_tac A1 = "A2" in compat_commute [THEN iffD1])
apply (simp add: ioa_implements_def inputs_of_par outputs_of_par externals_of_par)
apply auto
apply (simp add: compositionality_tr)
apply (subgoal_tac "ext A1 = ext A2 & ext B1 = ext B2")
prefer 2
apply (simp add: externals_def)
apply (erule conjE)+
(* rewrite with proven subgoal *)
apply (simp add: externals_of_par)
apply auto

(* 2 goals, the 3rd has been solved automatically *)
(* 1: Filter A2 x : traces A2 *)
apply (drule_tac A = "traces A1" in subsetD)
apply assumption
apply (simp add: Filter_actAisFilter_extA)
(* 2: Filter B2 x : traces B2 *)
apply (drule_tac A = "traces B1" in subsetD)
apply assumption
apply (simp add: Filter_actAisFilter_extA2)
done

end


(*  Title:      HOL/MicroJava/Comp/AuxLemmas.thy
    Author:     Martin Strecker
*)

(* Auxiliary Lemmas *)

theory AuxLemmas
imports "../J/JBasis"
begin

(**********************************************************************)
(* List.thy *)
(**********************************************************************)

lemma app_nth_greater_len [simp]:
 "length pre \<le> ind \<Longrightarrow> (pre @ a # post) ! (Suc ind) = (pre @ post) ! ind"
apply (induct pre arbitrary: ind)
apply auto
apply (case_tac ind)
apply auto
done

lemma length_takeWhile: "v \<in> set xs \<Longrightarrow> length (takeWhile (%z. z~=v) xs) < length xs"
by (induct xs) auto

lemma nth_length_takeWhile [simp]:
  "v \<in> set xs \<Longrightarrow> xs ! (length (takeWhile (%z. z~=v) xs)) = v"
by (induct xs) auto

lemma map_list_update [simp]:
  "\<lbrakk> x \<in> set xs; distinct xs\<rbrakk> \<Longrightarrow>
  (map f xs) [length (takeWhile (\<lambda>z. z \<noteq> x) xs) := v] =
  map (f(x:=v)) xs"
apply (induct xs)
apply simp
apply (case_tac "x=a")
apply auto
done

(**********************************************************************)
(* Product_Type.thy *)
(**********************************************************************)

lemma split_compose: "(split f) \<circ> (\<lambda> (a,b). ((fa a), (fb b))) =
  (\<lambda> (a,b). (f (fa a) (fb b)))"
by (simp add: split_def o_def)

lemma split_iter: "(\<lambda> (a,b,c). ((g1 a), (g2 b), (g3 c))) =
        (\<lambda> (a,p). ((g1 a), (\<lambda> (b, c). ((g2 b), (g3 c))) p))"
by (simp add: split_def o_def)

(**********************************************************************)
(* Set.thy *)
(**********************************************************************)

lemma singleton_in_set: "A = {a} \<Longrightarrow> a \<in> A" by simp

(**********************************************************************)
(* Map.thy *)
(**********************************************************************)

lemma the_map_upd: "(the \<circ> f(x\<mapsto>v)) = (the \<circ> f)(x:=v)"
by (simp add: fun_eq_iff)

lemma map_of_in_set:
  "(map_of xs x = None) = (x \<notin> set (map fst xs))"
by (induct xs, auto)

lemma map_map_upd [simp]:
  "y \<notin> set xs \<Longrightarrow> map (the \<circ> f(y\<mapsto>v)) xs = map (the \<circ> f) xs"
by (simp add: the_map_upd)

lemma map_map_upds [simp]:
  "(\<forall>y\<in>set ys. y \<notin> set xs) \<Longrightarrow> map (the \<circ> f(ys[\<mapsto>]vs)) xs = map (the \<circ> f) xs"
apply (induct xs arbitrary: f vs)
 apply simp
apply fastforce
done

lemma map_upds_distinct [simp]:
  "distinct ys \<Longrightarrow> length ys = length vs \<Longrightarrow> map (the \<circ> f(ys[\<mapsto>]vs)) ys = vs"
apply (induct ys arbitrary: f vs)
apply simp
apply (case_tac vs)
apply simp_all
done

lemma map_of_map_as_map_upd:
  "distinct (map f zs) \<Longrightarrow> map_of (map (\<lambda> p. (f p, g p)) zs) = empty (map f zs [\<mapsto>] map g zs)"
  by (induct zs) auto

(* In analogy to Map.map_of_SomeD *)
lemma map_upds_SomeD [rule_format (no_asm)]:
  "\<forall> m ys. (m(xs[\<mapsto>]ys)) k = Some y \<longrightarrow> k \<in> (set xs) \<or> (m k = Some y)"
apply (induct xs)
apply simp
apply auto
apply(case_tac ys)
apply auto
done

lemma map_of_upds_SomeD: "(map_of m (xs[\<mapsto>]ys)) k = Some y
  \<Longrightarrow> k \<in> (set (xs @ map fst m))"
by (auto dest: map_upds_SomeD map_of_SomeD fst_in_set_lemma)

lemma map_of_map_prop [rule_format (no_asm)]:
  "(map_of (map f xs) k = Some v) \<longrightarrow>
  (\<forall> x \<in> set xs. (P1 x)) \<longrightarrow>
  (\<forall> x. (P1 x) \<longrightarrow> (P2 (f x))) \<longrightarrow>
  (P2(k, v))"
by (induct xs,auto)

lemma map_of_map2: "\<forall> x \<in> set xs. (fst (f x)) = (fst x) \<Longrightarrow>
  map_of (map f xs) a = map_option (\<lambda> b. (snd (f (a, b)))) (map_of xs a)"
by (induct xs, auto)

lemma map_option_map_of [simp]: "(map_option f (map_of xs k) = None) = ((map_of xs k) = None)"
by (simp add: map_option_case split: option.split)

end


(* Author: Andreas Lochbihler, ETH Zurich *)

section \<open>Distinct, non-empty list\<close>

theory Applicative_DNEList imports
  "Applicative_List"
  "~~/src/HOL/Library/Dlist"
begin

lemma bind_eq_Nil_iff [simp]: "List.bind xs f = [] \<longleftrightarrow> (\<forall>x\<in>set xs. f x = [])"
by(simp add: List.bind_def)

lemma zip_eq_Nil_iff [simp]: "zip xs ys = [] \<longleftrightarrow> xs = [] \<or> ys = []"
by(cases xs ys rule: list.exhaust[case_product list.exhaust]) simp_all

lemma remdups_append1: "remdups (remdups xs @ ys) = remdups (xs @ ys)"
by(induction xs) simp_all

lemma remdups_append2: "remdups (xs @ remdups ys) = remdups (xs @ ys)"
by(induction xs) simp_all

lemma remdups_append1_drop: "set xs \<subseteq> set ys \<Longrightarrow> remdups (xs @ ys) = remdups ys"
by(induction xs) auto

lemma remdups_concat_map: "remdups (concat (map remdups xss)) = remdups (concat xss)"
by(induction xss)(simp_all add: remdups_append1, metis remdups_append2)

lemma remdups_concat_remdups: "remdups (concat (remdups xss)) = remdups (concat xss)"
apply(induction xss)
apply(auto simp add: remdups_append1_drop)
 apply(subst remdups_append1_drop; auto)
apply(metis remdups_append2)
done

lemma remdups_replicate: "remdups (replicate n x) = (if n = 0 then [] else [x])"
by(induction n) simp_all

typedef 'a dnelist = "{xs::'a list. distinct xs \<and> xs \<noteq> []}"
  morphisms list_of_dnelist Abs_dnelist
proof
  show "[x] \<in> ?dnelist" for x by simp
qed

setup_lifting type_definition_dnelist

lemma dnelist_subtype_dlist:
  "type_definition (\<lambda>x. Dlist (list_of_dnelist x)) (\<lambda>x. Abs_dnelist (list_of_dlist x)) {xs. xs \<noteq> Dlist.empty}"
apply unfold_locales
subgoal by(transfer; auto simp add: dlist_eq_iff)
subgoal by(simp add: distinct_remdups_id dnelist.list_of_dnelist[simplified] list_of_dnelist_inverse)
subgoal by(simp add: dlist_eq_iff Abs_dnelist_inverse)
done

lift_bnf 'a dnelist via dnelist_subtype_dlist for map: map by(simp_all add: dlist_eq_iff)
hide_const (open) map

context begin
qualified lemma map_def: "Applicative_DNEList.map = map_fun id (map_fun list_of_dnelist Abs_dnelist) (\<lambda>f xs. remdups (list.map f xs))"
unfolding map_def by(simp add: fun_eq_iff distinct_remdups_id list_of_dnelist[simplified])

qualified lemma map_transfer [transfer_rule]:
  "rel_fun op = (rel_fun (pcr_dnelist op =) (pcr_dnelist op =)) (\<lambda>f xs. remdups (map f xs)) Applicative_DNEList.map"
by(simp add: map_def rel_fun_def dnelist.pcr_cr_eq cr_dnelist_def list_of_dnelist[simplified] Abs_dnelist_inverse)

qualified lift_definition single :: "'a \<Rightarrow> 'a dnelist" is "\<lambda>x. [x]" by simp
qualified lift_definition insert :: "'a \<Rightarrow> 'a dnelist \<Rightarrow> 'a dnelist" is "\<lambda>x xs. if x \<in> set xs then xs else x # xs" by auto
qualified lift_definition append :: "'a dnelist \<Rightarrow> 'a dnelist \<Rightarrow> 'a dnelist" is "\<lambda>xs ys. remdups (xs @ ys)" by auto
qualified lift_definition bind :: "'a dnelist \<Rightarrow> ('a \<Rightarrow> 'b dnelist) \<Rightarrow> 'b dnelist" is "\<lambda>xs f. remdups (List.bind xs f)" by auto

abbreviation (input) pure_dnelist :: "'a \<Rightarrow> 'a dnelist"
where "pure_dnelist \<equiv> single"

end

lift_definition ap_dnelist :: "('a \<Rightarrow> 'b) dnelist \<Rightarrow> 'a dnelist \<Rightarrow> 'b dnelist"
is "\<lambda>f x. remdups (ap_list f x)"
by(auto simp add: ap_list_def)

adhoc_overloading Applicative.ap ap_dnelist

lemma ap_pure_list [simp]: "ap_list [f] xs = map f xs"
by(simp add: ap_list_def List.bind_def)

context begin interpretation applicative_syntax .

lemma ap_pure_dlist: "pure_dnelist f \<diamondop> x = Applicative_DNEList.map f x"
by transfer simp

applicative dnelist (K)
for pure: pure_dnelist
    ap: ap_dnelist
proof -
  show "pure_dnelist (\<lambda>x. x) \<diamondop> x = x" for x :: "'a dnelist"
    by transfer simp

  have *: "remdups (remdups (remdups ([\<lambda>g f x. g (f x)] \<diamondop> g) \<diamondop> f) \<diamondop> x) = remdups (g \<diamondop> remdups (f \<diamondop> x))"
    (is "?lhs = ?rhs") for g :: "('b \<Rightarrow> 'c) list" and f :: "('a \<Rightarrow> 'b) list" and x
  proof -
    have "?lhs = remdups (concat (map (\<lambda>f. map f x) (remdups (concat (map (\<lambda>x. map (\<lambda>f y. x (f y)) f) g)))))"
      unfolding ap_list_def List.bind_def
      by(subst (2) remdups_concat_remdups[symmetric])(simp add: o_def remdups_map_remdups remdups_concat_remdups)
    also have "\<dots> =  remdups (concat (map (\<lambda>f. map f x) (concat (map (\<lambda>x. map (\<lambda>f y. x (f y)) f) g))))"
      by(subst (1) remdups_concat_remdups[symmetric])(simp add: remdups_map_remdups remdups_concat_remdups)
    also have "\<dots> = remdups (concat (map remdups (map (\<lambda>g. map g (concat (map (\<lambda>f. map f x) f))) g)))"
      using list.pure_B_conv[of g f x] unfolding remdups_concat_map
      by(simp add: ap_list_def List.bind_def o_def)
    also have "\<dots> = ?rhs" unfolding ap_list_def List.bind_def
      by(subst (2) remdups_concat_map[symmetric])(simp add: o_def remdups_map_remdups)
    finally show ?thesis .
  qed
  show "pure_dnelist (\<lambda>g f x. g (f x)) \<diamondop> g \<diamondop> f \<diamondop> x = g \<diamondop> (f \<diamondop> x)"
    for g :: "('b \<Rightarrow> 'c) dnelist" and f :: "('a \<Rightarrow> 'b) dnelist" and x
    by transfer(rule *)
  show "pure_dnelist f \<diamondop> pure_dnelist x = pure_dnelist (f x)" for f :: "'a \<Rightarrow> 'b" and x
    by transfer simp
  show "f \<diamondop> pure_dnelist x = pure_dnelist (\<lambda>f. f x) \<diamondop> f" for f :: "('a \<Rightarrow> 'b) dnelist" and x
    by transfer(simp add: list.interchange)

  have *: "remdups (remdups ([\<lambda>x y. x] \<diamondop> x) \<diamondop> y) = x" if x: "distinct x" and y: "distinct y" "y \<noteq> []"
    for x :: "'b list" and y :: "'a list"
  proof -
    have "remdups (map (\<lambda>(x :: 'b) (y :: 'a). x) x) = map (\<lambda>(x :: 'b) (y :: 'a). x) x"
      using that by(simp add: distinct_map inj_on_def fun_eq_iff)
    hence "remdups (remdups ([\<lambda>x y. x] \<diamondop> x) \<diamondop> y) = remdups (concat (map (\<lambda>f. map f y) (map (\<lambda>x y. x) x)))"
      by(simp add: ap_list_def List.bind_def del: remdups_id_iff_distinct)
    also have "\<dots> = x" using that
      by(simp add: o_def map_replicate_const)(subst remdups_concat_map[symmetric], simp add: o_def remdups_replicate)
    finally show ?thesis .
  qed
  show "pure_dnelist (\<lambda>x y. x) \<diamondop> x \<diamondop> y = x"
    for x :: "'b dnelist" and y :: "'a dnelist"
    by transfer(rule *; simp)
qed

text \<open>@{typ "_ dnelist"} does not have combinator C, so it cannot have W either.\<close>

context begin
private lift_definition x :: "int dnelist" is "[2,3]" by simp
private lift_definition y :: "int dnelist" is "[5,7]" by simp
private lemma "pure_dnelist (\<lambda>f x y. f y x) \<diamondop> pure_dnelist (op *) \<diamondop> x \<diamondop> y \<noteq> pure_dnelist (op *) \<diamondop> y \<diamondop> x"
  by transfer(simp add: ap_list_def fun_eq_iff)
end

end

end


(*<*)
theory Introduction
imports Main
begin
(*>*)
text\<open>
\section{Introduction}
\label{sec:Intro}

This thesis aims at modelling parts of the US Constitution with higher order logic (HOL) in theorem prover \textsc{Isabelle/HOL}
in order to verify the possibility of a legal dictatorship in the USA.
The basis for the argument is a notorious anecdote on how, at his US citizenship hearing, logician Kurt Gödel informed the judge that the US Constitution was in fact
faulty and allowed for the erection of a constitutional dictatorship.
We shall explore both the argument Gödel might have had in mind when saying this and a verified version of the supposed argument, modelled on the computer.

Before delving into the argument, we give a short \hyperref[sec:Framework]{overview} on the tools used, including an introduction to Isabelle/HOL and the
manner in which we are going to use it.

The ensuing  \hyperref[sec:Arg]{section} of this work is concerned with Gödel's supposed argument on the
Constitution's shortcomings. This also encompasses a quick overview of the Constitution and a more detailed consideration of the articles
most relevant to the argument.

After having laid a theoretical foundation, we will devise and implement a HOL model for the argument in the  \hyperref[sec:Model]{main} part
 of this work.
Being mindful of the technical restrictions, we shall choose a suitable logic embedded into Isabelle's HOL-language and map the relevant parts of the Constitution to
their equivalents in the proposed logic.
Having succeeded in this, we shall prove that it is possible to build a dictatorship without violating the Constitution, thus verifying Gödel's argument.
The main part concludes with a few remarks on what to avoid when modelling a concept with Isabelle/HOL.

The \hyperref[sec:Outlook]{last section} will present a few further problematic properties of the US Constitution in addition to the one modelled in the main part.
We then name a few questions not yet addressed and conclude the thesis.

For convenience, the terms ``US Constitution" and ``(the) Constitution" shall be used interchangeably.

\<close>
(*<*)
end
(*>*)


section \<open> LTS by RBTs \<close>
theory RBT_QAQ_LTSImpl
imports
  "../../LTSByTripleSetQAQ"
  "../../LTSGA"
  "../../LTS_Impl"
  "RBT_TripleSetImpl"
begin

interpretation rs_lts_defs: ltsbm_QAQ_defs rs_ts_\<alpha> rs_ts_invar .

definition "rs_lts_\<alpha> \<equiv> rs_ts_\<alpha>"
definition "rs_lts_invar \<equiv> rs_ts_invar"
definition[code_unfold]: "rs_lts_empty \<equiv> rs_ts_empty"
definition[code_unfold]: "rs_lts_add \<equiv> rs_ts_add"
definition[code_unfold]: "rs_lts_memb \<equiv> rs_ts_memb"
definition[code_unfold]: "rs_lts_add_succs \<equiv> rs_ts_add_Cl"
definition[code_unfold]: "rs_lts_delete \<equiv> rs_ts_delete"

definition[code_unfold]: "rs_lts_it \<equiv> rs_ts_it"
definition[code_unfold]: "rs_lts_filter_it \<equiv> rs_ts_filter_it"
definition[code_unfold]: "rs_lts_succ_it \<equiv> rs_ts_C_it"
definition "rs_lts_succ \<equiv> LTSGA.ltsga_succ rs_lts_succ_it"
definition[code_unfold]: "rs_lts_succ_label_it \<equiv> rs_ts_BC_it"
definition "rs_lts_pre_it \<equiv> rs_lts_defs.ltsbm_pre_it rs_ts_A_it"
definition[code_unfold]: "rs_lts_pre_label_it \<equiv> rs_ts_AB_it"

definition "rs_lts_from_list \<equiv>  ltsga_from_list rs_lts_empty rs_lts_add"
definition "rs_lts_to_list \<equiv> ltsga_to_list rs_lts_it"
definition "rs_lts_from_collect_list \<equiv>  ltsga_from_collect_list rs_lts_empty rs_lts_add"
definition "rs_lts_to_collect_list \<equiv> ltsga_to_collect_list rs_lts_to_list"
definition "rs_lts_succ_ball \<equiv> ltsga_succ_ball rs_lts_succ_it"
definition "rs_lts_succ_bex \<equiv> ltsga_succ_bex rs_lts_succ_it"
definition "rs_lts_pre_ball \<equiv> ltsga_pre_ball rs_lts_pre_it"
definition "rs_lts_pre_bex \<equiv> ltsga_pre_bex rs_lts_pre_it"
definition "rs_lts_reverse \<equiv> ltsga_reverse rs_lts_empty rs_lts_add rs_lts_it"
definition "rs_lts_image_filter \<equiv> ltsga_image_filter rs_lts_empty rs_lts_add rs_lts_filter_it"
definition "rs_lts_filter \<equiv> ltsga_filter rs_lts_empty rs_lts_add rs_lts_filter_it"
definition "rs_lts_image \<equiv> ltsga_image rs_lts_image_filter"

lemmas rs_lts_defs_raw =
  rs_lts_defs.ltsbm_pre_it_def[abs_def]
  ltsga_succ_alt_def
  ltsga_from_list_def[abs_def]
  ltsga_from_collect_list_def[abs_def]
  ltsga_from_list_aux_def[abs_def]
  ltsga_to_list_def[abs_def]
  ltsga_to_collect_list_def[abs_def]
  ltsga_succ_ball_def[abs_def]
  ltsga_succ_bex_def[abs_def]
  ltsga_pre_ball_def[abs_def]
  ltsga_pre_bex_def[abs_def]
  ltsga_reverse_def[abs_def]
  ltsga_image_filter_def[abs_def]
  ltsga_image_def[abs_def]
  ltsga_filter_def[abs_def]
  iterate_to_list_def[abs_def] o_def
  iterate_ball_def[abs_def] iterate_bex_def

lemmas rs_lts_defs =
  rs_lts_\<alpha>_def
  rs_lts_invar_def
  rs_lts_empty_def
  rs_lts_memb_def
  rs_lts_add_def
  rs_lts_add_succs_def
  rs_lts_delete_def
  rs_lts_from_list_def
  rs_lts_to_list_def
  rs_lts_from_collect_list_def
  rs_lts_to_collect_list_def
  rs_lts_it_def
  rs_lts_filter_it_def
  rs_lts_succ_it_def
  rs_lts_succ_def
  rs_lts_succ_label_it_def
  rs_lts_pre_it_def
  rs_lts_pre_label_it_def
  rs_lts_succ_ball_def
  rs_lts_succ_bex_def
  rs_lts_pre_ball_def
  rs_lts_pre_bex_def
  rs_lts_reverse_def
  rs_lts_image_filter_def
  rs_lts_filter_def
  rs_lts_image_def

lemmas [code] =
  rs_lts_defs[unfolded rs_lts_defs_raw rs_ts_ops_unfold, simplified]

(*lemmas [code] = rs_lts_defs[unfolded rs_lts_defs_raw rs_ts_ops_unfold
                         rm_ops_unfold rs_ops_unfold, simplified]
*)

lemmas rs_lts_empty_impl = rs_lts_defs.ltsbm_empty_correct[OF rs_ts_empty_impl, folded rs_lts_defs]
interpretation rs_lts: lts_empty rs_lts_\<alpha> rs_lts_invar rs_lts_empty
  using rs_lts_empty_impl .
lemmas rs_lts_memb_impl = rs_lts_defs.ltsbm_memb_correct[OF rs_ts_memb_impl, folded rs_lts_defs]
interpretation rs_lts: lts_memb rs_lts_\<alpha> rs_lts_invar rs_lts_memb
  using rs_lts_memb_impl .
lemmas rs_lts_add_impl = rs_lts_defs.ltsbm_add_correct[OF rs_ts_add_impl, folded rs_lts_defs]
interpretation rs_lts: lts_add rs_lts_\<alpha> rs_lts_invar rs_lts_add
  using rs_lts_add_impl .
lemmas rs_lts_add_succs_impl = rs_lts_defs.ltsbm_add_succs_correct[OF rs_ts_add_Cl_impl, folded rs_lts_defs]
interpretation rs_lts: lts_add_succs rs_lts_\<alpha> rs_lts_invar rs_lts_add_succs
  using rs_lts_add_succs_impl .
lemmas rs_lts_delete_impl = rs_lts_defs.ltsbm_delete_correct[OF rs_ts_delete_impl, folded rs_lts_defs]
interpretation rs_lts: lts_delete rs_lts_\<alpha> rs_lts_invar rs_lts_delete
  using rs_lts_delete_impl .

lemmas rs_lts_from_list_impl =
  ltsga_from_list_correct [OF rs_lts_empty_impl rs_lts_add_impl, folded rs_lts_defs]
interpretation rs_lts: lts_from_list rs_lts_\<alpha> rs_lts_invar rs_lts_from_list
  using rs_lts_from_list_impl .
lemmas rs_lts_from_collect_list_impl =
  ltsga_from_collect_list_correct [OF rs_lts_empty_impl rs_lts_add_impl, folded rs_lts_defs]
interpretation rs_lts: lts_from_collect_list rs_lts_\<alpha> rs_lts_invar rs_lts_from_collect_list
  using rs_lts_from_collect_list_impl .

lemmas rs_lts_it_impl = rs_lts_defs.ltsbm_it_correct[OF rs_ts_it_impl, folded rs_lts_defs]
interpretation rs_lts: lts_iterator rs_lts_\<alpha> rs_lts_invar rs_lts_it
  using rs_lts_it_impl .

interpretation rs_lts: finite_lts rs_lts_\<alpha> rs_lts_invar
  using ltsga_it_implies_finite[OF rs_lts_it_impl] .

lemmas rs_lts_filter_it_impl = rs_lts_defs.ltsbm_filter_it_correct[OF rs_ts_filter_it_impl, folded rs_lts_defs]
interpretation rs_lts: lts_filter_it rs_lts_\<alpha> rs_lts_invar rs_lts_filter_it
  using rs_lts_filter_it_impl .

lemmas rs_lts_succ_it_impl = rs_lts_defs.ltsbm_succ_it_correct[OF rs_ts_C_it_impl, folded rs_lts_defs]
interpretation rs_lts: lts_succ_it rs_lts_\<alpha> rs_lts_invar rs_lts_succ_it
  using rs_lts_succ_it_impl .

lemmas rs_lts_succ_impl = ltsga_succ_correct[OF rs_lts_succ_it_impl, folded rs_lts_defs]
interpretation rs_lts: lts_succ rs_lts_\<alpha> rs_lts_invar rs_lts_succ
  using rs_lts_succ_impl .

lemmas rs_lts_succ_label_it_impl = rs_lts_defs.ltsbm_succ_label_it_correct[OF rs_ts_BC_it_impl, folded rs_lts_defs]
interpretation rs_lts: lts_succ_label_it rs_lts_\<alpha> rs_lts_invar rs_lts_succ_label_it
  using rs_lts_succ_label_it_impl .

lemmas rs_lts_pre_it_impl = rs_lts_defs.ltsbm_pre_it_correct[OF rs_ts_A_it_impl, folded rs_lts_defs]
interpretation rs_lts: lts_pre_it rs_lts_\<alpha> rs_lts_invar rs_lts_pre_it
  using rs_lts_pre_it_impl .

lemmas rs_lts_pre_label_it_impl = rs_lts_defs.ltsbm_pre_label_it_correct[OF rs_ts_AB_it_impl, folded rs_lts_defs]
interpretation rs_lts: lts_pre_label_it rs_lts_\<alpha> rs_lts_invar rs_lts_pre_label_it
  using rs_lts_pre_label_it_impl .

lemmas rs_lts_to_list_impl = ltsga_to_list_correct [OF rs_lts_it_impl, folded rs_lts_defs]
interpretation rs_lts: lts_to_list rs_lts_\<alpha> rs_lts_invar rs_lts_to_list
  using rs_lts_to_list_impl .

lemmas rs_lts_to_collect_list_impl = ltsga_to_collect_list_correct
  [OF rs_lts_to_list_impl, folded rs_lts_defs]
interpretation rs_lts: lts_to_collect_list rs_lts_\<alpha> rs_lts_invar rs_lts_to_collect_list
  using rs_lts_to_collect_list_impl .

lemmas rs_lts_succ_ball_impl = ltsga_succ_ball_correct [OF rs_lts_succ_it_impl, folded rs_lts_defs]
interpretation rs_lts: lts_succ_ball rs_lts_\<alpha> rs_lts_invar rs_lts_succ_ball
  using rs_lts_succ_ball_impl .

lemmas rs_lts_succ_bex_impl = ltsga_succ_bex_correct [OF rs_lts_succ_it_impl, folded rs_lts_defs]
interpretation rs_lts: lts_succ_bex rs_lts_\<alpha> rs_lts_invar rs_lts_succ_bex
  using rs_lts_succ_bex_impl .

lemmas rs_lts_pre_ball_impl = ltsga_pre_ball_correct [OF rs_lts_pre_it_impl, folded rs_lts_defs]
interpretation rs_lts: lts_pre_ball rs_lts_\<alpha> rs_lts_invar rs_lts_pre_ball
  using rs_lts_pre_ball_impl .

lemmas rs_lts_pre_bex_impl = ltsga_pre_bex_correct [OF rs_lts_pre_it_impl, folded rs_lts_defs]
interpretation rs_lts: lts_pre_bex rs_lts_\<alpha> rs_lts_invar rs_lts_pre_bex
  using rs_lts_pre_bex_impl .

lemmas rs_lts_reverse_impl = ltsga_reverse_correct [OF rs_lts_empty_impl rs_lts_add_impl
   rs_lts_it_impl, folded rs_lts_defs]
interpretation rs_lts: lts_reverse rs_lts_\<alpha> rs_lts_invar rs_lts_\<alpha> rs_lts_invar rs_lts_reverse
  using rs_lts_reverse_impl .

lemmas rs_lts_image_filter_impl = ltsga_image_filter_correct [OF rs_lts_empty_impl
   rs_lts_add_impl rs_lts_filter_it_impl, folded rs_lts_image_filter_def]
interpretation rs_lts: lts_image_filter rs_lts_\<alpha> rs_lts_invar rs_lts_\<alpha> rs_lts_invar rs_lts_image_filter
  using rs_lts_image_filter_impl .

lemmas rs_lts_filter_impl = ltsga_filter_correct [OF rs_lts_empty_impl
   rs_lts_add_impl rs_lts_filter_it_impl, folded rs_lts_filter_def]
interpretation rs_lts: lts_filter rs_lts_\<alpha> rs_lts_invar rs_lts_filter
  using rs_lts_filter_impl .

lemmas rs_lts_image_impl = ltsga_image_correct [OF rs_lts_image_filter_impl, folded rs_lts_image_def]
interpretation rs_lts: lts_image rs_lts_\<alpha> rs_lts_invar rs_lts_\<alpha> rs_lts_invar rs_lts_image
  using rs_lts_image_impl .

type_synonym ('V,'E) rs_lts =
  "('V, ('E, ('V, unit) RBT.rbt) RBT.rbt) RBT.rbt"

definition rs_lts_ops :: "('V::{linorder},'E::{linorder},('V,'E) rs_lts) lts_ops" where
   "rs_lts_ops \<equiv> \<lparr>
    lts_op_\<alpha> = rs_lts_\<alpha>,
    lts_op_invar = rs_lts_invar,
    lts_op_empty = rs_lts_empty,
    lts_op_memb = rs_lts_memb,
    lts_op_iterator = rs_lts_it,
    lts_op_add = rs_lts_add,
    lts_op_add_succs = rs_lts_add_succs,
    lts_op_delete = rs_lts_delete,
    lts_op_succ_ball = rs_lts_succ_ball,
    lts_op_succ_bex = rs_lts_succ_bex,
    lts_op_pre_ball = rs_lts_pre_ball,
    lts_op_pre_bex = rs_lts_pre_bex,
    lts_op_to_list = rs_lts_to_list,
    lts_op_to_collect_list = rs_lts_to_collect_list,
    lts_op_from_list = rs_lts_from_list,
    lts_op_from_collect_list = rs_lts_from_collect_list,
    lts_op_image_filter = rs_lts_image_filter,
    lts_op_filter = rs_lts_filter,
    lts_op_image = rs_lts_image,
    lts_op_succ = rs_lts_succ \<rparr>"

lemma rs_lts_ops_unfold[code_unfold] :
    "lts_op_\<alpha> rs_lts_ops = rs_lts_\<alpha>"
    "lts_op_invar rs_lts_ops = rs_lts_invar"
    "lts_op_empty rs_lts_ops = rs_lts_empty"
    "lts_op_memb rs_lts_ops = rs_lts_memb"
    "lts_op_iterator rs_lts_ops = rs_lts_it"
    "lts_op_add rs_lts_ops = rs_lts_add"
    "lts_op_add_succs rs_lts_ops = rs_lts_add_succs"
    "lts_op_delete rs_lts_ops = rs_lts_delete"
    "lts_op_succ_ball rs_lts_ops = rs_lts_succ_ball"
    "lts_op_succ_bex rs_lts_ops = rs_lts_succ_bex"
    "lts_op_pre_ball rs_lts_ops = rs_lts_pre_ball"
    "lts_op_pre_bex rs_lts_ops = rs_lts_pre_bex"
    "lts_op_to_list rs_lts_ops = rs_lts_to_list"
    "lts_op_to_collect_list rs_lts_ops = rs_lts_to_collect_list"
    "lts_op_from_list rs_lts_ops = rs_lts_from_list"
    "lts_op_from_collect_list rs_lts_ops = rs_lts_from_collect_list"
    "lts_op_image_filter rs_lts_ops = rs_lts_image_filter"
    "lts_op_filter rs_lts_ops = rs_lts_filter"
    "lts_op_image rs_lts_ops = rs_lts_image"
    "lts_op_succ rs_lts_ops = rs_lts_succ"
  by (simp_all add: rs_lts_ops_def)

lemma rs_lts_impl: "StdLTS rs_lts_ops"
  apply (rule StdLTS.intro)
  apply (simp_all add: rs_lts_ops_def)
  apply unfold_locales
  done

interpretation rs_ltsr: StdLTS rs_lts_ops by (rule rs_lts_impl)

definition "rs_lts_is_reachable \<equiv> rs_ltsr.is_reachable_impl"
lemmas rs_lts_is_reachable_code[code] = rs_ltsr.is_reachable_impl.simps [folded rs_lts_is_reachable_def rs_lts_defs, unfolded rs_lts_ops_unfold]
declare rs_lts_is_reachable_def [symmetric, code_unfold]

end


theory Let
imports "../Nominal2"
begin

atom_decl name

nominal_datatype trm =
  Var "name"
| App "trm" "trm"
| Lam x::"name" t::"trm"    binds  x in t
| Let as::"assn" t::"trm"   binds "bn as" in t
and assn =
  ANil
| ACons "name" "trm" "assn"
binder
  bn
where
  "bn ANil = []"
| "bn (ACons x t as) = (atom x) # (bn as)"

print_theorems

thm alpha_trm_raw_alpha_assn_raw_alpha_bn_raw.intros
thm bn_raw.simps
thm permute_bn_raw.simps
thm trm_assn.perm_bn_alpha
thm trm_assn.permute_bn

thm trm_assn.fv_defs
thm trm_assn.eq_iff
thm trm_assn.bn_defs
thm trm_assn.bn_inducts
thm trm_assn.perm_simps
thm trm_assn.induct
thm trm_assn.inducts
thm trm_assn.distinct
thm trm_assn.supp
thm trm_assn.fresh
thm trm_assn.exhaust
thm trm_assn.strong_exhaust
thm trm_assn.perm_bn_simps

lemma alpha_bn_inducts_raw[consumes 1]:
  "\<lbrakk>alpha_bn_raw a b; P3 ANil_raw ANil_raw;
 \<And>trm_raw trm_rawa assn_raw assn_rawa name namea.
    \<lbrakk>alpha_trm_raw trm_raw trm_rawa; alpha_bn_raw assn_raw assn_rawa;
     P3 assn_raw assn_rawa\<rbrakk>
    \<Longrightarrow> P3 (ACons_raw name trm_raw assn_raw)
        (ACons_raw namea trm_rawa assn_rawa)\<rbrakk> \<Longrightarrow> P3 a b"
  by (erule alpha_trm_raw_alpha_assn_raw_alpha_bn_raw.inducts(3)[of _ _ "\<lambda>x y. True" _ "\<lambda>x y. True", simplified]) auto

lemmas alpha_bn_inducts[consumes 1] = alpha_bn_inducts_raw[quot_lifted]

lemma alpha_bn_refl: "alpha_bn x x"
  by (induct x rule: trm_assn.inducts(2))
     (rule TrueI, auto simp add: trm_assn.eq_iff)
lemma alpha_bn_sym: "alpha_bn x y \<Longrightarrow> alpha_bn y x"
  sorry
lemma alpha_bn_trans: "alpha_bn x y \<Longrightarrow> alpha_bn y z \<Longrightarrow> alpha_bn x z"
  sorry

lemma bn_inj[rule_format]:
  assumes a: "alpha_bn x y"
  shows "bn x = bn y \<longrightarrow> x = y"
  by (rule alpha_bn_inducts[OF a]) (simp_all add: trm_assn.bn_defs)

lemma bn_inj2:
  assumes a: "alpha_bn x y"
  shows "\<And>q r. (q \<bullet> bn x) = (r \<bullet> bn y) \<Longrightarrow> permute_bn q x = permute_bn r y"
using a
apply(induct rule: alpha_bn_inducts)
apply(simp add: trm_assn.perm_bn_simps)
apply(simp add: trm_assn.perm_bn_simps)
apply(simp add: trm_assn.bn_defs)
apply(simp add: atom_eqvt)
done

lemma Abs_lst_fcb2:
  fixes as bs :: "atom list"
    and x y :: "'b :: fs"
    and c::"'c::fs"
  assumes eq: "[as]lst. x = [bs]lst. y"
  and fcb1: "(set as) \<sharp>* c \<Longrightarrow> (set as) \<sharp>* f as x c"
  and fresh1: "set as \<sharp>* c"
  and fresh2: "set bs \<sharp>* c"
  and perm1: "\<And>p. supp p \<sharp>* c \<Longrightarrow> p \<bullet> (f as x c) = f (p \<bullet> as) (p \<bullet> x) c"
  and perm2: "\<And>p. supp p \<sharp>* c \<Longrightarrow> p \<bullet> (f bs y c) = f (p \<bullet> bs) (p \<bullet> y) c"
  shows "f as x c = f bs y c"
proof -
  have "supp (as, x, c) supports (f as x c)"
    unfolding  supports_def fresh_def[symmetric]
    by (simp add: fresh_Pair perm1 fresh_star_def supp_swap swap_fresh_fresh)
  then have fin1: "finite (supp (f as x c))"
    by (auto intro: supports_finite simp add: finite_supp)
  have "supp (bs, y, c) supports (f bs y c)"
    unfolding  supports_def fresh_def[symmetric]
    by (simp add: fresh_Pair perm2 fresh_star_def supp_swap swap_fresh_fresh)
  then have fin2: "finite (supp (f bs y c))"
    by (auto intro: supports_finite simp add: finite_supp)
  obtain q::"perm" where
    fr1: "(q \<bullet> (set as)) \<sharp>* (x, c, f as x c, f bs y c)" and
    fr2: "supp q \<sharp>* Abs_lst as x" and
    inc: "supp q \<subseteq> (set as) \<union> q \<bullet> (set as)"
    using at_set_avoiding3[where xs="set as" and c="(x, c, f as x c, f bs y c)" and x="[as]lst. x"]
      fin1 fin2
    by (auto simp add: supp_Pair finite_supp Abs_fresh_star dest: fresh_star_supp_conv)
  have "Abs_lst (q \<bullet> as) (q \<bullet> x) = q \<bullet> Abs_lst as x" by simp
  also have "\<dots> = Abs_lst as x"
    by (simp only: fr2 perm_supp_eq)
  finally have "Abs_lst (q \<bullet> as) (q \<bullet> x) = Abs_lst bs y" using eq by simp
  then obtain r::perm where
    qq1: "q \<bullet> x = r \<bullet> y" and
    qq2: "q \<bullet> as = r \<bullet> bs" and
    qq3: "supp r \<subseteq> (q \<bullet> (set as)) \<union> set bs"
    apply(drule_tac sym)
    apply(simp only: Abs_eq_iff2 alphas)
    apply(erule exE)
    apply(erule conjE)+
    apply(drule_tac x="p" in meta_spec)
    apply(simp add: set_eqvt)
    apply(blast)
    done
  have "(set as) \<sharp>* f as x c"
    apply(rule fcb1)
    apply(rule fresh1)
    done
  then have "q \<bullet> ((set as) \<sharp>* f as x c)"
    by (simp add: permute_bool_def)
  then have "set (q \<bullet> as) \<sharp>* f (q \<bullet> as) (q \<bullet> x) c"
    apply(simp add: fresh_star_eqvt set_eqvt)
    apply(subst (asm) perm1)
    using inc fresh1 fr1
    apply(auto simp add: fresh_star_def fresh_Pair)
    done
  then have "set (r \<bullet> bs) \<sharp>* f (r \<bullet> bs) (r \<bullet> y) c" using qq1 qq2 by simp
  then have "r \<bullet> ((set bs) \<sharp>* f bs y c)"
    apply(simp add: fresh_star_eqvt set_eqvt)
    apply(subst (asm) perm2[symmetric])
    using qq3 fresh2 fr1
    apply(auto simp add: set_eqvt fresh_star_def fresh_Pair)
    done
  then have fcb2: "(set bs) \<sharp>* f bs y c" by (simp add: permute_bool_def)
  have "f as x c = q \<bullet> (f as x c)"
    apply(rule perm_supp_eq[symmetric])
    using inc fcb1[OF fresh1] fr1 by (auto simp add: fresh_star_def)
  also have "\<dots> = f (q \<bullet> as) (q \<bullet> x) c"
    apply(rule perm1)
    using inc fresh1 fr1 by (auto simp add: fresh_star_def)
  also have "\<dots> = f (r \<bullet> bs) (r \<bullet> y) c" using qq1 qq2 by simp
  also have "\<dots> = r \<bullet> (f bs y c)"
    apply(rule perm2[symmetric])
    using qq3 fresh2 fr1 by (auto simp add: fresh_star_def)
  also have "... = f bs y c"
    apply(rule perm_supp_eq)
    using qq3 fr1 fcb2 by (auto simp add: fresh_star_def)
  finally show ?thesis by simp
qed

lemma Abs_lst1_fcb2:
  fixes a b :: "atom"
    and x y :: "'b :: fs"
    and c::"'c :: fs"
  assumes e: "(Abs_lst [a] x) = (Abs_lst [b] y)"
  and fcb1: "a \<sharp> c \<Longrightarrow> a \<sharp> f a x c"
  and fresh: "{a, b} \<sharp>* c"
  and perm1: "\<And>p. supp p \<sharp>* c \<Longrightarrow> p \<bullet> (f a x c) = f (p \<bullet> a) (p \<bullet> x) c"
  and perm2: "\<And>p. supp p \<sharp>* c \<Longrightarrow> p \<bullet> (f b y c) = f (p \<bullet> b) (p \<bullet> y) c"
  shows "f a x c = f b y c"
using e
apply(drule_tac Abs_lst_fcb2[where c="c" and f="\<lambda>(as::atom list) . f (hd as)"])
apply(simp_all)
using fcb1 fresh perm1 perm2
apply(simp_all add: fresh_star_def)
done

function
  apply_assn2 :: "(trm \<Rightarrow> trm) \<Rightarrow> assn \<Rightarrow> assn"
where
  "apply_assn2 f ANil = ANil"
| "apply_assn2 f (ACons x t as) = ACons x (f t) (apply_assn2 f as)"
  apply(case_tac x)
  apply(case_tac b rule: trm_assn.exhaust(2))
  apply(simp_all)
  apply(blast)
  done

termination by lexicographic_order

lemma apply_assn_eqvt[eqvt]:
  "p \<bullet> (apply_assn2 f a) = apply_assn2 (p \<bullet> f) (p \<bullet> a)"
  apply(induct f a rule: apply_assn2.induct)
  apply simp_all
  apply(perm_simp)
  apply rule
  done

lemma
  fixes x y :: "'a :: fs"
  shows "[a # as]lst. x = [b # bs]lst. y \<Longrightarrow> [[a]]lst. [as]lst. x = [[b]]lst. [bs]lst. y"
  apply (simp add: Abs_eq_iff)
  apply (elim exE)
  apply (rule_tac x="p" in exI)
  apply (simp add: alphas)
  apply clarify
  apply rule
  apply (simp add: supp_Abs)
  apply blast
  apply (simp add: supp_Abs fresh_star_def)
  apply blast
  done

lemma
  assumes neq: "a \<noteq> b" "sort_of a = sort_of b"
  shows "[[a]]lst. [[a]]lst. a = [[a]]lst. [[b]]lst. b \<and> [[a, a]]lst. a \<noteq> [[a, b]]lst. b"
  apply (simp add: Abs1_eq_iff)
  apply rule
  apply (simp add: Abs_eq_iff alphas supp_atom fresh_star_def)
  apply (rule_tac x="(a \<rightleftharpoons> b)" in exI)
  apply (simp add: neq)
  apply (simp add: Abs_eq_iff alphas supp_atom fresh_star_def neq)
  done

nominal_function
    subst  :: "name \<Rightarrow> trm \<Rightarrow> trm \<Rightarrow> trm"
where
  "subst s t (Var x) = (if (s = x) then t else (Var x))"
| "subst s t (App l r) = App (subst s t l) (subst s t r)"
| "atom v \<sharp> (s, t) \<Longrightarrow> subst s t (Lam v b) = Lam v (subst s t b)"
| "set (bn as) \<sharp>* (s, t) \<Longrightarrow> subst s t (Let as b) = Let (apply_assn2 (subst s t) as) (subst s t b)"
  apply (simp only: eqvt_def subst_graph_def)
  apply (rule, perm_simp, rule)
  apply (rule TrueI)
  apply (case_tac x)
  apply (rule_tac y="c" and c="(a,b)" in trm_assn.strong_exhaust(1))
  apply (auto simp add: fresh_star_def)[3]
  apply (drule_tac x="assn" in meta_spec)
  apply (simp add: Abs1_eq_iff alpha_bn_refl)
  apply auto[7]
  prefer 2
  apply(simp)
  thm subst_sumC_def
  thm THE_default_def
  thm theI
  apply (erule_tac c="(sa, ta)" in Abs_lst1_fcb2)
  apply (simp add: Abs_fresh_iff)
  apply (simp add: fresh_star_def)
  apply (simp_all add: fresh_star_Pair_elim perm_supp_eq eqvt_at_def)[2]
  apply (subgoal_tac "apply_assn2 (\<lambda>x2\<Colon>trm. subst_sumC (sa, ta, x2)) asa
    = apply_assn2 (\<lambda>x2\<Colon>trm. subst_sumC (sa, ta, x2)) as")
  prefer 2
  apply (erule alpha_bn_inducts)
  apply simp
  apply (simp only: apply_assn2.simps)
  apply simp
--"We know nothing about names; not true; but we can apply fcb2"
  defer
  apply (simp only: )
  apply (erule_tac c="(sa, ta)" in Abs_lst_fcb2)
--"We again need induction for fcb assumption; this time true"
  apply (induct_tac as rule: trm_assn.inducts(2))
  apply (rule TrueI)+
  apply (simp_all add: trm_assn.bn_defs fresh_star_def)[2]
  apply (auto simp add: Abs_fresh_iff)[1]
  apply assumption+
--"But eqvt is not going to be true as well"
  apply (simp add: fresh_star_Pair_elim perm_supp_eq eqvt_at_def trm_assn.fv_bn_eqvt)
  apply (simp add: apply_assn_eqvt)
  apply (drule sym)
  apply (subgoal_tac "p \<bullet> (\<lambda>x2\<Colon>trm. subst_sumC (sa, ta, x2)) = (\<lambda>x2\<Colon>trm. subst_sumC (sa, ta, x2))")
  apply (simp)
  apply (erule alpha_bn_inducts)
  apply simp
  apply simp
  apply (simp add: trm_assn.bn_defs)
--"Again we cannot relate 'namea' with 'p \<bullet> name'"
  prefer 4
  apply (erule alpha_bn_inducts)
  apply simp_all[2]
  oops

end


theory TheoremD12
imports TheoremD11
begin

context LocalLexing begin

lemma charslength_appendix_is_empty:
  "charslength (p@ts) = charslength p \<Longrightarrow> (\<And> t. t \<in> set ts \<Longrightarrow> chars_of_token t = [])"
proof (induct ts)
  case Nil then show ?case by auto
next
  case (Cons s ts)
    have "charslength (p @ s # ts) = charslength (p @ ts) + length (chars_of_token s)"
      by simp
    then have "charslength (p @ s # ts) = charslength p + charslength ts + length (chars_of_token s)"
      by simp
    with Cons.prems(1) have "charslength ts + length (chars_of_token s) = 0" by arith
    then show ?case using Cons.prems(2) charslength_0 by auto
qed

lemma empty_tokens_have_charslength_0:
  "(\<And> t. t \<in> set ts \<Longrightarrow> chars_of_token t = []) \<Longrightarrow> charslength ts = 0"
proof (induct ts)
  case Nil then show ?case by simp
next
  case (Cons t ts)
    then show ?case by auto
qed

lemma \<pi>_idempotent': "\<pi> k {} (\<pi> k T I) = \<pi> k T I"
  apply (simp add: \<pi>_no_tokens)
  by (simp add: Complete_\<pi>_fix Predict_\<pi>_fix fix_is_fix_of_limit)

theorem thmD12:
  assumes induct: "items_le k (\<J> k u) = Gen (paths_le k (\<P> k u))"
  assumes induct_tokens: "\<T> k u = \<Z> k u"
  shows "items_le k (\<J> k (Suc u)) \<supseteq> Gen (paths_le k (\<P> k (Suc u)))"
proof -
  {
    fix x :: item
    assume x_dom: "x \<in> Gen (paths_le k (\<P> k (Suc u)))"
    have "\<exists> q. pvalid q x \<and> q \<in> \<P> k (Suc u) \<and> charslength q \<le> k"
    proof -
      have "\<And>i I n. i \<in> I \<or> i \<notin> items_le n I"
        by (meson items_le_is_filter subsetCE)
      then show ?thesis
        by (metis Gen_implies_pvalid x_dom items_le_fix_D items_le_idempotent items_le_paths_le
          pvalid_item_end)
    qed
    then obtain q where q: "pvalid q x \<and> q \<in> \<P> k (Suc u) \<and> charslength q \<le> k" by blast
    have "q \<in> \<P> k u \<or> q \<notin> \<P> k u" by blast
    then have "x \<in> items_le k (\<J> k (Suc u))"
    proof (induct rule: disjCases2)
      case 1
        with q have "x \<in> Gen (paths_le k (\<P> k u))"
          apply (auto simp add: Gen_def)
          apply (rule_tac x=q in exI)
          by (simp add: paths_le_def)
        with induct have "x \<in> items_le k (\<J> k u)" by simp
        then show ?case
          using LocalLexing.items_le_def LocalLexing_axioms \<J>_subset_Suc_u by fastforce
    next
      case 2
        have q_is_limit: "q \<in> limit (Append (\<Y> (\<Z> k u) (\<P> k u) k) k) (\<P> k u)" using q by auto
        from limit_Append_path_nonelem_split[OF q_is_limit 2] obtain p ts where p_ts:
          "q = p @ ts \<and>
           p \<in> \<P> k u \<and>
           charslength p = k \<and>
           admissible (p @ ts) \<and>
           (\<forall>t\<in>set ts. t \<in> \<Y> (\<Z> k u) (\<P> k u) k) \<and> (\<forall>t\<in>set (butlast ts). chars_of_token t = [])"
           by blast
        then have ts_nonempty: "ts \<noteq> []" using 2 using self_append_conv by auto
        obtain T where T: "T = \<Y> (\<Z> k u) (\<P> k u) k" by blast
        obtain J where J: "J = \<pi> k T (Gen (paths_le k (\<P> k u)))" by blast
        from q p_ts have chars_of_token_is_empty: "\<And> t. t\<in>set ts \<Longrightarrow> chars_of_token t = []"
          using charslength_appendix_is_empty chars_append charslength.simps le_add1 le_imp_less_Suc
            le_neq_implies_less length_append not_less_eq by auto
        {
          fix sss :: "token list"
          have "is_prefix sss ts \<Longrightarrow> pvalid (p @ sss) x \<Longrightarrow> x \<in> J"
          proof (induct "length sss" arbitrary: sss x rule: less_induct)
            case less
              have "sss = [] \<or> sss \<noteq> []" by blast
              then show ?case
              proof (induct rule: disjCases2)
                case 1
                  with less have pvalid_p_x: "pvalid p x" by auto
                  have charslength_p: "charslength p \<le> k" using p_ts by blast
                  with p_ts have "p \<in> paths_le k (\<P> k u)"
                    by (simp add: paths_le_def)
                  with pvalid_p_x have "x \<in> Gen (paths_le k (\<P> k u))"
                    using Gen_def mem_Collect_eq by blast
                  then have "x \<in> \<pi> k T (Gen (paths_le k (\<P> k u)))" using \<pi>_apply_setmonotone
                    by blast
                  then show "x \<in> J" using pvalid_item_end q J LocalLexing.items_le_def
                    LocalLexing_axioms charslength_p mem_Collect_eq pvalid_p_x by auto
              next
                case 2
                  then have "\<exists> a ss. sss = ss@[a]" using rev_exhaust by blast
                  then obtain a ss where snoc: "sss = ss@[a]" by blast
                  obtain p' where p': "p' = p @ ss" by auto
                  then have "pvalid_left (p'@[a]) x" using snoc less pvalid_left by simp
                  from iffD1[OF pvalid_left_def this] obtain r \<omega> where pvalid:
                    "wellformed_tokens (p' @ [a]) \<and>
                     wellformed_item x \<and>
                     r \<le> length (p' @ [a]) \<and>
                     charslength (p' @ [a]) = item_end x \<and>
                     charslength (take r (p' @ [a])) = item_origin x \<and>
                     is_leftderivation (terminals (take r (p' @ [a])) @ [item_nonterminal x] @ \<omega>) \<and>
                     leftderives (item_\<alpha> x) (terminals (drop r (p' @ [a])))" by blast
                  obtain q' where q': "q' = p'@[a]" by blast
                  have is_prefix_ss_ts: "is_prefix ss ts" using snoc less
                    by (simp add: is_prefix_append)
                  then have "is_prefix (p@ss) q" using p' snoc p_ts by simp
                  then have "is_prefix p' q" using p' by simp
                  then have h1: "p' \<in> \<PP>" using q \<PP>_covers_\<P> prefixes_are_paths' subsetCE by blast
                  have charslength_ss: "charslength ss = 0"
                    apply (rule empty_tokens_have_charslength_0)
                    by (metis is_prefix_ss_ts append_is_Nil_conv chars_append chars_of_token_is_empty
                      charslength.simps charslength_0 is_prefix_def length_greater_0_conv list.size(3))
                  then have h2: "charslength p' = k" using p' p_ts by auto
                  have a_in_ts: "a \<in> set ts"
                    by (metis in_set_dropD is_prefix_append is_prefix_cons list.set_intros(1)
                      snoc less(2))
                  then have h3: "a \<in> T" using T p_ts by blast
                  have h4: "T \<subseteq> \<X> k"
                    using LocalLexing.\<Z>.simps(2) LocalLexing_axioms T \<Z>_subset_\<X> by blast
                  note h5 = q'
                  obtain N where N: "N = item_nonterminal x" by blast
                  obtain \<alpha> where \<alpha>: "\<alpha> = item_\<alpha> x" by blast
                  obtain \<beta> where \<beta>: "\<beta> = item_\<beta> x" by blast
                  have item_rule_x: "item_rule x = (N, \<alpha> @ \<beta>)"
                    using N \<alpha> \<beta> item_nonterminal_def item_rhs_def item_rhs_split by auto
                  have "wellformed_item x" using pvalid by blast
                  then have h6: "(N, \<alpha>@\<beta>) \<in> \<RR>" using item_rule_x
                    by (simp add: wellformed_item_def)
                  have h7: "r \<le> length q'" using pvalid q' by blast
                  have h8: "leftderives [\<SS>] (terminals (take r q') @ [N] @ \<omega>)"
                    using N is_leftderivation_def pvalid q' by blast
                  have h9: "leftderives \<alpha> (terminals (drop r q'))" using \<alpha> pvalid q' by blast
                  have h10: "k = k + length (chars_of_token a)"
                    by (simp add: a_in_ts chars_of_token_is_empty)
                  have h11: "x = Item (N, \<alpha> @ \<beta>) (length \<alpha>) (charslength (take r q')) k"
                    by (metis \<alpha> charslength_ss a_in_ts append_Nil2 chars.simps(2) chars_append
                      chars_of_token_is_empty charslength.simps h2 item.collapse item_dot_is_\<alpha>_length
                      item_rule_x length_greater_0_conv list.size(3) pvalid q')
                  have x_dom: "x \<in> items_le k (\<pi> k {} (Scan T k (Gen (Prefixes p'))))"
                    using thmD11[OF h1 h2 h3 h4 h5 h6 h7 h8 h9 h10 h11] by auto
                  {
                    fix y :: item
                    fix toks :: "token list"
                    assume pvalid_toks_y: "pvalid toks y"
                    assume is_prefix_toks_p': "is_prefix toks p'"
                    then have charslength_toks: "charslength toks \<le> k"
                      using charslength_of_prefix h2 by blast
                    then have item_end_y: "item_end y \<le> k" using pvalid_item_end pvalid_toks_y
                      by auto
                    have "is_prefix toks p \<or> (\<exists> ss'. is_prefix ss' ss \<and> toks = p@ss')"
                      using is_prefix_of_append is_prefix_toks_p' p' by auto
                    then have "y \<in> J"
                    proof (induct rule: disjCases2)
                      case 1
                        then have "toks \<in> \<P> k u" using p_ts prefixes_are_paths by blast
                        with charslength_toks have "toks \<in> paths_le k (\<P> k u)"
                          by (simp add: paths_le_def)
                        then have "y \<in> Gen (paths_le k (\<P> k u))" using pvalid_toks_y
                          Gen_def mem_Collect_eq by blast
                        then have "y \<in> \<pi> k T (Gen (paths_le k (\<P> k u)))" using \<pi>_apply_setmonotone
                          by blast
                        then show "y \<in> J" by (simp add: J items_le_def item_end_y)
                    next
                      case 2
                        then obtain ss' where ss': "is_prefix ss' ss \<and> toks = p@ss'" by blast
                        then have l1: "length ss' < length sss"
                          using append_eq_conv_conj append_self_conv is_prefix_length length_append
                            less_le_trans nat_neq_iff not_Cons_self2 not_add_less1 snoc by fastforce
                        have l2: "is_prefix ss' ts" using ss' is_prefix_ss_ts
                          by (metis append_dropped_prefix is_prefix_append)
                        have l3: "pvalid (p @ ss') y" using ss' pvalid_toks_y by simp
                        show ?case using less.hyps[OF l1 l2 l3] by blast
                    qed
                  }
                  then have "Gen (Prefixes p') \<subseteq> J"
                    by (meson Gen_implies_pvalid Prefixes_is_prefix subsetI)
                  with x_dom have r0: "x \<in> items_le k (\<pi> k {} (Scan T k J))"
                    by (metis (no_types, lifting) LocalLexing.items_le_def LocalLexing_axioms
                      mem_Collect_eq mono_Scan mono_\<pi> mono_subset_elem subsetI)
                  then have x_in_\<pi>: "x \<in> \<pi> k {} (Scan T k J)"
                    using LocalLexing.items_le_is_filter LocalLexing_axioms subsetCE by blast
                  have r1: "Scan T k J = J"
                    by (simp add: J Scan_\<pi>_fix)
                  have r2: "\<pi> k {} J = J" using \<pi>_idempotent' using J by blast
                  from x_in_\<pi> r1 r2 show "x \<in> J" by auto
              qed
          qed
        }
        note th = this
        have x_in_J: "x \<in> J"
          apply (rule th[of ts])
          apply (simp add: is_prefix_eq_proper_prefix)
          using p_ts q by blast
        have \<T>_eq_\<Z>: "\<T> k (Suc u) = \<Z> k (Suc u)"
          using induct induct_tokens \<T>_equals_\<Z>_induct_step by blast
        have T_alt: "T = \<T> k (Suc u)" using \<T>_eq_\<Z> T by simp
        have "J = \<pi> k T (items_le k (\<J> k u))" using induct J by simp
        then have "J \<subseteq> \<pi> k T (\<J> k u)" by (simp add: items_le_is_filter monoD mono_\<pi>)
        with T_alt have "J \<subseteq> \<J> k (Suc u)" using \<J>.simps(2) by blast
        with x_in_J have "x \<in> \<J> k (Suc u)" by blast
        then show ?case
          using LocalLexing.items_le_def LocalLexing_axioms pvalid_item_end q by auto
    qed
  }
  then show ?thesis by auto
qed

end

end


theory Refine_Rigorous_Numerics
  imports
    Abstract_Rigorous_Numerics
begin

context approximate_sets begin

lemma ivl_rep_of_set_nres[le, refine_vcg]:
  fixes X::"'a::executable_euclidean_space set"
  shows "op_ivl_rep_of_set X \<le> ivl_rep_of_set X"
  unfolding ivl_rep_of_set_def Inf_spec_def Sup_spec_def op_ivl_rep_of_set_def
  by (refine_vcg) (auto simp: inf.coboundedI1)

lemma ivl_rep_of_sets_nres[le, refine_vcg]:
  "op_ivl_rep_of_sets XS \<le> ivl_rep_of_sets XS"
proof cases
  assume ne: "XS \<noteq> {}"
  have "op_ivl_rep_of_sets XS \<le> SPEC (\<lambda>(i, s). (\<forall>X\<in>XS. X \<subseteq> {i..s} \<and> i \<le> s))"
    unfolding op_ivl_rep_of_sets_def ivl_rep_of_sets_def split_beta
    by (refine_vcg FORWEAK_elementwise_rule)
      (auto simp: subset_iff le_infI1 le_infI2 le_supI1 le_supI2 ivl_rep_of_set_def split_beta'
        intro!: FORWEAK_elementwise_rule)
  also have "\<dots> = ivl_rep_of_sets XS" unfolding ivl_rep_of_sets_def
    using ne
    by (auto simp add: ivl_rep_of_sets_def)
  finally show ?thesis .
qed (auto simp: op_ivl_rep_of_sets_def ivl_rep_of_sets_def)

lemma ivl_rep_of_set_coll[unfolded ivl_rep_of_set_def, refine_vcg]:
  "ivl_rep_of_set_coll X \<le> ivl_rep_of_set X"
  unfolding ivl_rep_of_set_coll_def ivl_rep_of_set_def
  by refine_vcg auto

lemma ivls_of_set_FORWEAK[le, refine_vcg]:
  "ivls_of_sets X \<le> SPEC (\<lambda>R. X \<subseteq> R)"
  unfolding ivls_of_sets_def autoref_tag_defs
  by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>XS U. \<Union>XS \<subseteq> U"]) auto

lemma intersects_nres[unfolded intersects_spec_def, le, refine_vcg]:
  shows "op_intersects X sctn \<le> intersects_spec X sctn"
  unfolding intersects_spec_def Inf_inner_def Sup_inner_def op_intersects_def
  by refine_vcg (force simp: plane_of_def)

lemma sbelow_sctns_coll_refine[unfolded sbelow_sctns_def, le, refine_vcg]:
  "sbelow_sctns_coll XS sctns \<le> sbelow_sctns XS sctns"
  unfolding sbelow_sctns_def autoref_tag_defs sbelow_sctns_coll_def
  by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>X b. b \<longrightarrow> (\<Union>X \<subseteq> sbelow_halfspaces sctns)"]) auto

lemma below_sctn_coll_refine[unfolded below_sctn_def, le, refine_vcg]:
  "below_sctn_coll XS sctn \<le> below_sctn XS sctn"
  unfolding below_sctn_def autoref_tag_defs below_sctn_coll_def
  by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>X b. b \<longrightarrow> (\<Union>X \<subseteq> below_halfspace sctn)"]) auto

lemma intersects_clw[unfolded intersects_spec_def, le, refine_vcg]:
  shows "intersects_clw X sctn \<le> intersects_spec X sctn"
  unfolding intersects_spec_def intersects_clw_def
  by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>XS b. b \<or> \<Union>XS \<inter> plane_of sctn = {}"]) auto

lemma subset_spec_ivl_impl[unfolded subset_spec_def, le, refine_vcg]: "op_subset X ivl \<le> subset_spec X ivl"
  unfolding subset_spec_def autoref_tag_defs op_subset_def
  by (refine_vcg) force

lemma subset_spec_ivl_coll_impl[unfolded subset_spec_def, le, refine_vcg]: "subset_spec_coll X ivl  \<le> subset_spec X ivl"
  unfolding autoref_tag_defs subset_spec_def subset_spec_coll_def
  by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>x b. b \<longrightarrow> \<Union>x \<subseteq> ivl"])
     (auto simp: subset_iff set_of_ivl_def)

lemma project_set_appr_le[unfolded project_set_def, le, refine_vcg]:
  "op_project_set X b y \<le> project_set X b y"
  unfolding project_set_def op_project_set_def
  by (refine_vcg) (force simp: plane_of_def)+

lemma project_set_clw_le[unfolded project_set_def, le, refine_vcg]: "project_set_clw X b y \<le> project_set X b y"
  unfolding autoref_tag_defs project_set_def project_set_clw_def
  by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>X P. \<Union>X \<inter> {x. x \<bullet> b = y} \<subseteq> P \<and> P \<subseteq> {x. x \<bullet> b = y}"])
      auto

lemma subset_spec_ivls[unfolded subset_spec_def, le, refine_vcg]:
  "subset_spec_ivls X Y \<le> subset_spec X Y"
  unfolding subset_spec_ivls_def subset_spec_def
  by (refine_vcg FORWEAK_mono_rule'[where I="\<lambda>Ys b. b \<longrightarrow> X - \<Union>Ys \<subseteq> Y"]) auto

lemma split_along_ivls2[le, refine_vcg]:"split_along_ivls2 M X IS \<le> SPEC (\<lambda>R. R = X)"
  unfolding split_along_ivls2_def
  by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>x xi. \<Union>x \<subseteq> xi \<and> xi \<subseteq> X"]) auto

end

context includes autoref_syntax begin

lemma length_slp_of_fas_le: "length fas \<le> length (slp_of_fas fas)"
  by (auto simp: slp_of_fas_def split: prod.splits)

lemma list_of_eucl_eqD: "list_of_eucl x = xs \<Longrightarrow> x = eucl_of_list xs"
  by auto

lemma slp_of_fasI:
  "d = (length fas) \<Longrightarrow>
    take d (interpret_slp (slp_of_fas fas) xs) =
    interpret_floatariths fas xs"
  using slp_of_fas by force

end

context approximate_sets begin

lemma approx_fas[le, refine_vcg]:
  "approx_slp_appr fas slp X \<le> SPEC (\<lambda>R. \<forall>x \<in> X. einterpret fas x \<in> (R::'a set))"
  if "slp_of_fas fas = slp" "length fas = DIM('a::executable_euclidean_space)"
  unfolding approx_slp_appr_def
  by (refine_vcg that)

lemma mig_set[le, refine_vcg]: "mig_set D X \<le> SPEC (\<lambda>m. \<forall>x \<in> X. m \<le> norm x)"
  unfolding mig_set_def
  apply refine_vcg
  apply (auto simp: dest!: bspec)
  apply (rule order_trans, assumption)
  apply (rule norm_mig_componentwise_le)
  by auto

end

end


section "Example: User Database"
theory example_userbase
  imports
    program_verification_tactics
    impl_language_loops
    crdt_specs2
    unique_ids
    program_proof_rules_loops
    app_verification_helpers
    unique_ids_loops
    proof_state_facts
begin

datatype val =
  String string
  | UserId int
  | Bool bool
  | Undef
  | Found string string
  | NotFound

instance val :: countable
  by countable_datatype

instantiation val :: valueType begin

definition uniqueIds_val where
  "uniqueIds_val x \<equiv> case x of UserId u \<Rightarrow> {to_nat (UserId u)} | _ \<Rightarrow> {}"

definition [simp]: "default_val \<equiv> Undef"

lemma uniqueIds_simp[simp]:
  shows "uniqueIds (String x) = {}"
    "uniqueIds (Bool b) = {}"
    "uniqueIds Undef = {}"
    "uniqueIds (Found x y) = {}"
    "uniqueIds NotFound = {}"
  by (auto simp add: uniqueIds_val_def)

instance by (standard, auto)
end

instantiation val :: from_bool begin
definition [simp]: "from_bool_val \<equiv> Bool"

instance by (standard, auto)
end

definition "isUserId x \<equiv> case x of UserId _ \<Rightarrow> True | _ \<Rightarrow> False"

lemma "uniqueIds (Bool True) = {}"
  by (simp add: uniqueIds_val_def)

fun stringval where
  "stringval (String s) = s"
| "stringval _ = ''''"

datatype userDataOp =
  Name "val registerOp"
  | Mail "val registerOp"

instance userDataOp :: countable
  by countable_datatype
instantiation userDataOp :: crdt_op begin
definition "uniqueIds_userDataOp x \<equiv>
  case x of
     Name x \<Rightarrow> uniqueIds x
   | Mail x \<Rightarrow> uniqueIds x"

definition [simp]: "default_userDataOp = Mail default"

definition "is_update_userDataOp x \<equiv> case x of Name x \<Rightarrow> is_update x | Mail x \<Rightarrow> is_update x"

instance by (standard, auto)
end

type_synonym operation =
  "(val, userDataOp) mapOp"

text_raw \<open>\DefineSnippet{userbase_impl}{\<close>
definition registerUser_impl :: "val \<Rightarrow> val \<Rightarrow> (val,operation,val) io" where
  "registerUser_impl name mail \<equiv>  do {
  u \<leftarrow> newId isUserId;
  atomic (do {
    call (NestedOp u (Name (Assign name)));
    call (NestedOp u (Mail (Assign mail)))
  });
  return u
}"

definition updateMail_impl :: "val \<Rightarrow> val \<Rightarrow> (val,operation,val) io" where
  "updateMail_impl u mail \<equiv>  do {
  atomic (do {
  exists \<leftarrow> call (KeyExists u);
    (if exists = Bool True then do {
      call (NestedOp u (Mail (Assign mail)))
    } else skip)
  });
  return Undef
}"

definition removeUser_impl :: "val \<Rightarrow> (val,operation,val) io" where
  "removeUser_impl u \<equiv>  do {
  atomic (do {
      call (DeleteKey u)
  });
  return Undef
}"

definition getUser_impl :: "val \<Rightarrow> (val,operation,val) io" where
  "getUser_impl u \<equiv>  do {
  atomic (do {
    exists \<leftarrow> call (KeyExists u);
    (if exists = Bool True then do {
      name \<leftarrow> call (NestedOp u (Name Read));
      mail \<leftarrow> call (NestedOp u (Mail Read));
      return (Found (stringval name) (stringval mail))
    } else return NotFound)
  })
}"
text_raw \<open>}%EndSnippet\<close>

datatype proc =
  RegisterUser string string
  | UpdateMail int string
  | RemoveUser int
  | GetUser int

instance proc :: countable
  by countable_datatype

instantiation proc :: valueType begin
definition "uniqueIds_proc proc \<equiv>
  case proc of
     UpdateMail u _ \<Rightarrow> uniqueIds (UserId u)
   | RemoveUser u  \<Rightarrow> uniqueIds (UserId u)
   | GetUser u  \<Rightarrow> uniqueIds (UserId u)
   | RegisterUser _ _ \<Rightarrow> {}"

lemma [simp]:
  "uniqueIds (UpdateMail u x) = uniqueIds (UserId u)"
  "uniqueIds (RemoveUser u ) = uniqueIds (UserId u)"
  "uniqueIds (GetUser u ) = uniqueIds (UserId u)"
  "uniqueIds (RegisterUser x y) = {}"
  by (auto simp add: uniqueIds_proc_def)

definition [simp]: "default_proc \<equiv> RegisterUser [] []"

instance by (standard, auto)
end

type_synonym localState = "val store  \<times> uniqueId set \<times> (val, operation, val) io"

definition procedures :: "proc \<Rightarrow> (localState \<times> (localState, operation, val) procedureImpl)" where
  "procedures invoc \<equiv>
  case invoc of
    RegisterUser name mail \<Rightarrow> toImpl' invoc (registerUser_impl (String name) (String mail))
  | UpdateMail u mail \<Rightarrow> toImpl' invoc (updateMail_impl (UserId u) (String mail))
  | RemoveUser u \<Rightarrow>  toImpl' invoc (removeUser_impl (UserId u))
  | GetUser u  \<Rightarrow>  toImpl' invoc (getUser_impl (UserId u))
"

text_raw \<open>\DefineSnippet{userbase_invariants}{\<close>
definition inv1  where
  "inv1 op res ihb \<equiv> \<forall>r g u g_res.
    op r \<triangleq> RemoveUser u
  \<longrightarrow> op g \<triangleq> GetUser u
  \<longrightarrow> (r,g) \<in> ihb
  \<longrightarrow> res g \<triangleq> g_res
  \<longrightarrow> g_res = NotFound"

definition inv2  where
  "inv2 c_calls hb \<equiv> \<not>(\<exists>write delete u upd.
    (cOp c_calls write \<triangleq> NestedOp u upd)
  \<and> is_update upd
  \<and> (cOp c_calls delete \<triangleq> DeleteKey u)
  \<and> (delete, write) \<in> hb
  )"

definition inv3  where
  "inv3 op i_origin c_calls \<equiv> \<forall>u i c.
    op i \<triangleq> RemoveUser u
  \<longrightarrow> i_origin c \<triangleq> i
  \<longrightarrow> cOp c_calls c \<triangleq> DeleteKey (UserId u)"

definition inv :: "(proc, operation, val) invContext \<Rightarrow> bool" where
  "inv ctxt \<equiv>
    inv1 (invocOp ctxt) (invocRes ctxt) (invocation_happensBefore ctxt)
  \<and> inv2 (calls ctxt) (happensBefore ctxt)
  \<and> inv3 (invocOp ctxt) (i_callOriginI ctxt) (calls ctxt)"
text_raw \<open>}%EndSnippet\<close>

lemma use_inv2'':
  assumes "inv2 c_calls hb"
    and "cOp c_calls write \<triangleq> NestedOp u upd"
    and "is_update upd"
    and "cOp c_calls delete \<triangleq> DeleteKey u"
  shows "(delete, write) \<notin> hb"
  by (meson assms inv2_def)

lemmas use_inv3 = inv3_def[unfolded atomize_eq, THEN iffD1, rule_format]

definition userStruct :: "(userDataOp, val) crdtSpec" where
  "userStruct \<equiv>
      struct_field Name (register_spec Undef)
  .\<or>. struct_field Mail (register_spec Undef)"

definition crdtSpec :: "(operation, val) crdtSpec" where
  "crdtSpec \<equiv> map_sdw_spec userStruct"

definition userStruct' :: "('a, userDataOp, val) ccrdtSpec" where
  "userStruct' \<equiv>
      struct_field' Name (register_spec' Undef)
 .\<or>.. struct_field' Mail (register_spec' Undef)"

definition crdtSpec' :: "(operation, operation, val) ccrdtSpec" where
  "crdtSpec' \<equiv> map_sdw_spec' userStruct'"

lemma inj_fields[simp]:
  "inj Name" "inj Mail"
  by (auto simp add: inj_def)

lemma crdtSpec_rel:
  shows "crdt_spec_rel crdtSpec crdtSpec'"
  by (auto simp add: crdtSpec_def crdtSpec'_def userStruct_def userStruct'_def)

definition progr :: "(proc, localState, operation, val) prog" where
  "progr \<equiv> \<lparr>
  querySpec = crdtSpec,
  procedure = procedures,
  invariant = inv
\<rparr>"

lemma procedure_progr[simp]: "procedure progr = procedures"
  by (simp add: progr_def)

lemma querySpec_progr[simp]: "querySpec progr = crdtSpec"
  by (simp add: progr_def)

lemma progr_wf[simp]: "program_wellFormed progr"
proof (auto simp add: program_wellFormed_def)
  show "invocations_cannot_guess_ids progr"
  proof (rule invocations_cannot_guess_ids_io)

    show "impl = impl_language_loops.toImpl \<and> localKnown = uniqueIds proc"
      if c0: "procedure progr proc = ((store, localKnown, cmd), impl)"
      for  proc store localKnown cmd impl
      using that
      by (auto simp add: progr_def procedures_def split: proc.splits)
  qed

  show "queries_cannot_guess_ids crdtSpec"
    by (auto simp add: crdtSpec_def userStruct_def)
qed

lemma isUserId_infinite[simp]: "infinite (Collect isUserId)"
proof (rule infinite_if_mappable_to_nat)
  show "\<exists>x\<in>Collect isUserId. n \<le> (case x of UserId n \<Rightarrow> nat n)" for n
    by (rule bexI[where x="UserId (int n)"],
        auto simp add: isUserId_def)
qed

lemma invariant_progr[simp]: "invariant progr = example_userbase.inv"
  by (auto simp add: progr_def)

declare invContext.defs[simp]

lemmas crdt_spec_defs =
  toplevel_spec_def crdtSpec'_def struct_field'_def map_sdw_spec'_def map_spec'_def userStruct'_def register_spec'_def
  set_rw_spec'_def deleted_calls_sdw'_def

theorem userbase_correct: "programCorrect progr"
proof M_show_programCorrect

  case invariant_initial_state
  show "invariant_all' (initialState progr)"
    by (simp add: example_userbase.inv_def initialState_def inv1_def inv3_def inv2_def invContextH2_happensBefore invContextH2_i_invocOp progr_def)

  case (procedure_correct S i)

  show "procedureCorrect S i"
  proof (rule Initial_Label, rule show_initial_state_prop[OF procedure_correct], rule DC_final2, casify)
    case (show_P S_pre proc initState impl)
    have "invocOp S i \<triangleq> proc"
      using show_P by auto
    have "invocRes S i = None"
      using show_P apply auto
      using state_wellFormed_invocation_before_result by blast

    have "uniqueIds proc \<subseteq> knownIds S"
      using show_P by auto

    note show_P[simp]

    show "procedureCorrect S i"
    proof (cases proc)
      case (RegisterUser name mail)

      show "procedureCorrect S i"
      proof M_show_procedureCorrect
        case after_invocation
        show ?case
          using show_P.invariant_pre RegisterUser
          by (auto simp add:  inv_def inv1_def inv3_def invContextH2_simps)

      next
        case execution
        show "execution_s_correct S i"
          using procedure_correct.in_initial_state
        proof (fuzzy_rule execution_s_check_sound4)

          show "currentProc S i \<triangleq> toImpl"
            by (auto simp add: RegisterUser procedures_def )

          show "localState S i \<triangleq> (Map.empty, uniqueIds (RegisterUser name mail), registerUser_impl (String name) (String mail))"
            by (auto simp add: RegisterUser procedures_def )

          note registerUser_impl_def[simp]

          show "invocOp S i \<triangleq> RegisterUser name mail"
            using RegisterUser \<open>invocOp S i \<triangleq> proc\<close> by blast

          show "program_wellFormed (prog S)"
            by (simp add: initialStates_reachable_from_initialState procedure_correct.in_initial_state)

          show "invariant_all' S"
            using execution.in_initial_state by blast

          from crdtSpec_rel
          show "crdt_spec_rel (querySpec progr) crdtSpec'"
            by simp

          show "execution_s_check (invariant progr) crdtSpec' \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> RegisterUser name mail), invocRes = s_invocRes(i := None), ps_i = i, ps_generatedLocal = {}, ps_generatedLocalPrivate = {}, ps_localKnown = uniqueIds (RegisterUser name mail), ps_vis = {}, ps_localCalls = [], ps_tx = None, ps_firstTx = True, ps_store = Map.empty, ps_prog = progr\<rparr> (registerUser_impl (String name) (String mail)) (finalCheck (invariant progr) i)"
            if c0: "\<And>tx. s_txOrigin tx \<noteq> Some i"
              and c1: "invariant progr \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> RegisterUser name mail), invocRes = s_invocRes(i := None)\<rparr>"
            for  s_calls s_happensBefore s_callOrigin s_txOrigin s_knownIds s_invocOp s_invocRes
          proof (repliss_vcg_l, fuzzy_goal_cases "AtCommit" "AtReturn" )
            case (AtCommit v vn tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res ca resa PS')

            from AtCommit.inv
            show ?case
            proof (auto simp add: inv_def AtCommit.PS'_eq, fuzzy_goal_cases inv1 inv2 inv3)

              case inv1

              from `inv1 (s_invocOp'(i \<mapsto> RegisterUser name mail)) (s_invocRes'(i := None))
                  (invocation_happensBeforeH (i_callOriginI_h s_callOrigin' s_txOrigin') s_happensBefore')`
              show ?case
                using AtCommit.invocation_happensBeforeH_eq
                by (auto simp add: inv1_def)

            next
              case inv3
              from `inv3 (s_invocOp'(i \<mapsto> RegisterUser name mail)) (i_callOriginI_h s_callOrigin' s_txOrigin') s_calls'`
              show ?case
                by (auto simp add: inv3_def map_update_all_get i_callOriginI_h_simp i_callOriginI_h_update_to3 split: if_splits)
            next
              case inv2

              from `uid_is_private' i s_calls' s_invocOp' s_invocRes' s_knownIds' vn`
              have "new_unique_not_in_calls s_calls' vn"
                by (auto simp add: uid_is_private'_def)

              text "Because v is a new unique id there can be no delete operation on that type:"
              hence no_delete: "cOp s_calls' delete \<noteq> Some (DeleteKey v)" for delete
                using `uniqueIds v = {vn}` by (auto simp add: new_unique_not_in_calls_def uniqueIds_mapOp_def cOp_Some_iff, force)

              from `inv2 s_calls' s_happensBefore'`
              show ?case
                by (auto simp add: no_delete inv2_def  updateHb_cases in_sequence_cons  )

            qed

          next
            case (AtReturn v vn tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res ca resa)
            then show ?case
              by (auto simp add: inv_def inv1_def split: if_splits)
          qed

        qed
      qed

    next
      case (UpdateMail user mail)

      show "procedureCorrect S i"
      proof M_show_procedureCorrect
        case after_invocation
        show ?case
          using show_P.invariant_pre UpdateMail
          by (auto simp add:  inv_def inv1_def inv3_def inv2_def invContextH2_simps)

      next
        case execution
        show "execution_s_correct S i"
          using procedure_correct.in_initial_state
        proof (fuzzy_rule execution_s_check_sound4)

          show "currentProc S i \<triangleq> toImpl"
            by (auto simp add: UpdateMail procedures_def )

          show "localState S i \<triangleq> (Map.empty, uniqueIds (UpdateMail user mail), updateMail_impl (UserId user) (String mail))"
            by (auto simp add: UpdateMail procedures_def )

          note updateMail_impl_def[simp]

          show "invocOp S i \<triangleq> UpdateMail user mail"
            using UpdateMail \<open>invocOp S i \<triangleq> proc\<close> by blast

          show "program_wellFormed (prog S)"
            by (simp add: procedure_correct.in_initial_state)

          show "invariant_all' S"
            using execution.in_initial_state by blast

          from crdtSpec_rel
          show "crdt_spec_rel (querySpec progr) crdtSpec'"
            by simp

          show "execution_s_check (invariant progr) crdtSpec' \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> UpdateMail user mail), invocRes = s_invocRes(i := None), ps_i = i, ps_generatedLocal = {}, ps_generatedLocalPrivate = {}, ps_localKnown = uniqueIds (UpdateMail user mail), ps_vis = {}, ps_localCalls = [], ps_tx = None, ps_firstTx = True, ps_store = Map.empty, ps_prog = progr\<rparr> (updateMail_impl (UserId user) (String mail)) (finalCheck (invariant progr) i)"
            if c0: "\<And>tx. s_txOrigin tx \<noteq> Some i"
              and c1: "invariant progr \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> UpdateMail user mail), invocRes = s_invocRes(i := None)\<rparr>"
            for  s_calls s_happensBefore s_callOrigin s_txOrigin s_knownIds s_invocOp s_invocRes
          proof (repliss_vcg_l, fuzzy_goal_cases "Exists_AtCommit" "Exists_AtReturn" "NotExists_AtCommit" "NotExists_AtReturn"  )
            case (Exists_AtCommit tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c ca resa PS')

            from Exists_AtCommit
            show ?case
            proof (auto simp add: inv_def, fuzzy_goal_cases inv1 inv2 inv3)
              case inv1

              from `inv1 (s_invocOp'(i \<mapsto> UpdateMail user mail)) (s_invocRes'(i := None))
               (invocation_happensBeforeH (i_callOriginI_h s_callOrigin' s_txOrigin') s_happensBefore')`
              show ?case
                by (auto simp add: inv1_def)

            next
              case inv3
              from `inv3 (s_invocOp'(i \<mapsto> UpdateMail user mail)) (i_callOriginI_h s_callOrigin' s_txOrigin') s_calls'`
              show ?case
                by (auto simp add: inv3_def i_callOriginI_h_update_to3 split: if_splits)

            next
              case inv2

              from \<open>toplevel_spec crdtSpec' \<lparr>calls = s_calls', happensBefore = s_happensBefore'\<rparr> vis' (KeyExists (UserId user)) (Bool True)\<close>

              obtain upd_c upd_op
                where a0: "upd_c \<in> vis'"
                  and a1: "extract_op s_calls' upd_c = NestedOp (UserId user) upd_op"
                  and a2: "is_update upd_op"
                  and a3: "\<forall>d\<in>vis'. extract_op s_calls' d = DeleteKey (UserId user) \<longrightarrow> (d, upd_c) \<in> s_happensBefore'"
                by (auto simp add: crdt_spec_defs)

              from a1
              have a1': "cOp s_calls' upd_c \<triangleq> NestedOp (UserId user) upd_op"
                by (metis (mono_tags, lifting) a0 cOp_Some extract_op_def in_dom inv2.less_eq option.sel)

              from a3
              have a3': "\<forall>d\<in>vis'. cOp s_calls' d \<triangleq> DeleteKey (UserId user) \<longrightarrow> (d, upd_c) \<in> s_happensBefore'"
                by (meson extract_op_eq' inv2.less_eq subset_iff)

              text \<open>There can be no delete:\<close>

              have noDelete: "delete \<notin> vis'" if "cOp s_calls' delete \<triangleq> DeleteKey (UserId user)" for delete
                using use_inv2''[OF \<open>inv2 s_calls' s_happensBefore'\<close> a1' a2 that] a3' that by blast

              text \<open>With this we can show that inv2 is maintained:\<close>

              show ?case
                using noDelete inv2.not_member3 use_inv2''[OF inv2.inv2]
                by (auto simp add: inv2_def `c \<noteq> ca` `c \<noteq> ca`[symmetric] updateHb_cons)

            qed

          next
            case (Exists_AtReturn tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c ca resa)
            then show ?case
              by (auto simp add: inv_def inv1_def, presburger)
          next
            case (NotExists_AtCommit tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res PS')

            show ?case
              using NotExists_AtCommit.invocation_happensBeforeH_eq
              using NotExists_AtCommit.inv
              by (auto simp add: inv_def inv1_def inv3_def inv2_def
                  i_callOriginI_h_update_to3 map_update_all_get updateHb_single NotExists_AtCommit.PS'_eq, meson)

          next
            case (NotExists_AtReturn tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res)
            then show ?case
              by (auto simp add: inv_def inv1_def, presburger)
          qed
        qed
      qed

    next
      case (RemoveUser user)

      show "procedureCorrect S i"
      proof M_show_procedureCorrect
        case after_invocation
        show ?case
          using show_P.invariant_pre RemoveUser
          apply (auto simp add:  inv_def inv1_def inv3_def inv2_def invContextH2_simps)
          using new_invocation_cannot_happen_before show_P.i_fresh show_P.wf_pre apply blast
          using i_callOriginI_notI1 show_P.i_fresh show_P.wf_pre by blast

      next
        case execution
        show "execution_s_correct S i"
          using procedure_correct.in_initial_state
        proof (fuzzy_rule execution_s_check_sound4)

          show "currentProc S i \<triangleq> toImpl"
            by (auto simp add: RemoveUser procedures_def )

          show "localState S i \<triangleq> (Map.empty, uniqueIds (RemoveUser user), removeUser_impl (UserId user))"
            by (auto simp add: RemoveUser procedures_def )

          note removeUser_impl_def[simp]

          show "invocOp S i \<triangleq> RemoveUser user"
            using RemoveUser \<open>invocOp S i \<triangleq> proc\<close> by blast

          show "program_wellFormed (prog S)"
            by simp

          show "invariant_all' S"
            using execution.in_initial_state by blast

          from crdtSpec_rel
          show "crdt_spec_rel (querySpec progr) crdtSpec'"
            by simp

          show "execution_s_check (invariant progr) crdtSpec' \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> RemoveUser user), invocRes = s_invocRes(i := None), ps_i = i, ps_generatedLocal = {}, ps_generatedLocalPrivate = {}, ps_localKnown = uniqueIds (RemoveUser user), ps_vis = {}, ps_localCalls = [], ps_tx = None, ps_firstTx = True, ps_store = Map.empty, ps_prog = progr\<rparr> (removeUser_impl (UserId user)) (finalCheck (invariant progr) i)"
            if c0: "\<And>tx. s_txOrigin tx \<noteq> Some i"
              and c1: "invariant progr \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> RemoveUser user), invocRes = s_invocRes(i := None)\<rparr>"
            for  s_calls s_happensBefore s_callOrigin s_txOrigin s_knownIds s_invocOp s_invocRes
          proof (repliss_vcg_l, fuzzy_goal_cases "Exists_AtCommit" "Exists_AtReturn" )
            case (Exists_AtCommit tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res PS')

            from Exists_AtCommit.inv Exists_AtCommit.invocation_happensBeforeH_eq
            show ?case
            proof (auto simp add: inv_def Exists_AtCommit.PS'_eq, fuzzy_goal_cases inv1 inv2 inv3)
              case inv1
              from `inv1 (s_invocOp'(i \<mapsto> RemoveUser user)) (s_invocRes'(i := None))
                   (invocation_happensBeforeH (i_callOriginI_h s_callOrigin' s_txOrigin') s_happensBefore')`
              show ?case
                by (auto simp add: inv1_def)

            next
              case inv3
              from `inv3 (s_invocOp'(i \<mapsto> RemoveUser user)) (i_callOriginI_h s_callOrigin' s_txOrigin') s_calls'`
              show ?case
                by (auto simp add: inv3_def i_callOriginI_h_update_to3   `\<And>c. s_callOrigin' c \<noteq> Some tx` split: if_splits)

            next
              case inv2
              from `inv2 s_calls' s_happensBefore'`
              show ?case
                using Exists_AtCommit.not_member2
                by (auto simp add: inv2_def updateHb_cases  in_sequence_cons  inv2)

            qed

          next
            case (Exists_AtReturn tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res)
            then show ?case
              by (auto simp add: inv_def inv1_def split: if_splits)
          qed
        qed
      qed
    next
      case (GetUser user)

      show "procedureCorrect S i"
      proof M_show_procedureCorrect
        case after_invocation
        show ?case
          using show_P.invariant_pre GetUser
          by (auto simp add:  inv_def inv1_def inv3_def inv2_def invContextH2_simps  new_invocation_cannot_happen_after)

      next
        case execution
        show "execution_s_correct S i"
          using procedure_correct.in_initial_state
        proof (fuzzy_rule execution_s_check_sound4)

          show "currentProc S i \<triangleq> toImpl"
            by (auto simp add: GetUser procedures_def )

          show "localState S i \<triangleq> (Map.empty, uniqueIds (GetUser user), getUser_impl (UserId user))"
            by (auto simp add: GetUser procedures_def )

          note getUser_impl_def[simp]

          show "invocOp S i \<triangleq> GetUser user"
            using GetUser \<open>invocOp S i \<triangleq> proc\<close> by blast

          show "program_wellFormed (prog S)"
            by simp
          show "invariant_all' S"
            using execution.in_initial_state by blast

          from crdtSpec_rel
          show "crdt_spec_rel (querySpec progr) crdtSpec'"
            by simp

          show "execution_s_check (invariant progr) crdtSpec' \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> GetUser user), invocRes = s_invocRes(i := None), ps_i = i, ps_generatedLocal = {}, ps_generatedLocalPrivate = {}, ps_localKnown = uniqueIds (GetUser user), ps_vis = {}, ps_localCalls = [], ps_tx = None, ps_firstTx = True, ps_store = Map.empty, ps_prog = progr\<rparr> (getUser_impl (UserId user)) (finalCheck (invariant progr) i)"
            if c0: "\<And>tx. s_txOrigin tx \<noteq> Some i"
              and c1: "invariant progr \<lparr>calls = s_calls, happensBefore = s_happensBefore, callOrigin = s_callOrigin, txOrigin = s_txOrigin, knownIds = s_knownIds, invocOp = s_invocOp(i \<mapsto> GetUser user), invocRes = s_invocRes(i := None)\<rparr>"
            for  s_calls s_happensBefore s_callOrigin s_txOrigin s_knownIds s_invocOp s_invocRes
          proof (repliss_vcg_l, fuzzy_goal_cases "Exists_AtCommit" "Exists_AtReturn" "NotExists_AtCommit" "NotExists_AtReturn"  )
            case (Exists_AtCommit tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c ca resa cb res PS')

            from Exists_AtCommit.inv
            show ?case
            proof (auto simp add: inv_def Exists_AtCommit.PS'_eq, fuzzy_goal_cases inv1 inv2 inv3)
              case (inv1)
              then show ?case
                using Exists_AtCommit.invocation_happensBeforeH_eq
                by (auto simp add: inv1_def)

            next
              case (inv3)
              then show ?case
                using Exists_AtCommit.not_ca_eq Exists_AtCommit.not_c_eq Exists_AtCommit.not_c_eq2
                by (auto simp add: inv3_def i_callOriginI_h_update_to3 split: if_splits)
            next
              case (inv2)
              then show ?case
                by (auto simp add: inv2_def i_callOriginI_h_update_to3 updateHb_cases in_sequence_cons is_update_userDataOp_def)
            qed

          next
            case (Exists_AtReturn tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c ca resa cb res)

            find_theorems name: "Exists_AtReturn."

            from Exists_AtReturn.inv
            show ?case
            proof (auto simp add: inv_def, fuzzy_goal_cases inv1 inv2 inv3)
              case (inv1)

              text "From the query result, we get an update that is not affected by a remove."

              from \<open>toplevel_spec crdtSpec' \<lparr>calls = s_calls', happensBefore = s_happensBefore'\<rparr> vis' (KeyExists (UserId user)) (Bool True)\<close>
              obtain upd_c upd_op
                where upd_c0: "upd_c \<in> vis'"
                  and upd_c1: "extract_op s_calls' upd_c = NestedOp (UserId user) upd_op"
                  and upd_c2: "is_update upd_op"
                  and upd_c3: "\<forall>d\<in>vis'. extract_op s_calls' d = DeleteKey (UserId user) \<longrightarrow> (d, upd_c) \<in> s_happensBefore'"
                by (auto simp add: crdt_spec_defs  split: if_splits)

              from upd_c1
              have upd_c1': "cOp s_calls' upd_c \<triangleq> NestedOp (UserId user) upd_op"
                by (metis Exists_AtReturn.less_eq extract_op_eq' in_mono upd_c0)

              from upd_c3
              have upd_c3': "(d, upd_c) \<in> s_happensBefore'"
                if "cOp s_calls' d \<triangleq> DeleteKey (UserId user)"
                  and "d \<in> vis'"
                for d
                using that
                by (meson extract_op_eq' Exists_AtReturn.less_eq subset_iff)

              text "No calls means we do not have any invocation happened before in the pre-state."
              have no_hb: "(r, i) \<notin> invocation_happensBeforeH (i_callOriginI_h s_callOrigin' s_txOrigin') s_happensBefore'" for r
                using Exists_AtReturn.not_s_txOrigin'_eq by (auto simp add: invocation_happensBeforeH_def i_callOriginI_h_def split: option.splits)

              have [simp]: "s_txOrigin'(tx := None) = s_txOrigin'"
                by (simp add: fun_upd_idem_iff Exists_AtReturn.s_txOrigin'_eq)

              show ?case
              proof (auto simp add: inv1_def no_hb Exists_AtReturn.invocation_happensBeforeH_eq)

                show "\<exists>c''. i_callOriginI_h s_callOrigin' s_txOrigin' c'' \<triangleq> r \<and> c'' \<notin> vis'"
                  if c0: "r \<noteq> i"
                    and c1: "s_invocOp' r \<triangleq> RemoveUser user"
                    and c3: "i_callOriginI_h s_callOrigin' s_txOrigin' c' \<triangleq> r"
                    and c4: "c' \<in> vis'"
                  for  r c'
                proof -

                  from c1 c0
                  have c1': \<open>(s_invocOp'(i \<mapsto> GetUser user)) r \<triangleq> RemoveUser user\<close> by simp

                  text \<open>use inv3 to get the delete operation\<close>

                  from use_inv3[OF inv1.inv3 c1' c3]
                  have "cOp s_calls' c' \<triangleq> DeleteKey (UserId user)" .

                  text \<open>The delete must be before upd_c by the CRDT spec (otherwise entry would not exist)\<close>

                  from upd_c3'[OF \<open>cOp s_calls' c' \<triangleq> DeleteKey (UserId user)\<close> c4]
                  have "(c', upd_c) \<in> s_happensBefore'" .

                  from use_inv2''[OF inv1.inv2 upd_c1' upd_c2 \<open>cOp s_calls' c' \<triangleq> DeleteKey (UserId user)\<close>]
                  have \<open>(c', upd_c) \<notin> s_happensBefore'\<close>  .

                  with \<open>(c', upd_c) \<in> s_happensBefore'\<close>
                  show ?thesis by blast
                qed

                show "g_res = NotFound"
                  if c0: "r \<noteq> i"
                    and c1: "g \<noteq> i"
                    and c2: "s_invocOp' r \<triangleq> RemoveUser u"
                    and c3: "s_invocOp' g \<triangleq> GetUser u"
                    and r_g_hb: "(r, g) \<in> invocation_happensBeforeH (i_callOriginI_h s_callOrigin' s_txOrigin') s_happensBefore'"
                    and c5: "s_invocRes' g \<triangleq> g_res"
                  for  r g u g_res
                  using \<open>inv1 (s_invocOp'(i \<mapsto> GetUser user)) (s_invocRes'(i := None))
                         (invocation_happensBeforeH (i_callOriginI_h s_callOrigin' s_txOrigin') s_happensBefore')\<close>
                  using that  by (auto simp add: inv1_def split: if_splits)

              qed

            next
              case inv2
              thus ?case
                by (auto simp add: inv2_def Exists_AtReturn is_update_userDataOp_def updateHb_simp2)
            next
              case inv3
              thus ?case
                by (auto simp add: inv3_def Exists_AtReturn i_callOriginI_h_update_to3 split: if_splits)

            qed
          next
            case (NotExists_AtCommit tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res)
            then show ?case
              by (auto simp add: inv_def inv1_def inv3_def inv2_def i_callOriginI_h_update_to3 map_update_all_get updateHb_cases in_sequence_cons split: if_splits, meson)

          next
            case (NotExists_AtReturn tx s_calls' s_happensBefore' s_callOrigin' s_txOrigin' s_knownIds' vis' s_invocOp' s_invocRes' c res)
            then show ?case
              by  (auto simp add: inv_def inv1_def, presburger)
          qed
        qed
      qed
    qed
  qed
qed

end


theory Heap_Default
  imports
    Heap_Main
    "../Indexing"
begin

locale dp_consistency_heap_default =
  fixes bound :: "'k :: {index, heap} bound"
    and mem :: "'v::heap option array"
    and dp :: "'k \<Rightarrow> 'v"
begin

interpretation idx: bounded_index bound .

sublocale dp_consistency_heap
  where P="\<lambda>heap. Array.length heap mem = idx.size"
    and lookup="mem_lookup idx.size idx.checked_idx mem"
    and update="mem_update idx.size idx.checked_idx mem"
  apply (rule dp_consistency_heap.intro)
  apply (rule mem_heap_correct)
  apply (rule idx.checked_idx_injective)
  done

context
  fixes empty
  assumes empty: "map_of_heap empty \<subseteq>\<^sub>m Map.empty"
      and len: "Array.length empty mem = idx.size"
begin

interpretation consistent: dp_consistency_heap_empty
  where P="\<lambda>heap. Array.length heap mem = idx.size"
    and lookup="mem_lookup idx.size idx.checked_idx mem"
    and update="mem_update idx.size idx.checked_idx mem"
  by (standard; rule len empty)

lemmas memoizedI = consistent.memoized
lemmas successI = consistent.memoized_success

end

lemma mem_empty_empty:
  "map_of_heap (heap_of (mem_empty idx.size :: 'v option array Heap) Heap.empty) \<subseteq>\<^sub>m Map.empty"
  if "mem = result_of (mem_empty idx.size) Heap.empty"
  by (auto intro!: map_emptyI simp:
      that length_mem_empty Let_def nth_mem_empty mem_lookup_def heap_mem_defs.map_of_heap_def
      )

lemma memoized_empty:
  "dp x = result_of ((mem_empty idx.size :: 'v option array Heap) \<bind> (\<lambda>mem. dp\<^sub>T mem x)) Heap.empty"
  if "consistentDP (dp\<^sub>T mem)" "mem = result_of (mem_empty idx.size) Heap.empty"
  apply (subst execute_bind_success)
   defer
   apply (subst memoizedI[OF _ _ that(1)])
  using mem_empty_empty[OF that(2)] by (auto simp: that(2) length_mem_empty)

lemma init_success:
  "success ((mem_empty idx.size :: 'v option array Heap) \<bind> (\<lambda>mem. dp\<^sub>T mem x)) Heap.empty"
  if "consistentDP (dp\<^sub>T mem)" "mem = result_of (mem_empty idx.size) Heap.empty"
  apply (rule success_bind_I[OF success_empty])
  apply (frule execute_result_ofD)
  apply (drule execute_heap_ofD)
  using mem_empty_empty that by (auto simp: length_mem_empty intro: successI)

end

end