theory Lense_Knowledge_Base (* TODO: Improve Theory Name! *)
  imports SE_Monad More_Eisbach_Tools
begin

section \<open>Generic Lens Based Transfer Tool\<close>
definition "VAL L x s \<equiv> hlens L \<and> get L s = Some x"

lemma VAL_get[simp]:
  assumes "VAL L x s"
  shows "pre_get L s" "get' L s = x"
  using assms unfolding VAL_def by auto

definition DEL_TAG :: "bool \<Rightarrow> bool" where "DEL_TAG x \<equiv> x"
definition DEL_TAG' :: "bool \<Rightarrow> bool" where "DEL_TAG' x \<equiv> True"
lemma DEL_TAG_cong[cong]: "DEL_TAG x = DEL_TAG x" ..
lemma DEL_TAG'_cong[cong]: "DEL_TAG' x = DEL_TAG' x" ..

lemmas DEL_congs = DEL_TAG_cong DEL_TAG'_cong

lemma DEL_TAG'E: "P \<Longrightarrow> DEL_TAG' P \<Longrightarrow> Q \<Longrightarrow> Q" .

lemma DEL_TAG'_simp:
  "DEL_TAG' x \<Longrightarrow> x = DEL_TAG x"
  by (auto simp: DEL_TAG_def)

definition KBXFER :: "_ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> bool" where "KBXFER R s s' \<equiv> R s s'"

lemma KBXFER_trans: "KBXFER R\<^sub>1 s sh \<Longrightarrow> KBXFER R\<^sub>2 sh s' \<Longrightarrow> KBXFER (R\<^sub>1 OO R\<^sub>2) s s'"
  by (auto simp: KBXFER_def)

