theory State
imports HeapLang
begin

section \<open> State \<close>
text \<open> State specific definitions and lemmata;
  based on \<^url>\<open>https://gitlab.mpi-sws.org/iris/iris/-/blob/master/iris_heap_lang/lang.v\<close> \<close>

(* The state: heaps of val options, with None representing deallocated locations. *)
datatype state = State (heap: "(loc,val option) fmap") (used_proph_id: "proph_id fset")

definition state_upd_heap :: "((loc,val option) fmap \<Rightarrow> (loc,val option) fmap) \<Rightarrow> state \<Rightarrow> state" where
  "state_upd_heap f \<sigma> = State (f (heap \<sigma>)) (used_proph_id \<sigma>)"

definition state_upd_used_proph_id :: "(proph_id fset \<Rightarrow> proph_id fset) \<Rightarrow> state \<Rightarrow> state" where
  "state_upd_used_proph_id f \<sigma> = State (heap \<sigma>) (f (used_proph_id \<sigma>))"

lemma state_upd_proph: "used_proph_id (state_upd_heap f \<sigma>) = used_proph_id \<sigma>"
  unfolding state_upd_heap_def by simp

fun heap_array :: "loc \<Rightarrow> val list \<Rightarrow> (loc, val option) fmap" where
  "heap_array l [] = fmempty"
| "heap_array l (v#vs) = fmupd l (Some v) (heap_array (l+\<^sub>\<iota>1) vs)"

lemma heap_array_singleton: "heap_array l [v] = fmupd l (Some v) fmempty" by simp

lemma heap_array_dom: "fmdom (heap_array l vs) = Abs_fset {l ..< (l +\<^sub>\<iota> int (length vs))}"
proof (induction vs arbitrary: l)
  case Nil
  then show ?case by (auto simp: loc_add_0 bot_fset.abs_eq)
next
  case (Cons a vs)
  have "fmdom (heap_array l (a # vs)) = finsert l (fmdom (heap_array (l+\<^sub>\<iota>1) vs))" by simp
  then have "fset (fmdom (heap_array l (a # vs))) = insert l (fset (fmdom (heap_array (l+\<^sub>\<iota>1) vs)))"
    by simp
  also have "... = insert l (fset (Abs_fset {(l+\<^sub>\<iota>1)..< ((l+\<^sub>\<iota>1) +\<^sub>\<iota> int (length vs))}))"
    using Cons by simp
  also have "... = insert l {(l+\<^sub>\<iota>1)..< ((l+\<^sub>\<iota>1) +\<^sub>\<iota> int (length vs))}"
    using Abs_fset_inverse finite_atLeastLessThan_loc by blast
  also have "... = {l} \<union> {(l+\<^sub>\<iota>1)..< ((l+\<^sub>\<iota>1) +\<^sub>\<iota> int (length vs))}"
    by simp
  also have "... = {l..<(l+\<^sub>\<iota>1)} \<union> {(l+\<^sub>\<iota>1)..<((l+\<^sub>\<iota>1) +\<^sub>\<iota> int (length vs))}"
    using less_eq_loc_def loc_add_def less_loc_def loc.expand finite_atLeastLessThan_int by auto
  also have "... = ({l..<(l+\<^sub>\<iota>1)} \<union> {(l+\<^sub>\<iota>1)..<(l+\<^sub>\<iota>(1 + int (length vs)))})" by (simp add: loc_add_assoc)
  also have "... = ({l..<(l+\<^sub>\<iota>1)} \<union> {(l+\<^sub>\<iota>1)..<(l+\<^sub>\<iota> int (length (a#vs)))})" by simp
  also have "... = {l..<(l +\<^sub>\<iota> int (length (a#vs)))}"
    by (auto simp: loc_add_def loc.expand less_eq_loc_def ivl_disj_un(17))
  finally have "Abs_fset (fset (fmdom (heap_array l (a # vs)))) = Abs_fset {l..<(l +\<^sub>\<iota> int (length (a#vs)))}"
    by simp
  then show ?case unfolding fset_inverse .
qed

lemma heap_array_shift: "fmlookup (heap_array l vs) k = fmlookup (heap_array (l+\<^sub>\<iota>n) vs) (k+\<^sub>\<iota>n)"
proof (induction vs arbitrary: l k)
  case (Cons a vs)
  show ?case apply (simp; rule impI; rule conjI) using loc_add_def apply (simp_all add: loc.expand)
    using Cons using loc_add_def loc.expand apply blast
    by (smt (verit) loc.sel local.Cons)
qed (simp)

lemma heap_array_cons_shift: "(fmlookup (heap_array l vs) k = Some w) \<Longrightarrow>
  (fmlookup (heap_array l (v#vs)) (k+\<^sub>\<iota>1) = Some w)"
proof -
  assume assm: "fmlookup (heap_array l vs) k = Some w"
  hence "k |\<in>| fmdom (heap_array l vs)" by (rule fmdomI)
  then have "k \<in> {l ..< (l +\<^sub>\<iota> int (length vs))}" unfolding heap_array_dom
    by (simp add: eq_onp_same_args fmember.abs_eq)
  then have "l\<noteq>k+\<^sub>\<iota>1"  using less_eq_loc_def loc_add_def by force
  with assm show "fmlookup (heap_array l (v#vs)) (k+\<^sub>\<iota>1) = Some w" unfolding loc_add_def apply simp
  using heap_array_shift loc_add_def by fastforce
qed

lemma heap_array_elements: "fmlookup (heap_array l vs) k = Some (Some w) \<Longrightarrow> w \<in> set vs"
proof (induction vs arbitrary: l k)
  case (Cons a vs)
  then show ?case by (metis fmupd_lookup heap_array.simps(2) in_set_member member_rec(1) option.inject)
qed (simp)

lemma heap_array_step: "\<lbrakk>fmlookup (heap_array l (v#vs)) k = Some w; l\<noteq>k\<rbrakk> \<Longrightarrow>
  fmlookup (heap_array l vs) (k+\<^sub>\<iota>(-1)) = Some w"
proof (induction vs arbitrary: l k v)
  case (Cons a vs)
  from Cons(3) have "fmlookup (heap_array l (v # a # vs)) k = fmlookup (heap_array (l+\<^sub>\<iota>1) (a#vs)) k"
    by simp
  with Cons(2) have step: "fmlookup (heap_array (l+\<^sub>\<iota>1) (a#vs)) k = Some w" by simp
  then show ?case proof (cases "(l+\<^sub>\<iota>1=k)")
    case True
    with step have "w=Some a" by simp
    with True show ?thesis unfolding loc_add_def by auto
  next
    case False
    from Cons(3) have "fmlookup (heap_array l (a # vs)) (k +\<^sub>\<iota> - 1) = fmlookup (heap_array (l+\<^sub>\<iota>1) vs) (k +\<^sub>\<iota> - 1)"
      using loc_add_def False by force
    with Cons(1)[OF step False] show ?thesis by simp
  qed
qed (simp)

(* Due to nth being defined as primrec, this can't be an iff but only a one sided implication. *)
lemma heap_array_lookup: "(fmlookup (heap_array l vs) k = Some (Some ow)) \<Longrightarrow>
  (\<exists>j w. 0 \<le> j \<and> k = l +\<^sub>\<iota> j \<and> vs!(nat j) = w \<and> w=ow)"
proof (induction vs arbitrary: k)
  case (Cons a vs)
  then show ?case proof (cases "l=k")
    case True
    hence "fmlookup (heap_array l (a#vs)) k = Some (Some a)" by simp
    with Cons(2) have "ow = a" by simp
    moreover from True have "k=l+\<^sub>\<iota>0 \<and> (0::int)\<le>0 \<and> (a#vs)!(nat 0) = a" by (simp add: loc_add_0)
    ultimately show ?thesis by blast
  next
    case False
    from Cons(1)[OF heap_array_step[OF Cons(2) False]] obtain j w
      where jw: "0 \<le> j \<and> k +\<^sub>\<iota> - 1 = l +\<^sub>\<iota> j \<and> vs ! nat j = w \<and> w = ow" by blast
    hence "0\<le>j+1 \<and> k=l+\<^sub>\<iota>(j+1) \<and> (a#vs)!(nat (j+1)) = w \<and> w = ow" by (simp add: loc_add_def)
      (smt (verit, ccfv_SIG) loc.collapse nat_1 nat_diff_distrib)
    then show ?thesis by fast
  qed
qed (simp)

lemma state_array_map_disjoint: "(\<forall>i. (0\<le>i \<longrightarrow> (nat i < length vs) \<longrightarrow> fmlookup h (l+\<^sub>\<iota>i) = None))
  \<Longrightarrow> fmdom (heap_array l vs) |\<inter>| fmdom h = {||}"
proof
  assume assm: "\<forall>i\<ge>0. nat i < length vs \<longrightarrow> fmlookup h (l +\<^sub>\<iota> i) = None"
  from assm have "\<forall>i\<ge>0. nat i < length vs \<longrightarrow> (l +\<^sub>\<iota> i) |\<notin>| fmdom h" by fastforce
  hence "\<forall>i \<in> {0..<(int (length vs))}. (l +\<^sub>\<iota> i) |\<notin>| fmdom h" by fastforce
  hence "\<forall>l' \<in> {(l +\<^sub>\<iota> i) | i. i \<in> {0..<(int (length vs))} }. l' |\<notin>| fmdom h" by blast
  hence "\<forall>l' \<in> {l..<(l +\<^sub>\<iota> int (length vs))}. l' |\<notin>| fmdom h" using loc_ranges by blast
  hence "Abs_fset {l..<(l +\<^sub>\<iota> int (length vs))} |\<inter>| fmdom h = {||}"
    by (metis all_not_fin_conv eq_onp_same_args finite_atLeastLessThan_loc finter_iff fmember.abs_eq)
  with heap_array_dom show "fmdom (heap_array l vs) |\<inter>| fmdom h |\<subseteq>| {||}" by auto
qed (simp)

definition state_init_heap :: "loc \<Rightarrow> nat \<Rightarrow> val \<Rightarrow> state \<Rightarrow> state" where
  "state_init_heap l n v \<sigma> = state_upd_heap (\<lambda>h. h ++\<^sub>f heap_array l (replicate n v)) \<sigma>"

lemma state_init_heap_singleton: "state_init_heap l 1 v \<sigma> = state_upd_heap (\<lambda>h. fmupd l (Some v) h) \<sigma>"
unfolding state_init_heap_def by simp

inductive head_step :: "expr \<Rightarrow> state \<Rightarrow> observation list \<Rightarrow> expr \<Rightarrow> state \<Rightarrow> expr list \<Rightarrow> bool"
  ("_ _ _ \<Rightarrow>\<^sub>h _ _ _")  where
  RecS: "(Rec f x e) \<sigma> [] \<Rightarrow>\<^sub>h (Val(RecV f x e)) \<sigma> []"
| PairS: "(Pair (Val v1) (Val v2)) \<sigma> [] \<Rightarrow>\<^sub>h (Val(PairV v1 v2)) \<sigma> []"
| InjLS: "(InjL(Val v)) \<sigma> [] \<Rightarrow>\<^sub>h (Val(InjLV v)) \<sigma> []"
| InjRS: "(InjR(Val v)) \<sigma> [] \<Rightarrow>\<^sub>h (Val(InjRV v)) \<sigma> []"
| BetaS: "e' = subst' x v2 (subst' f (RecV f x e1) e1) \<Longrightarrow>
  (App (Val(RecV f x e1)) (Val v2)) \<sigma> [] \<Rightarrow>\<^sub>h e' \<sigma> []"
| UnOpS: "un_op_eval op v = Some v' \<Longrightarrow>
  (UnOp op (Val v)) \<sigma> [] \<Rightarrow>\<^sub>h (Val v') \<sigma> []"
| BinOpS: "bin_op_eval op v1 v2 = Some v' \<Longrightarrow>
  (BinOp op (Val v1) (Val v2)) \<sigma> [] \<Rightarrow>\<^sub>h (Val v') \<sigma> []"
| IfTrueS: "(If (Val(LitV(LitBool True))) e1 e2) \<sigma> [] \<Rightarrow>\<^sub>h e1 \<sigma> []"
| IfFalseS: "(If (Val(LitV(LitBool False))) e1 e2) \<sigma> [] \<Rightarrow>\<^sub>h e2 \<sigma> []"
| FstS: "(Fst (Val(PairV v1 v2))) \<sigma> [] \<Rightarrow>\<^sub>h (Val v1) \<sigma> []"
| SndS: "(Snd (Val(PairV v1 v2))) \<sigma> [] \<Rightarrow>\<^sub>h (Val v2) \<sigma> []"
| CaseLS: "(Case (Val(InjLV v)) e1 e2) \<sigma> [] \<Rightarrow>\<^sub>h (App e1 (Val v)) \<sigma> []"
| CaseRS: "(Case (Val(InjRV v)) e1 e2) \<sigma> [] \<Rightarrow>\<^sub>h (App e2 (Val v)) \<sigma> []"
| ForkS: "(Fork e) \<sigma> [] \<Rightarrow>\<^sub>h (Val(LitV LitUnit)) \<sigma> [e]"
| AllocNS: "\<lbrakk>(0 < n); (\<forall> (i::int). (0 \<le> i) \<longrightarrow> (i < n) \<longrightarrow> fmlookup (heap \<sigma>) (l +\<^sub>\<iota> i) = None)\<rbrakk> \<Longrightarrow>
  (AllocN (Val(LitV(LitInt n))) (Val v)) \<sigma> [] \<Rightarrow>\<^sub>h
  (Val(LitV(LitLoc l))) (state_init_heap l (nat n) v \<sigma>) []"
| FreeS: "fmlookup (heap \<sigma>) l = Some v \<Longrightarrow>
  (Free (Val(LitV(LitLoc l)))) \<sigma> [] \<Rightarrow>\<^sub>h (Val(LitV LitUnit)) (state_upd_heap (\<lambda>h. fmupd l None h) \<sigma>) []"
| LoadS: "fmlookup (heap \<sigma>) l = Some (Some v) \<Longrightarrow> (Load (Val(LitV(LitLoc l)))) \<sigma> [] \<Rightarrow>\<^sub>h (of_val v) \<sigma> []"
| StoreS: "fmlookup (heap \<sigma>) l = Some (Some v) \<Longrightarrow>
  (Store (Val(LitV(LitLoc l))) (Val w)) \<sigma> [] \<Rightarrow>\<^sub>h
  (Val(LitV LitUnit)) (state_upd_heap (\<lambda>h. fmupd l (Some w) h) \<sigma>) []"
| XchgS: "fmlookup (heap \<sigma>) l = Some (Some v1) \<Longrightarrow>
  (Xchg (Val(LitV(LitLoc l))) (Val v2)) \<sigma> [] \<Rightarrow>\<^sub>h
  (Val v1) (state_upd_heap (\<lambda>h. fmupd l (Some v2) h) \<sigma>) []"
   (* Crucially, this compares the same way as [EqOp]! *)
| CmpXchgS: "\<lbrakk>fmlookup (heap \<sigma>) l = Some (Some vl); vals_compare_safe vl v1; b = (vl = v1)\<rbrakk> \<Longrightarrow>
  (CmpXchg (Val(LitV(LitLoc l))) (Val v1) (Val v2)) \<sigma> [] \<Rightarrow>\<^sub>h
  (Val(PairV vl (LitV(LitBool b)))) (if b then state_upd_heap (\<lambda>h. fmupd l (Some v2) h) \<sigma> else \<sigma>) []"
| FaaS: "fmlookup (heap \<sigma>) l = Some (Some (LitV (LitInt i1))) \<Longrightarrow>
  (FAA (Val(LitV(LitLoc l))) (Val(LitV(LitInt i2)))) \<sigma> [] \<Rightarrow>\<^sub>h
  (Val(LitV(LitInt i1))) (state_upd_heap (\<lambda>h. fmupd l (Some (LitV (LitInt (i1 + i2)))) h) \<sigma>) []"
| NewProphS: "p |\<notin>| used_proph_id \<sigma> \<Longrightarrow>
  NewProph \<sigma> [] \<Rightarrow>\<^sub>h (Val(LitV(LitProphecy p))) (state_upd_used_proph_id (finsert p) \<sigma>) []"
| ResolveS: "e \<sigma> \<kappa>s \<Rightarrow>\<^sub>h (Val v) \<sigma>' ts \<Longrightarrow>
  (Resolve e (Val(LitV(LitProphecy p))) (Val w)) \<sigma> (\<kappa>s@[(p, (v, w))]) \<Rightarrow>\<^sub>h (Val v) \<sigma>' ts"

declare head_step.intros[intro]
inductive_cases headE[elim]: "(Rec f x e) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(Pair v1 v2) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(InjL v) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(InjR v) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(App f v2) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e' \<sigma>2 \<kappa>2"
  "(UnOp op v) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(BinOp op v1 v2) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(If b e1 e2) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e' \<sigma>2 \<kappa>2"
  "(Fst v) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(Snd v) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(Case v e1 e2) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(Fork e) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 efs"
  "(AllocN e v) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(Free l) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(Load l) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(Store l v) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(Xchg l v) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(CmpXchg l v1 v2) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(FAA l i) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "NewProph \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"
  "(Resolve e v1 w) \<sigma> \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 \<kappa>2"

lemma fill_item_val: "\<exists>x. Some x = (to_val (fill_item Ki e)) \<Longrightarrow> \<exists>x. Some x = (to_val e)"
by (induct Ki) auto

lemma val_head_stuck: "(e1 \<sigma>1 \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 efs) \<Longrightarrow> (to_val e1 = None)"
by (induct rule: head_step.induct) auto

lemma head_ctx_step_val: "(fill_item Ki e) \<sigma>1 \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 efs \<Longrightarrow> \<exists>x. Some x = (to_val e)"
proof (induction Ki arbitrary: \<kappa> e2)
  case (CaseCtx x1a x2a)
  then show ?case by cases auto
next
  case (ResolveLCtx Ki v1 v2)
  hence step: "(Resolve (fill_item Ki e) (Val v1) (Val v2)) \<sigma>1 \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 efs" by simp
  show ?case by (rule headE(21)[OF step, of "\<exists>x. Some x = to_val e"]) (simp add: ResolveLCtx(1))
next
  case (ResolveMCtx x1a x2a)
  then show ?case by cases auto
next
  case (ResolveRCtx x1a x2a)
  then show ?case by cases auto
qed auto

lemma fill_item_no_val_inj: "\<lbrakk>to_val e1 = None; to_val e2 = None; fill_item Ki1 e1 = fill_item Ki2 e2\<rbrakk>
   \<Longrightarrow> Ki1 = Ki2"
proof (induction Ki2 arbitrary: Ki1)
  case (AppLCtx x)
  then show ?case by (cases Ki1) auto
next
  case (AppRCtx x)
  then show ?case by (cases Ki1) auto
next
  case (UnOpCtx x)
  then show ?case by (cases Ki1) auto
next
  case (BinOpLCtx x1a x2a)
  then show ?case by (cases Ki1) auto
next
  case (BinOpRCtx x1a x2a)
  then show ?case by (cases Ki1) auto
next
  case (IfCtx x1a x2a)
  then show ?case by (cases Ki1) auto
next
  case (PairLCtx x)
  then show ?case by (cases Ki1) auto
next
  case (PairRCtx x)
  then show ?case by (cases Ki1) auto
next
  case FstCtx
  then show ?case by (cases Ki1) auto
next
  case SndCtx
  then show ?case by (cases Ki1) auto
next
  case InjLCtx
  then show ?case by (cases Ki1) auto
next
  case InjRCtx
  then show ?case by (cases Ki1) auto
next
  case (CaseCtx x1a x2a)
  then show ?case by (cases Ki1) auto
next
  case (AllocNLCtx x)
  then show ?case by (cases Ki1) auto
next
  case (AllocNRCtx x)
  then show ?case by (cases Ki1) auto
next
  case FreeCtx
  then show ?case by (cases Ki1) auto
next
  case LoadCtx
  then show ?case by (cases Ki1) auto
next
  case (StoreLCtx x)
  then show ?case by (cases Ki1) auto
next
  case (StoreRCtx x)
  then show ?case by (cases Ki1) auto
next
  case (XchgLCtx x)
  then show ?case by (cases Ki1) auto
next
  case (XchgRCtx x)
  then show ?case by (cases Ki1) auto
next
  case (CmpXchgLCtx x1a x2a)
  then show ?case by (cases Ki1) auto
next
  case (CmpXchgMCtx x1a x2a)
  then show ?case by (cases Ki1) auto
next
  case (CmpXchgRCtx x1a x2a)
  then show ?case by (cases Ki1) auto
next
  case (FaaLCtx x)
  then show ?case by (cases Ki1) auto
next
  case (FaaRCtx x)
  then show ?case by (cases Ki1) auto
next
  case (ResolveLCtx Ki2 x2a x3a)
  then show ?case by (cases Ki1) auto
next
  case (ResolveMCtx x1a x2a)
  then show ?case by (cases Ki1) auto
next
  case (ResolveRCtx x1a x2a)
  then show ?case by (cases Ki1) auto
qed

lemma alloc_fresh:  "(0 < n) \<Longrightarrow>
  (AllocN ((Val(LitV(LitInt n)))) (Val v)) \<sigma> [] \<Rightarrow>\<^sub>h
  (Val(LitV(LitLoc (fresh_locs (sorted_list_of_fset (fmdom (heap \<sigma>)))))))
    (state_init_heap (fresh_locs (sorted_list_of_fset (fmdom (heap \<sigma>)))) (nat n) v \<sigma>) []"
  apply (rule AllocNS) using fresh_locs_fresh[of _ "(sorted_list_of_fset (fmdom (heap \<sigma>)))"]
  by (auto simp : fmdom'_alt_def fmdom'_notD)

lemma head_step_to_val: "\<lbrakk>e1 \<sigma>1 \<kappa> \<Rightarrow>\<^sub>h e2 \<sigma>2 efs; e1 \<sigma>1' \<kappa>' \<Rightarrow>\<^sub>h e2' \<sigma>2' efs'; \<exists>x. Some x = (to_val e2)\<rbrakk>
  \<Longrightarrow> \<exists>x. Some x = (to_val e2')"
  by (induction rule: head_step.induct) auto

lemma fill_item_not_val: "False \<longleftrightarrow> (of_val v = fill_item K e)"
  by (induction K) auto

(* Other lemmata contain references to the Iris base logic and can thus not be defined yet. *)
end


theory "Example_DIAnd"
imports "./Proof_Checker"
begin
context ids begin
  section \<open>Example 1: Differential Invariants\<close>

definition DIAndConcl::"('sf,'sc,'sz) sequent"
where "DIAndConcl = ([], [Implies (And (Predicational pid1) (Predicational pid2))
       (Implies ([[Pvar vid1]](And (Predicational pid3) (Predicational pid4)))
                ([[Pvar vid1]](And (Predicational pid1) (Predicational pid2))))])"

definition DIAndSG1::"('sf,'sc,'sz) formula"
where "DIAndSG1 = (Implies (Predicational pid1) (Implies ([[Pvar vid1]](Predicational pid3)) ([[Pvar vid1]](Predicational pid1))))"

definition DIAndSG2::"('sf,'sc,'sz) formula"
where "DIAndSG2 = (Implies (Predicational pid2) (Implies ([[Pvar vid1]](Predicational pid4)) ([[Pvar vid1]](Predicational pid2))))"

definition DIAndCut::"('sf,'sc,'sz) formula"
where "DIAndCut =
  (([[$\<alpha> vid1]]((And (Predicational ( pid3)) (Predicational ( pid4)))) \<rightarrow> (And (Predicational ( pid1)) (Predicational ( pid2))))
    \<rightarrow> ([[$\<alpha> vid1]](And (Predicational ( pid3)) (Predicational ( pid4)))) \<rightarrow> ([[$\<alpha> vid1]](And (Predicational (pid1)) (Predicational ( pid2)))))"

definition DIAndSubst::"('sf,'sc,'sz) subst"
where "DIAndSubst =
  \<lparr> SFunctions = (\<lambda>_. None),
    SPredicates = (\<lambda>_. None),
    SContexts = (\<lambda>C. (if C = pid1 then Some(And (Predicational (Inl pid3)) (Predicational (Inl pid4)))
                else (if C = pid2 then Some(And (Predicational (Inl pid1)) (Predicational (Inl pid2))) else None))),
    SPrograms = (\<lambda>_. None),
    SODEs = (\<lambda>_. None)
  \<rparr>"

(*[a]R&H->R->[a]R&H->[a]R DIAndSubst34*)

definition DIAndSubst341::"('sf,'sc,'sz) subst"
where "DIAndSubst341 =
  \<lparr> SFunctions = (\<lambda>_. None),
    SPredicates = (\<lambda>_. None),
    SContexts = (\<lambda>C. (if C = pid1 then Some(And (Predicational (Inl pid3)) (Predicational (Inl pid4)))
                else (if C = pid2 then Some(Predicational (Inl pid3)) else None))),
    SPrograms = (\<lambda>_. None),
    SODEs = (\<lambda>_. None)
  \<rparr>"
definition DIAndSubst342::"('sf,'sc,'sz) subst"
where "DIAndSubst342 =
  \<lparr> SFunctions = (\<lambda>_. None),
    SPredicates = (\<lambda>_. None),
    SContexts = (\<lambda>C. (if C = pid1 then Some(And (Predicational (Inl pid3)) (Predicational (Inl pid4)))
                else (if C = pid2 then Some(Predicational (Inl pid4)) else None))),
    SPrograms = (\<lambda>_. None),
    SODEs = (\<lambda>_. None)
  \<rparr>"

(*[a]P, [a]R&H, P, Q |- [a]Q->P&Q->[a]Q->[a]P&Q, [a]P&Q;;*)
definition DIAndSubst12::"('sf,'sc,'sz) subst"
where "DIAndSubst12 =
  \<lparr> SFunctions = (\<lambda>_. None),
    SPredicates = (\<lambda>_. None),
    SContexts = (\<lambda>C. (if C = pid1 then Some(Predicational (Inl pid2))
                else (if C = pid2 then Some(Predicational (Inl pid1) && Predicational (Inl pid2)) else None))),
    SPrograms = (\<lambda>_. None),
    SODEs = (\<lambda>_. None)
  \<rparr>"

  (*  P ->  Q->P&Q *)
definition DIAndCurry12::"('sf,'sc,'sz) subst"
where "DIAndCurry12 =
  \<lparr> SFunctions = (\<lambda>_. None),
    SPredicates = (\<lambda>_. None),
    SContexts = (\<lambda>C. (if C = pid1 then Some(Predicational (Inl pid1))
                else (if C = pid2 then Some(Predicational (Inl pid2) \<rightarrow> (Predicational (Inl pid1) && Predicational (Inl pid2))) else None))),
    SPrograms = (\<lambda>_. None),
    SODEs = (\<lambda>_. None)
  \<rparr>"

definition DIAnd :: "rule"
where "DIAnd =
  ([([],[DIAndSG1]),([],[DIAndSG2])],
  DIAndConcl)"

definition DIAndCutP1 :: "('sf,'sc,'sz) formula"
where "DIAndCutP1 = ([[Pvar vid1]](Predicational pid1))"

definition DIAndCutP2 :: "('sf,'sc,'sz) formula"
where "DIAndCutP2 = ([[Pvar vid1]](Predicational pid2))"

definition DIAndCutP12 :: "('sf,'sc,'sz) formula"
where "DIAndCutP12 = (([[Pvar vid1]](Pc pid1) \<rightarrow> (Pc pid2 \<rightarrow> (And (Pc pid1) (Pc pid2))))
  \<rightarrow> (([[Pvar vid1]]Pc pid1) \<rightarrow> ([[Pvar vid1]](Pc pid2 \<rightarrow> (And (Pc pid1) (Pc pid2))))))"

definition DIAndCut34Elim1 :: "('sf,'sc,'sz) formula"
where "DIAndCut34Elim1 = (([[Pvar vid1]](Pc pid3 && Pc pid4) \<rightarrow> (Pc pid3))
  \<rightarrow> (([[Pvar vid1]](Pc pid3 && Pc pid4)) \<rightarrow> ([[Pvar vid1]](Pc pid3))))"

definition DIAndCut34Elim2 :: "('sf,'sc,'sz) formula"
where "DIAndCut34Elim2 = (([[Pvar vid1]](Pc pid3 && Pc pid4) \<rightarrow> (Pc pid4))
  \<rightarrow> (([[Pvar vid1]](Pc pid3 && Pc pid4)) \<rightarrow> ([[Pvar vid1]](Pc pid4))))"

definition DIAndCut12Intro :: "('sf,'sc,'sz) formula"
where "DIAndCut12Intro = (([[Pvar vid1]](Pc pid2  \<rightarrow> (Pc pid1 && Pc pid2)))
  \<rightarrow> (([[Pvar vid1]](Pc pid2)) \<rightarrow> ([[Pvar vid1]](Pc pid1 && Pc pid2))))"

definition DIAndProof :: "('sf, 'sc, 'sz) pf"
where "DIAndProof =
  (DIAndConcl, [
   (0, Rrule ImplyR 0)  (* 1 *)
  ,(0, Lrule AndL 0)
  ,(0, Rrule ImplyR 0)
  ,(0, Cut DIAndCutP1)
  ,(1, Cut DIAndSG1)
  ,(0, Rrule CohideR 0)
  ,(Suc (Suc 0), Lrule ImplyL 0)
  ,(Suc (Suc (Suc 0)), CloseId 1 0)
  ,(Suc (Suc 0), Lrule ImplyL 0)
  ,(Suc (Suc 0), CloseId 0 0)
  ,(Suc (Suc 0), Cut DIAndCut34Elim1) (* 11 *)
  ,(0, Lrule ImplyL 0)
  ,(Suc (Suc (Suc 0)), Lrule ImplyL 0)
  ,(0, Rrule CohideRR 0)
  ,(0, Rrule CohideRR 0)
  ,(Suc 0, Rrule CohideRR 0)
  ,(Suc (Suc (Suc (Suc (Suc 0)))), G)
  ,(0, Rrule ImplyR 0)
  ,(Suc (Suc (Suc (Suc (Suc 0)))), Lrule AndL 0)
  ,(Suc (Suc (Suc (Suc (Suc 0)))), CloseId 0 0)
  ,(Suc (Suc (Suc 0)), AxSubst AK DIAndSubst341) (* 21 *)
  ,(Suc (Suc 0), CloseId 0 0)
  ,(Suc 0, CloseId 0 0)
  ,(0, Cut DIAndCut12Intro)
  ,(Suc 0, Rrule CohideRR 0)
  ,(Suc (Suc 0), AxSubst AK DIAndSubst12)
  ,(0, Lrule ImplyL 0)
  ,(1, Lrule ImplyL 0)
  ,(Suc (Suc 0), CloseId 0 0)
  ,(Suc 0, Cut DIAndCutP12)
  ,(0, Lrule ImplyL 0) (* 31 *)
  ,(0, Rrule CohideRR 0)
  ,(Suc (Suc (Suc (Suc 0))), AxSubst AK DIAndCurry12)
  ,(Suc (Suc (Suc 0)), Rrule CohideRR 0)
  ,(Suc (Suc 0), Lrule ImplyL 0)
  ,(Suc (Suc 0), G)
  ,(0, Rrule ImplyR 0)
  ,(Suc (Suc (Suc (Suc 0))), Rrule ImplyR 0)
  ,(Suc (Suc (Suc (Suc 0))), Rrule AndR 0)
  ,(Suc (Suc (Suc (Suc (Suc 0)))), CloseId 0 0)
  ,(Suc (Suc (Suc (Suc 0))), CloseId 1 0) (* 41 *)
  ,(Suc (Suc  0), CloseId 0 0)
  ,(Suc 0, Cut DIAndCut34Elim2)
  ,(0, Lrule ImplyL 0)
  ,(0, Rrule CohideRR 0)
  ,(Suc (Suc (Suc (Suc 0))), AxSubst AK DIAndSubst342) (* 46 *)
  ,(Suc (Suc (Suc 0)), Rrule CohideRR 0)
  ,(Suc (Suc (Suc 0)), G) (* 48 *)
  ,(0, Rrule ImplyR 0)
  ,(Suc (Suc (Suc 0)), Lrule AndL 0) (* 50 *)
  ,(Suc (Suc (Suc 0)), CloseId 1 0)
  ,(Suc (Suc 0), Lrule ImplyL 0)
  ,(Suc 0, CloseId 0 0)
  ,(1, Cut DIAndSG2)
  ,(0, Lrule ImplyL 0)
  ,(0, Rrule CohideRR 0)
  ,(Suc (Suc (Suc 0)), CloseId 4 0)
  ,(Suc (Suc 0), Lrule ImplyL 0)
  ,(Suc (Suc (Suc 0)), CloseId 0 0)
  ,(Suc (Suc (Suc 0)), CloseId 0 0)
  ,(1, CloseId 1 0)
  ])
  "

fun proof_take :: "nat \<Rightarrow> ('sf,'sc,'sz) pf \<Rightarrow> ('sf,'sc,'sz) pf"
where "proof_take n (C,D) = (C,List.take n D)"

fun last_step::"('sf,'sc,'sz) pf \<Rightarrow> nat \<Rightarrow> nat * ('sf,'sc,'sz ) step"
where "last_step (C,D) n = List.last (take n D)"

lemma DIAndSound_lemma:"sound (proof_result (proof_take 61 DIAndProof))"
  apply(rule proof_sound)
  unfolding DIAndProof_def DIAndConcl_def  DIAndCutP1_def DIAndSG1_def DIAndCut34Elim1_def  DIAndSubst341_def DIAndCut12Intro_def DIAndSubst12_def
    DIAndCutP12_def DIAndCurry12_def DIAndSubst342_def
    DIAndCut34Elim2_def (* 43*)
    DIAndSG2_def (* 54*)(* slow *)
  apply (auto simp add: prover)
  done

lemma DIAnd_result_correct:"proof_result (proof_take 61 DIAndProof) = DIAnd"
  unfolding DIAndProof_def DIAndConcl_def Implies_def Or_def
  proof_result.simps deriv_result.simps start_proof.simps DIAndCutP12_def  DIAndSG1_def DIAndSG2_def DIAndCutP1_def Box_def DIAndCut34Elim1_def DIAndCut12Intro_def DIAndCut34Elim2_def DIAnd_def
  using pne12 pne13 pne14 pne23 pne24 pne34 by (auto)

theorem DIAnd_sound: "sound DIAnd"
  using DIAndSound_lemma DIAnd_result_correct by auto

end
end


subsection \<open>DHH Extension\<close>

text \<open>We define a variant of the DDH assumption and show it is as hard as the original DDH assumption.\<close>

theory DH_Ext imports
  Game_Based_Crypto.Diffie_Hellman
  Cyclic_Group_Ext
begin

context ddh begin

definition DDH0 :: "'grp adversary \<Rightarrow> bool spmf"
  where "DDH0 \<A> = do {
    s \<leftarrow> sample_uniform (order \<G>);
    r \<leftarrow> sample_uniform (order \<G>);
    let h = \<^bold>g [^] s;
    \<A> h (\<^bold>g [^] r) (h [^] r)}"