lemma KBXFER_transE:
  assumes "KBXFER R s\<^sub>1 s\<^sub>2"
  assumes "KBXFER R' s\<^sub>2 s\<^sub>3"
  obtains "KBXFER (R OO R') s\<^sub>1 s\<^sub>3" "DEL_TAG' (KBXFER R' s\<^sub>2 s\<^sub>3)"
  using KBXFER_trans[OF assms] by (auto simp: DEL_TAG'_def)

named_theorems DEL_KBXFER_simps

lemma [DEL_KBXFER_simps]:
  assumes "KBXFER R s s'"
  shows
    "VAL L x s = DEL_TAG (VAL L x s)"
    by (auto simp: DEL_TAG_def)

lemma KBXFER_simp: "KBXFER R s s' \<Longrightarrow> eq_on\<^sub>L R L \<Longrightarrow> VAL L x s = VAL L x s'"
  unfolding VAL_def KBXFER_def
  by (simp add: eq_on\<^sub>L_def)

method handle_del =
  ((determ \<open>erule (1) DEL_TAG'E\<close>)+)?;
  elim_determ thin_rl[of "DEL_TAG _"] thin_rl[of "DEL_TAG' _"]

method kbxfer_trans =
  (determ \<open>erule (1) KBXFER_transE\<close>)+;
  handle_del;
  (simp only: triv_forall_equality)?

method kbxfer' =
  (simp add: KBXFER_simp eq_on_ltrans_indepI eq_on_compI)

method kbxfer =
  kbxfer';
  (simp only: DEL_KBXFER_simps cong: DEL_TAG_cong)?;
  elim_determ thin_rl[of "KBXFER _ _ _"] thin_rl[of "DEL_TAG _"];
  (simp only: triv_forall_equality)?

section \<open>Wps Setup\<close>

lemma wps_use_val_eq[wps_iffs]:
  assumes "VAL L x s"
  shows "wps (use L) Q s \<longleftrightarrow> Q x s"
  supply wps_use_eq[wps_iffs]
  using assms by (auto simp: VAL_def wps_eqs)

lemma wps_upd_val_eq[wps_simps]  (* Not in wps_rls, as we will put a kbxfer-based lemma there *):
  assumes "VAL L x s"
  shows "wps (L %= f) Q s \<longleftrightarrow> Q () (put' L (f x) s)"
  supply wps_upd_eq[wps_iffs]
  using assms by (auto simp: VAL_def wps_eqs)

lemma wps_upd_valI[wps_intros]:
  assumes "VAL L x s"
  assumes "\<And>s'. KBXFER (ltrans L) s s' \<Longrightarrow> VAL L (f x) s' \<Longrightarrow> Q () s'"
  shows "wps (L %= f) Q s"
  supply wps_upd_eq[wps_iffs]
  apply (rule wps_rls)
  using assms unfolding VAL_def
  by (auto simp: KBXFER_def)

lemma wps_set_valI[wps_intros]:
  assumes "hlens L" "pre_put L s"
  assumes "\<And>s'. KBXFER (ltrans L) s s' \<Longrightarrow> VAL L x s' \<Longrightarrow> Q () s'"
  shows "wps (L ::= x) Q s"
  supply wps_assign_eq[wps_iffs]
  apply (rule wps_rls)
  using assms unfolding VAL_def
  by (auto simp: KBXFER_def)

end


section \<open> Circus Interaction Tree Semantics \<close>

theory ITree_Circus
  imports "ITree_FDSem" "Shallow-Expressions-Z.Shallow_Expressions_Z"
begin

subsection \<open> Main Operators \<close>

type_synonym ('e, 's) action = "('e, 's) htree"
type_synonym 'e process = "('e, unit) itree"

definition Skip :: "('e, 'r) htree" where
"Skip = (\<lambda> s. Ret s)"

lemma Skip_unit [simp]:
  "Skip ;; S = S" "S ;; Skip = S"
  by (simp_all add: seq_itree_def Skip_def kleisli_comp_def bind_itree_right_unit)

text \<open> Like @{const Skip}, but do a single silent step. \<close>

definition Step :: "('e, 'r) htree" where
"Step = \<tau> \<circ> Skip"

lemma straces_Skip: "traces\<^sub>s (Skip) = ({[], [\<checkmark> [\<leadsto>]]})\<^sub>e"
  by (simp add: Skip_def straces_def traces_Ret, expr_simp)

abbreviation Div :: "('e, 'r) htree" where
"Div \<equiv> (\<lambda> s. diverge)"

lemma Div_left_zero [simp]: "Div ;; P = Div"
  by (simp add: seq_itree_def kleisli_comp_def)

lemma traces_deadlock: "traces(deadlock) = {[]}"
  by (auto simp add: deadlock_def traces_Vis)

abbreviation
"Stop \<equiv> (\<lambda> s. deadlock)"

lemma Stop_left_zero [simp]: "Stop ;; S = Stop"
  by (simp add: seq_itree_def kleisli_comp_def)

definition "assume" :: "('s \<Rightarrow> bool) \<Rightarrow> ('e, 's) htree" where
"assume b = (\<lambda> s. if (b s) then Ret s else diverge)"

syntax "_assume" :: "logic \<Rightarrow> logic" ("\<questiondown>_?")
translations "_assume b" == "CONST assume (b)\<^sub>e"

lemma assume_true: "\<questiondown>True? = Skip"
  by (simp add: assume_def Skip_def)

lemma assume_false: "\<questiondown>False? = Div"
  by (simp add: assume_def)

definition test :: "('s \<Rightarrow> bool) \<Rightarrow> ('e, 's) htree" where
"test b = (\<lambda> s. if (b s) then Ret s else deadlock)"

abbreviation (input) "assert b \<equiv> test b"

syntax "_test" :: "logic \<Rightarrow> logic" ("\<exclamdown>_!")
translations "_test b" == "CONST test (b)\<^sub>e"

lemma test_true: "\<exclamdown>True! = Skip"
  by (simp add: test_def Skip_def)

lemma test_false: "\<exclamdown>False! = Stop"
  by (simp add: test_def)

definition cond_itree :: "('e, 's) htree \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('e, 's) htree \<Rightarrow> ('e, 's) htree" where
"cond_itree P b Q = (\<lambda> s. if b s then P s else Q s)"

text \<open> Similar to @{const Let} in HOL, but it evaluates the assigned expression on the initial state. \<close>

definition let_itree :: "('i, 's) expr \<Rightarrow> ('i \<Rightarrow> ('e, 's) htree) \<Rightarrow> ('e, 's) htree" where
"let_itree e S = (\<lambda> s. S (e s) s)"

definition for_itree :: "'i list \<Rightarrow> ('i \<Rightarrow> ('e, 's) htree) \<Rightarrow> ('e, 's) htree" where
"for_itree I P = (\<lambda> s. (foldr (\<lambda> i Q. P i ;; Q) I Skip) s)"

syntax
  "_cond_itree"  :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("if _ then _ else _ fi")
  "_cond_itree1" :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("if _ then _ fi")
  "_cond_itree_infix"  :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("(3_ \<lhd> _ \<rhd>/ _)" [52,0,53] 52)
  "_while_itree" :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("while _ do _ od")
  "_let_itree" :: "id \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("(let _ \<leftarrow> (_) in (_))" [0, 0, 10] 10)
  "_for_itree"   :: "id \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("for _ in _ do _ od")
  "_for_to_itree" :: "id \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("for _ = _ to _ do _ od")
  "_for_downto_itree" :: "id \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("for _ = _ downto _ do _ od")

translations
  "_cond_itree b P Q" == "CONST cond_itree P (b)\<^sub>e Q"
  "_cond_itree1 b P " == "CONST cond_itree P (b)\<^sub>e (CONST Skip)"
  "_cond_itree_infix P b Q" => "_cond_itree b P Q"
  "_while_itree b P" == "CONST iterate (b)\<^sub>e P"
  "_let_itree x e S" == "CONST let_itree (e)\<^sub>e (\<lambda> x. S)"
  "_for_itree i I P" == "CONST for_itree I (\<lambda> i. P)"
  "_for_to_itree i m n P" == "_for_itree i [m..<CONST Suc n] P"
  "_for_downto_itree i n m P" == "_for_itree i (CONST rev [m..<CONST Suc n]) P"

definition assigns :: "('s\<^sub>1, 's\<^sub>2) psubst \<Rightarrow> ('s\<^sub>1 \<Rightarrow> ('e, 's\<^sub>2) itree)" ("\<langle>_\<rangle>\<^sub>a") where
"assigns \<sigma> = (\<lambda> s. Ret (\<sigma> s))"

syntax
  "_assignment"     :: "svids \<Rightarrow> uexprs \<Rightarrow> logic"  (infixr ":=" 61)
  "_swap" :: "svid \<Rightarrow> svid \<Rightarrow> logic" ("swap'(_, _')")

translations
  "_assignment x e" == "CONST assigns (CONST subst_upd (CONST subst_id) x (e)\<^sub>e)"
  "_assignment (_svid_tuple (_of_svid_list (x +\<^sub>L y))) e" <= "_assignment (x +\<^sub>L y) e"
  "_swap x y" => "(x, y) := ($y, $x)"

named_theorems assigns_combine

lemma assigns_id: "\<langle>id\<rangle>\<^sub>a = Skip"
  by (simp add: assigns_def Skip_def)

lemma assigns_empty: "\<langle>[\<leadsto>]\<rangle>\<^sub>a = Skip"
  by (simp add: subst_id_def assigns_def Skip_def)

lemma assigns_seq: "\<langle>\<sigma>\<rangle>\<^sub>a ;; (P ;; Q) = (\<langle>\<sigma>\<rangle>\<^sub>a ;; P) ;; Q"
  by (simp add: seq_itree_def kleisli_comp_def assigns_def)

lemma assigns_seq_comp [assigns_combine]: "\<langle>\<sigma>\<rangle>\<^sub>a ;; \<langle>\<rho>\<rangle>\<^sub>a = \<langle>\<rho> \<circ>\<^sub>s \<sigma>\<rangle>\<^sub>a"
  by (simp add: seq_itree_def kleisli_comp_def assigns_def subst_comp_def)

lemma assigns_test: "\<langle>\<sigma>\<rangle>\<^sub>a ;; \<exclamdown>b! = \<exclamdown>\<sigma> \<dagger> b! ;; \<langle>\<sigma>\<rangle>\<^sub>a"
  by (simp add: seq_itree_def kleisli_comp_def assigns_def test_def fun_eq_iff expr_defs)

lemma assigns_assume: "\<langle>\<sigma>\<rangle>\<^sub>a ;; \<questiondown>b? = \<questiondown>\<sigma> \<dagger> b? ;; \<langle>\<sigma>\<rangle>\<^sub>a"
  by (simp add: seq_itree_def kleisli_comp_def assigns_def assume_def fun_eq_iff expr_defs)

lemma assigns_Stop: "\<langle>\<sigma>\<rangle>\<^sub>a ;; Stop = Stop"
  by (simp add: seq_itree_def assigns_def kleisli_comp_def)

lemma assign_Stop: "x := e ;; Stop = Stop"
  by (fact assigns_Stop)

lemma assigns_Step: "\<langle>\<sigma>\<rangle>\<^sub>a ;; Step = Step ;; \<langle>\<sigma>\<rangle>\<^sub>a"
  by (simp add: seq_itree_def assigns_def Step_def kleisli_comp_def Skip_def)

lemma assign_self: "vwb_lens x \<Longrightarrow> x := $x = Skip"
  by (simp add: usubst assigns_empty)

lemma assign_twice: "vwb_lens x \<Longrightarrow> (x := e;; x := f) = x := f\<lbrakk>e/x\<rbrakk>"
  by (simp add: assigns_combine usubst)

lemma assign_combine:
  assumes "vwb_lens x" "vwb_lens y" "x \<bowtie> y"
  shows "x := e ;; y := f = (x, y) := (e, f\<lbrakk>e/x\<rbrakk>)"
  using assms by (simp add: seq_itree_def kleisli_comp_def assigns_def fun_eq_iff expr_defs lens_defs lens_indep_comm)

lemma swap_self: "vwb_lens x \<Longrightarrow> swap(x, x) = Skip"
  by (simp add: usubst assigns_empty)

lemma swap_commute: "x \<bowtie> y \<Longrightarrow> swap(x, y) = swap(y, x)"
  by (simp add: usubst usubst_upd_comm)

lemma cond_assigns [assigns_combine]: "(cond_itree \<langle>\<sigma>\<rangle>\<^sub>a b \<langle>\<rho>\<rangle>\<^sub>a) = \<langle>expr_if \<sigma> b \<rho>\<rangle>\<^sub>a"
  by (auto simp add: assigns_def cond_itree_def fun_eq_iff expr_defs Skip_def)

lemma cond1_assigns [assigns_combine]: "(cond_itree \<langle>\<sigma>\<rangle>\<^sub>a b Skip) = \<langle>expr_if \<sigma> b [\<leadsto>]\<rangle>\<^sub>a"
  by (auto simp add: assigns_def cond_itree_def fun_eq_iff expr_defs Skip_def)

lemma assign_cond: "if b then x := e else x := f fi = x := (if b then e else f)"
  by (simp add: assigns_combine usubst, simp add: expr_if_def)

lemma cond_simps:
  "S \<lhd> True \<rhd> T = S"
  "S \<lhd> False \<rhd> T = T"
  "S \<lhd> \<not> b \<rhd> T = T \<lhd> b \<rhd> S"
  "S \<lhd> b \<rhd> (T \<lhd> b \<rhd> U) = S \<lhd> b \<rhd> U"
  "(S \<lhd> b \<rhd> T) ;; U = (S ;; U) \<lhd> b \<rhd> (T ;; U)"
  "x := e ;; (S \<lhd> b \<rhd> T) = (x := e ;; S) \<lhd> b\<lbrakk>e/x\<rbrakk> \<rhd> (x := e ;; T)"
   by (simp_all add: seq_itree_def cond_itree_def fun_eq_iff kleisli_comp_def assigns_def expr_defs)

lemma for_empty: "for x in [] do P x od = Skip"
  by (simp add: for_itree_def)

lemma for_Cons: "for_itree (x # xs) P = P x ;; for_itree xs P"
  by (simp add: for_itree_def)

text \<open> A for loop terminates provided that the body does so in each iteration. We use an invariant
  expression @{term R} to restrict the possible states encountered. \<close>

lemma terminates_for_itree:
  assumes
    "\<And> i s\<^sub>0 tr\<^sub>0 s\<^sub>1. \<lbrakk> i < length xs; R i s\<^sub>0; S (xs ! i) s\<^sub>0 \<midarrow>tr\<^sub>0\<leadsto> Ret s\<^sub>1 \<rbrakk> \<Longrightarrow> R (i + 1) s\<^sub>1"
    "\<And> i s\<^sub>0. \<lbrakk> i < length xs; R i s\<^sub>0 \<rbrakk> \<Longrightarrow> terminates (S (xs ! i) s\<^sub>0)"
  shows "R 0 s \<Longrightarrow> terminates (for_itree xs S s)"
using assms proof (induct xs arbitrary: R s)
  case Nil
  then show ?case by (simp add: for_empty Skip_def terminates_Ret)
next
  case (Cons a xs)
  have 1: "terminates (S a s)"
    by (metis Cons.prems(1) Cons.prems(3) length_greater_0_conv list.distinct(1) nth_Cons_0)
  have 2: "\<And> s\<^sub>0. s\<^sub>0 \<in> \<^bold>R (S a s) \<Longrightarrow> terminates (for_itree xs S s\<^sub>0)"
  proof -
    fix s\<^sub>0
    assume "s\<^sub>0 \<in> \<^bold>R (S a s)"
    then obtain tr\<^sub>0 where S_term: "S a s \<midarrow>tr\<^sub>0\<leadsto> Ret s\<^sub>0"
      by (auto simp add: retvals_def)
    hence R_1: "R 1 s\<^sub>0"
      by (metis Cons.prems(1) Cons.prems(2) One_nat_def Suc_eq_plus1 length_Cons nth_Cons_0 zero_less_Suc)
    with S_term show "terminates (for_itree xs S s\<^sub>0)"
      by (auto intro!: Cons(1)[of "\<lambda> i s. R (i + 1) s"])
         (metis Cons.prems(2) Suc_eq_plus1 Suc_less_eq length_Cons nth_Cons_Suc
         ,metis Cons.prems(3) Suc_less_eq length_Cons nth_Cons_Suc)
  qed

  from 1 2 show ?case
    by (auto intro!: terminates_bind simp add: for_Cons seq_itree_def kleisli_comp_def)
qed

lemma while_unfold: "while b do S od = (S ;; Step ;; while b do S od) \<lhd> b \<rhd> Skip"
  by (auto simp add: seq_itree_def fun_eq_iff iterate.code kleisli_comp_def cond_itree_def Step_def Skip_def comp_def)

lemma while_True_Skip: "while True do Skip od = Div"
  by (simp add: Skip_def SEXP_def loop_Ret)

text \<open> Hide the state of an action to produce a process \<close>

definition process :: "'s::default subst \<Rightarrow> ('e, 's, 'a) ktree \<Rightarrow> 'e process" where
"process I A = (\<langle>(\<lambda> _. default)\<rangle>\<^sub>a ;; \<langle>I\<rangle>\<^sub>a ;; A ;; assigns (\<lambda> s. ())) ()"

text \<open> Animatable processes -- need a show instance for the event type \<close>

definition anim_process :: "'s::default subst \<Rightarrow> ('e::show, 's, 'a) ktree \<Rightarrow> 'e process" where
"anim_process = process"

lemma deadlock_free_processI: "(\<And> s. deadlock_free ((\<langle>\<sigma>\<rangle>\<^sub>a ;; P) s)) \<Longrightarrow> deadlock_free (process \<sigma> P)"
  by (simp add: process_def seq_itree_def kleisli_comp_def deadlock_free_bind_iff assigns_def deadlock_free_Ret)

abbreviation "abs_st P \<equiv> P ;; assigns (\<lambda> s. ())"

lemma traces_inp: "wb_prism c \<Longrightarrow> traces (inp c) = {[]} \<union> {[Ev (build\<^bsub>c\<^esub> v)] | v. True} \<union> {[Ev (build\<^bsub>c\<^esub> v), \<checkmark> v] | v. True}"
  apply (simp add: inp_in_where_def traces_Vis traces_Ret)
  apply (auto simp add: inp_in_where_def bind_eq_Some_conv traces_Ret domIff pdom.abs_eq  elim!: in_tracesE trace_to_VisE)
  done

definition input_in_where :: "('a \<Longrightarrow>\<^sub>\<triangle> 'e) \<Rightarrow> ('s \<Rightarrow> 'a set) \<Rightarrow> ('a \<Rightarrow> (('s \<Rightarrow> bool) \<times> ('e, 's) htree)) \<Rightarrow> ('e, 's) htree" where
"input_in_where c A P = (\<lambda>s. inp_in_where c (A s) (\<lambda> v. fst (P v) s) \<bind> (\<lambda>x. snd (P x) s))"

definition input_list_where :: "('a \<Longrightarrow>\<^sub>\<triangle> 'e) \<Rightarrow> ('s \<Rightarrow> 'a list) \<Rightarrow> ('a \<Rightarrow> ('s \<Rightarrow> bool) \<times> ('e, 's) htree) \<Rightarrow> ('e, 's) htree" where
"input_list_where c A P = (\<lambda>s. inp_list_where c (A s) (\<lambda> v. fst (P v) s) \<bind> (\<lambda>x. snd (P x) s))"

definition input_map_in_where :: "('a \<Longrightarrow>\<^sub>\<triangle> 'e) \<Rightarrow> _ \<Rightarrow> ('a \<Rightarrow> ('s \<Rightarrow> bool) \<times> ('e, 's) htree) \<Rightarrow> ('e, 's) htree" where
"input_map_in_where c A P = (\<lambda>s. inp_map_in_where c (A s) (\<lambda> v. fst (P v) s) \<bind> (\<lambda>x. snd (P x) s))"

abbreviation "input c P \<equiv> input_in_where c (UNIV)\<^sub>e (\<lambda> e. ((True)\<^sub>e, P e))"

(*
definition input :: "('a \<Longrightarrow>\<^sub>\<triangle> 'e) \<Rightarrow> ('a \<Rightarrow> ('e, 's) htree) \<Rightarrow> ('e, 's) htree" where
"input c P = (\<lambda> s. inp c \<bind> (\<lambda> x. P x s))"
*)

abbreviation input_in :: "('a \<Longrightarrow>\<^sub>\<triangle> 'e) \<Rightarrow> ('s \<Rightarrow> 'a set) \<Rightarrow> ('a \<Rightarrow> ('e, 's) htree) \<Rightarrow> ('e, 's) htree" where
"input_in c A P \<equiv> input_in_where c A (\<lambda> e. ((True)\<^sub>e, P e))"

lemma input_in_where_map_code:
  "wb_prism c \<Longrightarrow> input_in_where c A P = input_map_in_where c A P"
  by (simp add: input_in_where_def inp_in_where_map_code input_map_in_where_def)

lemma input_in_where_enum [code_unfold]: "wb_prism c \<Longrightarrow> input_in_where c (UNIV)\<^sub>e P = input_list_where c (enum_class.enum)\<^sub>e P"
  by (simp add: input_in_where_def input_list_where_def inp_in_where_list_code inp_where_enum)

abbreviation input_where :: "('a \<Longrightarrow>\<^sub>\<triangle> 'e) \<Rightarrow> ('a \<Rightarrow> ('s \<Rightarrow> bool) \<times> ('e, 's) htree) \<Rightarrow> ('e, 's) htree" where
"input_where c P \<equiv> input_in_where c (UNIV)\<^sub>e P"

(*
definition "input' c P = (\<lambda>s. inp' c \<bind> (\<lambda>x. P x s))"

lemma input_code_unfold [code_unfold]:
  "wb_prism c \<Longrightarrow> input c P = input' c P"
  using inp_in_coset by (fastforce simp add: input_def input'_def inp_in_coset inp'_def)

term inp_list

lemma "wb_prism c \<Longrightarrow> input_where c P = (\<lambda>s. inp_list_where c enum_class.enum (\<lambda> v. fst (P v) s) \<bind> (\<lambda>x. snd (P x) s))"
*)

bundle Circus_Syntax
begin

unbundle Expression_Syntax

no_notation disj (infixr "|" 30)
no_notation conj (infixr "&" 35)

end

unbundle Circus_Syntax

syntax
  "_input"          :: "id \<Rightarrow> pttrn \<Rightarrow> logic \<Rightarrow> logic" ("_?_ \<rightarrow> _" [60, 0, 61] 61)
  "_input_in_where" :: "id \<Rightarrow> pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("_?_:_/ |/ _ \<rightarrow> _" [60, 0, 0, 0, 61] 61)
  "_input_in"       :: "id \<Rightarrow> pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("_?_:_ \<rightarrow> _" [60, 0, 0, 61] 61)
  "_input_where"    :: "id \<Rightarrow> pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("_?_/ |/ _ \<rightarrow> _" [60, 0, 0, 61] 61)

translations "c?(x) \<rightarrow> P" == "CONST input c (\<lambda> (x). P)"
translations "c?(x):A|B \<rightarrow> P" == "CONST input_in_where c (A)\<^sub>e (\<lambda> x. ((B)\<^sub>e, P))"
translations "c?(x):A \<rightarrow> P" == "CONST input_in c (A)\<^sub>e (\<lambda> (x). P)"
translations "c?(x)|P \<rightarrow> Q" == "CONST input_where c (\<lambda> (x). ((P)\<^sub>e, Q))"

lemma assigns_input: "\<langle>\<sigma>\<rangle>\<^sub>a ;; c?(x) \<rightarrow> P(x) = c?(x) \<rightarrow> (\<langle>\<sigma>\<rangle>\<^sub>a ;; P(x))"
  by (simp add: seq_itree_def input_in_where_def kleisli_comp_def assigns_def)

definition "output" :: "('a \<Longrightarrow>\<^sub>\<triangle> 'e) \<Rightarrow> ('s \<Rightarrow> 'a) \<Rightarrow> ('e, 's) htree \<Rightarrow> ('e, 's) htree" where
"output c e P = (\<lambda> s. outp c (e s) \<then> P s)"

syntax "_output" :: "id \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("_!'(_') \<rightarrow> _" [90, 0, 91] 91)
translations "c!(e) \<rightarrow> P" == "CONST output c (e)\<^sub>e P"

lemma assigns_output: "\<langle>\<sigma>\<rangle>\<^sub>a ;; c!(e) \<rightarrow> P = c!(\<sigma> \<dagger> e) \<rightarrow> (\<langle>\<sigma>\<rangle>\<^sub>a ;; P)"
  by (simp add: seq_itree_def assigns_def kleisli_comp_def output_def expr_defs)

lemma trace_of_deadlock: "deadlock \<midarrow>t\<leadsto> P \<Longrightarrow> (t, P) = ([], deadlock)"
  by (auto simp add: deadlock_def)

instantiation "fun" :: (type, extchoice) extchoice
begin

definition extchoice_fun :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
"extchoice_fun P Q \<equiv> (\<lambda> s. extchoice (P s) (Q s))"

instance ..

end

lemma extchoice_Stop [simp]: "Stop \<box> P = P"
  by (auto simp add: extchoice_fun_def fun_eq_iff)

lemma extchoice_Stop' [simp]: "P \<box> Stop = P"
  by (auto simp add: extchoice_fun_def fun_eq_iff)

lemma extchoice_commutative: "(P :: ('s, 'e) htree) \<box> Q = Q \<box> P"
  by (simp add: extchoice_fun_def fun_eq_iff choice_commutative)

lemma extchoice_Div: "Div \<box> P = Div"
  by (simp add: choice_diverge extchoice_fun_def)

lemma assigns_extchoice: "\<langle>\<sigma>\<rangle>\<^sub>a ;; (P \<box> Q) = (\<langle>\<sigma>\<rangle>\<^sub>a ;; P) \<box> (\<langle>\<sigma>\<rangle>\<^sub>a ;; Q)"
  by (simp add: seq_itree_def kleisli_comp_def extchoice_fun_def expr_defs assigns_def)

no_notation conj  (infixr "&" 35)

syntax
  "_cguard" :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("_ & _" [50, 51] 50)

translations
  "_cguard b P" == "(CONST test (b)\<^sub>e) ;; P"

text \<open> The frame operator deletes updates made outside of the frame @{term a}. \<close>

definition frame :: "'s scene \<Rightarrow> ('e, 's) htree \<Rightarrow> ('e, 's) htree" where
"frame a P = (\<lambda> s. P s \<bind> (\<lambda> s'. Ret (s \<oplus>\<^sub>S s' on a)))"

syntax
  "_frame" :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("(frame _ in (_))" [0, 10] 10)

translations
  "_frame a P" == "CONST ITree_Circus.frame a P"

definition frame_ext :: "('s\<^sub>1 \<Longrightarrow> 's\<^sub>2) \<Rightarrow> ('e, 's\<^sub>1) htree \<Rightarrow> ('e, 's\<^sub>2) htree" where
"frame_ext a P = (\<lambda> s. P (get\<^bsub>a\<^esub> s) \<bind> (\<lambda> v. Ret (put\<^bsub>a\<^esub> s v)))"

definition not_modifies :: "('e, 's) htree \<Rightarrow> ('a, 's) expr \<Rightarrow> bool" where
"not_modifies P e = (\<forall> s s'. s' \<in> \<^bold>R(P s) \<longrightarrow> e s' = e s)"

lemma not_modifiesI: "(\<And> s s'. s' \<in> \<^bold>R(P s) \<Longrightarrow> e s' = e s) \<Longrightarrow> not_modifies P e"
  by (auto simp add: not_modifies_def)

syntax
  "_nmods" :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("_ nmods _" [40, 41] 40)

translations
  "P nmods e" == "CONST not_modifies P (e)\<^sub>e"

named_theorems nmods

lemma assigns_nmods_iff : "\<langle>\<sigma>\<rangle>\<^sub>a nmods e \<longleftrightarrow> \<sigma> \<dagger> (e)\<^sub>e = (e)\<^sub>e"
  by (simp add: not_modifies_def assigns_def subst_app_def fun_eq_iff)

lemma assigns_nmods [nmods]: "\<sigma> \<dagger> (e)\<^sub>e = (e)\<^sub>e \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>a nmods e"
  by (simp add: assigns_nmods_iff)

lemma Skip_nmods [nmods]: "Skip nmods e"
  by (simp add: Skip_def not_modifies_def)

lemma seq_nmods [nmods]: "\<lbrakk> P nmods e; Q nmods e \<rbrakk> \<Longrightarrow> P ;; Q nmods e"
  by (auto elim!:trace_to_bindE bind_RetE' simp add: seq_itree_def kleisli_comp_def not_modifies_def retvals_def)
     (metis trace_to_Nil)+

text \<open> The following law ignore the condition when checking for modification. However, if we were
  checking for modification conditions, we could make use of it. \<close>

lemma cond_nmods [nmods]: "\<lbrakk> P nmods e; Q nmods e \<rbrakk> \<Longrightarrow> if b then P else Q fi nmods e"
  by (simp add: not_modifies_def cond_itree_def)

lemma while_nmods_lemma: "\<lbrakk> s \<turnstile> P \<midarrow>chn\<leadsto>\<^sup>* s'; P nmods e; s\<^sub>0 \<in> chain_states chn \<rbrakk> \<Longrightarrow> e s = e s\<^sub>0"
  by (induct arbitrary: s\<^sub>0 rule: itree_chain.induct)
     (auto simp add: SEXP_def not_modifies_def retvals_def, metis+)

lemma while_nmods [nmods]:
  assumes "P nmods e"
  shows "while b do P od nmods e"
proof (rule not_modifiesI, simp add: SEXP_def)
  fix s s'
  assume s': "s' \<in> \<^bold>R (iterate b P s)"
  show "e s' = e s"
  proof (cases "b s")
    case True
    with s' obtain chn s\<^sub>0 tr\<^sub>0 where "b s" "\<not> b s'" "s \<turnstile> P \<midarrow>chn\<leadsto>\<^sup>* s\<^sub>0" "\<forall>x\<in>chain_states chn. b x" "P s\<^sub>0 \<midarrow>tr\<^sub>0\<leadsto> \<checkmark> s'"
      by (auto simp add: retvals_def iterate_term_chain_iff itree_term_chain.simps)
    have "\<forall> s\<^sub>0 \<in> chain_states chn. e s = e s\<^sub>0"
      by (meson \<open>s \<turnstile> P \<midarrow>chn\<leadsto>\<^sup>* s\<^sub>0\<close> assms while_nmods_lemma)
    hence "e s = e s\<^sub>0"
      by (metis \<open>s \<turnstile> P \<midarrow>chn\<leadsto>\<^sup>* s\<^sub>0\<close> final_state_in_chain itree_chain.cases list.discI)
    then show ?thesis
      by (metis SEXP_def \<open>P s\<^sub>0 \<midarrow>tr\<^sub>0\<leadsto> \<checkmark> s'\<close> assms not_modifies_def retvals_traceI)
  next
    case False
    then show ?thesis
      using s' by force
  qed
qed

text \<open> @{const not_modifies} is quite useful as a predicate to determine whether expressions are
  invariant under a program by checking whether variables are updated. However, it may be better
  to have a ``weakest modification condition'' calculus, that allows us to determine the weakest
  precondition under which a program will not modify a particular expression. \<close>

definition promote :: "('e, 's\<^sub>1) htree \<Rightarrow> ('s\<^sub>1 \<Longrightarrow> 's\<^sub>2) \<Rightarrow> ('e, 's\<^sub>2) htree" where
[code_unfold]: "promote P a = \<exclamdown>\<^bold>D(a)! ;; frame_ext a P"

syntax "_promote" :: "logic \<Rightarrow> svid \<Rightarrow> logic" (infix "\<Up>\<Up>" 60)
translations "_promote P a" == "CONST promote P a"

named_theorems prog_defs

subsection \<open> Event Choice Blocks \<close>

definition event_fun_empty :: "('s \<Rightarrow> 'e \<Zpfun> ('e, 's) itree)" ("{}\<^sub>E") where
"event_fun_empty = (\<lambda> s. {\<mapsto>})"

definition event_fun_upd :: "('s \<Rightarrow> 'e \<Zpfun> ('e, 's) itree) \<Rightarrow> ('a \<Longrightarrow>\<^sub>\<triangle> 'e) \<Rightarrow> ('s \<Rightarrow> 'a set) \<Rightarrow> ('a \<Rightarrow> ('s \<Rightarrow> \<bool>) \<times> ('s \<Rightarrow> ('e, 's) itree)) \<Rightarrow> 's \<Rightarrow> 'e \<Zpfun> ('e, 's) itree" where
"event_fun_upd F c A PB = (\<lambda> s. (F s)(c{v \<in> A s. fst (PB v) s} \<Rightarrow> snd (PB v) s))"

syntax
  "_event_fun_upd" :: "logic \<Rightarrow> prism_maplets \<Rightarrow> logic" ("_'(_')\<^sub>E" [900, 0] 900)
  "_event_fun" :: "prism_maplets \<Rightarrow> logic" ("{_}\<^sub>E")

translations
  "f(c{v \<in> A. P} \<Rightarrow> B)\<^sub>E" == "CONST event_fun_upd f c (A)\<^sub>e (\<lambda> v. ((P)\<^sub>e, B))"
  "_event_fun_upd m (_prism_Maplets xy ms)"  \<rightleftharpoons> "_event_fun_upd (_event_fun_upd m xy) ms"
  "_event_fun ms"                            \<rightleftharpoons> "_event_fun_upd {}\<^sub>E ms"
  "_event_fun (_prism_Maplets ms1 ms2)"     \<leftharpoondown> "_event_fun_upd (_event_fun ms1) ms2"

definition "event_choice F = (\<lambda> s. Vis (F s))"

definition event_block :: "('a \<Longrightarrow>\<^sub>\<triangle> 'e) \<Rightarrow> ('s \<Rightarrow> 'a set) \<Rightarrow> ('a \<Rightarrow> ('s \<Rightarrow> \<bool>) \<times> ('s \<Rightarrow> 's)) \<Rightarrow> ('e, 's) htree" where
"event_block c A PB = (\<lambda> s. Vis (prism_fun c (A s) (\<lambda> c. (fst (PB c) s, Ret (snd (PB c) s)))))"

lemma case_sum_prod_dist: "case_sum (\<lambda> x. (f\<^sub>1 x, f\<^sub>2 x)) (\<lambda> x. (g\<^sub>1 x, g\<^sub>2 x)) = (\<lambda> x. (case_sum f\<^sub>1 g\<^sub>1 x, case_sum f\<^sub>2 g\<^sub>2 x))"
  by (simp add: fun_eq_iff sum.case_eq_if)

lemma case_sum_dist: "(case a of Inl x \<Rightarrow> op (f x) | Inr y \<Rightarrow> op (g y)) = op (case a of Inl x \<Rightarrow> f x | Inr y \<Rightarrow> g y)"
  by (simp add: sum.case_eq_if)

lemma extchoice_event_block:
  assumes "wb_prism c" "wb_prism d" "c \<nabla> d"
  shows "event_block c A P\<sigma> \<box> event_block d B Q\<sigma> = event_block (c +\<^sub>\<triangle> d) (A <+> B)\<^sub>e (case_sum P\<sigma> Q\<sigma>)"
  using assms
  by (auto intro!:prism_fun_cong simp add: event_block_def fun_eq_iff extchoice_fun_def map_prod_as_ovrd prism_diff_implies_indep_funs prism_fun_combine case_sum_prod_dist sum.case_eq_if)

(*
syntax
  "_match_syntax" :: "['a, cases_syn] \<Rightarrow> 'b"  ("(match _ of/ _)" 10)

translations
  "_match_syntax e y" => "\<lambda> _sexp_state. _case_syntax ((e)\<^sub>e _sexp_state) y"
  "_match_syntax e y" <= "\<lambda> s. _case_syntax (e)\<^sub>e y"
*)

end


theory Asymptotic_Security imports Concrete_Security begin

section \<open>Asymptotic security definition\<close>

locale constructive_security_obsf' =
  fixes real_resource :: "security \<Rightarrow> ('a + 'e, 'b + 'f) resource"
    and ideal_resource :: "security \<Rightarrow> ('c + 'e, 'd + 'f) resource"
    and sim :: "security \<Rightarrow> ('a, 'b, 'c, 'd) converter"
    and \_real :: "security \<Rightarrow> ('a, 'b) \"
    and \_ideal :: "security \<Rightarrow> ('c, 'd) \"
    and \_common :: "security \<Rightarrow> ('e, 'f) \"
    and \ :: "security \<Rightarrow> ('a + 'e, 'b + 'f) distinguisher_obsf"
  assumes constructive_security_aux_obsf: "\<And>\<eta>.
    constructive_security_aux_obsf (real_resource \<eta>) (ideal_resource \<eta>) (sim \<eta>) (\_real \<eta>) (\_ideal \<eta>) (\_common \<eta>) 0"
    and adv: "\<lbrakk> \<And>\<eta>. exception_\ (\_real \<eta> \<oplus>\<^sub>\ \_common \<eta>) \<turnstile>g \ \<eta> \<surd> \<rbrakk>
      \<Longrightarrow> negligible (\<lambda>\<eta>. advantage (\ \<eta>) (obsf_resource (sim \<eta> |\<^sub>= 1\<^sub>C \<rhd> ideal_resource \<eta>)) (obsf_resource (real_resource \<eta>)))"
begin

sublocale constructive_security_aux_obsf
  "real_resource \<eta>"
  "ideal_resource \<eta>"
  "sim \<eta>"
  "\_real \<eta>"
  "\_ideal \<eta>"
  "\_common \<eta>"
  "0"
  for \<eta> by(rule constructive_security_aux_obsf)

lemma constructive_security_obsf'D:
  "constructive_security_obsf (real_resource \<eta>) (ideal_resource \<eta>) (sim \<eta>) (\_real \<eta>) (\_ideal \<eta>) (\_common \<eta>) (\ \<eta>)
    (advantage (\ \<eta>) (obsf_resource (sim \<eta> |\<^sub>= 1\<^sub>C \<rhd> ideal_resource \<eta>)) (obsf_resource (real_resource \<eta>)))"
  by(rule constructive_security_obsf_refl)

end

lemma constructive_security_obsf'I:
  assumes "\<And>\<eta>. constructive_security_obsf (real_resource \<eta>) (ideal_resource \<eta>) (sim \<eta>) (\_real \<eta>) (\_ideal \<eta>) (\_common \<eta>) (\ \<eta>) (adv \<eta>)"
    and "(\<And>\<eta>. exception_\ (\_real \<eta> \<oplus>\<^sub>\ \_common \<eta>) \<turnstile>g \ \<eta> \<surd>) \<Longrightarrow> negligible adv"
  shows "constructive_security_obsf' real_resource ideal_resource sim \_real \_ideal \_common \"
proof -
  interpret constructive_security_obsf
    "real_resource \<eta>"
    "ideal_resource \<eta>"
    "sim \<eta>"
    "\_real \<eta>"
    "\_ideal \<eta>"
    "\_common \<eta>"
    "\ \<eta>"
    "adv \<eta>"
    for \<eta> by fact
  show ?thesis
  proof
    show "negligible (\<lambda>\<eta>. advantage (\ \<eta>) (obsf_resource (sim \<eta> |\<^sub>= 1\<^sub>C \<rhd> ideal_resource \<eta>)) (obsf_resource (real_resource \<eta>)))"
      if "\<And>\<eta>. exception_\ (\_real \<eta> \<oplus>\<^sub>\ \_common \<eta>) \<turnstile>g \ \<eta> \<surd>" using assms(2)[OF that]
      by(rule negligible_mono)(auto intro!: eventuallyI landau_o.big_mono simp add: advantage_nonneg adv_nonneg adv[OF that])
  qed(rule WT_intro pfinite_intro order_refl)+
qed

lemma constructive_security_obsf'_into_constructive_security:
  assumes "\<And>\ :: security \<Rightarrow> ('a + 'b, 'c + 'd) distinguisher_obsf.
   \<lbrakk>  \<And>\<eta>. interaction_bounded_by (\<lambda>_. True) (\ \<eta>) (bound \<eta>);
      \<And>\<eta>. lossless \<Longrightarrow> plossless_gpv (exception_\ (\_real \<eta> \<oplus>\<^sub>\ \_common \<eta>)) (\ \<eta>) \<rbrakk>
   \<Longrightarrow> constructive_security_obsf' real_resource ideal_resource sim \_real \_ideal \_common \"
    and correct: "\<exists>cnv. \<forall>\<D>. (\<forall>\<eta>. \_ideal \<eta> \<oplus>\<^sub>\ \_common \<eta> \<turnstile>g \<D> \<eta> \<surd>) \<longrightarrow>
               (\<forall>\<eta>. interaction_any_bounded_by (\<D> \<eta>) (bound \<eta>)) \<longrightarrow>
               (\<forall>\<eta>. lossless \<longrightarrow> plossless_gpv (\_ideal \<eta> \<oplus>\<^sub>\ \_common \<eta>) (\<D> \<eta>)) \<longrightarrow>
               (\<forall>\<eta>. wiring (\_ideal \<eta>) (\_real \<eta>) (cnv \<eta>) (w \<eta>)) \<and>
               Negligible.negligible (\<lambda>\<eta>. advantage (\<D> \<eta>) (ideal_resource \<eta>) (cnv \<eta> |\<^sub>= 1\<^sub>C \<rhd> real_resource \<eta>))"
  shows "constructive_security real_resource ideal_resource sim \_real \_ideal \_common bound lossless w"
proof
  interpret constructive_security_obsf' real_resource ideal_resource sim \_real \_ideal \_common \<open>\<lambda>_. Done undefined\<close>
    by(rule assms) simp_all
  show "\_real \<eta> \<oplus>\<^sub>\ \_common \<eta> \<turnstile>res real_resource \<eta> \<surd>"
    and "\_ideal \<eta> \<oplus>\<^sub>\ \_common \<eta> \<turnstile>res ideal_resource \<eta> \<surd>"
    and "\_real \<eta>, \_ideal \<eta> \<turnstile>\<^sub>C sim \<eta> \<surd>" for \<eta> by(rule WT_intro)+

  show "\<exists>cnv. \<forall>\<D>. (\<forall>\<eta>. \_ideal \<eta> \<oplus>\<^sub>\ \_common \<eta> \<turnstile>g \<D> \<eta> \<surd>) \<longrightarrow>
               (\<forall>\<eta>. interaction_any_bounded_by (\<D> \<eta>) (bound \<eta>)) \<longrightarrow>
               (\<forall>\<eta>. lossless \<longrightarrow> plossless_gpv (\_ideal \<eta> \<oplus>\<^sub>\ \_common \<eta>) (\<D> \<eta>)) \<longrightarrow>
               (\<forall>\<eta>. wiring (\_ideal \<eta>) (\_real \<eta>) (cnv \<eta>) (w \<eta>)) \<and>
               Negligible.negligible (\<lambda>\<eta>. advantage (\<D> \<eta>) (ideal_resource \<eta>) (cnv \<eta> |\<^sub>= 1\<^sub>C \<rhd> real_resource \<eta>))"
    by fact
next
  fix \ :: "security \<Rightarrow> ('a + 'b, 'c + 'd) distinguisher"
  assume WT_adv [WT_intro]: "\<And>\<eta>. \_real \<eta> \<oplus>\<^sub>\ \_common \<eta> \<turnstile>g \ \<eta> \<surd>"
    and bound [interaction_bound]: "\<And>\<eta>. interaction_any_bounded_by (\ \<eta>) (bound \<eta>)"
    and lossless: "\<And>\<eta>. lossless \<Longrightarrow> plossless_gpv (\_real \<eta> \<oplus>\<^sub>\ \_common \<eta>) (\ \<eta>)"
  let ?\ = "\<lambda>\<eta>. obsf_distinguisher (\ \<eta>)"
  interpret constructive_security_obsf' real_resource ideal_resource sim \_real \_ideal \_common ?\
  proof(rule assms)
    show "interaction_any_bounded_by (?\ \<eta>) (bound \<eta>)" for \<eta> by(rule interaction_bound)+
    show "plossless_gpv (exception_\ (\_real \<eta> \<oplus>\<^sub>\ \_common \<eta>)) (?\ \<eta>)" if lossless for \<eta>
      using WT_adv[of \<eta>] lossless that by(simp)
  qed
  have "negligible (\<lambda>\<eta>. advantage (?\ \<eta>) (obsf_resource (sim \<eta> |\<^sub>= 1\<^sub>C \<rhd> ideal_resource \<eta>)) (obsf_resource (real_resource \<eta>)))"
    by(rule adv)(rule WT_intro)+
  then show "negligible (\<lambda>\<eta>. advantage (\ \<eta>) (sim \<eta> |\<^sub>= 1\<^sub>C \<rhd> ideal_resource \<eta>) (real_resource \<eta>))"
    unfolding advantage_obsf_distinguisher .
qed

subsection \<open>Composition theorems\<close>

theorem constructive_security_obsf'_composability:
  fixes real
  assumes "constructive_security_obsf' middle ideal sim_inner \_middle \_inner \_common (\<lambda>\<eta>. absorb (\ \<eta>) (obsf_converter (sim_outer \<eta> |\<^sub>= 1\<^sub>C)))"
  assumes "constructive_security_obsf' real middle sim_outer \_real \_middle \_common \"
  shows "constructive_security_obsf' real ideal (\<lambda>\<eta>. sim_outer \<eta> \<odot> sim_inner \<eta>) \_real \_inner \_common \"
proof(rule constructive_security_obsf'I)
  let ?\ = "\<lambda>\<eta>. absorb (\ \<eta>) (obsf_converter (sim_outer \<eta> |\<^sub>= 1\<^sub>C))"
  interpret inner: constructive_security_obsf' middle ideal sim_inner \_middle \_inner \_common ?\ by fact
  interpret outer: constructive_security_obsf' real middle sim_outer \_real \_middle \_common \ by fact

  let ?adv1 = "\<lambda>\<eta>. advantage (?\ \<eta>) (obsf_resource (sim_inner \<eta> |\<^sub>= 1\<^sub>C \<rhd> ideal \<eta>)) (obsf_resource (middle \<eta>))"
  let ?adv2 = "\<lambda>\<eta>. advantage (\ \<eta>) (obsf_resource (sim_outer \<eta> |\<^sub>= 1\<^sub>C \<rhd> middle \<eta>)) (obsf_resource (real \<eta>))"
  let ?adv = "\<lambda>\<eta>. ?adv1 \<eta> + ?adv2 \<eta>"
  show "constructive_security_obsf (real \<eta>) (ideal \<eta>) (sim_outer \<eta> \<odot> sim_inner \<eta>) (\_real \<eta>) (\_inner \<eta>) (\_common \<eta>) (\ \<eta>) (?adv \<eta>)" for \<eta>
    using inner.constructive_security_obsf'D outer.constructive_security_obsf'D
    by(rule constructive_security_obsf_composability)
  assume [WT_intro]: "exception_\ (\_real \<eta> \<oplus>\<^sub>\ \_common \<eta>) \<turnstile>g \ \<eta> \<surd>" for \<eta>
  have "negligible ?adv1" by(rule inner.adv)(rule WT_intro)+
  also have "negligible ?adv2" by(rule outer.adv)(rule WT_intro)+
  finally (negligible_plus) show "negligible ?adv" .
qed

theorem constructive_security_obsf'_lifting: (* TODO: generalize! *)
  assumes sec: "constructive_security_obsf' real_resource ideal_resource sim \_real \_ideal \_common (\<lambda>\<eta>. absorb (\ \<eta>) (obsf_converter (1\<^sub>C |\<^sub>= conv \<eta>)))"
  assumes WT_conv [WT_intro]: "\<And>\<eta>. \_common' \<eta>, \_common \<eta> \<turnstile>\<^sub>C conv \<eta> \<surd>"
    and pfinite [pfinite_intro]: "\<And>\<eta>. pfinite_converter (\_common' \<eta>) (\_common \<eta>) (conv \<eta>)"
  shows "constructive_security_obsf'
     (\<lambda>\<eta>. 1\<^sub>C |\<^sub>= conv \<eta> \<rhd> real_resource \<eta>) (\<lambda>\<eta>. 1\<^sub>C |\<^sub>= conv \<eta> \<rhd> ideal_resource \<eta>) sim
     \_real \_ideal \_common' \"
proof(rule constructive_security_obsf'I)
  let ?\ = "\<lambda>\<eta>. absorb (\ \<eta>) (obsf_converter (1\<^sub>C |\<^sub>= conv \<eta>))"
  interpret constructive_security_obsf' real_resource ideal_resource sim \_real \_ideal \_common ?\ by fact
  let ?adv = "\<lambda>\<eta>. advantage (?\ \<eta>) (obsf_resource (sim \<eta> |\<^sub>= 1\<^sub>C \<rhd> ideal_resource \<eta>)) (obsf_resource (real_resource \<eta>))"

  fix \<eta> :: security
  show "constructive_security_obsf (1\<^sub>C |\<^sub>= conv \<eta> \<rhd> real_resource \<eta>) (1\<^sub>C |\<^sub>= conv \<eta> \<rhd> ideal_resource \<eta>) (sim \<eta>)
     (\_real \<eta>) (\_ideal \<eta>) (\_common' \<eta>) (\ \<eta>)
     (?adv \<eta>)"
    using constructive_security_obsf.constructive_security_aux_obsf[OF constructive_security_obsf'D]
     constructive_security_obsf.constructive_security_sim_obsf[OF constructive_security_obsf'D]
    by(rule constructive_security_obsf_lifting_usr)(rule WT_intro pfinite_intro)+
  show "negligible ?adv" if [WT_intro]: "\<And>\<eta>. exception_\ (\_real \<eta> \<oplus>\<^sub>\ \_common' \<eta>) \<turnstile>g \ \<eta> \<surd>"
    by(rule adv)(rule WT_intro)+
qed

theorem constructive_security_obsf'_trivial:
  fixes res
  assumes [WT_intro]: "\<And>\<eta>. \ \<eta> \<oplus>\<^sub>\ \_common \<eta> \<turnstile>res res \<eta> \<surd>"
  shows "constructive_security_obsf' res res (\<lambda>_. 1\<^sub>C) \ \ \_common \"
proof(rule constructive_security_obsf'I)
  show "constructive_security_obsf (res \<eta>) (res \<eta>) 1\<^sub>C (\ \<eta>) (\ \<eta>) (\_common \<eta>) (\ \<eta>) 0" for \<eta>
    using assms by(rule constructive_security_obsf_trivial)
qed simp

theorem parallel_constructive_security_obsf':
  assumes "constructive_security_obsf' real1 ideal1 sim1 \_real1 \_inner1 \_common1 (\<lambda>\<eta>. absorb (\ \<eta>) (obsf_converter (parallel_wiring \<odot> parallel_converter 1\<^sub>C (converter_of_resource (sim2 \<eta> |\<^sub>= 1\<^sub>C \<rhd> ideal2 \<eta>)))))"
    (is "constructive_security_obsf' _ _ _ _ _ _ ?\1")
  assumes "constructive_security_obsf' real2 ideal2 sim2 \_real2 \_inner2 \_common2 (\<lambda>\<eta>. absorb (\ \<eta>) (obsf_converter (parallel_wiring \<odot> parallel_converter (converter_of_resource (real1 \<eta>)) 1\<^sub>C)))"
    (is "constructive_security_obsf' _ _ _ _ _ _ ?\2")
  shows "constructive_security_obsf' (\<lambda>\<eta>. parallel_wiring \<rhd> real1 \<eta> \<parallel> real2 \<eta>) (\<lambda>\<eta>. parallel_wiring \<rhd> ideal1 \<eta> \<parallel> ideal2 \<eta>) (\<lambda>\<eta>. sim1 \<eta> |\<^sub>= sim2 \<eta>)
    (\<lambda>\<eta>. \_real1 \<eta> \<oplus>\<^sub>\ \_real2 \<eta>) (\<lambda>\<eta>. \_inner1 \<eta> \<oplus>\<^sub>\ \_inner2 \<eta>) (\<lambda>\<eta>. \_common1 \<eta> \<oplus>\<^sub>\ \_common2 \<eta>) \"
proof(rule constructive_security_obsf'I)
  interpret sec1: constructive_security_obsf' real1 ideal1 sim1 \_real1 \_inner1 \_common1 ?\1 by fact
  interpret sec2: constructive_security_obsf' real2 ideal2 sim2 \_real2 \_inner2 \_common2 ?\2 by fact
  let ?adv1 = "\<lambda>\<eta>. advantage (?\1 \<eta>) (obsf_resource (sim1 \<eta> |\<^sub>= 1\<^sub>C \<rhd> ideal1 \<eta>)) (obsf_resource (real1 \<eta>))"
  let ?adv2 = "\<lambda>\<eta>. advantage (?\2 \<eta>) (obsf_resource (sim2 \<eta> |\<^sub>= 1\<^sub>C \<rhd> ideal2 \<eta>)) (obsf_resource (real2 \<eta>))"
  let ?adv = "\<lambda>\<eta>. ?adv1 \<eta> + ?adv2 \<eta>"
  show "constructive_security_obsf (parallel_wiring \<rhd> real1 \<eta> \<parallel> real2 \<eta>) (parallel_wiring \<rhd> ideal1 \<eta> \<parallel> ideal2 \<eta>)
     (sim1 \<eta> |\<^sub>= sim2 \<eta>) (\_real1 \<eta> \<oplus>\<^sub>\ \_real2 \<eta>) (\_inner1 \<eta> \<oplus>\<^sub>\ \_inner2 \<eta>) (\_common1 \<eta> \<oplus>\<^sub>\ \_common2 \<eta>) (\ \<eta>)
     (?adv \<eta>)" for \<eta>
    using sec1.constructive_security_obsf'D sec2.constructive_security_obsf'D
    by(rule parallel_constructive_security_obsf)
  assume [WT_intro]: "exception_\ ((\_real1 \<eta> \<oplus>\<^sub>\ \_real2 \<eta>) \<oplus>\<^sub>\ (\_common1 \<eta> \<oplus>\<^sub>\ \_common2 \<eta>)) \<turnstile>g \ \<eta> \<surd>" for \<eta>
  have "negligible ?adv1" by(rule sec1.adv)(rule WT_intro)+
  also have "negligible ?adv2" by(rule sec2.adv)(rule WT_intro)+
  finally (negligible_plus) show "negligible ?adv" .
qed

end


header {* \isaheader{Generic Map To Set Converter} *}
theory Gen_Map2Set
imports
  "../Intf/Intf_Map"
  "../Intf/Intf_Set"
  "../Intf/Intf_Comp"
  "../../Iterator/Iterator"
begin

lemma map_fst_unit_distinct_eq[simp]:
  fixes l :: "('k\<times>unit) list"
  shows "distinct (map fst l) \<longleftrightarrow> distinct l"
  by (induct l) auto

definition
  map2set_rel :: "
    (('ki\<times>'k) set \<Rightarrow> (unit\<times>unit) set \<Rightarrow> ('mi\<times>('k\<rightharpoonup>unit))set) \<Rightarrow>
    ('ki\<times>'k) set \<Rightarrow>
    ('mi\<times>('k set)) set"
  where
  map2set_rel_def_internal:
  "map2set_rel R Rk \<equiv> \<langle>Rk,Id::(unit\<times>_) set\<rangle>R O {(m,dom m)| m. True}"

lemma map2set_rel_def: "\<langle>Rk\<rangle>(map2set_rel R)
  = \<langle>Rk,Id::(unit\<times>_) set\<rangle>R O {(m,dom m)| m. True}"
  unfolding map2set_rel_def_internal[abs_def] by (simp add: relAPP_def)

lemma map2set_relI:
  assumes "(s,m')\<in>\<langle>Rk,Id\<rangle>R" and "s'=dom m'"
  shows "(s,s')\<in>\<langle>Rk\<rangle>map2set_rel R"
  using assms unfolding map2set_rel_def by blast

lemma map2set_relE:
  assumes "(s,s')\<in>\<langle>Rk\<rangle>map2set_rel R"
  obtains m' where "(s,m')\<in>\<langle>Rk,Id\<rangle>R" and "s'=dom m'"
  using assms unfolding map2set_rel_def by blast

lemma map2set_rel_sv[relator_props]:
  "single_valued (\<langle>Rk,Id\<rangle>Rm) \<Longrightarrow> single_valued (\<langle>Rk\<rangle>map2set_rel Rm)"
  unfolding map2set_rel_def
  by (auto intro: single_valuedI dest: single_valuedD)

lemma map2set_empty[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP e op_map_empty (\<langle>Rk,Id\<rangle>R)"
  shows "(e,{})\<in>\<langle>Rk\<rangle>map2set_rel R"
  using assms
  unfolding map2set_rel_def
  by auto

lemmas [autoref_rel_intf] =
  REL_INTFI[of "map2set_rel R" i_set] for R

definition "map2set_insert i k s \<equiv> i k () s"
lemma map2set_insert[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP i op_map_update (Rk \<rightarrow> Id \<rightarrow> \<langle>Rk,Id\<rangle>R \<rightarrow> \<langle>Rk,Id\<rangle>R)"
  shows
    "(map2set_insert i,Set.insert)\<in>Rk\<rightarrow>\<langle>Rk\<rangle>map2set_rel R \<rightarrow> \<langle>Rk\<rangle>map2set_rel R"
  using assms
  unfolding map2set_rel_def map2set_insert_def[abs_def]
  by (force dest: fun_relD)

definition "map2set_memb l k s \<equiv> case l k s of None \<Rightarrow> False | Some _ \<Rightarrow> True"
lemma map2set_memb[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP l op_map_lookup (Rk \<rightarrow> \<langle>Rk,Id\<rangle>R \<rightarrow> \<langle>Id\<rangle>option_rel)"
  shows "(map2set_memb l ,op\<in>)
    \<in> Rk\<rightarrow>\<langle>Rk\<rangle>map2set_rel R\<rightarrow>Id"
  using assms
  unfolding map2set_rel_def map2set_memb_def[abs_def]
  by (force dest: fun_relD split: option.splits)

lemma map2set_delete[autoref_rules_raw]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP d op_map_delete (Rk\<rightarrow>\<langle>Rk,Id\<rangle>R\<rightarrow>\<langle>Rk,Id\<rangle>R)"
  shows "(d,op_set_delete)\<in>Rk\<rightarrow>\<langle>Rk\<rangle>map2set_rel R\<rightarrow>\<langle>Rk\<rangle>map2set_rel R"
  using assms
  unfolding map2set_rel_def
  by (force dest: fun_relD)

lemma map2set_to_sorted_list[autoref_ga_rules]:
  (*assumes SV: "single_valued Rk"*)
  fixes it :: "'m \<Rightarrow> ('k\<times>unit) list"
  assumes A: "GEN_ALGO_tag (is_map_to_sorted_list ordR Rk Id R it)"
  shows "is_set_to_sorted_list ordR Rk (map2set_rel R)
    (it_to_list (map_iterator_dom o (foldli o it)))"
proof -
  {
    fix l::"('k\<times>unit) list"
    have "\<And>l0. foldli l (\<lambda>_. True) (\<lambda>x \<sigma>. \<sigma> @ [fst x]) l0 = l0@map fst l"
      by (induct l) auto
  }
  hence S: "it_to_list (map_iterator_dom o (foldli o it)) = map fst o it"
    unfolding it_to_list_def[abs_def] map_iterator_dom_def[abs_def]
      set_iterator_image_def set_iterator_image_filter_def
    by (auto)
  show ?thesis
    unfolding S
    using assms
    unfolding is_map_to_sorted_list_def is_set_to_sorted_list_def
    apply clarsimp
    apply (erule map2set_relE)
    apply (drule spec, drule spec)
    apply (drule (1) mp)
    apply (elim exE conjE)
    apply (rule_tac x="map fst l'" in exI)
    apply (rule conjI)
    apply parametricity

    unfolding it_to_sorted_list_def
    apply (simp add: map_to_set_dom)
    apply (simp add: sorted_by_rel_map key_rel_def[abs_def])
    done
qed

lemma map2set_to_list[autoref_ga_rules]:
  fixes it :: "'m \<Rightarrow> ('k\<times>unit) list"
  assumes A: "GEN_ALGO_tag (is_map_to_list Rk Id R it)"
  shows "is_set_to_list Rk (map2set_rel R)
    (it_to_list (map_iterator_dom o (foldli o it)))"
  using assms unfolding is_set_to_list_def is_map_to_list_def
  by (rule map2set_to_sorted_list)

(*lemma map2set_it_simp[iterator_simps]:
  "foldli ((map fst o it) x) c f s = foldli (it x) c (\<lambda>(k,v) s. f k s) s"
  by (simp add: foldli_map comp_def fn_fst_conv)
*)

text {* Transfering also non-basic operations results in specializations
  of map-algorithms to also be used for sets *}
lemma map2set_union[autoref_rules_raw]:
  assumes "MINOR_PRIO_TAG (- 9)"
  assumes "GEN_OP u op ++ (\<langle>Rk,Id\<rangle>R\<rightarrow>\<langle>Rk,Id\<rangle>R\<rightarrow>\<langle>Rk,Id\<rangle>R)"
  shows "(u,op \<union>)\<in>\<langle>Rk\<rangle>map2set_rel R\<rightarrow>\<langle>Rk\<rangle>map2set_rel R\<rightarrow>\<langle>Rk\<rangle>map2set_rel R"
  using assms
  unfolding map2set_rel_def
  by (force dest: fun_relD)

lemmas [autoref_ga_rules] = cmp_unit_eq_linorder
lemmas [autoref_rules_raw] = param_cmp_unit

lemma cmp_lex_zip_unit[simp]:
  "cmp_lex (cmp_prod cmp cmp_unit) (map (\<lambda>k. (k, ())) l)
           (map (\<lambda>k. (k, ())) m) =
          cmp_lex cmp l m"
  apply (induct cmp l m rule: cmp_lex.induct)
  apply (auto split: comp_res.split)
  done

lemma cmp_img_zip_unit[simp]:
  "cmp_img (\<lambda>m. map (\<lambda>k. (k,())) (f m)) (cmp_lex (cmp_prod cmp1 cmp_unit))
    = cmp_img f (cmp_lex cmp1)"
  unfolding cmp_img_def[abs_def]
  apply (intro ext)
  apply simp
  done

(* TODO: Move *)

lemma map2set_finite[relator_props]:
  assumes "finite_map_rel (\<langle>Rk,Id\<rangle>R)"
  shows "finite_set_rel (\<langle>Rk\<rangle>map2set_rel R)"
  using assms
  unfolding map2set_rel_def finite_set_rel_def finite_map_rel_def
  by auto

lemma map2set_cmp[autoref_rules_raw]:
  assumes ELO: "SIDE_GEN_ALGO (eq_linorder cmpk)"
  assumes MPAR:
    "GEN_OP cmp (cmp_map cmpk cmp_unit) (\<langle>Rk,Id\<rangle>R \<rightarrow> \<langle>Rk,Id\<rangle>R \<rightarrow> Id)"
  assumes FIN: "PREFER finite_map_rel (\<langle>Rk, Id\<rangle>R)"
  shows "(cmp,cmp_set cmpk)\<in>\<langle>Rk\<rangle>map2set_rel R \<rightarrow> \<langle>Rk\<rangle>map2set_rel R \<rightarrow> Id"
proof -
  interpret linorder "comp2le cmpk" "comp2lt cmpk"
    using ELO by (simp add: eq_linorder_class_conv)

  show ?thesis
    using MPAR
    unfolding cmp_map_def cmp_set_def
    apply simp
    apply parametricity
    apply (drule cmp_extend_paramD)
    apply (insert FIN, fastforce simp add: finite_map_rel_def) []
    apply (simp add: sorted_list_of_map_def[abs_def])
    apply (auto simp: map2set_rel_def cmp_img_def[abs_def] dest: fun_relD) []

    apply (insert map2set_finite[OF FIN[unfolded autoref_tag_defs]],
      fastforce simp add: finite_set_rel_def)
    done
qed

end


section \<open> Variable Blocks \<close>

theory utp_blocks
  imports utp_rel
begin

subsection \<open> Extra Symmetric Lens Properties \<close>

text \<open> The following result is needed to demonstrate the combination of the view and co-view
  covers all of the statespace. \<close>

context psym_lens
begin

lemma put_region_coregion_cover: "put\<^bsub>\<V>\<^esub> (put\<^bsub>\<C>\<^esub> s\<^sub>1 v\<^sub>1) v\<^sub>2 = put\<^bsub>\<V>\<^esub> (put\<^bsub>\<C>\<^esub> s\<^sub>2 v\<^sub>1) v\<^sub>2"
proof -
  have "\<And> \<sigma> \<rho> v\<^sub>1 v\<^sub>2. put\<^bsub>\<V> +\<^sub>L \<C>\<^esub> \<sigma> (v\<^sub>1, v\<^sub>2) = put\<^bsub>\<V> +\<^sub>L \<C>\<^esub> \<rho> (v\<^sub>1, v\<^sub>2)"
    by (simp add: pbij_lens.put_det)
  thus ?thesis
    by (simp add: lens_defs)
qed

end

subsection \<open> Extending and Contracting the Statespace \<close>

definition ext_state :: "(<'s\<^sub>1, 'c> \<Longleftrightarrow> 's\<^sub>2) \<Rightarrow> ('s\<^sub>1 \<Rightarrow> 's\<^sub>2)" ("ext\<^bsub>_\<^esub>") where
[lens_defs]: "ext\<^bsub>\<X>\<^esub> = (\<lambda> s. put\<^bsub>\<V>\<^bsub>\<X>\<^esub>\<^esub> (create\<^bsub>\<C>\<^bsub>\<X>\<^esub>\<^esub> undefined) s)"

lemma ext_state_subst: "psym_lens \<X> \<Longrightarrow> ext\<^bsub>\<X>\<^esub> = \<lparr>\<C>[\<X>] \<leadsto> undefined, \<V>[\<X>] \<leadsto> $\<^bold>v\<rparr>"
  by (simp add: expr_defs lens_defs fun_eq_iff psym_lens.put_region_coregion_cover)

definition con_state :: "(<'s\<^sub>1, 'c> \<Longleftrightarrow> 's\<^sub>2) \<Rightarrow> ('s\<^sub>2 \<Rightarrow> 's\<^sub>1)" ("con\<^bsub>_\<^esub>") where
[lens_defs]: "con\<^bsub>\<X>\<^esub> = (\<lambda> s. get\<^bsub>\<V>\<^bsub>\<X>\<^esub>\<^esub> s)"

lemma con_state_subst: "con\<^bsub>\<X>\<^esub> = \<lparr>\<^bold>v \<leadsto> $\<V>[\<X>]\<rparr>"
  by (simp add: lens_defs expr_defs)

lemma ext_con: "psym_lens \<X> \<Longrightarrow> con\<^bsub>\<X>\<^esub> (ext\<^bsub>\<X>\<^esub> s) = s"
  by (simp add: lens_defs comp_def id_def)

lemma con_surj: "psym_lens \<X> \<Longrightarrow> surj con\<^bsub>\<X>\<^esub>"
  by (meson ext_con surjI)

lemma put_con_in: "\<lbrakk> psym_lens \<X>; x \<subseteq>\<^sub>L \<C>\<^bsub>\<X>\<^esub> \<rbrakk> \<Longrightarrow> con\<^bsub>\<X>\<^esub> (put\<^bsub>x\<^esub> s v) = con\<^bsub>\<X>\<^esub> s"
  by (simp add: con_state_def sublens_pres_indep')

subsection \<open> Open and Close \<close>

definition open_var :: "(<'s\<^sub>1, 'c> \<Longleftrightarrow> 's\<^sub>2) \<Rightarrow> 's\<^sub>1 \<leftrightarrow> 's\<^sub>2" ("open\<^bsub>_\<^esub>") where
[pred]: "open_var \<X> = \<langle>ext\<^bsub>\<X>\<^esub>\<rangle> \<^bold>; \<C>[\<X>] := *"

definition close_var :: "(<'s\<^sub>1, 'c> \<Longleftrightarrow> 's\<^sub>2) \<Rightarrow> 's\<^sub>2 \<leftrightarrow> 's\<^sub>1" ("close\<^bsub>_\<^esub>") where
[pred]: "close_var \<X> = \<langle>con\<^bsub>\<X>\<^esub>\<rangle>"

lemma open_close: "psym_lens \<X> \<Longrightarrow> open\<^bsub>\<X>\<^esub> \<^bold>; close\<^bsub>\<X>\<^esub> = II"
  by pred_auto

subsection \<open> Lifting Symmetric Lenses \<close>

definition slens_pcomp :: "(<'a, 'b> \<Longleftrightarrow> 's\<^sub>1) \<Rightarrow> ('s\<^sub>1 \<Longrightarrow> 's\<^sub>2) \<Rightarrow> (<'a, 'b> \<Longleftrightarrow> 's\<^sub>2)" where
[lens_defs]: "slens_pcomp S L = \<lparr> view = view S ;\<^sub>L L, coview = coview S ;\<^sub>L L \<rparr>"

text \<open> This rather complex looking operator converts a endogeneous lens on one state space, to one
  on a larger state space. An example of a endogeneous lens is @{term "tl\<^sub>L"}, which views the tail
  of a list. Let's say then we have a state space with a variable denoting a list. Then the
  following function constructs a lens which allows us to view the state space, where the only
  change is that we are viewing the tail of the lens. \<close>

definition lens_lift :: "('s\<^sub>1 \<Longrightarrow> 's\<^sub>1) \<Rightarrow> ('s\<^sub>1 \<Longrightarrow> 's\<^sub>2) \<Rightarrow> ('s\<^sub>2 \<Longrightarrow> 's\<^sub>2)" where
[lens_defs]: "lens_lift X Y = \<lparr> lens_get = (\<lambda> s. put\<^bsub>Y\<^esub> s (get\<^bsub>X\<^esub> (get\<^bsub>Y\<^esub> s)))
                              , lens_put = (\<lambda> s v. put\<^bsub>Y\<^esub> v (put\<^bsub>X\<^esub> (get\<^bsub>Y\<^esub> s) (get\<^bsub>Y\<^esub> v)))  \<rparr>"

lemma lens_lift_mwb [simp]: "\<lbrakk> mwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> mwb_lens (lens_lift X Y)"
  by (unfold_locales, simp_all add: lens_defs)

lemma lens_lift_vwb [simp]: "\<lbrakk> vwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> vwb_lens (lens_lift X Y)"
  by (unfold_locales, simp_all add: lens_defs)

definition slens_lift :: "(<'s\<^sub>1, 'a> \<Longleftrightarrow> 's\<^sub>1) \<Rightarrow> ('s\<^sub>1 \<Longrightarrow> 's\<^sub>2) \<Rightarrow> (<'s\<^sub>2, 'a> \<Longleftrightarrow> 's\<^sub>2)" (infixl "\<up>\<^sub>S" 80) where
[lens_defs]: "slens_lift S L = \<lparr> view = lens_lift (view S) L, coview = coview S ;\<^sub>L L \<rparr>"

lemma "\<lbrakk> psym_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> psym_lens (X \<up>\<^sub>S Y)"
  apply (simp add: slens_lift_def)
  apply (rule psym_lens.intro)
  apply (simp_all)
  using comp_mwb_lens psym_lens.mwb_coregion vwb_lens_mwb apply blast
  oops

subsection \<open> Adding and Deleting Variables \<close>

text \<open> The functions implement addition and deletion of variables in the style proposed by
   Back and Preoteasa. A variable is a lens point to a stack-like local variable store. We
  By lifting a symmetric lens for splitting the statespace we can save and retrieve values
  in the stack. \<close>

abbreviation add_var ("add[_]\<^bsub>_\<^esub>") where "add_var \<X> x \<equiv> ext\<^bsub>\<X> \<up>\<^sub>S x\<^esub>"
abbreviation del_var ("del[_]\<^bsub>_\<^esub>") where "del_var \<X> x \<equiv> con\<^bsub>\<X> \<up>\<^sub>S x\<^esub>"

lemma del_var_def: "del[\<X>]\<^bsub>x\<^esub> = (\<lambda>s. put\<^bsub>x\<^esub> s (get\<^bsub>\<V>\<^bsub>\<X>\<^esub>\<^esub> (get\<^bsub>x\<^esub> s)))"
  by (simp add: con_state_def slens_lift_def lens_lift_def)

lemma add_var_prop:
  "\<lbrakk> psym_lens \<X>; weak_lens x \<rbrakk> \<Longrightarrow>
    put\<^bsub>\<V>\<^bsub>\<X>\<^esub>\<^esub> (get\<^bsub>x\<^esub> (create\<^bsub>\<C>\<^bsub>\<X>\<^esub> ;\<^sub>L x\<^esub> undefined)) v
    = put\<^bsub>\<C>\<^bsub>\<X>\<^esub>\<^esub> (put\<^bsub>\<V>\<^bsub>\<X>\<^esub>\<^esub> s v) undefined"
  using psym_lens.put_region_coregion_cover psym_lens_compl
  by (fastforce simp add: lens_defs lens_indep_comm)

lemma add_var_def:
  "\<lbrakk> psym_lens \<X>; weak_lens x \<rbrakk> \<Longrightarrow>
    add[\<X>]\<^bsub>x\<^esub> = (\<lambda>s. put\<^bsub>x\<^esub> s (put\<^bsub>\<C>\<^bsub>\<X>\<^esub>\<^esub> (put\<^bsub>\<V>\<^bsub>\<X>\<^esub>\<^esub> undefined (get\<^bsub>x\<^esub> s)) undefined))"
  using add_var_prop by (fastforce simp add: ext_state_def slens_lift_def lens_lift_def)

text \<open> Back and von Wright's axioms \<close>

lemma add_del:
  "\<lbrakk> psym_lens \<X>; vwb_lens x \<rbrakk> \<Longrightarrow> del[\<X>]\<^bsub>x\<^esub> (add[\<X>]\<^bsub>x\<^esub> s) = s"
  by (simp add: add_var_def del_var_def)

lemma del_surj: "\<lbrakk> psym_lens \<X>; vwb_lens x \<rbrakk> \<Longrightarrow> surj del[\<X>]\<^bsub>x\<^esub>"
  by (meson add_del surjI)

lemma del_get: "x \<bowtie> y \<Longrightarrow> get\<^bsub>x\<^esub> (del[\<X>]\<^bsub>y\<^esub> s) = get\<^bsub>x\<^esub> s"
  by (simp add: del_var_def)

lemma put_del_diff: "x \<bowtie> y \<Longrightarrow> del[\<X>]\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> s v) = put\<^bsub>x\<^esub> (del[\<X>]\<^bsub>y\<^esub> s) v"
  by (simp add: del_var_def lens_indep_comm, simp add: lens_indep_sym)

subsection \<open> Variable Stacks \<close>

text \<open> A variable stack is a non-empty list. This means there is always a value at the top, and
  there is always a @{const vwb_lens} for pointing the current value of a local variable. \<close>

typedef 'a vstack = "{xs :: 'a list. xs \<noteq> []}"
  by auto

setup_lifting type_definition_vstack

lift_definition vtop :: "'a vstack \<Rightarrow> 'a" is hd .
lift_definition vpush :: "'a \<Rightarrow> 'a vstack \<Rightarrow> 'a vstack" is "(#)" by simp
lift_definition vmake :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a vstack" is "(#)" by simp
lift_definition vtop_put :: "'a \<Rightarrow> 'a vstack \<Rightarrow> 'a vstack" is "\<lambda> x stk. x # tl stk" by simp
lift_definition vshrink :: "'a vstack \<Rightarrow> 'a vstack" is "\<lambda> xs. if (length xs > 1) then tl xs else [undefined]"
  apply (auto)
  apply (simp add: Nitpick.size_list_simp(2))
  done
lift_definition vappend :: "'a vstack \<Rightarrow> 'a vstack \<Rightarrow> 'a vstack" is "(@)"
  by simp

lemma vtop_put_vtop [simp]: "vtop (vtop_put x s) = x"
  by (transfer, simp_all)

lemma vpush_vtop_put [simp]: "vtop_put y (vpush x s) = vpush y s"
  by (transfer, simp)

lemma vtop_put_vshrink [simp]: "vshrink (vtop_put v s) = vshrink s"
  by (transfer, simp)

lemma vtop_put_vshrink [simp]: "vshrink (vtop_put x s) = s"
  apply (transfer, auto)
  oops

lemma vtop_vpush [simp]: "vtop (vpush x s) = x"
  by (transfer, simp)

lemma vshrink_vpush [simp]: "vshrink (vpush x s) = s"
  by (transfer, simp)

lemma vtop_put_put [simp]: "vtop_put x (vtop_put y s) = vtop_put x s"
  by (transfer, simp)

lemma vtop_vtop_put [simp]: "vtop_put (vtop s) s = s"
  by (transfer, simp)

definition vtop\<^sub>L :: "'a \<Longrightarrow> 'a vstack" where
[lens_defs]: "vtop\<^sub>L = \<lparr> lens_get = vtop, lens_put = (\<lambda> s v. vtop_put v s) \<rparr>"

definition vshrink\<^sub>L :: "'a vstack \<Longrightarrow> 'a vstack" where
[lens_defs]: "vshrink\<^sub>L = \<lparr> lens_get = vshrink, lens_put = (\<lambda> s v. vpush (vtop s) v) \<rparr>"

lemma vtop_vwb [simp]: "vwb_lens vtop\<^sub>L"
  by (unfold_locales, simp_all add: lens_defs)

lemma vshrink_vwb [simp]: "mwb_lens vshrink\<^sub>L"
  by (unfold_locales, simp_all add: lens_defs)

lemma vshrink_vtop_indep [simp]: "vshrink\<^sub>L \<bowtie> vtop\<^sub>L"
  by (unfold_locales, simp_all add: lens_defs)

abbreviation "vstack\<^sub>L \<equiv> \<lparr> view = vshrink\<^sub>L, coview = vtop\<^sub>L \<rparr>"

lemma vstack_psym_lens [simp]: "psym_lens vstack\<^sub>L"
  apply (rule psym_lens.intro)
     apply (simp_all)
  apply (rule pbij_lens.intro)
  using mwb_lens_weak plus_mwb_lens vshrink_vtop_indep vshrink_vwb vtop_vwb vwb_lens_mwb apply blast
  apply (simp add: pbij_lens_axioms_def)
  apply (simp add: lens_defs)
  done

text \<open> This theorem can only be proved when we know how to select the variable last created. \<close>

lemma put_del: "vwb_lens x \<Longrightarrow> del[vstack\<^sub>L]\<^bsub>x\<^esub> (put\<^bsub>vtop\<^sub>L ;\<^sub>L x\<^esub> s v) = del[vstack\<^sub>L]\<^bsub>x\<^esub> s"
  by (simp add: del_var_def lens_defs)

lemma add_vstack: "weak_lens x \<Longrightarrow> add[vstack\<^sub>L]\<^bsub>x\<^esub> = (\<lambda> s. put\<^bsub>x\<^esub> s (vpush undefined (get\<^bsub>x\<^esub> s)))"
  by (simp add: lens_defs)

end


chapter \<open>Section 6 Material and Gödel's First Incompleteness Theorem\<close>

theory Goedel_I
imports Pf_Predicates Functions II_Prelims
begin

section\<open>The Function W and Lemma 6.1\<close>

subsection\<open>Predicate form, defined on sequences\<close>

nominal_function SeqWRP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,sl); atom sl \<sharp> (s)\<rbrakk> \<Longrightarrow>
    SeqWRP s k y = LstSeqP s k y AND
          HPair Zero Zero IN s AND
          All2 l k (Ex sl (HPair (Var l) (Var sl) IN s AND
                           HPair (SUCC (Var l)) (Q_Succ (Var sl)) IN s))"
  by (auto simp: eqvt_def SeqWRP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows SeqWRP_fresh_iff [simp]: "a \<sharp> SeqWRP s k y \<longleftrightarrow> a \<sharp> s \<and> a \<sharp> k \<and> a \<sharp> y" (is ?thesis1)
    and SeqWRP_sf [iff]:         "Sigma_fm (SeqWRP s k y)"  (is ?thsf)
    and SeqWRP_imp_OrdP:         "{SeqWRP s k t} \<turnstile> OrdP k" (is ?thOrd)
    and SeqWRP_LstSeqP:          "{SeqWRP s k t} \<turnstile> LstSeqP s k t" (is ?thlstseq)
proof -
  obtain l::name and sl::name where "atom l \<sharp> (s,k,sl)" "atom sl \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf ?thOrd ?thlstseq
      by (auto intro: LstSeqP_OrdP[THEN cut1])
qed

lemma SeqWRP_subst [simp]:
      "(SeqWRP s k y)(i::=t) = SeqWRP (subst i t s) (subst i t k) (subst i t y)"
proof -
  obtain l::name and sl::name
    where "atom l \<sharp> (s,k,sl,t,i)" "atom sl \<sharp> (s,k,t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqWRP.simps [where l=l and sl=sl])
qed

lemma SeqWRP_cong:
  assumes "H \<turnstile> s EQ s'" and  "H \<turnstile> k EQ k'" and  "H \<turnstile> y EQ y'"
  shows "H \<turnstile> SeqWRP s k y IFF SeqWRP s' k' y'"
  by (rule P3_cong [OF _ assms], auto)

declare SeqWRP.simps [simp del]

subsection\<open>Predicate form of W\<close>

nominal_function WRP :: "tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom s \<sharp> (x,y)\<rbrakk> \<Longrightarrow>
    WRP x y = Ex s (SeqWRP (Var s) x y)"
  by (auto simp: eqvt_def WRP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
  shows WRP_fresh_iff [simp]: "a \<sharp> WRP x y \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> y" (is ?thesis1)
    and sigma_fm_WRP [simp]:  "Sigma_fm (WRP x y)"  (is ?thsf)
proof -
  obtain s::name where "atom s \<sharp> (x,y)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf
    by auto
qed

lemma WRP_subst [simp]: "(WRP x y)(i::=t) = WRP (subst i t x) (subst i t y)"
proof -
  obtain s::name where "atom s \<sharp> (x,y,t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: WRP.simps [of s])
qed

lemma WRP_cong: "H \<turnstile> t EQ t' \<Longrightarrow> H \<turnstile> u EQ u' \<Longrightarrow> H \<turnstile> WRP t u IFF WRP t' u'"
  by (rule P2_cong) auto

declare WRP.simps [simp del]

lemma ground_WRP [simp]: "ground_fm (WRP x y) \<longleftrightarrow> ground x \<and> ground y"
  by (auto simp: ground_aux_def ground_fm_aux_def supp_conv_fresh)

lemma SeqWRP_Zero: "{} \<turnstile> SyntaxN.Ex s (SeqWRP (Var s) Zero Zero)"
proof -
  obtain l sl :: name where "atom l \<sharp> (s, sl)" "atom sl \<sharp> s" by (metis obtain_fresh)
  then show ?thesis
    apply (subst SeqWRP.simps[of l _ _ sl]; simp)
    apply (rule Ex_I[where x="(Eats Zero (HPair Zero Zero))"], simp)
    apply (auto intro!: Mem_Eats_I2)
    done
qed

lemma WRP_Zero: "{} \<turnstile> WRP Zero Zero"
  by (subst WRP.simps[of undefined]) (auto simp: SeqWRP_Zero)

lemma SeqWRP_HPair_Zero_Zero: "{SeqWRP s k y} \<turnstile> HPair Zero Zero IN s"
proof -
  let ?vs = "(s,k,y)"
  obtain l::name and sl::name
    where "atom l \<sharp> (?vs,sl)" "atom sl \<sharp> (?vs)" by (metis obtain_fresh)
  then show ?thesis
    by (subst SeqWRP.simps[of l _ _ sl]) auto
qed

lemma SeqWRP_Succ:
  assumes "atom s \<sharp> (s1,k1,y)"
  shows "{SeqWRP s1 k1 y} \<turnstile> SyntaxN.Ex s (SeqWRP (Var s) (SUCC k1) (Q_Succ y))"
proof -
  let ?vs = "(s,s1,k1,y)"
  obtain l::name and sl::name and l1::name and sl1::name
    where atoms:
      "atom l \<sharp> (?vs,sl1,l1,sl)"
      "atom sl \<sharp> (?vs,sl1,l1)"
      "atom l1 \<sharp> (?vs,sl1)"
      "atom sl1 \<sharp> (?vs)"
    by (metis obtain_fresh)
  let ?hyp = "{RestrictedP s1 (SUCC k1) (Var s), OrdP k1, SeqWRP s1 k1 y}"
  show ?thesis
    using assms atoms
    apply (auto simp: SeqWRP.simps [of l "Var s" _ sl])
    apply (rule cut_same [where A="OrdP k1"])
    apply (rule SeqWRP_imp_OrdP)
    apply (rule cut_same [OF exists_RestrictedP [of s s1 "SUCC k1"]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
      apply (rule Ex_I [where x="Eats (Var s) (HPair (SUCC k1)  (Q_Succ y))"])
      apply (simp_all (no_asm_simp))
    apply (rule Conj_I)
    apply (blast intro: RestrictedP_LstSeqP_Eats[THEN cut2] SeqWRP_LstSeqP[THEN cut1])
    apply (rule Conj_I)
     apply (rule Mem_Eats_I1)
     apply (blast intro: RestrictedP_Mem[THEN cut3] SeqWRP_HPair_Zero_Zero[THEN cut1] Zero_In_SUCC[THEN cut1])
  proof (rule All2_SUCC_I, simp_all)
    show "?hyp \<turnstile>  SyntaxN.Ex sl
     (HPair k1 (Var sl) IN Eats (Var s) (HPair (SUCC k1) (Q_Succ y)) AND
      HPair (SUCC k1) (Q_Succ (Var sl)) IN
      Eats (Var s) (HPair (SUCC k1) (Q_Succ y)))"
      \<comment> \<open>verifying the final values\<close>
      apply (rule Ex_I [where x="y"])
      using assms atoms apply simp
      apply (rule Conj_I[rotated])
       apply (rule Mem_Eats_I2, rule Refl)
     apply (rule Mem_Eats_I1)
      apply (rule RestrictedP_Mem[THEN cut3])
        apply (rule AssumeH)
       apply (simp add: LstSeqP_imp_Mem SeqWRP_LstSeqP thin1)
      apply (rule Mem_SUCC_Refl)
      done
  next
    show "?hyp \<turnstile> All2 l k1
     (SyntaxN.Ex sl
       (HPair (Var l) (Var sl) IN
        Eats (Var s) (HPair (SUCC k1) (Q_Succ y)) AND
        HPair (SUCC (Var l)) (Q_Succ (Var sl)) IN
        Eats (Var s) (HPair (SUCC k1) (Q_Succ y))))"
      \<comment> \<open>verifying the sequence buildup\<close>
      apply (rule All_I Imp_I)+
      using assms atoms apply simp_all
        \<comment> \<open>... the sequence buildup via s1\<close>
    apply (simp add: SeqWRP.simps [of l s1 _ sl])
      apply (rule AssumeH Ex_EH Conj_EH)+
      apply (rule All2_E [THEN rotate2], auto del: Disj_EH)
      apply (rule Ex_I [where x="Var sl"], simp)
      apply (rule Conj_I)
       apply (blast intro: Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] Mem_SUCC_I1)
      apply (blast intro: Mem_Eats_I1 [OF RestrictedP_Mem [THEN cut3]] OrdP_IN_SUCC)
      done
  qed
qed (*>*)

lemma WRP_Succ: "{OrdP i, WRP i y} \<turnstile> WRP (SUCC i) (Q_Succ y)"
proof -
  obtain s t :: name where "atom s \<sharp> (i, y)" "atom t \<sharp> (s,i, y)" by (metis obtain_fresh)
  then show ?thesis
    by (subst WRP.simps[of s], simp, subst WRP.simps[of t], simp) (force intro: SeqWRP_Succ[THEN cut1])
qed

lemma WRP: "{} \<turnstile> WRP (ORD_OF i) \<guillemotleft>ORD_OF i\<guillemotright>"
  by (induct i)
    (auto simp: WRP_Zero quot_Succ intro!: WRP_Succ[THEN cut2])

lemma prove_WRP:  "{} \<turnstile> WRP \<guillemotleft>Var x\<guillemotright> \<guillemotleft>\<guillemotleft>Var x\<guillemotright>\<guillemotright>"
  unfolding quot_Var quot_Succ
  by (rule WRP_Succ[THEN cut2]) (auto simp: WRP)

subsection\<open>Proving that these relations are functions\<close>

lemma SeqWRP_Zero_E:
  assumes "insert (y EQ Zero) H \<turnstile> A"  "H \<turnstile> k EQ Zero"
  shows "insert (SeqWRP s k y) H \<turnstile> A"
proof -
  obtain l::name and sl::name
    where "atom l \<sharp> (s,k,sl)" "atom sl \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (auto simp: SeqWRP.simps [where s=s and l=l and sl=sl])
    apply (rule cut_same [where A = "LstSeqP s Zero y"])
    apply (blast intro: thin1 assms  LstSeqP_cong [OF Refl _ Refl, THEN Iff_MP_same])
    apply (rule cut_same [where A = "y EQ Zero"])
    apply (blast intro: LstSeqP_EQ)
    apply (metis rotate2 assms(1) thin1)
    done
qed

lemma SeqWRP_SUCC_lemma:
  assumes y': "atom y' \<sharp> (s,k,y)"
  shows "{SeqWRP s (SUCC k) y} \<turnstile> Ex y' (SeqWRP s k (Var y') AND y EQ Q_Succ (Var y'))"
proof -
  obtain l::name and sl::name
    where atoms: "atom l \<sharp> (s,k,y,y',sl)" "atom sl \<sharp> (s,k,y,y')"
    by (metis obtain_fresh)
  thus ?thesis using y'
    apply (auto simp: SeqWRP.simps [where s=s and l=l and sl=sl])
    apply (rule All2_SUCC_E' [where t=k, THEN rotate2], auto)
    apply (rule Ex_I [where x = "Var sl"], auto)
    apply (blast intro: LstSeqP_SUCC) \<comment> \<open>showing @{term"SeqWRP s k (Var sl)"}\<close>
    apply (blast intro: ContraProve LstSeqP_EQ)
    done
qed

lemma SeqWRP_SUCC_E:
  assumes y': "atom y' \<sharp> (s,k,y)" and k': "H \<turnstile> k' EQ (SUCC k)"
  shows "insert (SeqWRP s k' y) H  \<turnstile> Ex y' (SeqWRP s k (Var y') AND y EQ Q_Succ (Var y'))"
  using SeqWRP_cong [OF Refl k' Refl] cut1 [OF SeqWRP_SUCC_lemma [of y' s k y]]
  by (metis Assume Iff_MP_left Iff_sym y')

lemma SeqWRP_unique: "{OrdP x, SeqWRP s x y, SeqWRP s' x y'} \<turnstile> y' EQ y"
proof -
  obtain i::name and j::name and j'::name and k::name and sl::name and sl'::name and l::name and pi::name
    where  i: "atom i \<sharp> (s,s',y,y')" and j: "atom j \<sharp> (s,s',i,x,y,y')" and j': "atom j' \<sharp> (s,s',i,j,x,y,y')"
      and atoms: "atom k \<sharp> (s,s',i,j,j')" "atom sl \<sharp> (s,s',i,j,j',k)" "atom sl' \<sharp> (s,s',i,j,j',k,sl)"
                 "atom pi \<sharp> (s,s',i,j,j',k,sl,sl')"
    by (metis obtain_fresh)
  have "{OrdP (Var i)} \<turnstile> All j (All j' (SeqWRP s (Var i) (Var j) IMP (SeqWRP s' (Var i) (Var j') IMP Var j' EQ Var j)))"
    apply (rule OrdIndH [where j=k])
    using i j j' atoms apply auto
    apply (rule rotate4)
    apply (rule OrdP_cases_E [where k=pi], simp_all)
    \<comment> \<open>Zero case\<close>
    apply (rule SeqWRP_Zero_E [THEN rotate3])
    prefer 2 apply blast
    apply (rule SeqWRP_Zero_E [THEN rotate4])
    prefer 2 apply blast
    apply (blast intro: ContraProve [THEN rotate4] Sym Trans)
    \<comment> \<open>SUCC case\<close>
    apply (rule Ex_I [where x = "Var pi"], auto)
    apply (metis ContraProve EQ_imp_SUBS2 Mem_SUCC_I2 Refl Subset_D)
    apply (rule cut_same)
    apply (rule SeqWRP_SUCC_E [of sl' s' "Var pi", THEN rotate4], auto)
    apply (rule cut_same)
    apply (rule SeqWRP_SUCC_E [of sl s "Var pi", THEN rotate7], auto)
    apply (rule All_E [where x = "Var sl", THEN rotate5], simp)
    apply (rule All_E [where x = "Var sl'"], simp)
    apply (rule Imp_E, blast)+
    apply (rule cut_same [OF Q_Succ_cong [OF Assume]])
    apply (blast intro: Trans [OF Hyp Sym] HPair_cong)
    done
  hence "{OrdP (Var i)} \<turnstile> (All j' (SeqWRP s (Var i) (Var j) IMP (SeqWRP s' (Var i) (Var j') IMP Var j' EQ Var j)))(j::=y)"
    by (metis All_D)
  hence "{OrdP (Var i)} \<turnstile> (SeqWRP s (Var i) y IMP (SeqWRP s' (Var i) (Var j') IMP Var j' EQ y))(j'::=y')"
    using j j'
    by simp (drule All_D [where x=y'], simp)
  hence "{} \<turnstile> OrdP (Var i) IMP (SeqWRP s (Var i) y IMP (SeqWRP s' (Var i) y' IMP y' EQ y))"
    using j j'
    by simp (metis Imp_I)
  hence "{} \<turnstile> (OrdP (Var i) IMP (SeqWRP s (Var i) y IMP (SeqWRP s' (Var i) y' IMP y' EQ y)))(i::=x)"
    by (metis Subst emptyE)
  thus ?thesis using i
    by simp (metis anti_deduction insert_commute)
qed

theorem WRP_unique: "{OrdP x, WRP x y, WRP x y'} \<turnstile> y' EQ y"
proof -
  obtain s::name and s'::name
    where "atom s \<sharp> (x,y,y')"  "atom s' \<sharp> (x,y,y',s)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqWRP_unique [THEN rotate3] WRP.simps [of s _ y]  WRP.simps [of s' _ y'])
qed

section\<open>The Function HF and Lemma 6.2\<close>

subsection \<open>Defining the syntax: quantified body\<close>

nominal_function SeqHRP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom l \<sharp> (s,k,sl,sl',m,n,sm,sm',sn,sn');
          atom sl \<sharp> (s,sl',m,n,sm,sm',sn,sn');
          atom sl' \<sharp> (s,m,n,sm,sm',sn,sn');
          atom m \<sharp> (s,n,sm,sm',sn,sn');
          atom n \<sharp> (s,sm,sm',sn,sn');
          atom sm \<sharp> (s,sm',sn,sn');
          atom sm' \<sharp> (s,sn,sn');
          atom sn \<sharp> (s,sn');
          atom sn' \<sharp> (s)\<rbrakk> \<Longrightarrow>
    SeqHRP x x' s k =
      LstSeqP s k (HPair x x') AND
      All2 l (SUCC k) (Ex sl (Ex sl' (HPair (Var l) (HPair (Var sl) (Var sl')) IN s AND
                ((OrdP (Var sl) AND WRP (Var sl) (Var sl')) OR
                 Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn' (Var m IN Var l AND Var n IN Var l AND
                       HPair (Var m) (HPair (Var sm) (Var sm')) IN s AND
                       HPair (Var n) (HPair (Var sn) (Var sn')) IN s AND
                       Var sl EQ HPair (Var sm) (Var sn) AND
                       Var sl' EQ Q_HPair (Var sm') (Var sn')))))))))))"
by (auto simp: eqvt_def SeqHRP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows SeqHRP_fresh_iff [simp]:
      "a \<sharp> SeqHRP x x' s k \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> x' \<and> a \<sharp> s \<and> a \<sharp> k"  (is ?thesis1)
  and SeqHRP_sf [iff]:  "Sigma_fm (SeqHRP x x' s k)"  (is ?thsf)
  and SeqHRP_imp_OrdP: "{ SeqHRP x y s k } \<turnstile> OrdP k"  (is ?thord)
  and SeqHRP_imp_LstSeqP: "{ SeqHRP x y s k } \<turnstile> LstSeqP s k (HPair x y)"  (is ?thlstseq)
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name and
         sm::name and sm'::name and sn::name and sn'::name
    where atoms:
         "atom l \<sharp> (s,k,sl,sl',m,n,sm,sm',sn,sn')"
         "atom sl \<sharp> (s,sl',m,n,sm,sm',sn,sn')" "atom sl' \<sharp> (s,m,n,sm,sm',sn,sn')"
         "atom m \<sharp> (s,n,sm,sm',sn,sn')" "atom n \<sharp> (s,sm,sm',sn,sn')"
         "atom sm \<sharp> (s,sm',sn,sn')" "atom sm' \<sharp> (s,sn,sn')"
         "atom sn \<sharp> (s,sn')" "atom sn' \<sharp> (s)"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf ?thord ?thlstseq
    by (auto intro: LstSeqP_OrdP)
qed

lemma SeqHRP_subst [simp]:
      "(SeqHRP x x' s k)(i::=t) = SeqHRP (subst i t x) (subst i t x') (subst i t s) (subst i t k)"
proof -
  obtain l::name and sl::name and sl'::name and m::name and n::name and
         sm::name and sm'::name and sn::name and sn'::name
    where "atom l \<sharp> (s,k,t,i,sl,sl',m,n,sm,sm',sn,sn')"
          "atom sl \<sharp> (s,t,i,sl',m,n,sm,sm',sn,sn')"
          "atom sl' \<sharp> (s,t,i,m,n,sm,sm',sn,sn')"
          "atom m \<sharp> (s,t,i,n,sm,sm',sn,sn')" "atom n \<sharp> (s,t,i,sm,sm',sn,sn')"
          "atom sm \<sharp> (s,t,i,sm',sn,sn')" "atom sm' \<sharp> (s,t,i,sn,sn')"
          "atom sn \<sharp> (s,t,i,sn')" "atom sn' \<sharp> (s,t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqHRP.simps [of l _ _ sl sl' m n sm sm' sn sn'])
qed

lemma SeqHRP_cong:
  assumes "H \<turnstile> x EQ x'" and "H \<turnstile> y EQ y'" "H \<turnstile> s EQ s'" and  "H \<turnstile> k EQ k'"
  shows "H \<turnstile> SeqHRP x y s k IFF SeqHRP x' y' s' k'"
  by (rule P4_cong [OF _ assms], auto)

subsection \<open>Defining the syntax: main predicate\<close>

nominal_function HRP :: "tm \<Rightarrow> tm \<Rightarrow> fm"
  where "\<lbrakk>atom s \<sharp> (x,x',k); atom k \<sharp> (x,x')\<rbrakk> \<Longrightarrow>
         HRP x x' = Ex s (Ex k (SeqHRP x x' (Var s) (Var k)))"
  by (auto simp: eqvt_def HRP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma
 shows HRP_fresh_iff [simp]: "a \<sharp> HRP x x' \<longleftrightarrow> a \<sharp> x \<and> a \<sharp> x'"  (is ?thesis1)
   and HRP_sf [iff]:         "Sigma_fm (HRP x x')"  (is ?thsf)
proof -
  obtain s::name and k::name  where "atom s \<sharp> (x,x',k)"  "atom k \<sharp> (x,x')"
    by (metis obtain_fresh)
  thus ?thesis1 ?thsf
    by auto
qed

lemma HRP_subst [simp]: "(HRP x x')(i::=t) = HRP (subst i t x) (subst i t x')"
proof -
  obtain s::name and k::name where "atom s \<sharp> (x,x',t,i,k)"  "atom k \<sharp> (x,x',t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: HRP.simps [of s _ _ k])
qed

subsection\<open>Proving that these relations are functions\<close>

lemma SeqHRP_lemma:
  assumes "atom m \<sharp> (x,x',s,k,n,sm,sm',sn,sn')" "atom n \<sharp> (x,x',s,k,sm,sm',sn,sn')"
          "atom sm \<sharp> (x,x',s,k,sm',sn,sn')" "atom sm' \<sharp> (x,x',s,k,sn,sn')"
          "atom sn \<sharp> (x,x',s,k,sn')" "atom sn' \<sharp> (x,x',s,k)"
    shows "{ SeqHRP x x' s k }
         \<turnstile> (OrdP x AND WRP x x') OR
             Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn' (Var m IN k AND Var n IN k AND
                       SeqHRP (Var sm) (Var sm') s (Var m) AND
                       SeqHRP (Var sn) (Var sn') s (Var n) AND
                       x EQ HPair (Var sm) (Var sn) AND
                       x' EQ Q_HPair (Var sm') (Var sn')))))))"
proof -
  obtain l::name and sl::name and sl'::name
    where atoms:
          "atom l \<sharp> (x,x',s,k,sl,sl',m,n,sm,sm',sn,sn')"
          "atom sl \<sharp> (x,x',s,k,sl',m,n,sm,sm',sn,sn')"
          "atom sl' \<sharp> (x,x',s,k,m,n,sm,sm',sn,sn')"
    by (metis obtain_fresh)
  thus ?thesis using atoms assms
    apply (simp add: SeqHRP.simps [of l s k sl sl' m n sm sm' sn sn'])
    apply (rule Conj_E)
    apply (rule All2_SUCC_E' [where t=k, THEN rotate2], simp_all)
    apply (rule rotate2)
    apply (rule Ex_E Conj_E)+
    apply (rule cut_same [where A = "HPair x x' EQ HPair (Var sl) (Var sl')"])
    apply (metis Assume LstSeqP_EQ rotate4, simp_all, clarify)
    apply (rule Disj_E [THEN rotate4])
    apply (rule Disj_I1)
    apply (metis Assume AssumeH(3) Sym thin1  Iff_MP_same [OF Conj_cong [OF OrdP_cong WRP_cong] Assume])
    \<comment> \<open>auto could be used but is VERY SLOW\<close>
    apply (rule Disj_I2)
    apply (rule Ex_E Conj_EH)+
    apply simp_all
    apply (rule Ex_I [where x = "Var m"], simp)
    apply (rule Ex_I [where x = "Var n"], simp)
    apply (rule Ex_I [where x = "Var sm"], simp)
    apply (rule Ex_I [where x = "Var sm'"], simp)
    apply (rule Ex_I [where x = "Var sn"], simp)
    apply (rule Ex_I [where x = "Var sn'"], simp)
    apply (simp add: SeqHRP.simps [of l _ _ sl sl' m n sm sm' sn sn'])
    apply (rule Conj_I, blast)+
    \<comment> \<open>first SeqHRP subgoal\<close>
    apply (rule Conj_I)+
    apply (blast intro: LstSeqP_Mem)
    apply (rule All2_Subset [OF Hyp], blast)
    apply (blast intro!: SUCC_Subset_Ord LstSeqP_OrdP, blast, simp)
    \<comment> \<open>next SeqHRP subgoal\<close>
    apply (rule Conj_I)+
    apply (blast intro: LstSeqP_Mem)
    apply (rule All2_Subset [OF Hyp], blast)
    apply (auto intro!: SUCC_Subset_Ord LstSeqP_OrdP)
    \<comment> \<open>finally, the equality pair\<close>
    apply (blast intro: Trans)+
    done
qed

lemma SeqHRP_unique: "{SeqHRP x y s u, SeqHRP x y' s' u'} \<turnstile> y' EQ y"
proof -
  obtain i::name and j::name and j'::name and k::name and k'::name and l::name
     and m::name and n::name and sm::name and sn::name and sm'::name and sn'::name
     and m2::name and n2::name and sm2::name and sn2::name and sm2'::name and sn2'::name
    where atoms:  "atom i \<sharp> (s,s',y,y')"   "atom j \<sharp> (s,s',i,x,y,y')"  "atom j' \<sharp> (s,s',i,j,x,y,y')"
                  "atom k \<sharp> (s,s',x,y,y',u',i,j,j')" "atom k' \<sharp> (s,s',x,y,y',k,i,j,j')" "atom l \<sharp> (s,s',i,j,j',k,k')"
                  "atom m \<sharp> (s,s',i,j,j',k,k',l)"   "atom n \<sharp> (s,s',i,j,j',k,k',l,m)"
                  "atom sm \<sharp> (s,s',i,j,j',k,k',l,m,n)"  "atom sn \<sharp> (s,s',i,j,j',k,k',l,m,n,sm)"
                  "atom sm' \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn)"   "atom sn' \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm')"
                  "atom m2 \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn')"   "atom n2 \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2)"
                  "atom sm2 \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2)"  "atom sn2 \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2)"
                  "atom sm2' \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2,sn2)"   "atom sn2' \<sharp> (s,s',i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2,sn2,sm2')"
    by (metis obtain_fresh)
  have "{OrdP (Var k)}
       \<turnstile> All i (All j (All j' (All k' (SeqHRP (Var i) (Var j) s (Var k) IMP (SeqHRP (Var i) (Var j') s' (Var k') IMP Var j' EQ Var j)))))"
    apply (rule OrdIndH [where j=l])
    using atoms apply auto
    apply (rule Swap)
    apply (rule cut_same)
    apply (rule cut1 [OF SeqHRP_lemma [of m "Var i" "Var j" s "Var k" n sm sm' sn sn']], simp_all, blast)
    apply (rule cut_same)
    apply (rule cut1 [OF SeqHRP_lemma [of m2 "Var i" "Var j'" s' "Var k'" n2 sm2 sm2' sn2 sn2']], simp_all, blast)
    apply (rule Disj_EH Conj_EH)+
    \<comment> \<open>case 1, both are ordinals\<close>
    apply (blast intro: cut3 [OF WRP_unique])
    \<comment> \<open>case 2, @{term "OrdP (Var i)"} but also a pair\<close>
    apply (rule Conj_EH Ex_EH)+
    apply simp_all
    apply (rule cut_same [where A = "OrdP (HPair (Var sm) (Var sn))"])
    apply (blast intro: OrdP_cong [OF Hyp, THEN Iff_MP_same], blast)
    \<comment> \<open>towards second two cases\<close>
    apply (rule Ex_E Disj_EH Conj_EH)+
    \<comment> \<open>case 3, @{term "OrdP (Var i)"} but also a pair\<close>
    apply (rule cut_same [where A = "OrdP (HPair (Var sm2) (Var sn2))"])
    apply (blast intro: OrdP_cong [OF Hyp, THEN Iff_MP_same], blast)
    \<comment> \<open>case 4, two pairs\<close>
    apply (rule Ex_E Disj_EH Conj_EH)+
    apply (rule All_E' [OF Hyp, where x="Var m"], blast)
    apply (rule All_E' [OF Hyp, where x="Var n"], blast, simp_all)
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (rule All_E [where x="Var sm"], simp)
    apply (rule All_E [where x="Var sm'"], simp)
    apply (rule All_E [where x="Var sm2'"], simp)
    apply (rule All_E [where x="Var m2"], simp)
    apply (rule All_E [where x="Var sn", THEN rotate2], simp)
    apply (rule All_E [where x="Var sn'"], simp)
    apply (rule All_E [where x="Var sn2'"], simp)
    apply (rule All_E [where x="Var n2"], simp)
    apply (rule cut_same [where A = "HPair (Var sm) (Var sn) EQ HPair (Var sm2) (Var sn2)"])
    apply (blast intro: Sym Trans)
    apply (rule cut_same [where A = "SeqHRP (Var sn) (Var sn2') s' (Var n2)"])
    apply (blast intro: SeqHRP_cong [OF Hyp Refl Refl, THEN Iff_MP2_same])
    apply (rule cut_same [where A = "SeqHRP (Var sm) (Var sm2') s' (Var m2)"])
    apply (blast intro: SeqHRP_cong [OF Hyp Refl Refl, THEN Iff_MP2_same])
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (blast intro: Trans [OF Hyp Sym] intro!: HPair_cong)
    done
  hence "{OrdP (Var k)}
         \<turnstile> All j (All j' (All k' (SeqHRP x (Var j) s (Var k)
               IMP (SeqHRP x (Var j') s' (Var k') IMP Var j' EQ Var j))))"
    apply (rule All_D [where x = x, THEN cut_same])
    using atoms by auto
  hence "{OrdP (Var k)}
         \<turnstile> All j' (All k' (SeqHRP x y s (Var k) IMP (SeqHRP x (Var j') s' (Var k') IMP Var j' EQ y)))"
    apply (rule All_D [where x = y, THEN cut_same])
    using atoms by auto
  hence "{OrdP (Var k)}
          \<turnstile> All k' (SeqHRP x y s (Var k) IMP (SeqHRP x y' s' (Var k') IMP y' EQ y))"
    apply (rule All_D [where x = y', THEN cut_same])
    using atoms by auto
  hence "{OrdP (Var k)} \<turnstile> SeqHRP x y s (Var k) IMP (SeqHRP x y' s' u' IMP y' EQ y)"
    apply (rule All_D [where x = u', THEN cut_same])
    using atoms by auto
  hence "{SeqHRP x y s (Var k)} \<turnstile> SeqHRP x y s (Var k) IMP (SeqHRP x y' s' u' IMP y' EQ y)"
    by (metis SeqHRP_imp_OrdP cut1)
  hence "{} \<turnstile> ((SeqHRP x y s (Var k) IMP (SeqHRP x y' s' u' IMP y' EQ y)))(k::=u)"
    by (metis Subst emptyE Assume MP_same Imp_I)
  hence "{} \<turnstile> SeqHRP x y s u IMP (SeqHRP x y' s' u' IMP y' EQ y)"
    using atoms by simp
  thus ?thesis
    by (metis anti_deduction insert_commute)
qed

theorem HRP_unique: "{HRP x y, HRP x y'} \<turnstile> y' EQ y"
proof -
  obtain s::name and s'::name and k::name and k'::name
    where "atom s \<sharp> (x,y,y')" "atom s' \<sharp> (x,y,y',s)"
          "atom k \<sharp> (x,y,y',s,s')" "atom k' \<sharp> (x,y,y',s,s',k)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SeqHRP_unique HRP.simps [of s x y k]  HRP.simps [of s' x y' k'])
qed

lemma HRP_ORD_OF: "{} \<turnstile> HRP (ORD_OF i) \<guillemotleft>ORD_OF i\<guillemotright>"
proof -
  let ?vs = "(i)"
  obtain s k l::name and sl::name and sl'::name and m::name and n::name and
    sm::name and sm'::name and sn::name and sn'::name
    where atoms:
      "atom s \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn',l,k)"
      "atom k \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn',l)"
      "atom l \<sharp> (?vs,sl,sl',m,n,sm,sm',sn,sn')"
      "atom sl \<sharp> (?vs,sl',m,n,sm,sm',sn,sn')" "atom sl' \<sharp> (?vs,m,n,sm,sm',sn,sn')"
      "atom m \<sharp> (?vs,n,sm,sm',sn,sn')" "atom n \<sharp> (?vs,sm,sm',sn,sn')"
      "atom sm \<sharp> (?vs,sm',sn,sn')" "atom sm' \<sharp> (?vs,sn,sn')"
      "atom sn \<sharp> (?vs,sn')" "atom sn' \<sharp> ?vs"
    by (metis obtain_fresh)
  then show ?thesis
  apply (subst HRP.simps[of s _ _ k]; simp)
    apply (subst SeqHRP.simps[of l _ _ sl sl' m n sm sm' sn sn']; simp?)
    apply (rule Ex_I[where x="Eats Zero (HPair Zero (HPair (ORD_OF i) \<guillemotleft>ORD_OF i\<guillemotright>))"]; simp)
    apply (rule Ex_I[where x="Zero"]; simp)
    apply (rule Conj_I[OF LstSeqP_single])
    apply (rule All2_SUCC_I, simp)
     apply auto [2]
    apply (rule Ex_I[where x="ORD_OF i"], simp)
    apply (rule Ex_I[where x="\<guillemotleft>ORD_OF i\<guillemotright>"], simp)
    apply (auto intro!: Disj_I1 WRP Mem_Eats_I2)
    done
qed

lemma SeqHRP_HPair:
  assumes "atom s \<sharp> (k,s1,s2,k1,k2,x,y,x',y')" "atom k \<sharp> (s1,s2,k1,k2,x,y,x',y')"
  shows "{SeqHRP x x' s1 k1,
            SeqHRP y y' s2 k2}
           \<turnstile> Ex s (Ex k (SeqHRP (HPair x y) (Q_HPair x' y') (Var s) (Var k)))" (*<*)
proof -
  let ?vs = "(s1,s2,s,k1,k2,k,x,y,x',y')"
  obtain km::name and kn::name and j::name and k'::name
    and l::name and sl::name and sl'::name and m::name and n::name
    and sm::name and sm'::name and sn::name and sn'::name
    where atoms2: "atom km \<sharp> (kn,j,k',l,s1,s2,s,k1,k2,k,x,y,x',y',sl,sl',m,n,sm,sm',sn,sn')"
      "atom kn \<sharp> (j,k',l,s1,s2,s,k1,k2,k,x,y,x',y',sl,sl',m,n,sm,sm',sn,sn')"
      "atom j \<sharp> (k',l,s1,s2,s,k1,k2,k,x,y,x',y',sl,sl',m,n,sm,sm',sn,sn')"
      and atoms: "atom k' \<sharp> (l,s1,s2,s,k1,k2,k,x,y,x',y',sl,sl',m,n,sm,sm',sn,sn')"
      "atom l \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',sl,sl',m,n,sm,sm',sn,sn')"
      "atom sl \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',sl',m,n,sm,sm',sn,sn')"
      "atom sl' \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',m,n,sm,sm',sn,sn')"
      "atom m \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',n,sm,sm',sn,sn')"
      "atom n \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',sm,sm',sn,sn')"
      "atom sm \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',sm',sn,sn')"
      "atom sm' \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',sn,sn')"
      "atom sn \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y',sn')"
      "atom sn' \<sharp> (s1,s2,s,k1,k2,k,x,y,x',y')"
    by (metis obtain_fresh)
  let ?hyp = "{HaddP k1 k2 (Var k'), OrdP k1, OrdP k2, SeqAppendP s1 (SUCC k1) s2 (SUCC k2) (Var s),
               SeqHRP x x' s1 k1, SeqHRP y y' s2 k2}"
  show ?thesis
    using assms atoms
    apply (auto simp: SeqHRP.simps [of l "Var s" _ sl sl' m n sm sm' sn sn'])
    apply (rule cut_same [where A="OrdP k1 AND OrdP k2"])
     apply (metis Conj_I SeqHRP_imp_OrdP thin1 thin2)
    apply (rule cut_same [OF exists_SeqAppendP [of s s1 "SUCC k1" s2 "SUCC k2"]])
     apply (rule AssumeH Ex_EH Conj_EH | simp)+
      apply (rule cut_same [OF exists_HaddP [where j=k' and x=k1 and y=k2]])
        apply (rule AssumeH Ex_EH Conj_EH | simp)+
        apply (rule Ex_I [where x="Eats (Var s) (HPair (SUCC(SUCC(Var k'))) (HPair(HPair x y)(Q_HPair x' y')))"])
        apply (simp_all (no_asm_simp))
    apply (rule Ex_I [where x="SUCC (SUCC (Var k'))"], simp)
    apply (rule Conj_I)
     apply (blast intro: LstSeqP_SeqAppendP_Eats SeqHRP_imp_LstSeqP [THEN cut1])
  proof (rule All2_SUCC_I, simp_all)
    show "?hyp \<turnstile>     SyntaxN.Ex sl
     (SyntaxN.Ex sl'
       (HPair (SUCC (SUCC (Var k'))) (HPair (Var sl) (Var sl')) IN
        Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (HPair x y) (Q_HPair x' y'))) AND
        (OrdP (Var sl) AND WRP (Var sl) (Var sl') OR
         SyntaxN.Ex m
          (SyntaxN.Ex n
            (SyntaxN.Ex sm
              (SyntaxN.Ex sm'
                (SyntaxN.Ex sn
                  (SyntaxN.Ex sn'
                    (Var m IN SUCC (SUCC (Var k')) AND
                     Var n IN SUCC (SUCC (Var k')) AND
                     HPair (Var m) (HPair (Var sm) (Var sm')) IN
                     Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (HPair x y) (Q_HPair x' y'))) AND
                     HPair (Var n) (HPair (Var sn) (Var sn')) IN
                     Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (HPair x y) (Q_HPair x' y'))) AND
                     Var sl EQ HPair (Var sm) (Var sn) AND Var sl' EQ Q_HPair (Var sm') (Var sn'))))))))))"
      \<comment> \<open>verifying the final values\<close>
      apply (rule Ex_I [where x="HPair x y"])
      using assms atoms apply simp
      apply (rule Ex_I [where x="Q_HPair x' y'"], simp)
      apply (rule Conj_I, metis Mem_Eats_I2 Refl)
      apply (rule Disj_I2)
      apply (rule Ex_I [where x=k1], simp)
      apply (rule Ex_I [where x="SUCC (Var k')"], simp)
      apply (rule Ex_I [where x=x], simp)
      apply (rule_tac x=x' in Ex_I, simp)
      apply (rule Ex_I [where x=y], simp)
      apply (rule_tac x=y' in Ex_I, simp)
      apply (rule Conj_I)
       apply (blast intro: HaddP_Mem_I LstSeqP_OrdP Mem_SUCC_I1)
      apply (rule Conj_I [OF Mem_SUCC_Refl])
      apply (blast intro: Disj_I1 Mem_Eats_I1 Mem_SUCC_Refl SeqHRP_imp_LstSeqP [THEN cut1]
          LstSeqP_imp_Mem SeqAppendP_Mem1 [THEN cut3] SeqAppendP_Mem2 [THEN cut4] HaddP_SUCC1 [THEN cut1])
      done
  next
    show "?hyp \<turnstile>  All2 l (SUCC (SUCC (Var k')))
     (SyntaxN.Ex sl
       (SyntaxN.Ex sl'
         (HPair (Var l) (HPair (Var sl) (Var sl')) IN
          Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (HPair x y) (Q_HPair x' y'))) AND
          (OrdP (Var sl) AND WRP (Var sl) (Var sl') OR
           SyntaxN.Ex m
            (SyntaxN.Ex n
              (SyntaxN.Ex sm
                (SyntaxN.Ex sm'
                  (SyntaxN.Ex sn
                    (SyntaxN.Ex sn'
                      (Var m IN Var l AND
                       Var n IN Var l AND
                       HPair (Var m) (HPair (Var sm) (Var sm')) IN
                       Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (HPair x y) (Q_HPair x' y'))) AND
                       HPair (Var n) (HPair (Var sn) (Var sn')) IN
                       Eats (Var s) (HPair (SUCC (SUCC (Var k'))) (HPair (HPair x y) (Q_HPair x' y'))) AND
                       Var sl EQ HPair (Var sm) (Var sn) AND Var sl' EQ Q_HPair (Var sm') (Var sn')))))))))))"
      \<comment> \<open>verifying the sequence buildup\<close>
      apply (rule cut_same [where A="HaddP (SUCC k1) (SUCC k2) (SUCC (SUCC (Var k')))"])
       apply (blast intro: HaddP_SUCC1 [THEN cut1] HaddP_SUCC2 [THEN cut1])
      apply (rule All_I Imp_I)+
       apply (rule HaddP_Mem_cases [where i=j])
      using assms atoms atoms2 apply simp_all
          apply (rule AssumeH)
         apply (blast intro: OrdP_SUCC_I LstSeqP_OrdP)
        \<comment> \<open>... the sequence buildup via s1\<close>
        apply (simp add: SeqHRP.simps [of l s1 _ sl sl' m n sm sm' sn sn'])
        apply (rule AssumeH Ex_EH Conj_EH)+
        apply (rule All2_E [THEN rotate2])
          apply (simp | rule AssumeH Ex_EH Conj_EH)+
            apply (rule Ex_I [where x="Var sl"], simp)
            apply (rule Ex_I [where x="Var sl'"], simp)
            apply (rule Conj_I [OF Mem_Eats_I1])
             apply (metis SeqAppendP_Mem1 rotate3 thin2 thin4)
            apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
                        apply (rule Ex_I [where x="Var m"], simp)
                        apply (rule Ex_I [where x="Var n"], simp)
                        apply (rule Ex_I [where x="Var sm"], simp)
                        apply (rule Ex_I [where x="Var sm'"], simp)
                        apply (rule Ex_I [where x="Var sn"], simp)
                        apply (rule Ex_I [where x="Var sn'"], simp_all (no_asm_simp))
       apply (rule Conj_I, rule AssumeH)+
       apply (rule Conj_I)
        apply (blast intro: OrdP_Trans [OF OrdP_SUCC_I] Mem_Eats_I1 [OF SeqAppendP_Mem1 [THEN cut3]] Hyp)
       apply (blast intro: Disj_I1 Disj_I2 OrdP_Trans [OF OrdP_SUCC_I] Mem_Eats_I1 [OF SeqAppendP_Mem1 [THEN cut3]] Hyp)
        \<comment> \<open>... the sequence buildup via s2\<close>
      apply (simp add: SeqHRP.simps [of l s2 _ sl sl' m n sm sm' sn sn'])
      apply (rule AssumeH Ex_EH Conj_EH)+
      apply (rule All2_E [THEN rotate2])
        apply (simp | rule AssumeH Ex_EH Conj_EH)+
          apply (rule Ex_I [where x="Var sl"], simp)
          apply (rule Ex_I [where x="Var sl'"], simp)
          apply (rule cut_same [where A="OrdP (Var j)"])
           apply (metis HaddP_imp_OrdP rotate2 thin2)
          apply (rule Conj_I)
           apply (blast intro: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] del: Disj_EH)
          apply (rule AssumeH Disj_IE1H Ex_EH Conj_EH)+
                      apply (rule cut_same [OF exists_HaddP [where j=km and x="SUCC k1" and y="Var m"]])
                        apply (blast intro: Ord_IN_Ord, simp)
                      apply (rule cut_same [OF exists_HaddP [where j=kn and x="SUCC k1" and y="Var n"]])
                        apply (metis AssumeH(6) Ord_IN_Ord0 rotate8, simp)
                      apply (rule AssumeH Ex_EH Conj_EH | simp)+
                          apply (rule Ex_I [where x="Var km"], simp)
                          apply (rule Ex_I [where x="Var kn"], simp)
                          apply (rule Ex_I [where x="Var sm"], simp)
                          apply (rule Ex_I [where x="Var sm'"], simp)
                          apply (rule Ex_I [where x="Var sn"], simp)
                          apply (rule Ex_I [where x="Var sn'"], simp_all (no_asm_simp))
      apply (rule Conj_I [OF _ Conj_I])
        apply (blast intro!: HaddP_Mem_cancel_left [THEN Iff_MP2_same] OrdP_SUCC_I intro: LstSeqP_OrdP Hyp)+
      apply (blast del: Disj_EH  intro: OrdP_Trans Hyp
          intro!: Mem_Eats_I1 SeqAppendP_Mem2 [THEN cut4] HaddP_imp_OrdP [THEN cut1])
      done
  qed
qed (*>*)

lemma HRP_HPair: "{HRP x x', HRP y y'} \<turnstile> HRP (HPair x y) (Q_HPair x' y')"
proof -
  obtain k1::name and s1::name and k2::name and s2::name and k::name and s::name
    where "atom s1 \<sharp> (x,y,x',y')"        "atom k1 \<sharp> (x,y,x',y',s1)"
      "atom s2 \<sharp> (x,y,x',y',k1,s1)"  "atom k2 \<sharp> (x,y,x',y',s2,k1,s1)"
      "atom s  \<sharp> (x,y,x',y',k2,s2,k1,s1)" "atom k  \<sharp> (x,y,x',y',s,k2,s2,k1,s1)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp: HRP.simps [of s "HPair x y" _ k]
        HRP.simps [of s1 x _ k1]
        HRP.simps [of s2 y _ k2]
        intro: SeqHRP_HPair [THEN cut2])
qed

lemma HRP_HPair_quot: "{HRP x \<guillemotleft>x\<guillemotright>, HRP y \<guillemotleft>y\<guillemotright>} \<turnstile> HRP (HPair x y) \<guillemotleft>HPair x y\<guillemotright>"
  using HRP_HPair[of x "\<guillemotleft>x\<guillemotright>" y "\<guillemotleft>y\<guillemotright>"]
  unfolding HPair_def quot_simps by auto

lemma prove_HRP_coding_tm: fixes t::tm shows "coding_tm t \<Longrightarrow> {} \<turnstile> HRP t \<guillemotleft>t\<guillemotright>"
  by (induct t rule: coding_tm.induct)
    (auto simp: quot_simps HRP_ORD_OF HRP_HPair_quot[THEN cut2])

lemmas prove_HRP = prove_HRP_coding_tm[OF quot_fm_coding]

section\<open>The Function K and Lemma 6.3\<close>

nominal_function KRP :: "tm \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> fm"
  where "atom y \<sharp> (v,x,x') \<Longrightarrow>
         KRP v x x' = Ex y (HRP x (Var y) AND SubstFormP v (Var y) x x')"
  by (auto simp: eqvt_def KRP_graph_aux_def flip_fresh_fresh) (metis obtain_fresh)

nominal_termination (eqvt)
  by lexicographic_order

lemma KRP_fresh_iff [simp]: "a \<sharp> KRP v x x' \<longleftrightarrow> a \<sharp> v \<and> a \<sharp> x \<and> a \<sharp> x'"
proof -
  obtain y::name where "atom y \<sharp> (v,x,x')"
    by (metis obtain_fresh)
  thus ?thesis
    by auto
qed

lemma KRP_subst [simp]: "(KRP v x x')(i::=t) = KRP (subst i t v) (subst i t x) (subst i t x')"
proof -
  obtain y::name where "atom y \<sharp> (v,x,x',t,i)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: KRP.simps [of y])
qed

declare KRP.simps [simp del]

lemma prove_SubstFormP: "{} \<turnstile> SubstFormP \<guillemotleft>Var i\<guillemotright> \<guillemotleft>\<guillemotleft>A\<guillemotright>\<guillemotright> \<guillemotleft>A\<guillemotright> \<guillemotleft>A(i::=\<guillemotleft>A\<guillemotright>)\<guillemotright>"
  using SubstFormP by blast

lemma prove_KRP: "{} \<turnstile> KRP \<guillemotleft>Var i\<guillemotright> \<guillemotleft>A\<guillemotright> \<guillemotleft>A(i::=\<guillemotleft>A\<guillemotright>)\<guillemotright>"
  by (auto simp: KRP.simps [of y]
           intro!: Ex_I [where x="\<guillemotleft>\<guillemotleft>A\<guillemotright>\<guillemotright>"] prove_HRP prove_SubstFormP)

lemma KRP_unique: "{KRP v x y, KRP v x y'} \<turnstile> y' EQ y"
proof -
  obtain u::name and u'::name where "atom u \<sharp> (v,x,y,y')" "atom u' \<sharp> (v,x,y,y',u)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: KRP.simps [of u v x y] KRP.simps [of u' v x y']
             intro: SubstFormP_cong [THEN Iff_MP2_same]
                    SubstFormP_unique [THEN cut2] HRP_unique [THEN cut2])
qed

lemma KRP_subst_fm: "{KRP \<guillemotleft>Var i\<guillemotright> \<guillemotleft>\<beta>\<guillemotright> (Var j)} \<turnstile> Var j EQ \<guillemotleft>\<beta>(i::=\<guillemotleft>\<beta>\<guillemotright>)\<guillemotright>"
  by (metis KRP_unique cut0 prove_KRP)

end