definition DDH1 :: "'grp adversary \<Rightarrow> bool spmf"
  where "DDH1 \<A> = do {
    s \<leftarrow> sample_uniform (order \<G>);
    r \<leftarrow> sample_uniform (order \<G>);
    let h = \<^bold>g [^] s;
    \<A> h (\<^bold>g [^] r) ((h [^] r) \<otimes> \<^bold>g)}"

definition DDH_advantage :: "'grp adversary \<Rightarrow> real"
  where "DDH_advantage \<A> = \<bar>spmf (DDH0 \<A>) True - spmf (DDH1 \<A>) True\<bar>"

definition DDH_\<A>' :: "'grp adversary \<Rightarrow> 'grp \<Rightarrow> 'grp \<Rightarrow> 'grp \<Rightarrow> bool spmf"
  where "DDH_\<A>' D_ddh a b c = D_ddh a b (c \<otimes> \<^bold>g)"

end

locale ddh_ext = ddh + cyclic_group \<G>
begin

lemma DDH0_eq_ddh_0: "ddh.DDH0 \<G> \<A> = ddh.ddh_0 \<G> \<A>"
  by(simp add: ddh.DDH0_def Let_def monoid.nat_pow_pow ddh.ddh_0_def)

lemma DDH_bound1: "\<bar>spmf (ddh.DDH0 \<G> \<A>) True - spmf (ddh.DDH1 \<G> \<A>) True\<bar>
                        \<le> \<bar>spmf (ddh.ddh_0 \<G> \<A>) True - spmf (ddh.ddh_1 \<G> \<A>) True\<bar>
                              + \<bar>spmf (ddh.ddh_1 \<G> \<A>) True - spmf (ddh.DDH1 \<G> \<A>) True\<bar>"
  by (simp add: abs_diff_triangle_ineq2 DDH0_eq_ddh_0)

lemma DDH_bound2:
  shows "\<bar>spmf (ddh.DDH0 \<G> \<A>) True - spmf (ddh.DDH1 \<G> \<A>) True\<bar>
               \<le> ddh.advantage \<G> \<A> + \<bar>spmf (ddh.ddh_1 \<G> \<A>) True - spmf (ddh.DDH1 \<G> \<A>) True\<bar>"
  using advantage_def DDH_bound1 by simp

lemma rewrite:
  shows "(sample_uniform (order \<G>) \<bind> (\<lambda>x. sample_uniform (order \<G>)
            \<bind> (\<lambda>y. sample_uniform (order \<G>) \<bind> (\<lambda>z. \<A> (\<^bold>g [^] x) (\<^bold>g [^] y) (\<^bold>g [^] z \<otimes> \<^bold>g)))))
              = (sample_uniform (order \<G>) \<bind> (\<lambda>x. sample_uniform (order \<G>)
                \<bind> (\<lambda>y. sample_uniform (order \<G>) \<bind> (\<lambda>z. \<A> (\<^bold>g [^] x) (\<^bold>g [^] y) (\<^bold>g [^] z)))))"
(is "?lhs = ?rhs")
proof-
  have "?lhs = do {
   x \<leftarrow> sample_uniform (order \<G>);
   y \<leftarrow> sample_uniform (order \<G>);
   c \<leftarrow> map_spmf (\<lambda> z. \<^bold>g [^] z \<otimes> \<^bold>g) (sample_uniform (order \<G>));
   \<A> (\<^bold>g [^] x) (\<^bold>g [^] y) c}"
    by(simp add: o_def bind_map_spmf Let_def)
  also have "... = do {
   x \<leftarrow> sample_uniform (order \<G>);
   y \<leftarrow> sample_uniform (order \<G>);
   c \<leftarrow> map_spmf (\<lambda>x. \<^bold>g [^] x) (sample_uniform (order \<G>));
   \<A> (\<^bold>g [^] x) (\<^bold>g [^] y) c}"
    by(simp add: sample_uniform_one_time_pad)
  ultimately show ?thesis
    by(simp add: Let_def bind_map_spmf o_def)
qed

lemma DDH_\<A>'_bound: "ddh.advantage \<G> (ddh.DDH_\<A>' \<G> \<A>) = \<bar>spmf (ddh.ddh_1 \<G> \<A>) True - spmf (ddh.DDH1 \<G> \<A>) True\<bar>"
  unfolding ddh.advantage_def ddh.ddh_1_def ddh.DDH1_def Let_def ddh.DDH_\<A>'_def ddh.ddh_0_def
  by (simp add: rewrite abs_minus_commute nat_pow_pow)

lemma DDH_advantage_bound: "ddh.DDH_advantage \<G> \<A> \<le> ddh.advantage \<G> \<A> + ddh.advantage \<G> (ddh.DDH_\<A>' \<G> \<A>)"
  using DDH_bound2 DDH_\<A>'_bound DDH_advantage_def by simp

end

end


(*
Title: Strong-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory Up_To_Technique
imports Strong_Security
begin

context Strong_Security
begin

\<comment> \<open>define d-bisimulation 'up to' union of strong d-Bisimulations\<close>
definition d_Bisimulation_Up_To_USdB ::
"'d \<Rightarrow> 'com Bisimulation_type \<Rightarrow> bool"
where
"d_Bisimulation_Up_To_USdB d R \<equiv>
  (sym R) \<and> (\<forall>(V,V') \<in> R. length V = length V') \<and>
  (\<forall>(V,V') \<in> R. \<forall>i < length V. \<forall>m1 m1' W m2.
  \<langle>V!i,m1\<rangle> \<rightarrow> \<langle>W,m2\<rangle> \<and> (m1 =\<^bsub>d\<^esub> m1')
  \<longrightarrow> (\<exists>W' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle>
    \<and> (W,W') \<in> (R \<union> (\<approx>\<^bsub>d\<^esub>)) \<and> (m2 =\<^bsub>d\<^esub> m2')))"

lemma UpTo_aux: "\<And>V V' m1 m1' m2 W i. \<lbrakk> d_Bisimulation_Up_To_USdB d R;
  i < length V; (V,V') \<in> R; \<langle>V!i,m1\<rangle> \<rightarrow> \<langle>W,m2\<rangle>; m1 =\<^bsub>d\<^esub> m1' \<rbrakk>
  \<Longrightarrow> (\<exists>W' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle>
  \<and> (W,W') \<in> (R \<union> (\<approx>\<^bsub>d\<^esub>)) \<and> (m2 =\<^bsub>d\<^esub> m2'))"
  by (simp add: d_Bisimulation_Up_To_USdB_def, fastforce)

lemma RuUSdBeqlen:
"\<lbrakk> d_Bisimulation_Up_To_USdB d R;
  (V,V') \<in> (R \<union> (\<approx>\<^bsub>d\<^esub>)) \<rbrakk>
  \<Longrightarrow> length V = length V'"
by (auto, simp add: d_Bisimulation_Up_To_USdB_def, auto,
  rule USdBeqlen, auto)

lemma Up_To_Technique:
  assumes upToR: "d_Bisimulation_Up_To_USdB d R"
  shows "R \<subseteq> \<approx>\<^bsub>d\<^esub>"
proof -
  define S where "S = R \<union> (\<approx>\<^bsub>d\<^esub>)"
  from S_def have "R \<subseteq> S"
    by auto
  moreover
  have "S \<subseteq> (\<approx>\<^bsub>d\<^esub>)"
  proof (simp add: USdB_def, auto, rule_tac x="S" in exI, auto,
      simp add: Strong_d_Bisimulation_def, auto)
      \<comment> \<open>show symmetry\<close>
    show symS: "sym S"
    proof -
      from upToR
      have Rsym: "sym R"
        by (simp add: d_Bisimulation_Up_To_USdB_def)
      with USdBsym have Usym:
        "sym (R \<union> (\<approx>\<^bsub>d\<^esub>))"
        by (metis sym_Un)
      with S_def show ?thesis
        by simp
    qed
  next
    fix V V'
    assume inS: "(V,V') \<in> S"
      \<comment> \<open>show equal length (by definition)\<close>
    from inS S_def upToR RuUSdBeqlen
    show eqlen: "length V = length V'"
      by simp
  next
      \<comment> \<open>show general bisimulation property\<close>
    fix V V' W m1 m1' m2 i
    assume inS: "(V,V') \<in> S"
    assume irange: "i < length V"
    assume stepV: "\<langle>V!i,m1\<rangle> \<rightarrow> \<langle>W,m2\<rangle>"
    assume dequal: "m1 =\<^bsub>d\<^esub> m1'"

    from inS show "\<exists>W' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and>
      (W,W') \<in> S \<and> m2 =\<^bsub>d\<^esub> m2'"
    proof (simp add: S_def, auto)
      assume firstcase: "(V,V') \<in> R"

      with upToR dequal irange stepV
        UpTo_aux[of "d" "R" "i" "V" "V'" "m1" "W" "m2" "m1'"]
      show "\<exists>W' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and>
        ((W,W') \<in> R \<or> W \<approx>\<^bsub>d\<^esub> W') \<and> m2 =\<^bsub>d\<^esub> m2'"
        by (auto simp add: S_def)
    next
      assume secondcase: "V \<approx>\<^bsub>d\<^esub> V'"

      from USdB_Strong_d_Bisimulation upToR
        secondcase dequal irange stepV
        strongdB_aux[of "d" "\<approx>\<^bsub>d\<^esub>" "i" "V" "V'" "m1" "W" "m2" "m1'"]
      show "\<exists>W' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow> \<langle>W',m2'\<rangle> \<and>
        ((W,W') \<in> R \<or> W \<approx>\<^bsub>d\<^esub> W') \<and> m2 =\<^bsub>d\<^esub> m2'"
        by auto
    qed
  qed

  ultimately show ?thesis by auto
qed

end

end


(*
 * Copyright 2016, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory L4vBucket
imports
  "../../../../../l4v/lib/WordLemmaBucket"
begin

no_notation fun_app (infixr "$" 10)

(* Copied from HaskellLemmaBucket.thy *)
lemma is_aligned_alignUp[simp]:
  "is_aligned (alignUp p n) n"
  by (simp add: alignUp_def complement_def
                is_aligned_mask mask_def
                word_bw_assocs)

lemma alignUp_le[simp]:
  "alignUp p n \<le> p + 2 ^ n - 1"
  unfolding alignUp_def
  by (rule word_and_le2)

lemma complement_mask:
  "complement (2 ^ n - 1) = ~~ mask n"
  unfolding complement_def mask_def
  by simp

lemma alignUp_idem:
  fixes a :: "'a::len word"
  assumes al: "is_aligned a n"
  and   sz: "n < len_of TYPE('a)"
  shows "alignUp a n = a"
  using sz al unfolding alignUp_def
  apply (simp add: complement_mask)
  apply (subst x_power_minus_1)
  apply (subst neg_mask_is_div)
  apply (simp only: word_arith_nat_div  unat_word_ariths)
  apply (simp only: unat_power_lower)
  apply (subst power_mod_div)
  apply (erule is_alignedE)
  apply simp
  apply (subst unat_mult_power_lem)
   apply simp
  apply (subst unat_sub)
   apply (subst unat_arith_simps)
   apply (simp add: word_bits_def)
  apply (simp add: word_bits_def del: unat_1)
  apply simp
  done

lemma alignUp_not_aligned_eq:
  fixes a :: "'a :: len word"
  assumes al: "\<not> is_aligned a n"
  and     sz: "n < len_of TYPE('a)"
  shows   "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
proof -
  have anz: "a mod 2 ^ n \<noteq> 0"
    by (rule not_aligned_mod_nz) fact+

  hence um: "unat (a mod 2 ^ n - 1) div 2 ^ n = 0" using sz
    apply -
    apply (rule div_less)
    apply (simp add: unat_minus_one del: word_neq_0_conv)
    apply (rule order_less_trans)
     apply (rule diff_Suc_less)
     apply (erule contrapos_np)
     apply (simp add: unat_eq_zero)
    apply (subst unat_power_lower [symmetric, OF sz[unfolded word_bits_def]])
    apply (subst word_less_nat_alt [symmetric])
    apply (rule word_mod_less_divisor)
    apply (simp add: p2_gt_0)
    done

  have "a + 2 ^ n - 1 = (a div 2 ^ n) * 2 ^ n + (a mod 2 ^ n) + 2 ^ n - 1"
    by (simp add: word_mod_div_equality)
  also have "\<dots> = (a mod 2 ^ n - 1) + (a div 2 ^ n + 1) * 2 ^ n"
    by (simp add: field_simps)
  finally show "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n" using sz
    unfolding alignUp_def
    apply (subst complement_mask)
    apply (erule ssubst)
    apply (subst neg_mask_is_div)
    apply (simp add: word_arith_nat_div)
    apply (subst unat_word_ariths(1) unat_word_ariths(2))+
    apply (subst uno_simps)
    apply (subst unat_1)
    apply (subst mod_add_right_eq [symmetric])
    apply (simp add: unat_power_lower)
    apply (subst power_mod_div)
    apply (subst div_mult_self1)
    apply simp
    apply (subst um)
    apply simp
    apply (subst mod_mod_power)
    apply simp
    apply (subst word_unat_power, subst Abs_fnat_hom_mult)
    apply (subst mult_mod_left)
    apply (subst power_add [symmetric])
    apply simp
    apply (subst Abs_fnat_hom_1)
    apply (subst Abs_fnat_hom_add)
    apply (subst word_unat_power, subst Abs_fnat_hom_mult)
    apply (subst word_unat.Rep_inverse[symmetric], subst Abs_fnat_hom_mult)
    apply simp
    done
qed

lemma alignUp_ge:
  fixes a :: "'a :: len word"
  assumes sz: "n < len_of TYPE('a)"
  and nowrap: "alignUp a n \<noteq> 0"
  shows "a \<le> alignUp a n"
proof (cases "is_aligned a n")
  case True
  thus ?thesis using sz
    by (subst alignUp_idem, simp_all)
next
  case False

  have lt0: "unat a div 2 ^ n < 2 ^ (len_of TYPE('a) - n)" using sz
    apply -
    apply (subst td_gal_lt [symmetric])
     apply simp
    apply (simp add: power_add [symmetric])
    done

  have"2 ^ n * (unat a div 2 ^ n + 1) \<le> 2 ^ len_of TYPE('a)" using sz
    apply -
    apply (rule nat_le_power_trans)
    apply simp
    apply (rule Suc_leI [OF lt0])
    apply simp
    done
  moreover have "2 ^ n * (unat a div 2 ^ n + 1) \<noteq> 2 ^ len_of TYPE('a)" using nowrap sz
    apply -
    apply (erule contrapos_nn)
    apply (subst alignUp_not_aligned_eq [OF False sz])
    apply (subst unat_arith_simps)
    apply (subst unat_word_ariths)
    apply (subst unat_word_ariths)
    apply simp
    apply (subst mult_mod_left)
    apply (simp add: unat_div field_simps power_add[symmetric] mod_mod_power
                     min.absorb2 unat_power_lower)
    done
  ultimately have lt: "2 ^ n * (unat a div 2 ^ n + 1) < 2 ^ len_of TYPE('a)" by simp

  have "a = a div 2 ^ n * 2 ^ n + a mod 2 ^ n" by (rule word_mod_div_equality [symmetric])
  also have "\<dots> < (a div 2 ^ n + 1) * 2 ^ n" using sz lt
    apply (simp add: field_simps)
    apply (rule word_add_less_mono1)
    apply (rule word_mod_less_divisor)
    apply (simp add: word_less_nat_alt unat_power_lower)
    apply (subst unat_word_ariths)
    apply (simp add: unat_div unat_power_lower)
    done
  also have "\<dots> =  alignUp a n"
    by (rule alignUp_not_aligned_eq [symmetric]) fact+
  finally show ?thesis by (rule order_less_imp_le)
qed

lemma alignUp_le_greater_al:
  fixes x :: "'a :: len word"
  assumes le: "a \<le> x"
  and     sz: "n < len_of TYPE('a)"
  and     al: "is_aligned x n"
  shows   "alignUp a n \<le> x"
proof (cases "is_aligned a n")
  case True
  thus ?thesis using sz le by (simp add: alignUp_idem)
next
  case False

  hence anz: "a mod 2 ^ n \<noteq> 0"
    by (rule not_aligned_mod_nz)

  from al obtain k where xk: "x = 2 ^ n * of_nat k" and kv: "k < 2 ^ (len_of TYPE('a) - n)"
    by (auto elim!: is_alignedE)

  hence kn: "unat (of_nat k :: 'a word) * unat ((2::'a word) ^ n) < 2 ^ len_of TYPE('a)"
    using sz
    apply (subst unat_of_nat_eq)
     apply (erule order_less_le_trans)
     apply simp
    apply (subst mult.commute)
    apply (simp add: unat_power_lower)
    apply (rule nat_less_power_trans)
     apply simp
    apply simp
    done

  have au: "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
    by (rule alignUp_not_aligned_eq) fact+
  also have "\<dots> \<le> of_nat k * 2 ^ n"
  proof (rule word_mult_le_mono1 [OF inc_le _ kn])
    show "a div 2 ^ n < of_nat k" using kv xk le sz anz
      by (simp add: alignUp_div_helper)

    show "(0:: 'a word) < 2 ^ n" using sz by (simp add: p2_gt_0 sz)
  qed

  finally show ?thesis using xk by (simp add: field_simps)
qed

lemma alignUp_is_aligned_nz:
  fixes a :: "'a :: len word"
  assumes al: "is_aligned x n"
  and     sz: "n < len_of TYPE('a)"
  and     ax: "a \<le> x"
  and     az: "a \<noteq> 0"
  shows   "alignUp (a::'a :: len word) n \<noteq> 0"
proof (cases "is_aligned a n")
  case True
  hence "alignUp a n = a" using sz by (simp add: alignUp_idem)
  thus ?thesis using az by simp
next
  case False
  hence anz: "a mod 2 ^ n \<noteq> 0"
    by (rule not_aligned_mod_nz)

  {
    assume asm: "alignUp a n = 0"

    have lt0: "unat a div 2 ^ n < 2 ^ (len_of TYPE('a) - n)" using sz
      apply -
      apply (subst td_gal_lt [symmetric])
      apply simp
      apply (simp add: power_add [symmetric])
      done

    have leq: "2 ^ n * (unat a div 2 ^ n + 1) \<le> 2 ^ len_of TYPE('a)" using sz
      apply -
      apply (rule nat_le_power_trans)
      apply simp
      apply (rule Suc_leI [OF lt0])
      apply simp
      done

    from al obtain k where  kv: "k < 2 ^ (len_of TYPE('a) - n)" and xk: "x = 2 ^ n * of_nat k"
      by (auto elim!: is_alignedE)

    hence "a div 2 ^ n < of_nat k" using ax sz anz
      by (rule alignUp_div_helper)

    hence r: "unat a div 2 ^ n < k" using sz
      apply (simp add: unat_div word_less_nat_alt)
      apply (subst (asm) unat_of_nat)
      apply (subst (asm) mod_less)
      apply (rule order_less_le_trans [OF kv])
      apply (simp add: unat_power_lower)+
      done

    have "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
      by (rule alignUp_not_aligned_eq) fact+

    hence "\<dots> = 0" using asm by simp
    hence "unat a div 2 ^ n = 2 ^ (len_of TYPE('a) - n) - 1" using sz leq
      apply -
      apply (rule nat_diff_add)
      apply simp
      apply (subst nat_mult_eq_cancel1 [where k = "2 ^ n", symmetric])
      apply simp
      apply (subst power_add [symmetric])
      apply simp
      apply (drule unat_cong)
      apply simp
      apply (subst (asm) unat_word_ariths)
      apply (subst (asm) unat_word_ariths)
      apply (simp add: unat_div mult_mod_left power_add [symmetric] mod_mod_power
                       min.absorb2)
      apply (clarsimp simp: field_simps)
      apply (rule ccontr)
      apply (drule (1) order_le_neq_trans)
      apply (simp add: unat_power_lower)
      done

    hence "2 ^ (len_of TYPE('a) - n) - 1 < k" using r
      by simp
    hence False using kv by simp
  } thus ?thesis by (clarsimp simp del: word_neq_0_conv)
qed

lemma alignUp_ar_helper:
  fixes a :: "'a :: len word"
  assumes al: "is_aligned x n"
  and     sz: "n < len_of TYPE('a)"
  and    sub: "{x..x + 2 ^ n - 1} \<subseteq> {a..b}"
  and    anz: "a \<noteq> 0"
  shows "a \<le> alignUp a n \<and> alignUp a n + 2 ^ n - 1 \<le> b"
proof
  from al have xl: "x \<le> x + 2 ^ n - 1" by (simp add: is_aligned_no_overflow)

  from xl sub have ax: "a \<le> x"
    by (clarsimp elim!: range_subset_lower [where x = x])

  show "a \<le> alignUp a n"
  proof (rule alignUp_ge)
    show "alignUp a n \<noteq> 0" using al sz ax anz
      by (rule alignUp_is_aligned_nz)
  qed fact+

  show "alignUp a n + 2 ^ n - 1 \<le> b"
  proof (rule order_trans)
    from xl show tp: "x + 2 ^ n - 1 \<le> b" using sub
      by (clarsimp elim!: range_subset_upper [where x = x])

    from ax have "alignUp a n \<le> x"
      by (rule alignUp_le_greater_al) fact+
    hence "alignUp a n + (2 ^ n - 1) \<le> x + (2 ^ n - 1)" using xl
      apply -
      apply (erule word_plus_mono_left)
      apply (subst olen_add_eqv)
      apply (simp add: field_simps)
      done
    thus "alignUp a n + 2 ^ n - 1 \<le> x + 2 ^ n - 1"
      by (simp add: field_simps)
  qed
qed

end


theory Short_Theory_7_9
  imports "HOL-IMP.BExp" "HOL-IMP.Star"
begin

datatype
  com = SKIP
  | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
  | Seq    com  com         ("_;;/ _"  [60, 61] 60)
  | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
  | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
  | Or     com  com         ("(_/ OR _)" [0, 61] 61)

inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
  where
    Skip: "(SKIP, s) \<Rightarrow> s" |
    Assign: "(x ::= a, s) \<Rightarrow> s(x := aval a s)" |
    Seq: "\<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3\<rbrakk> \<Longrightarrow> (c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
    IfTrue: "\<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
    IfFalse: "\<lbrakk>\<not>bval b s;  (c\<^sub>2, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
    WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
    WhileTrue: "\<lbrakk>bval b s\<^sub>1; (c, s\<^sub>1) \<Rightarrow> s\<^sub>2; (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
      \<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
    OrLeft: "(c\<^sub>1,s) \<Rightarrow> t \<Longrightarrow> (c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t" |
    OrRight: "(c\<^sub>2,s) \<Rightarrow> t \<Longrightarrow> (c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t"

lemmas big_step_induct = big_step.induct[split_format(complete)]
declare big_step.intros [intro]

lemma BS_SkipE [elim!]: "\<lbrakk>(SKIP, s) \<Rightarrow> t; t = s \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases rule: big_step.cases) auto
lemma BS_AssignE [elim!]: "\<lbrakk>(x ::= a, s) \<Rightarrow> t; t = s(x := aval a s) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases rule: big_step.cases) auto
lemma BS_SeqE [elim!]: "\<lbrakk>(c\<^sub>1;; c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3;
 \<And>s\<^sub>2. \<lbrakk>(c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2; (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3\<rbrakk> \<Longrightarrow> P\<rbrakk>
\<Longrightarrow> P"
  by (cases rule: big_step.cases) auto
lemma BS_IfE [elim!]: "\<lbrakk>
  (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t;
  \<lbrakk>bval b s; (c\<^sub>1, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P;
  \<lbrakk>\<not> bval b s; (c\<^sub>2, s) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: big_step.cases) auto
lemma BS_WhileE [elim]: "\<lbrakk>
  (WHILE b DO c, s) \<Rightarrow> t;
  \<lbrakk>\<not> bval b t; s = t\<rbrakk> \<Longrightarrow> P;
  \<And>s\<^sub>2. \<lbrakk>bval b s; (c, s) \<Rightarrow> s\<^sub>2; (WHILE b DO c, s\<^sub>2) \<Rightarrow> t\<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: big_step.cases) auto
lemma BS_Or [elim!]: "\<lbrakk>(c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t; (c\<^sub>1, s) \<Rightarrow> t \<Longrightarrow> P; (c\<^sub>2, s) \<Rightarrow> t \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases rule: big_step.cases) auto

abbreviation equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"

lemma "(c\<^sub>1 OR c\<^sub>2) \<sim> (c\<^sub>2 OR c\<^sub>1)" by blast

inductive small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
  where
    Assign: "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |
    Seq1: "(SKIP;; c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
    Seq2: "(c\<^sub>1, s) \<rightarrow> (c\<^sub>1', s') \<Longrightarrow> (c\<^sub>1;; c\<^sub>2, s) \<rightarrow> (c\<^sub>1';; c\<^sub>2, s')" |
    IfTrue: "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>1, s)" |
    IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)" |
    While: "(WHILE b DO c, s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP, s)" |
    OrLeft: "(c\<^sub>1 OR c\<^sub>2, s) \<rightarrow> (c\<^sub>1, s)" |
    OrRight: "(c\<^sub>1 OR c\<^sub>2, s) \<rightarrow> (c\<^sub>2, s)"

abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
  where "x \<rightarrow>* y == star small_step x y"

lemmas small_step_induct = small_step.induct[split_format(complete)]
declare small_step.intros[simp,intro]

lemma SS_SkipE [elim!]: "(SKIP, s) \<rightarrow> ct \<Longrightarrow> P"
  by (cases rule: small_step.cases) auto
lemma SS_AssignE [elim!]: "\<lbrakk>(x ::= a, s) \<rightarrow> ct; ct = (SKIP, s(x := aval a s)) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases rule: small_step.cases) auto
lemma SS_SeqE [elim]: "\<lbrakk>
  (c1;; c2, s) \<rightarrow> ct;
  \<lbrakk>ct = (c2, s); c1 = SKIP\<rbrakk> \<Longrightarrow> P;
  \<And>c\<^sub>1' s'. \<lbrakk>ct = (c\<^sub>1';; c2, s'); (c1, s) \<rightarrow> (c\<^sub>1', s')\<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: small_step.cases) auto
lemma SS_IfE [elim!]: "\<lbrakk>
  (IF b THEN c1 ELSE c2, s) \<rightarrow> ct;
  \<lbrakk>ct = (c1, s); bval b s\<rbrakk> \<Longrightarrow> P;
  \<lbrakk>ct = (c2, s); \<not> bval b s\<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: small_step.cases) auto
lemma SS_WhileE [elim]: "\<lbrakk>
  (WHILE b DO c, s) \<rightarrow> ct;
  ct = (IF b THEN c;; WHILE b DO c ELSE SKIP, s) \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: small_step.cases) auto
lemma SS_OrE [elim!]: "\<lbrakk>(c\<^sub>1 OR c\<^sub>2, s) \<rightarrow> ct; ct = (c\<^sub>1, s) \<Longrightarrow> P; ct = (c\<^sub>2, s) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases rule: small_step.cases) auto

lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
  by (induct rule: star_induct) (simp, blast intro: star.step)

lemma seq_comp: "\<lbrakk>(c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3)\<rbrakk>
  \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
  by (blast intro: star.step star_seq2 star_trans)

lemma big_to_small: "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
  by (induction rule: big_step.induct) (blast intro: seq_comp star.step)+

lemma small1_big_continue: "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
  by (induct arbitrary: t rule: small_step.induct) auto

lemma small_to_big: "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
  by (induct cs "(SKIP,t)" rule: star.induct) (auto intro: small1_big_continue)

theorem big_iff_small: "cs \<Rightarrow> t = cs \<rightarrow>* (SKIP,t)"
  by (blast intro: big_to_small small_to_big)

end


(*  Title:      HOL/Hoare/SchorrWaite.thy
    Author:     Farhad Mehta
    Copyright   2003 TUM

Proof of the Schorr-Waite graph marking algorithm.
*)

theory SchorrWaite imports HeapSyntax begin

section \<open>Machinery for the Schorr-Waite proof\<close>

definition
  \<comment> \<open>Relations induced by a mapping\<close>
  rel :: "('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<times> 'a) set"
  where "rel m = {(x,y). m x = Ref y}"

definition
  relS :: "('a \<Rightarrow> 'a ref) set \<Rightarrow> ('a \<times> 'a) set"
  where "relS M = (\<Union>m \<in> M. rel m)"

definition
  addrs :: "'a ref set \<Rightarrow> 'a set"
  where "addrs P = {a. Ref a \<in> P}"

definition
  reachable :: "('a \<times> 'a) set \<Rightarrow> 'a ref set \<Rightarrow> 'a set"
  where "reachable r P = (r\<^sup>* `` addrs P)"

lemmas rel_defs = relS_def rel_def

text \<open>Rewrite rules for relations induced by a mapping\<close>

lemma self_reachable: "b \<in> B \<Longrightarrow> b \<in> R\<^sup>* `` B"
apply blast
done

lemma oneStep_reachable: "b \<in> R``B \<Longrightarrow> b \<in> R\<^sup>* `` B"
apply blast
done

lemma still_reachable: "\<lbrakk>B\<subseteq>Ra\<^sup>*``A; \<forall> (x,y) \<in> Rb-Ra. y\<in> (Ra\<^sup>*``A)\<rbrakk> \<Longrightarrow> Rb\<^sup>* `` B \<subseteq> Ra\<^sup>* `` A "
apply (clarsimp simp only:Image_iff)
apply (erule rtrancl_induct)
 apply blast
apply (subgoal_tac "(y, z) \<in> Ra\<union>(Rb-Ra)")
 apply (erule UnE)
 apply (auto intro:rtrancl_into_rtrancl)
apply blast
done

lemma still_reachable_eq: "\<lbrakk> A\<subseteq>Rb\<^sup>*``B; B\<subseteq>Ra\<^sup>*``A; \<forall> (x,y) \<in> Ra-Rb. y \<in>(Rb\<^sup>*``B); \<forall> (x,y) \<in> Rb-Ra. y\<in> (Ra\<^sup>*``A)\<rbrakk> \<Longrightarrow> Ra\<^sup>*``A =  Rb\<^sup>*``B "
apply (rule equalityI)
 apply (erule still_reachable ,assumption)+
done

lemma reachable_null: "reachable mS {Null} = {}"
apply (simp add: reachable_def addrs_def)
done

lemma reachable_empty: "reachable mS {} = {}"
apply (simp add: reachable_def addrs_def)
done

lemma reachable_union: "(reachable mS aS \<union> reachable mS bS) = reachable mS (aS \<union> bS)"
apply (simp add: reachable_def rel_defs addrs_def)
apply blast
done

lemma reachable_union_sym: "reachable r (insert a aS) = (r\<^sup>* `` addrs {a}) \<union> reachable r aS"
apply (simp add: reachable_def rel_defs addrs_def)
apply blast
done

lemma rel_upd1: "(a,b) \<notin> rel (r(q:=t)) \<Longrightarrow> (a,b) \<in> rel r \<Longrightarrow> a=q"
apply (rule classical)
apply (simp add:rel_defs fun_upd_apply)
done

lemma rel_upd2: "(a,b)  \<notin> rel r \<Longrightarrow> (a,b) \<in> rel (r(q:=t)) \<Longrightarrow> a=q"
apply (rule classical)
apply (simp add:rel_defs fun_upd_apply)
done

definition
  \<comment> \<open>Restriction of a relation\<close>
  restr ::"('a \<times> 'a) set \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<times> 'a) set"       ("(_/ | _)" [50, 51] 50)
  where "restr r m = {(x,y). (x,y) \<in> r \<and> \<not> m x}"

text \<open>Rewrite rules for the restriction of a relation\<close>

lemma restr_identity[simp]:
 " (\<forall>x. \<not> m x) \<Longrightarrow> (R |m) = R"
by (auto simp add:restr_def)

lemma restr_rtrancl[simp]: " \<lbrakk>m l\<rbrakk> \<Longrightarrow> (R | m)\<^sup>* `` {l} = {l}"
by (auto simp add:restr_def elim:converse_rtranclE)

lemma restr_upd: "((rel (r (q := t)))|(m(q := True))) = ((rel (r))|(m(q := True))) "
apply (auto simp:restr_def rel_def fun_upd_apply)
apply (rename_tac a b)
apply (case_tac "a=q")
 apply auto
done

lemma restr_un: "((r \<union> s)|m) = (r|m) \<union> (s|m)"
  by (auto simp add:restr_def)

lemma rel_upd3: "(a, b) \<notin> (r|(m(q := t))) \<Longrightarrow> (a,b) \<in> (r|m) \<Longrightarrow> a = q "
apply (rule classical)
apply (simp add:restr_def fun_upd_apply)
done

definition
  \<comment> \<open>A short form for the stack mapping function for List\<close>
  S :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<Rightarrow> 'a ref)"
  where "S c l r = (\<lambda>x. if c x then r x else l x)"

text \<open>Rewrite rules for Lists using S as their mapping\<close>

lemma [rule_format,simp]:
 "\<forall>p. a \<notin> set stack \<longrightarrow> List (S c l r) p stack = List (S (c(a:=x)) (l(a:=y)) (r(a:=z))) p stack"
apply(induct_tac stack)
 apply(simp add:fun_upd_apply S_def)+
done

lemma [rule_format,simp]:
 "\<forall>p. a \<notin> set stack \<longrightarrow> List (S c l (r(a:=z))) p stack = List (S c l r) p stack"
apply(induct_tac stack)
 apply(simp add:fun_upd_apply S_def)+
done

lemma [rule_format,simp]:
 "\<forall>p. a \<notin> set stack \<longrightarrow> List (S c (l(a:=z)) r) p stack = List (S c l r) p stack"
apply(induct_tac stack)
 apply(simp add:fun_upd_apply S_def)+
done

lemma [rule_format,simp]:
 "\<forall>p. a \<notin> set stack \<longrightarrow> List (S (c(a:=z)) l r) p stack = List (S c l r) p stack"
apply(induct_tac stack)
 apply(simp add:fun_upd_apply S_def)+
done

primrec
  \<comment> \<open>Recursive definition of what is means for a the graph/stack structure to be reconstructible\<close>
  stkOk :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> ('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow>'a list \<Rightarrow>  bool"
where
  stkOk_nil:  "stkOk c l r iL iR t [] = True"
| stkOk_cons:
    "stkOk c l r iL iR t (p#stk) = (stkOk c l r iL iR (Ref p) (stk) \<and>
      iL p = (if c p then l p else t) \<and>
      iR p = (if c p then t else r p))"

text \<open>Rewrite rules for stkOk\<close>

lemma [simp]: "\<And>t. \<lbrakk> x \<notin> set xs; Ref x\<noteq>t \<rbrakk> \<Longrightarrow>
  stkOk (c(x := f)) l r iL iR t xs = stkOk c l r iL iR t xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

lemma [simp]: "\<And>t. \<lbrakk> x \<notin> set xs; Ref x\<noteq>t \<rbrakk> \<Longrightarrow>
 stkOk c (l(x := g)) r iL iR t xs = stkOk c l r iL iR t xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

lemma [simp]: "\<And>t. \<lbrakk> x \<notin> set xs; Ref x\<noteq>t \<rbrakk> \<Longrightarrow>
 stkOk c l (r(x := g)) iL iR t xs = stkOk c l r iL iR t xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

lemma stkOk_r_rewrite [simp]: "\<And>x. x \<notin> set xs \<Longrightarrow>
  stkOk c l (r(x := g)) iL iR (Ref x) xs = stkOk c l r iL iR (Ref x) xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

lemma [simp]: "\<And>x. x \<notin> set xs \<Longrightarrow>
 stkOk c (l(x := g)) r iL iR (Ref x) xs = stkOk c l r iL iR (Ref x) xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

lemma [simp]: "\<And>x. x \<notin> set xs \<Longrightarrow>
 stkOk (c(x := g)) l r iL iR (Ref x) xs = stkOk c l r iL iR (Ref x) xs"
apply (induct xs)
 apply (auto simp:eq_sym_conv)
done

section\<open>The Schorr-Waite algorithm\<close>

theorem SchorrWaiteAlgorithm:
"VARS c m l r t p q root
 {R = reachable (relS {l, r}) {root} \<and> (\<forall>x. \<not> m x) \<and> iR = r \<and> iL = l}
 t := root; p := Null;
 WHILE p \<noteq> Null \<or> t \<noteq> Null \<and> \<not> t^.m
 INV {\<exists>stack.
          List (S c l r) p stack \<and>                                      \<comment> \<open>\<open>i1\<close>\<close>
          (\<forall>x \<in> set stack. m x) \<and>                                       \<comment> \<open>\<open>i2\<close>\<close>
          R = reachable (relS{l, r}) {t,p} \<and>                            \<comment> \<open>\<open>i3\<close>\<close>
          (\<forall>x. x \<in> R \<and> \<not>m x \<longrightarrow>                                         \<comment> \<open>\<open>i4\<close>\<close>
                 x \<in> reachable (relS{l,r}|m) ({t}\<union>set(map r stack))) \<and>
          (\<forall>x. m x \<longrightarrow> x \<in> R) \<and>                                         \<comment> \<open>\<open>i5\<close>\<close>
          (\<forall>x. x \<notin> set stack \<longrightarrow> r x = iR x \<and> l x = iL x) \<and>             \<comment> \<open>\<open>i6\<close>\<close>
          (stkOk c l r iL iR t stack)                                   \<comment> \<open>\<open>i7\<close>\<close>}
 DO IF t = Null \<or> t^.m
      THEN IF p^.c
               THEN q := t; t := p; p := p^.r; t^.r := q                \<comment> \<open>\<open>pop\<close>\<close>
               ELSE q := t; t := p^.r; p^.r := p^.l;                    \<comment> \<open>\<open>swing\<close>\<close>
                        p^.l := q; p^.c := True          FI
      ELSE q := p; p := t; t := t^.l; p^.l := q;                        \<comment> \<open>\<open>push\<close>\<close>
               p^.m := True; p^.c := False            FI       OD
 {(\<forall>x. (x \<in> R) = m x) \<and> (r = iR \<and> l = iL) }"
  (is "VARS c m l r t p q root {?Pre c m l r root} (?c1; ?c2; ?c3) {?Post c m l r}")
proof (vcg)
  let "While {(c, m, l, r, t, p, q, root). ?whileB m t p}
    {(c, m, l, r, t, p, q, root). ?inv c m l r t p} ?body" = ?c3
  {

    fix c m l r t p q root
    assume "?Pre c m l r root"
    thus "?inv c m l r root Null"  by (auto simp add: reachable_def addrs_def)
  next

    fix c m l r t p q
    let "\<exists>stack. ?Inv stack"  =  "?inv c m l r t p"
    assume a: "?inv c m l r t p \<and> \<not>(p \<noteq> Null \<or> t \<noteq> Null \<and> \<not> t^.m)"
    then obtain stack where inv: "?Inv stack" by blast
    from a have pNull: "p = Null" and tDisj: "t=Null \<or> (t\<noteq>Null \<and> t^.m )" by auto
    let "?I1 \<and> _ \<and> _ \<and> ?I4 \<and> ?I5 \<and> ?I6 \<and> _"  =  "?Inv stack"
    from inv have i1: "?I1" and i4: "?I4" and i5: "?I5" and i6: "?I6" by simp+
    from pNull i1 have stackEmpty: "stack = []" by simp
    from tDisj i4 have RisMarked[rule_format]: "\<forall>x.  x \<in> R \<longrightarrow> m x"  by(auto simp: reachable_def addrs_def stackEmpty)
    from i5 i6 show "(\<forall>x.(x \<in> R) = m x) \<and> r = iR \<and> l = iL"  by(auto simp: stackEmpty fun_eq_iff intro:RisMarked)

  next
      fix c m l r t p q root
      let "\<exists>stack. ?Inv stack"  =  "?inv c m l r t p"
      let "\<exists>stack. ?popInv stack"  =  "?inv c m l (r(p \<rightarrow> t)) p (p^.r)"
      let "\<exists>stack. ?swInv stack"  =
        "?inv (c(p \<rightarrow> True)) m (l(p \<rightarrow> t)) (r(p \<rightarrow> p^.l)) (p^.r) p"
      let "\<exists>stack. ?puInv stack"  =
        "?inv (c(t \<rightarrow> False)) (m(t \<rightarrow> True)) (l(t \<rightarrow> p)) r (t^.l) t"
      let "?ifB1"  =  "(t = Null \<or> t^.m)"
      let "?ifB2"  =  "p^.c"

      assume "(\<exists>stack.?Inv stack) \<and> (p \<noteq> Null \<or> t \<noteq> Null \<and> \<not> t^.m)" (is "_ \<and> ?whileB")
      then obtain stack where inv: "?Inv stack" and whileB: "?whileB" by blast
      let "?I1 \<and> ?I2 \<and> ?I3 \<and> ?I4 \<and> ?I5 \<and> ?I6 \<and> ?I7" = "?Inv stack"
      from inv have i1: "?I1" and i2: "?I2" and i3: "?I3" and i4: "?I4"
                  and i5: "?I5" and i6: "?I6" and i7: "?I7" by simp+
      have stackDist: "distinct (stack)" using i1 by (rule List_distinct)

      show "(?ifB1 \<longrightarrow> (?ifB2 \<longrightarrow> (\<exists>stack.?popInv stack)) \<and>
                            (\<not>?ifB2 \<longrightarrow> (\<exists>stack.?swInv stack)) ) \<and>
              (\<not>?ifB1 \<longrightarrow> (\<exists>stack.?puInv stack))"
      proof -
        {
          assume ifB1: "t = Null \<or> t^.m" and ifB2: "p^.c"
          from ifB1 whileB have pNotNull: "p \<noteq> Null" by auto
          then obtain addr_p where addr_p_eq: "p = Ref addr_p" by auto
          with i1 obtain stack_tl where stack_eq: "stack = (addr p) # stack_tl"
            by auto
          with i2 have m_addr_p: "p^.m" by auto
          have stackDist: "distinct (stack)" using i1 by (rule List_distinct)
          from stack_eq stackDist have p_notin_stack_tl: "addr p \<notin> set stack_tl" by simp
          let "?poI1\<and> ?poI2\<and> ?poI3\<and> ?poI4\<and> ?poI5\<and> ?poI6\<and> ?poI7" = "?popInv stack_tl"
          have "?popInv stack_tl"
          proof -

            \<comment> \<open>List property is maintained:\<close>
            from i1 p_notin_stack_tl ifB2
            have poI1: "List (S c l (r(p \<rightarrow> t))) (p^.r) stack_tl"
              by(simp add: addr_p_eq stack_eq, simp add: S_def)

            moreover
            \<comment> \<open>Everything on the stack is marked:\<close>
            from i2 have poI2: "\<forall> x \<in> set stack_tl. m x" by (simp add:stack_eq)
            moreover

            \<comment> \<open>Everything is still reachable:\<close>
            let "(R = reachable ?Ra ?A)" = "?I3"
            let "?Rb" = "(relS {l, r(p \<rightarrow> t)})"
            let "?B" = "{p, p^.r}"
            \<comment> \<open>Our goal is \<open>R = reachable ?Rb ?B\<close>.\<close>
            have "?Ra\<^sup>* `` addrs ?A = ?Rb\<^sup>* `` addrs ?B" (is "?L = ?R")
            proof
              show "?L \<subseteq> ?R"
              proof (rule still_reachable)
                show "addrs ?A \<subseteq> ?Rb\<^sup>* `` addrs ?B" by(fastforce simp:addrs_def relS_def rel_def addr_p_eq
                     intro:oneStep_reachable Image_iff[THEN iffD2])
                show "\<forall>(x,y) \<in> ?Ra-?Rb. y \<in> (?Rb\<^sup>* `` addrs ?B)" by (clarsimp simp:relS_def)
                     (fastforce simp add:rel_def Image_iff addrs_def dest:rel_upd1)
              qed
              show "?R \<subseteq> ?L"
              proof (rule still_reachable)
                show "addrs ?B \<subseteq> ?Ra\<^sup>* `` addrs ?A"
                  by(fastforce simp:addrs_def rel_defs addr_p_eq
                      intro:oneStep_reachable Image_iff[THEN iffD2])
              next
                show "\<forall>(x, y)\<in>?Rb-?Ra. y\<in>(?Ra\<^sup>*``addrs ?A)"
                  by (clarsimp simp:relS_def)
                     (fastforce simp add:rel_def Image_iff addrs_def dest:rel_upd2)
              qed
            qed
            with i3 have poI3: "R = reachable ?Rb ?B"  by (simp add:reachable_def)
            moreover

            \<comment> \<open>If it is reachable and not marked, it is still reachable using...\<close>
            let "\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Ra ?A"  =  ?I4
            let "?Rb" = "relS {l, r(p \<rightarrow> t)} | m"
            let "?B" = "{p} \<union> set (map (r(p \<rightarrow> t)) stack_tl)"
            \<comment> \<open>Our goal is \<open>\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Rb ?B\<close>.\<close>
            let ?T = "{t, p^.r}"

            have "?Ra\<^sup>* `` addrs ?A \<subseteq> ?Rb\<^sup>* `` (addrs ?B \<union> addrs ?T)"
            proof (rule still_reachable)
              have rewrite: "\<forall>s\<in>set stack_tl. (r(p \<rightarrow> t)) s = r s"
                by (auto simp add:p_notin_stack_tl intro:fun_upd_other)
              show "addrs ?A \<subseteq> ?Rb\<^sup>* `` (addrs ?B \<union> addrs ?T)"
                by (fastforce cong:map_cong simp:stack_eq addrs_def rewrite intro:self_reachable)
              show "\<forall>(x, y)\<in>?Ra-?Rb. y\<in>(?Rb\<^sup>*``(addrs ?B \<union> addrs ?T))"
                by (clarsimp simp:restr_def relS_def)
                  (fastforce simp add:rel_def Image_iff addrs_def dest:rel_upd1)
            qed
            \<comment> \<open>We now bring a term from the right to the left of the subset relation.\<close>
            hence subset: "?Ra\<^sup>* `` addrs ?A - ?Rb\<^sup>* `` addrs ?T \<subseteq> ?Rb\<^sup>* `` addrs ?B"
              by blast
            have poI4: "\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Rb ?B"
            proof (rule allI, rule impI)
              fix x
              assume a: "x \<in> R \<and> \<not> m x"
              \<comment> \<open>First, a disjunction on \<^term>\<open>p^.r\<close> used later in the proof\<close>
              have pDisj:"p^.r = Null \<or> (p^.r \<noteq> Null \<and> p^.r^.m)" using poI1 poI2
                by auto
              \<comment> \<open>\<^term>\<open>x\<close> belongs to the left hand side of @{thm[source] subset}:\<close>
              have incl: "x \<in> ?Ra\<^sup>*``addrs ?A" using  a i4 by (simp only:reachable_def, clarsimp)
              have excl: "x \<notin> ?Rb\<^sup>*`` addrs ?T" using pDisj ifB1 a by (auto simp add:addrs_def)
              \<comment> \<open>And therefore also belongs to the right hand side of @{thm[source]subset},\<close>
              \<comment> \<open>which corresponds to our goal.\<close>
              from incl excl subset  show "x \<in> reachable ?Rb ?B" by (auto simp add:reachable_def)
            qed
            moreover

            \<comment> \<open>If it is marked, then it is reachable\<close>
            from i5 have poI5: "\<forall>x. m x \<longrightarrow> x \<in> R" .
            moreover

            \<comment> \<open>If it is not on the stack, then its \<^term>\<open>l\<close> and \<^term>\<open>r\<close> fields are unchanged\<close>
            from i7 i6 ifB2
            have poI6: "\<forall>x. x \<notin> set stack_tl \<longrightarrow> (r(p \<rightarrow> t)) x = iR x \<and> l x = iL x"
              by(auto simp: addr_p_eq stack_eq fun_upd_apply)

            moreover

            \<comment> \<open>If it is on the stack, then its \<^term>\<open>l\<close> and \<^term>\<open>r\<close> fields can be reconstructed\<close>
            from p_notin_stack_tl i7 have poI7: "stkOk c l (r(p \<rightarrow> t)) iL iR p stack_tl"
              by (clarsimp simp:stack_eq addr_p_eq)

            ultimately show "?popInv stack_tl" by simp
          qed
          hence "\<exists>stack. ?popInv stack" ..
        }
        moreover

        \<comment> \<open>Proofs of the Swing and Push arm follow.\<close>
        \<comment> \<open>Since they are in principle simmilar to the Pop arm proof,\<close>
        \<comment> \<open>we show fewer comments and use frequent pattern matching.\<close>
        {
          \<comment> \<open>Swing arm\<close>
          assume ifB1: "?ifB1" and nifB2: "\<not>?ifB2"
          from ifB1 whileB have pNotNull: "p \<noteq> Null" by clarsimp
          then obtain addr_p where addr_p_eq: "p = Ref addr_p" by clarsimp
          with i1 obtain stack_tl where stack_eq: "stack = (addr p) # stack_tl" by clarsimp
          with i2 have m_addr_p: "p^.m" by clarsimp
          from stack_eq stackDist have p_notin_stack_tl: "(addr p) \<notin> set stack_tl"
            by simp
          let "?swI1\<and>?swI2\<and>?swI3\<and>?swI4\<and>?swI5\<and>?swI6\<and>?swI7" = "?swInv stack"
          have "?swInv stack"
          proof -

            \<comment> \<open>List property is maintained:\<close>
            from i1 p_notin_stack_tl nifB2
            have swI1: "?swI1"
              by (simp add:addr_p_eq stack_eq, simp add:S_def)
            moreover

            \<comment> \<open>Everything on the stack is marked:\<close>
            from i2
            have swI2: "?swI2" .
            moreover

            \<comment> \<open>Everything is still reachable:\<close>
            let "R = reachable ?Ra ?A" = "?I3"
            let "R = reachable ?Rb ?B" = "?swI3"
            have "?Ra\<^sup>* `` addrs ?A = ?Rb\<^sup>* `` addrs ?B"
            proof (rule still_reachable_eq)
              show "addrs ?A \<subseteq> ?Rb\<^sup>* `` addrs ?B"
                by(fastforce simp:addrs_def rel_defs addr_p_eq intro:oneStep_reachable Image_iff[THEN iffD2])
            next
              show "addrs ?B \<subseteq> ?Ra\<^sup>* `` addrs ?A"
                by(fastforce simp:addrs_def rel_defs addr_p_eq intro:oneStep_reachable Image_iff[THEN iffD2])
            next
              show "\<forall>(x, y)\<in>?Ra-?Rb. y\<in>(?Rb\<^sup>*``addrs ?B)"
                by (clarsimp simp:relS_def) (fastforce simp add:rel_def Image_iff addrs_def fun_upd_apply dest:rel_upd1)
            next
              show "\<forall>(x, y)\<in>?Rb-?Ra. y\<in>(?Ra\<^sup>*``addrs ?A)"
                by (clarsimp simp:relS_def) (fastforce simp add:rel_def Image_iff addrs_def fun_upd_apply dest:rel_upd2)
            qed
            with i3
            have swI3: "?swI3" by (simp add:reachable_def)
            moreover

            \<comment> \<open>If it is reachable and not marked, it is still reachable using...\<close>
            let "\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Ra ?A" = ?I4
            let "\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Rb ?B" = ?swI4
            let ?T = "{t}"
            have "?Ra\<^sup>*``addrs ?A \<subseteq> ?Rb\<^sup>*``(addrs ?B \<union> addrs ?T)"
            proof (rule still_reachable)
              have rewrite: "(\<forall>s\<in>set stack_tl. (r(addr p := l(addr p))) s = r s)"
                by (auto simp add:p_notin_stack_tl intro:fun_upd_other)
              show "addrs ?A \<subseteq> ?Rb\<^sup>* `` (addrs ?B \<union> addrs ?T)"
                by (fastforce cong:map_cong simp:stack_eq addrs_def rewrite intro:self_reachable)
            next
              show "\<forall>(x, y)\<in>?Ra-?Rb. y\<in>(?Rb\<^sup>*``(addrs ?B \<union> addrs ?T))"
                by (clarsimp simp:relS_def restr_def) (fastforce simp add:rel_def Image_iff addrs_def fun_upd_apply dest:rel_upd1)
            qed
            then have subset: "?Ra\<^sup>*``addrs ?A - ?Rb\<^sup>*``addrs ?T \<subseteq> ?Rb\<^sup>*``addrs ?B"
              by blast
            have ?swI4
            proof (rule allI, rule impI)
              fix x
              assume a: "x \<in> R \<and>\<not> m x"
              with i4 addr_p_eq stack_eq  have inc: "x \<in> ?Ra\<^sup>*``addrs ?A"
                by (simp only:reachable_def, clarsimp)
              with ifB1 a
              have exc: "x \<notin> ?Rb\<^sup>*`` addrs ?T"
                by (auto simp add:addrs_def)
              from inc exc subset  show "x \<in> reachable ?Rb ?B"
                by (auto simp add:reachable_def)
            qed
            moreover

            \<comment> \<open>If it is marked, then it is reachable\<close>
            from i5
            have "?swI5" .
            moreover

            \<comment> \<open>If it is not on the stack, then its \<^term>\<open>l\<close> and \<^term>\<open>r\<close> fields are unchanged\<close>
            from i6 stack_eq
            have "?swI6"
              by clarsimp
            moreover

            \<comment> \<open>If it is on the stack, then its \<^term>\<open>l\<close> and \<^term>\<open>r\<close> fields can be reconstructed\<close>
            from stackDist i7 nifB2
            have "?swI7"
              by (clarsimp simp:addr_p_eq stack_eq)

            ultimately show ?thesis by auto
          qed
          then have "\<exists>stack. ?swInv stack" by blast
        }
        moreover

        {
          \<comment> \<open>Push arm\<close>
          assume nifB1: "\<not>?ifB1"
          from nifB1 whileB have tNotNull: "t \<noteq> Null" by clarsimp
          then obtain addr_t where addr_t_eq: "t = Ref addr_t" by clarsimp
          with i1 obtain new_stack where new_stack_eq: "new_stack = (addr t) # stack" by clarsimp
          from tNotNull nifB1 have n_m_addr_t: "\<not> (t^.m)" by clarsimp
          with i2 have t_notin_stack: "(addr t) \<notin> set stack" by blast
          let "?puI1\<and>?puI2\<and>?puI3\<and>?puI4\<and>?puI5\<and>?puI6\<and>?puI7" = "?puInv new_stack"
          have "?puInv new_stack"
          proof -

            \<comment> \<open>List property is maintained:\<close>
            from i1 t_notin_stack
            have puI1: "?puI1"
              by (simp add:addr_t_eq new_stack_eq, simp add:S_def)
            moreover

            \<comment> \<open>Everything on the stack is marked:\<close>
            from i2
            have puI2: "?puI2"
              by (simp add:new_stack_eq fun_upd_apply)
            moreover

            \<comment> \<open>Everything is still reachable:\<close>
            let "R = reachable ?Ra ?A" = "?I3"
            let "R = reachable ?Rb ?B" = "?puI3"
            have "?Ra\<^sup>* `` addrs ?A = ?Rb\<^sup>* `` addrs ?B"
            proof (rule still_reachable_eq)
              show "addrs ?A \<subseteq> ?Rb\<^sup>* `` addrs ?B"
                by(fastforce simp:addrs_def rel_defs addr_t_eq intro:oneStep_reachable Image_iff[THEN iffD2])
            next
              show "addrs ?B \<subseteq> ?Ra\<^sup>* `` addrs ?A"
                by(fastforce simp:addrs_def rel_defs addr_t_eq intro:oneStep_reachable Image_iff[THEN iffD2])
            next
              show "\<forall>(x, y)\<in>?Ra-?Rb. y\<in>(?Rb\<^sup>*``addrs ?B)"
                by (clarsimp simp:relS_def) (fastforce simp add:rel_def Image_iff addrs_def dest:rel_upd1)
            next
              show "\<forall>(x, y)\<in>?Rb-?Ra. y\<in>(?Ra\<^sup>*``addrs ?A)"
                by (clarsimp simp:relS_def) (fastforce simp add:rel_def Image_iff addrs_def fun_upd_apply dest:rel_upd2)
            qed
            with i3
            have puI3: "?puI3" by (simp add:reachable_def)
            moreover

            \<comment> \<open>If it is reachable and not marked, it is still reachable using...\<close>
            let "\<forall>x. x \<in> R \<and> \<not> m x \<longrightarrow> x \<in> reachable ?Ra ?A" = ?I4
            let "\<forall>x. x \<in> R \<and> \<not> ?new_m x \<longrightarrow> x \<in> reachable ?Rb ?B" = ?puI4
            let ?T = "{t}"
            have "?Ra\<^sup>*``addrs ?A \<subseteq> ?Rb\<^sup>*``(addrs ?B \<union> addrs ?T)"
            proof (rule still_reachable)
              show "addrs ?A \<subseteq> ?Rb\<^sup>* `` (addrs ?B \<union> addrs ?T)"
                by (fastforce simp:new_stack_eq addrs_def intro:self_reachable)
            next
              show "\<forall>(x, y)\<in>?Ra-?Rb. y\<in>(?Rb\<^sup>*``(addrs ?B \<union> addrs ?T))"
                by (clarsimp simp:relS_def new_stack_eq restr_un restr_upd)
                   (fastforce simp add:rel_def Image_iff restr_def addrs_def fun_upd_apply addr_t_eq dest:rel_upd3)
            qed
            then have subset: "?Ra\<^sup>*``addrs ?A - ?Rb\<^sup>*``addrs ?T \<subseteq> ?Rb\<^sup>*``addrs ?B"
              by blast
            have ?puI4
            proof (rule allI, rule impI)
              fix x
              assume a: "x \<in> R \<and> \<not> ?new_m x"
              have xDisj: "x=(addr t) \<or> x\<noteq>(addr t)" by simp
              with i4 a have inc: "x \<in> ?Ra\<^sup>*``addrs ?A"
                by (fastforce simp:addr_t_eq addrs_def reachable_def intro:self_reachable)
              have exc: "x \<notin> ?Rb\<^sup>*`` addrs ?T"
                using xDisj a n_m_addr_t
                by (clarsimp simp add:addrs_def addr_t_eq)
              from inc exc subset  show "x \<in> reachable ?Rb ?B"
                by (auto simp add:reachable_def)
            qed
            moreover

            \<comment> \<open>If it is marked, then it is reachable\<close>
            from i5
            have "?puI5"
              by (auto simp:addrs_def i3 reachable_def addr_t_eq fun_upd_apply intro:self_reachable)
            moreover

            \<comment> \<open>If it is not on the stack, then its \<^term>\<open>l\<close> and \<^term>\<open>r\<close> fields are unchanged\<close>
            from i6
            have "?puI6"
              by (simp add:new_stack_eq)
            moreover

            \<comment> \<open>If it is on the stack, then its \<^term>\<open>l\<close> and \<^term>\<open>r\<close> fields can be reconstructed\<close>
            from stackDist i6 t_notin_stack i7
            have "?puI7" by (clarsimp simp:addr_t_eq new_stack_eq)

            ultimately show ?thesis by auto
          qed
          then have "\<exists>stack. ?puInv stack" by blast

        }
        ultimately show ?thesis by blast
      qed
    }
  qed

end


(*  Title:       Verification components with predicate transformers
    Author:      Jonathan Julián Huerta y Munive, 2019
    Maintainer:  Jonathan Julián Huerta y Munive <jjhuertaymunive1@sheffield.ac.uk>
*)

section \<open> Verification components with predicate transformers \<close>

text \<open> We use the categorical forward box operator @{text fb\<^sub>\<F>} to compute weakest liberal
preconditions (wlps) of hybrid programs. Then we repeat the three methods for verifying
correctness specifications of the continuous dynamics of a HS. \<close>

theory HS_VC_PT
  imports "../HS_ODEs" "Transformer_Semantics.Kleisli_Quantale"

begin

\<comment> \<open>We start by deleting some notation and introducing some new.\<close>

no_notation bres (infixr "\<rightarrow>" 60)
        and dagger ("_\<^sup>\<dagger>" [101] 100)
        and "Relation.relcomp" (infixl ";" 75)
        and eta ("\<eta>")
        and kcomp (infixl "\<circ>\<^sub>K" 75)

type_synonym 'a pred = "'a \<Rightarrow> bool"

notation eta ("skip")
     and kcomp (infixl ";" 75)
     and g_orbital ("(1x\<acute>=_ & _ on _ _ @ _)")

subsection \<open>Verification of regular programs\<close>

text \<open>Properties of the forward box operator. \<close>

lemma "fb\<^sub>\<F> F S = {s. F s \<subseteq> S}"
  unfolding ffb_def map_dual_def klift_def kop_def dual_set_def
  by(auto simp: Compl_eq_Diff_UNIV fun_eq_iff f2r_def converse_def r2f_def)

lemma ffb_eq: "fb\<^sub>\<F> F S = {s. \<forall>s'. s' \<in> F s \<longrightarrow> s' \<in> S}"
  unfolding ffb_def apply(simp add: kop_def klift_def map_dual_def)
  unfolding dual_set_def f2r_def r2f_def by auto

lemma ffb_iso: "P \<le> Q \<Longrightarrow> fb\<^sub>\<F> F P \<le> fb\<^sub>\<F> F Q"
  unfolding ffb_eq by auto

lemma ffb_invariants:
  assumes "{s. I s} \<le> fb\<^sub>\<F> F {s. I s}" and "{s. J s} \<le> fb\<^sub>\<F> F {s. J s}"
  shows "{s. I s \<and> J s} \<le> fb\<^sub>\<F> F {s. I s \<and> J s}"
    and "{s. I s \<or> J s} \<le> fb\<^sub>\<F> F {s. I s \<or> J s}"
  using assms unfolding ffb_eq by auto

text \<open>The weakest liberal precondition (wlp) of the ``skip'' program is the identity. \<close>

lemma ffb_skip[simp]: "fb\<^sub>\<F> skip S = S"
  unfolding ffb_def by(simp add: kop_def klift_def map_dual_def)

text \<open>Next, we introduce assignments and their wlps.\<close>

definition vec_upd :: "('a^'n) \<Rightarrow> 'n \<Rightarrow> 'a \<Rightarrow> 'a^'n"
  where "vec_upd s i a = (\<chi> j. ((($) s)(i := a)) j)"

definition assign :: "'n \<Rightarrow> ('a^'n \<Rightarrow> 'a) \<Rightarrow> ('a^'n) \<Rightarrow> ('a^'n) set" ("(2_ ::= _)" [70, 65] 61)
  where "(x ::= e) = (\<lambda>s. {vec_upd s x (e s)})"

lemma ffb_assign[simp]: "fb\<^sub>\<F> (x ::= e) Q = {s. (\<chi> j. ((($) s)(x := (e s))) j) \<in> Q}"
  unfolding vec_upd_def assign_def by (subst ffb_eq) simp

text \<open>The wlp of program composition is just the composition of the wlps.\<close>

lemma ffb_kcomp[simp]: "fb\<^sub>\<F> (G ; F) P = fb\<^sub>\<F> G (fb\<^sub>\<F> F P)"
  unfolding ffb_def apply(simp add: kop_def klift_def map_dual_def)
  unfolding dual_set_def f2r_def r2f_def by(auto simp: kcomp_def)

lemma hoare_kcomp:
  assumes "P \<le> fb\<^sub>\<F> F R" "R \<le> fb\<^sub>\<F> G Q"
  shows "P \<le> fb\<^sub>\<F> (F ; G) Q"
  apply(subst ffb_kcomp)
  by (rule order.trans[OF assms(1)]) (rule ffb_iso[OF assms(2)])

text \<open>We also have an implementation of the conditional operator and its wlp.\<close>

definition ifthenelse :: "'a pred \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b set)"
  ("IF _ THEN _ ELSE _" [64,64,64] 63) where
  "IF P THEN X ELSE Y = (\<lambda> x. if P x then X x else Y x)"

lemma ffb_if_then_else[simp]:
  "fb\<^sub>\<F> (IF T THEN X ELSE Y) Q = {s. T s \<longrightarrow> s \<in> fb\<^sub>\<F> X Q} \<inter> {s. \<not> T s \<longrightarrow> s \<in> fb\<^sub>\<F> Y Q}"
  unfolding ffb_eq ifthenelse_def by auto

lemma hoare_if_then_else:
  assumes "P \<inter> {s. T s} \<le> fb\<^sub>\<F> X Q"
    and "P \<inter> {s. \<not> T s} \<le> fb\<^sub>\<F> Y Q"
  shows "P \<le> fb\<^sub>\<F> (IF T THEN X ELSE Y) Q"
  using assms
  apply(subst ffb_eq)
  apply(subst (asm) ffb_eq)+
  unfolding ifthenelse_def by auto

text\<open> We also deal with finite iteration. \<close>

lemma kpower_inv: "I \<le> {s. \<forall>y. y \<in> F s \<longrightarrow> y \<in> I} \<Longrightarrow> I \<le> {s. \<forall>y. y \<in> (kpower F n s) \<longrightarrow> y \<in> I}"
  apply(induct n, simp)
  apply simp
  by(auto simp: kcomp_prop)

lemma kstar_inv: "I \<le> fb\<^sub>\<F> F I \<Longrightarrow> I \<subseteq> fb\<^sub>\<F> (kstar F) I"
  unfolding kstar_def ffb_eq apply clarsimp
  using kpower_inv by blast

lemma ffb_kstarI:
  assumes "P \<le> I" and "I \<le> Q" and "I \<le> fb\<^sub>\<F> F I"
  shows "P \<le> fb\<^sub>\<F> (kstar F) Q"
proof-
  have "I \<subseteq> fb\<^sub>\<F> (kstar F) I"
    using assms(3) kstar_inv by blast
  hence "P \<le> fb\<^sub>\<F> (kstar F) I"
    using assms(1) by auto
  also have "fb\<^sub>\<F> (kstar F) I \<le> fb\<^sub>\<F> (kstar F) Q"
    by (rule ffb_iso[OF assms(2)])
  finally show ?thesis .
qed

definition loopi :: "('a \<Rightarrow> 'a set) \<Rightarrow> 'a pred \<Rightarrow> ('a \<Rightarrow> 'a set)" ("LOOP _ INV _ " [64,64] 63)
  where "LOOP F INV I \<equiv> (kstar F)"

lemma ffb_loopI: "P \<le> {s. I s}  \<Longrightarrow> {s. I s} \<le> Q \<Longrightarrow> {s. I s} \<le> fb\<^sub>\<F> F {s. I s} \<Longrightarrow> P \<le> fb\<^sub>\<F> (LOOP F INV I) Q"
  unfolding loopi_def using ffb_kstarI[of "P"] by simp

subsection \<open>Verification of hybrid programs\<close>

text \<open>Verification by providing evolution\<close>

definition g_evol :: "(('a::ord) \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b pred \<Rightarrow> 'a set \<Rightarrow> ('b \<Rightarrow> 'b set)" ("EVOL")
  where "EVOL \<phi> G T = (\<lambda>s. g_orbit (\<lambda>t. \<phi> t s) G T)"

lemma fbox_g_evol[simp]:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "fb\<^sub>\<F> (EVOL \<phi> G T) Q = {s. (\<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> (\<phi> t s) \<in> Q)}"
  unfolding g_evol_def g_orbit_eq ffb_eq by auto

text \<open>Verification by providing solutions\<close>

lemma ffb_g_orbital: "fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) Q =
  {s. \<forall>X\<in>Sols (\<lambda>t. f) T S t\<^sub>0 s. \<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (X \<tau>)) \<longrightarrow> (X t) \<in> Q}"
  unfolding ffb_eq g_orbital_eq subset_eq by (auto simp: fun_eq_iff)

context local_flow
begin

lemma ffb_g_ode: "fb\<^sub>\<F> (x\<acute>= f & G on T S @ 0) Q =
  {s. s \<in> S \<longrightarrow> (\<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> (\<phi> t s) \<in> Q)}" (is "_ = ?wlp")
  unfolding ffb_g_orbital
  apply(safe, clarsimp)
    apply(erule_tac x="\<lambda>t. \<phi> t x" in ballE)
  using in_ivp_sols
     apply(force, force, force simp: init_time ivp_sols_def)
  apply(subgoal_tac "\<forall>\<tau>\<in>down T t. X \<tau> = \<phi> \<tau> x", simp_all, clarsimp)
  apply(subst eq_solution, simp_all add: ivp_sols_def)
  using init_time by auto

lemma ffb_orbit: "fb\<^sub>\<F> \<gamma>\<^sup>\<phi> Q = {s. s \<in> S \<longrightarrow> (\<forall> t \<in> T. \<phi> t s \<in> Q)}"
  unfolding orbit_def ffb_g_ode by simp

end

text \<open> Verification with differential invariants \<close>

definition g_ode_inv :: "(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> real set \<Rightarrow> 'a set \<Rightarrow>
  real \<Rightarrow> 'a pred \<Rightarrow> ('a \<Rightarrow> 'a set)" ("(1x\<acute>=_ & _ on _ _ @ _ DINV _ )")
  where "(x\<acute>= f & G on T S @ t\<^sub>0 DINV I) = (x\<acute>= f & G on T S @ t\<^sub>0)"

lemma ffb_g_orbital_guard:
  assumes "H = (\<lambda>s. G s \<and> Q s)"
  shows "fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) {s. Q s} = fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) {s. H s}"
  unfolding ffb_g_orbital using assms by auto

lemma ffb_g_orbital_inv:
  assumes "P \<le> I" and "I \<le> fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) I" and "I \<le> Q"
  shows "P \<le> fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) Q"
  using assms(1)
  apply(rule order.trans)
  using assms(2)
  apply(rule order.trans)
  by (rule ffb_iso[OF assms(3)])

lemma ffb_diff_inv[simp]:
  "({s. I s} \<le> fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) {s. I s}) = diff_invariant I f T S t\<^sub>0 G"
  by (auto simp: diff_invariant_def ivp_sols_def ffb_eq g_orbital_eq)

lemma bdf_diff_inv:
  "diff_invariant I f T S t\<^sub>0 G = (bd\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) {s. I s} \<le> {s. I s})"
  unfolding ffb_fbd_galois_var by (auto simp: diff_invariant_def ivp_sols_def ffb_eq g_orbital_eq)

lemma diff_inv_guard_ignore:
  assumes "{s. I s} \<le> fb\<^sub>\<F> (x\<acute>= f & (\<lambda>s. True) on T S @ t\<^sub>0) {s. I s}"
  shows "{s. I s} \<le> fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) {s. I s}"
  using assms unfolding ffb_diff_inv diff_invariant_eq image_le_pred by auto

context local_flow
begin

lemma ffb_diff_inv_eq: "diff_invariant I f T S 0 (\<lambda>s. True) =
  ({s. s \<in> S \<longrightarrow> I s} = fb\<^sub>\<F> (x\<acute>= f & (\<lambda>s. True) on T S @ 0) {s. s \<in> S \<longrightarrow> I s})"
  unfolding ffb_diff_inv[symmetric] ffb_g_orbital
  using init_time
  apply(clarsimp simp: subset_eq ivp_sols_def)
  apply(safe, force, force)
   apply(subst ivp(2)[symmetric], simp)
   apply(erule_tac x="\<lambda>t. \<phi> t x" in allE)
  using in_domain has_vderiv_on_domain ivp(2) init_time by auto

lemma diff_inv_eq_inv_set:
  "diff_invariant I f T S 0 (\<lambda>s. True) = (\<forall>s. I s \<longrightarrow> \<gamma>\<^sup>\<phi> s \<subseteq> {s. I s})"
  unfolding diff_inv_eq_inv_set orbit_def by simp

end

lemma ffb_g_odei: "P \<le> {s. I s} \<Longrightarrow> {s. I s} \<le> fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) {s. I s} \<Longrightarrow>
  {s. I s \<and> G s} \<le> Q \<Longrightarrow> P \<le> fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0 DINV I) Q"
  unfolding g_ode_inv_def
  apply(rule_tac b="fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) {s. I s}" in order.trans)
   apply(rule_tac I="{s. I s}" in ffb_g_orbital_inv, simp_all)
  apply(subst ffb_g_orbital_guard, simp)
  by (rule ffb_iso, force)

subsection \<open> Derivation of the rules of dL \<close>

text\<open> We derive domain specific rules of differential dynamic logic (dL). First we present a
generalised version, then we show the rules as instances of the general ones.\<close>

lemma diff_solve_axiom:
  fixes c::"'a::{heine_borel, banach}"
  assumes "0 \<in> T" and "is_interval T" "open T"
  shows "fb\<^sub>\<F> (x\<acute>=(\<lambda>s. c) & G on T UNIV @ 0) Q =
  {s. \<forall>t\<in>T. (\<P> (\<lambda>\<tau>. s + \<tau> *\<^sub>R c) (down T t) \<subseteq> {s. G s}) \<longrightarrow> (s + t *\<^sub>R c) \<in> Q}"
  apply(subst local_flow.ffb_g_ode[of "\<lambda>s. c" _ _ "(\<lambda>t s. s + t *\<^sub>R c)"])
  using line_is_local_flow assms unfolding image_le_pred by auto

lemma diff_solve_rule:
  assumes "local_flow f T UNIV \<phi>"
    and "\<forall>s. s \<in> P \<longrightarrow> (\<forall> t\<in>T. (\<P> (\<lambda>t. \<phi> t s) (down T t) \<subseteq> {s. G s}) \<longrightarrow> (\<phi> t s) \<in> Q)"
  shows "P \<le> fb\<^sub>\<F> (x\<acute>= f & G on T UNIV @ 0) Q"
  using assms by(subst local_flow.ffb_g_ode) auto

lemma diff_weak_axiom: "fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) Q = fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) {s. G s \<longrightarrow> s \<in> Q}"
  unfolding ffb_g_orbital image_def by force

lemma diff_weak_rule: "{s. G s} \<le> Q \<Longrightarrow> P \<le> fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) Q"
  by(auto intro: g_orbitalD simp: le_fun_def g_orbital_eq ffb_eq)

lemma ffb_g_orbital_eq_univD:
  assumes "fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) {s. C s} = UNIV"
    and "\<forall>\<tau>\<in>(down T t). x \<tau> \<in> (x\<acute>= f & G on T S @ t\<^sub>0) s"
  shows "\<forall>\<tau>\<in>(down T t). C (x \<tau>)"
proof
  fix \<tau> assume "\<tau> \<in> (down T t)"
  hence "x \<tau> \<in> (x\<acute>= f & G on T S @ t\<^sub>0) s"
    using assms(2) by blast
  also have "\<forall>y. y \<in> (x\<acute>= f & G on T S @ t\<^sub>0) s \<longrightarrow> C y"
    using assms(1) unfolding ffb_eq by fastforce
  ultimately show "C (x \<tau>)" by blast
qed

lemma diff_cut_axiom:
  assumes Thyp: "is_interval T" "t\<^sub>0 \<in> T"
    and "fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) {s. C s} = UNIV"
  shows "fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) Q = fb\<^sub>\<F> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on T S @ t\<^sub>0) Q"
proof(rule_tac f="\<lambda> x. fb\<^sub>\<F> x Q" in HOL.arg_cong, rule ext, rule subset_antisym)
  fix s
  {fix s' assume "s' \<in> (x\<acute>= f & G on T S @ t\<^sub>0) s"
    then obtain \<tau>::real and X where x_ivp: "X \<in> Sols (\<lambda>t. f) T S t\<^sub>0 s"
      and "X \<tau> = s'" and "\<tau> \<in> T" and guard_x:"\<P> X (down T \<tau>) \<subseteq> {s. G s}"
      using g_orbitalD[of s' "f" G T S t\<^sub>0 s]  by blast
    have "\<forall>t\<in>(down T \<tau>). \<P> X (down T t) \<subseteq> {s. G s}"
      using guard_x by (force simp: image_def)
    also have "\<forall>t\<in>(down T \<tau>). t \<in> T"
      using \<open>\<tau> \<in> T\<close> Thyp closed_segment_subset_interval by auto
    ultimately have "\<forall>t\<in>(down T \<tau>). X t \<in> (x\<acute>= f & G on T S @ t\<^sub>0) s"
      using g_orbitalI[OF x_ivp] by (metis (mono_tags, lifting))
    hence "\<forall>t\<in>(down T \<tau>). C (X t)"
      using assms unfolding ffb_eq by fastforce
    hence "s' \<in> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on T S @ t\<^sub>0) s"
      using g_orbitalI[OF x_ivp \<open>\<tau> \<in> T\<close>] guard_x \<open>X \<tau> = s'\<close>
      unfolding image_le_pred by fastforce}
  thus "(x\<acute>= f & G on T S @ t\<^sub>0) s \<subseteq> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on T S @ t\<^sub>0) s"
    by blast
next show "\<And>s. (x\<acute>= f & (\<lambda>s. G s \<and> C s) on T S @ t\<^sub>0) s \<subseteq> (x\<acute>= f & G on T S @ t\<^sub>0) s"
    by (auto simp: g_orbital_eq)
qed

lemma diff_cut_rule:
  assumes Thyp: "is_interval T" "t\<^sub>0 \<in> T"
    and ffb_C: "P \<le> fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) {s. C s}"
    and ffb_Q: "P \<le> fb\<^sub>\<F> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on T S @ t\<^sub>0) Q"
  shows "P \<le> fb\<^sub>\<F> (x\<acute>= f & G on T S @ t\<^sub>0) Q"
proof(subst ffb_eq, subst g_orbital_eq, clarsimp)
  fix t::real and X::"real \<Rightarrow> 'a" and s assume "s \<in> P" and "t \<in> T"
    and x_ivp:"X \<in> Sols (\<lambda>t. f) T S t\<^sub>0 s"
    and guard_x:"\<forall>\<tau>. s2p T \<tau> \<and> \<tau> \<le> t \<longrightarrow> G (X \<tau>)"
  have "\<forall>\<tau>\<in>(down T t). X \<tau> \<in> (x\<acute>= f & G on T S @ t\<^sub>0) s"
    using g_orbitalI[OF x_ivp] guard_x unfolding image_le_pred by auto
  hence "\<forall>\<tau>\<in>(down T t). C (X \<tau>)"
    using ffb_C \<open>s \<in> P\<close> by (subst (asm) ffb_eq, auto)
  hence "X t \<in> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on T S @ t\<^sub>0) s"
    using guard_x \<open>t \<in> T\<close> by (auto intro!: g_orbitalI x_ivp)
  thus "(X t) \<in> Q"
    using \<open>s \<in> P\<close> ffb_Q by (subst (asm) ffb_eq) auto
qed

text\<open>The rules of dL\<close>

abbreviation g_global_orbit ::"(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> 'a \<Rightarrow> 'a set"
  ("(1x\<acute>=_ & _)") where "(x\<acute>=f & G) \<equiv> (x\<acute>=f & G on UNIV UNIV @ 0)"

abbreviation g_global_ode_inv ::"(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a \<Rightarrow> 'a set"
  ("(1x\<acute>=_ & _ DINV _)") where "(x\<acute>=f & G DINV I) \<equiv> (x\<acute>=f & G on UNIV UNIV @ 0 DINV I)"

lemma solve:
  assumes "local_flow f UNIV UNIV \<phi>"
    and "\<forall>s. s \<in> P \<longrightarrow> (\<forall>t. (\<forall>\<tau>\<le>t. G (\<phi> \<tau> s)) \<longrightarrow> (\<phi> t s) \<in> Q)"
  shows "P \<le> fb\<^sub>\<F> (x\<acute>= f & G) Q"
  apply(rule diff_solve_rule[OF assms(1)])
  using assms(2) by simp

lemma DS:
  fixes c::"'a::{heine_borel, banach}"
  shows "fb\<^sub>\<F> (x\<acute>=(\<lambda>s. c) & G) Q = {x. \<forall>t. (\<forall>\<tau>\<le>t. G (x + \<tau> *\<^sub>R c)) \<longrightarrow> (x + t *\<^sub>R c) \<in> Q}"
  by (subst diff_solve_axiom[of UNIV]) auto

lemma DW: "fb\<^sub>\<F> (x\<acute>= f & G) Q = fb\<^sub>\<F> (x\<acute>= f & G) {s. G s \<longrightarrow> s \<in> Q}"
  by (rule diff_weak_axiom)

lemma DC:
  assumes "fb\<^sub>\<F> (x\<acute>= f & G) {s. C s} = UNIV"
  shows "fb\<^sub>\<F> (x\<acute>= f & G) Q = fb\<^sub>\<F> (x\<acute>= f & (\<lambda>s. G s \<and> C s)) Q"
  by (rule diff_cut_axiom) (auto simp: assms)

lemma dC:
  assumes "P \<le> fb\<^sub>\<F> (x\<acute>= f & G) {s. C s}"
    and "P \<le> fb\<^sub>\<F> (x\<acute>= f & (\<lambda>s. G s \<and> C s)) Q"
  shows "P \<le> fb\<^sub>\<F> (x\<acute>= f & G) Q"
  apply(rule diff_cut_rule)
  using assms by auto

end