           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                 August 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009-2       |
            |                October 2010  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2017         |
            |                  April 2018  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Set_F_cpo
imports Set_F CSP.CPO
begin

(*****************************************************************

         1. Set_F is a pointed cpo.
         2.
         3.
         4.

 *****************************************************************)

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)

(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
(* no simp rules in Isabelle 2017
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]
*)

(*********************************************************
                      Bottom in Set_T
 *********************************************************)
(*
instance setF :: (type) bot0
by (intro_classes)
*)

instantiation setF :: (type) bot0
begin

definition
  bottom_setF_def : "Bot == {}f"
instance ..
end

(*

defs (overloaded)
  bottom_setF_def : "Bot == {}f"
*)

lemma bottom_setF : "ALL (F::'a setF). Bot <= F"
by (simp add: bottom_setF_def)

instance setF :: (type) bot
apply (intro_classes)
by (simp add: bottom_setF)

(**********************************************************
      lemmas used in a proof that set_F is a cpo.
 **********************************************************)

(* UnionF Fs is an upper bound of Fs *)

lemma UnionF_isUB : "(UnionF Fs) isUB Fs"
apply (simp add: isUB_def)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (rule_tac x=y in bexI)
by (auto)

(* UnionF Fs is the least upper bound of Fs *)

lemma UnionF_isLUB : "UnionF Fs isLUB Fs"
apply (simp add: isLUB_def UnionF_isUB)
apply (simp add: isUB_def)
apply (simp add: subsetF_iff)
apply (intro allI impI)
apply (erule bexE)
apply (drule_tac x="F" in spec)
by (simp)

(* the least upper bound of Fs is UnionF Fs *)

lemma isLUB_UnionF_only_if: "F isLUB Fs ==> F = UnionF Fs"
apply (insert UnionF_isLUB[of Fs])
apply (rule LUB_unique)
by (simp_all)

(* iff *)

lemma isLUB_UnionF : "(F isLUB Fs) = (F = UnionF Fs)"
apply (rule iffI)
apply (simp add: isLUB_UnionF_only_if)
apply (simp add: UnionF_isLUB)
done

(* LUB is UnionF Fs *)

lemma LUB_UnionF : "LUB Fs = UnionF Fs"
by (simp add: isLUB_LUB UnionF_isLUB)

(**********************************************************
                 ( setF, <= ) is a CPO
 **********************************************************)

instance setF :: (type) cpo
apply (intro_classes)
apply (simp add: hasLUB_def)
apply (rule_tac x="UnionF X" in exI)
apply (simp add: directed_def UnionF_isLUB)
done

(**********************************************************
              ( setF, <= ) is a pointed CPO
 **********************************************************)

instance setF :: (type) cpo_bot
by (intro_classes)

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
(*
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
*)
end


(*  Title:       Lazy_LList.thy
    Author:      Andreas Lochbihler
*)
section \<open>Code generator setup to implement lazy lists lazily\<close>

theory Lazy_LList imports
  Coinductive_List
begin

subsection \<open>Lazy lists\<close>

code_identifier code_module Lazy_LList \<rightharpoonup>
  (SML) Coinductive_List and
  (OCaml) Coinductive_List and
  (Haskell) Coinductive_List and
  (Scala) Coinductive_List

definition Lazy_llist :: "(unit \<Rightarrow> ('a \<times> 'a llist) option) \<Rightarrow> 'a llist"
where [simp]:
  "Lazy_llist xs = (case xs () of None \<Rightarrow> LNil | Some (x, ys) \<Rightarrow> LCons x ys)"

definition force :: "'a llist \<Rightarrow> ('a \<times> 'a llist) option"
where [simp, code del]: "force xs = (case xs of LNil \<Rightarrow> None | LCons x ys \<Rightarrow> Some (x, ys))"

code_datatype Lazy_llist

declare \<comment> \<open>Restore consistency in code equations between @{const partial_term_of} and @{const narrowing} for @{typ "'a llist"}\<close>
   [[code drop: "partial_term_of :: _ llist itself => _"]]

lemma partial_term_of_llist_code [code]:
  fixes tytok :: "'a :: partial_term_of llist itself" shows
  "partial_term_of tytok (Quickcheck_Narrowing.Narrowing_variable p tt) \<equiv>
   Code_Evaluation.Free (STR ''_'') (Typerep.typerep TYPE('a llist))"
  "partial_term_of tytok (Quickcheck_Narrowing.Narrowing_constructor 0 []) \<equiv>
   Code_Evaluation.Const (STR ''Coinductive_List.llist.LNil'') (Typerep.typerep TYPE('a llist))"
  "partial_term_of tytok (Quickcheck_Narrowing.Narrowing_constructor 1 [head, tail]) \<equiv>
   Code_Evaluation.App
     (Code_Evaluation.App
        (Code_Evaluation.Const
           (STR ''Coinductive_List.llist.LCons'')
           (Typerep.typerep TYPE('a \<Rightarrow> 'a llist \<Rightarrow> 'a llist)))
        (partial_term_of TYPE('a) head))
     (partial_term_of TYPE('a llist) tail)"
by-(rule partial_term_of_anything)+

declare option.splits [split]

lemma Lazy_llist_inject [simp]:
  "Lazy_llist xs = Lazy_llist ys \<longleftrightarrow> xs = ys"
by(auto simp add: fun_eq_iff)

lemma Lazy_llist_inverse [code, simp]:
  "force (Lazy_llist xs) = xs ()"
by(auto)

lemma force_inverse [simp]:
  "Lazy_llist (\<lambda>_. force xs) = xs"
by(auto split: llist.split)

lemma LNil_Lazy_llist [code]: "LNil = Lazy_llist (\<lambda>_. None)"
by(simp)

lemma LCons_Lazy_llist [code, code_unfold]: "LCons x xs = Lazy_llist (\<lambda>_. Some (x, xs))"
by simp

lemma lnull_lazy [code]: "lnull = Option.is_none \<circ> force"
unfolding lnull_def
by (rule ext) (simp add: Option.is_none_def split: llist.split)

declare [[code drop: "equal_class.equal :: 'a :: equal llist \<Rightarrow> _"]]

lemma equal_llist_Lazy_llist [code]:
  "equal_class.equal (Lazy_llist xs) (Lazy_llist ys) \<longleftrightarrow>
   (case xs () of None \<Rightarrow> (case ys () of None \<Rightarrow> True | _ \<Rightarrow> False)
    | Some (x, xs') \<Rightarrow>
       (case ys () of None \<Rightarrow> False
        | Some (y, ys') \<Rightarrow> if x = y then equal_class.equal xs' ys' else False))"
by(auto simp add: equal_llist_def)

declare [[code drop: corec_llist]]

lemma corec_llist_Lazy_llist [code]:
  "corec_llist IS_LNIL LHD endORmore LTL_end LTL_more b =
  Lazy_llist (\<lambda>_. if IS_LNIL b then None
     else Some (LHD b,
       if endORmore b then LTL_end b
       else corec_llist IS_LNIL LHD endORmore LTL_end LTL_more (LTL_more b)))"
by(subst llist.corec_code) simp

declare [[code drop: unfold_llist]]

lemma unfold_llist_Lazy_llist [code]:
  "unfold_llist IS_LNIL LHD LTL b =
  Lazy_llist (\<lambda>_. if IS_LNIL b then None else Some (LHD b, unfold_llist IS_LNIL LHD LTL (LTL b)))"
by(subst unfold_llist.code) simp

declare [[code drop: case_llist]]

lemma case_llist_Lazy_llist [code]:
  "case_llist n c (Lazy_llist xs) = (case xs () of None \<Rightarrow> n | Some (x, ys) \<Rightarrow> c x ys)"
by simp

declare [[code drop: lappend]]

lemma lappend_Lazy_llist [code]:
  "lappend (Lazy_llist xs) ys =
  Lazy_llist (\<lambda>_. case xs () of None \<Rightarrow> force ys | Some (x, xs') \<Rightarrow> Some (x, lappend xs' ys))"
by(auto split: llist.splits)

declare [[code drop: lmap]]

lemma lmap_Lazy_llist [code]:
  "lmap f (Lazy_llist xs) = Lazy_llist (\<lambda>_. map_option (map_prod f (lmap f)) (xs ()))"
by simp

declare [[code drop: lfinite]]

lemma lfinite_Lazy_llist [code]:
  "lfinite (Lazy_llist xs) = (case xs () of None \<Rightarrow> True | Some (x, ys) \<Rightarrow> lfinite ys)"
by simp

declare [[code drop: list_of_aux]]

lemma list_of_aux_Lazy_llist [code]:
  "list_of_aux xs (Lazy_llist ys) =
  (case ys () of None \<Rightarrow> rev xs | Some (y, ys) \<Rightarrow> list_of_aux (y # xs) ys)"
by(simp add: list_of_aux_code)

declare [[code drop: gen_llength]]

lemma gen_llength_Lazy_llist [code]:
  "gen_llength n (Lazy_llist xs) = (case xs () of None \<Rightarrow> enat n | Some (_, ys) \<Rightarrow> gen_llength (n + 1) ys)"
by(simp add: gen_llength_code)

declare [[code drop: ltake]]

lemma ltake_Lazy_llist [code]:
  "ltake n (Lazy_llist xs) =
  Lazy_llist (\<lambda>_. if n = 0 then None else case xs () of None \<Rightarrow> None | Some (x, ys) \<Rightarrow> Some (x, ltake (n - 1) ys))"
by(cases n rule: enat_coexhaust) auto

declare [[code drop: ldropn]]

lemma ldropn_Lazy_llist [code]:
  "ldropn n (Lazy_llist xs) =
   Lazy_llist (\<lambda>_. if n = 0 then xs () else
                   case xs () of None \<Rightarrow> None | Some (x, ys) \<Rightarrow> force (ldropn (n - 1) ys))"
by(cases n)(auto simp add: eSuc_enat[symmetric] split: llist.split)

declare [[code drop: ltakeWhile]]

lemma ltakeWhile_Lazy_llist [code]:
  "ltakeWhile P (Lazy_llist xs) =
  Lazy_llist (\<lambda>_. case xs () of None \<Rightarrow> None | Some (x, ys) \<Rightarrow> if P x then Some (x, ltakeWhile P ys) else None)"
by auto

declare [[code drop: ldropWhile]]

lemma ldropWhile_Lazy_llist [code]:
  "ldropWhile P (Lazy_llist xs) =
   Lazy_llist (\<lambda>_. case xs () of None \<Rightarrow> None | Some (x, ys) \<Rightarrow> if P x then force (ldropWhile P ys) else Some (x, ys))"
by(auto split: llist.split)

declare [[code drop: lzip]]

lemma lzip_Lazy_llist [code]:
  "lzip (Lazy_llist xs) (Lazy_llist ys) =
  Lazy_llist (\<lambda>_. Option.bind (xs ()) (\<lambda>(x, xs'). map_option (\<lambda>(y, ys'). ((x, y), lzip xs' ys')) (ys ())))"
by auto

declare [[code drop: gen_lset]]

lemma lset_Lazy_llist [code]:
  "gen_lset A (Lazy_llist xs) =
  (case xs () of None \<Rightarrow> A | Some (y, ys) \<Rightarrow> gen_lset (insert y A) ys)"
by(auto simp add: gen_lset_code)

declare [[code drop: lmember]]

lemma lmember_Lazy_llist [code]:
  "lmember x (Lazy_llist xs) =
  (case xs () of None \<Rightarrow> False | Some (y, ys) \<Rightarrow> x = y \<or> lmember x ys)"
by(simp add: lmember_def)

declare [[code drop: llist_all2]]

lemma llist_all2_Lazy_llist [code]:
  "llist_all2 P (Lazy_llist xs) (Lazy_llist ys) =
  (case xs () of None \<Rightarrow> ys () = None
      | Some (x, xs') \<Rightarrow> (case ys () of None \<Rightarrow> False
                            | Some (y, ys') \<Rightarrow> P x y \<and> llist_all2 P xs' ys'))"
by auto

declare [[code drop: lhd]]

lemma lhd_Lazy_llist [code]:
  "lhd (Lazy_llist xs) = (case xs () of None \<Rightarrow> undefined | Some (x, xs') \<Rightarrow> x)"
by(simp add: lhd_def)

declare [[code drop: ltl]]

lemma ltl_Lazy_llist [code]:
  "ltl (Lazy_llist xs) = Lazy_llist (\<lambda>_. case xs () of None \<Rightarrow> None | Some (x, ys) \<Rightarrow> force ys)"
by(auto split: llist.split)

declare [[code drop: llast]]

lemma llast_Lazy_llist [code]:
  "llast (Lazy_llist xs) =
  (case xs () of
    None \<Rightarrow> undefined
  | Some (x, xs') \<Rightarrow>
    (case force xs' of None \<Rightarrow> x | Some (x', xs'') \<Rightarrow> llast (LCons x' xs'')))"
by(auto simp add: llast_def zero_enat_def eSuc_def split: enat.split llist.splits)

declare [[code drop: ldistinct]]

declare [[code drop: lprefix]]

lemma lprefix_Lazy_llist [code]:
  "lprefix (Lazy_llist xs) (Lazy_llist ys) =
  (case xs () of
    None \<Rightarrow> True
  | Some (x, xs') \<Rightarrow>
    (case ys () of None \<Rightarrow> False | Some (y, ys') \<Rightarrow> x = y \<and> lprefix xs' ys'))"
by auto

declare [[code drop: lstrict_prefix]]

lemma lstrict_prefix_Lazy_llist [code]:
  "lstrict_prefix (Lazy_llist xs) (Lazy_llist ys) \<longleftrightarrow>
  (case ys () of
    None \<Rightarrow> False
  | Some (y, ys') \<Rightarrow>
    (case xs () of None \<Rightarrow> True | Some (x, xs') \<Rightarrow> x = y \<and> lstrict_prefix xs' ys'))"
by auto

declare [[code drop: llcp]]

lemma llcp_Lazy_llist [code]:
  "llcp (Lazy_llist xs) (Lazy_llist ys) =
  (case xs () of None \<Rightarrow> 0
   | Some (x, xs') \<Rightarrow> (case ys () of None \<Rightarrow> 0
                     | Some (y, ys') \<Rightarrow> if x = y then eSuc (llcp xs' ys') else 0))"
by auto

declare [[code drop: llexord]]

lemma llexord_Lazy_llist [code]:
  "llexord r (Lazy_llist xs) (Lazy_llist ys) \<longleftrightarrow>
  (case xs () of
    None \<Rightarrow> True
  | Some (x, xs') \<Rightarrow>
    (case ys () of None \<Rightarrow> False | Some (y, ys') \<Rightarrow> r x y \<or> x = y \<and> llexord r xs' ys'))"
by auto

declare [[code drop: lfilter]]

lemma lfilter_Lazy_llist [code]:
  "lfilter P (Lazy_llist xs) =
  Lazy_llist (\<lambda>_. case xs () of None \<Rightarrow> None
                  | Some (x, ys) \<Rightarrow> if P x then Some (x, lfilter P ys) else force (lfilter P ys))"
by(auto split: llist.split)

declare [[code drop: lconcat]]

lemma lconcat_Lazy_llist [code]:
  "lconcat (Lazy_llist xss) =
  Lazy_llist (\<lambda>_. case xss () of None \<Rightarrow> None | Some (xs, xss') \<Rightarrow> force (lappend xs (lconcat xss')))"
by(auto split: llist.split)

declare option.splits [split del]
declare Lazy_llist_def [simp del]

text \<open>Simple ML test for laziness\<close>

ML_val \<open>
  val zeros = @{code iterates} (fn x => x + 1) 0;
  val lhd = @{code lhd} zeros;
  val ltl = @{code ltl} zeros;
  val ltl' = @{code force} ltl;

  val ltake = @{code ltake} (@{code eSuc} (@{code eSuc} @{code "0::enat"})) zeros;
  val ldrop = @{code ldrop} (@{code eSuc} @{code "0::enat"}) zeros;
  val list_of = @{code list_of} ltake;

  val ltakeWhile = @{code ltakeWhile} (fn _ => true) zeros;
  val ldropWhile = @{code ldropWhile} (fn _ => false) zeros;
  val hd = @{code lhd} ldropWhile;

  val lfilter = @{code lfilter} (fn _ => false) zeros;
\<close>

hide_const (open) force

end


(* Title: Computational_Model.thy
  Author: Andreas Lochbihler, ETH Zurich *)

section \<open>Oracle combinators\<close>

theory Computational_Model imports
  Generative_Probabilistic_Value
begin

type_synonym security = nat
type_synonym advantage = "security \<Rightarrow> real"

type_synonym ('\<sigma>, 'call, 'ret) oracle' = "'\<sigma> \<Rightarrow> 'call \<Rightarrow> ('ret \<times> '\<sigma>) spmf"
type_synonym ('\<sigma>, 'call, 'ret) "oracle" = "security \<Rightarrow> ('\<sigma>, 'call, 'ret) oracle' \<times> '\<sigma>"

print_translation \<comment> \<open>pretty printing for @{typ "('\<sigma>, 'call, 'ret) oracle"}\<close> \<open>
  let
    fun tr' [Const (@{type_syntax nat}, _),
      Const (@{type_syntax prod}, _) $
        (Const (@{type_syntax fun}, _) $ s1 $
          (Const (@{type_syntax fun}, _) $ call $
            (Const (@{type_syntax pmf}, _) $
              (Const (@{type_syntax option}, _) $
                (Const (@{type_syntax prod}, _) $ ret $ s2))))) $
        s3] =
      if s1 = s2 andalso s1 = s3 then Syntax.const @{type_syntax oracle} $ s1 $ call $ ret
      else raise Match;
  in [(@{type_syntax "fun"}, K tr')]
  end
\<close>
typ "('\<sigma>, 'call, 'ret) oracle"

subsection \<open>Shared state\<close>

context includes \<I>.lifting lifting_syntax begin

lift_definition plus_\<I> :: "('out, 'ret) \<I> \<Rightarrow> ('out', 'ret') \<I> \<Rightarrow> ('out + 'out', 'ret + 'ret') \<I>" (infix "\<oplus>\<^sub>\<I>" 500)
is "\<lambda>resp1 resp2. \<lambda>out. case out of Inl out' \<Rightarrow> Inl ` resp1 out' | Inr out' \<Rightarrow> Inr ` resp2 out'" .

lemma plus_\<I>_sel [simp]:
  shows outs_plus_\<I>: "outs_\<I> (plus_\<I> \<I>l \<I>r) = outs_\<I> \<I>l <+> outs_\<I> \<I>r"
  and responses_plus_\<I>_Inl: "responses_\<I> (plus_\<I> \<I>l \<I>r) (Inl x) = Inl ` responses_\<I> \<I>l x"
  and responses_plus_\<I>_Inr: "responses_\<I> (plus_\<I> \<I>l \<I>r) (Inr y) = Inr ` responses_\<I> \<I>r y"
by(transfer; auto split: sum.split_asm; fail)+

lemma vimage_Inl_Plus [simp]: "Inl -` (A <+> B) = A"
  and vimage_Inr_Plus [simp]: "Inr -` (A <+> B) = B"
by auto

lemma vimage_Inl_image_Inr: "Inl -` Inr ` A = {}"
  and vimage_Inr_image_Inl: "Inr -` Inl ` A = {}"
by auto

lemma plus_\<I>_parametric [transfer_rule]:
  "(rel_\<I> C R ===> rel_\<I> C' R' ===> rel_\<I> (rel_sum C C') (rel_sum R R')) plus_\<I> plus_\<I>"
apply(rule rel_funI rel_\<I>I)+
subgoal premises [transfer_rule] by(simp; rule conjI; transfer_prover)
apply(erule rel_sum.cases; clarsimp simp add: inj_vimage_image_eq vimage_Inl_image_Inr empty_transfer vimage_Inr_image_Inl)
subgoal premises [transfer_rule] by transfer_prover
subgoal premises [transfer_rule] by transfer_prover
done

lifting_update \<I>.lifting
lifting_forget \<I>.lifting

lemma \<I>_trivial_plus_\<I> [simp]: "\<I>_trivial (\<I>\<^sub>1 \<oplus>\<^sub>\<I> \<I>\<^sub>2) \<longleftrightarrow> \<I>_trivial \<I>\<^sub>1 \<and> \<I>_trivial \<I>\<^sub>2"
by(auto simp add: \<I>_trivial_def)

end

context
  fixes left :: "('s, 'a, 'b) oracle'"
  and right :: "('s,'c, 'd) oracle'"
  and s :: "'s"
begin

primrec plus_oracle :: "'a + 'c \<Rightarrow> (('b + 'd) \<times> 's) spmf"
where
  "plus_oracle (Inl a) = map_spmf (apfst Inl) (left s a)"
| "plus_oracle (Inr b) = map_spmf (apfst Inr) (right s b)"

lemma lossless_plus_oracleI [intro, simp]:
  "\<lbrakk> \<And>a. x = Inl a \<Longrightarrow> lossless_spmf (left s a);
     \<And>b. x = Inr b \<Longrightarrow> lossless_spmf (right s b) \<rbrakk>
  \<Longrightarrow> lossless_spmf (plus_oracle x)"
by(cases x) simp_all

lemma plus_oracle_split:
  "P (plus_oracle lr) \<longleftrightarrow>
  (\<forall>x. lr = Inl x \<longrightarrow> P (map_spmf (apfst Inl) (left s x))) \<and>
  (\<forall>y. lr = Inr y \<longrightarrow> P (map_spmf (apfst Inr) (right s y)))"
by(cases lr) auto

lemma plus_oracle_split_asm:
  "P (plus_oracle lr) \<longleftrightarrow>
  \<not> ((\<exists>x. lr = Inl x \<and> \<not> P (map_spmf (apfst Inl) (left s x))) \<or>
     (\<exists>y. lr = Inr y \<and> \<not> P (map_spmf (apfst Inr) (right s y))))"
by(cases lr) auto

end

notation plus_oracle (infix "\<oplus>\<^sub>O" 500)

context
  fixes left :: "('s, 'a, 'b) oracle'"
  and right :: "('s,'c, 'd) oracle'"
begin

lemma WT_plus_oracleI [intro!]:
  "\<lbrakk> \<I>l \<turnstile>c left s \<surd>; \<I>r \<turnstile>c right s \<surd> \<rbrakk> \<Longrightarrow> \<I>l \<oplus>\<^sub>\<I> \<I>r \<turnstile>c (left \<oplus>\<^sub>O right) s \<surd>"
by(rule WT_calleeI)(auto elim!: WT_calleeD simp add: inj_image_mem_iff)

lemma WT_plus_oracleD1:
  assumes "\<I>l \<oplus>\<^sub>\<I> \<I>r \<turnstile>c (left \<oplus>\<^sub>O right) s \<surd> " (is "?\<I> \<turnstile>c ?callee s \<surd>")
  shows "\<I>l \<turnstile>c left s \<surd>"
proof(rule WT_calleeI)
  fix call ret s'
  assume "call \<in> outs_\<I> \<I>l" "(ret, s') \<in> set_spmf (left s call)"
  hence "(Inl ret, s') \<in> set_spmf (?callee s (Inl call))" "Inl call \<in> outs_\<I> (\<I>l \<oplus>\<^sub>\<I> \<I>r)"
    by(auto intro: rev_image_eqI)
  hence "Inl ret \<in> responses_\<I> ?\<I> (Inl call)" by(rule WT_calleeD[OF assms])
  then show "ret \<in> responses_\<I> \<I>l call" by(simp add: inj_image_mem_iff)
qed

lemma WT_plus_oracleD2:
  assumes "\<I>l \<oplus>\<^sub>\<I> \<I>r \<turnstile>c (left \<oplus>\<^sub>O right) s \<surd> " (is "?\<I> \<turnstile>c ?callee s \<surd>")
  shows "\<I>r \<turnstile>c right s \<surd>"
proof(rule WT_calleeI)
  fix call ret s'
  assume "call \<in> outs_\<I> \<I>r" "(ret, s') \<in> set_spmf (right s call)"
  hence "(Inr ret, s') \<in> set_spmf (?callee s (Inr call))" "Inr call \<in> outs_\<I> (\<I>l \<oplus>\<^sub>\<I> \<I>r)"
    by(auto intro: rev_image_eqI)
  hence "Inr ret \<in> responses_\<I> ?\<I> (Inr call)" by(rule WT_calleeD[OF assms])
  then show "ret \<in> responses_\<I> \<I>r call" by(simp add: inj_image_mem_iff)
qed

lemma WT_plus_oracle_iff [simp]: "\<I>l \<oplus>\<^sub>\<I> \<I>r \<turnstile>c (left \<oplus>\<^sub>O right) s \<surd> \<longleftrightarrow> \<I>l \<turnstile>c left s \<surd> \<and> \<I>r \<turnstile>c right s \<surd>"
by(blast dest: WT_plus_oracleD1 WT_plus_oracleD2)

lemma callee_invariant_on_plus_oracle [simp]:
  "callee_invariant_on (left \<oplus>\<^sub>O right) I (\<I>l \<oplus>\<^sub>\<I> \<I>r) \<longleftrightarrow>
   callee_invariant_on left I \<I>l \<and> callee_invariant_on right I \<I>r"
   (is "?lhs \<longleftrightarrow> ?rhs")
proof(intro iffI conjI)
  assume ?lhs
  then interpret plus: callee_invariant_on "left \<oplus>\<^sub>O right" I "\<I>l \<oplus>\<^sub>\<I> \<I>r" .
  show "callee_invariant_on left I \<I>l"
  proof
    fix s x y s'
    assume "(y, s') \<in> set_spmf (left s x)" and "I s" and "x \<in> outs_\<I> \<I>l"
    then have "(Inl y, s') \<in> set_spmf ((left \<oplus>\<^sub>O right) s (Inl x))"
      by(auto intro: rev_image_eqI)
    then show "I s'" using \<open>I s\<close> by(rule plus.callee_invariant)(simp add: \<open>x \<in> outs_\<I> \<I>l\<close>)
  next
    show "\<I>l \<turnstile>c left s \<surd>" if "I s" for s using plus.WT_callee[OF that] by simp
  qed
  show "callee_invariant_on right I \<I>r"
  proof
    fix s x y s'
    assume "(y, s') \<in> set_spmf (right s x)" and "I s" and "x \<in> outs_\<I> \<I>r"
    then have "(Inr y, s') \<in> set_spmf ((left \<oplus>\<^sub>O right) s (Inr x))"
      by(auto intro: rev_image_eqI)
    then show "I s'" using \<open>I s\<close> by(rule plus.callee_invariant)(simp add: \<open>x \<in> outs_\<I> \<I>r\<close>)
  next
    show "\<I>r \<turnstile>c right s \<surd>" if "I s" for s using plus.WT_callee[OF that] by simp
  qed
next
  assume ?rhs
  interpret left: callee_invariant_on left I \<I>l using \<open>?rhs\<close> by simp
  interpret right: callee_invariant_on right I \<I>r using \<open>?rhs\<close> by simp
  show ?lhs
  proof
    fix s x y s'
    assume "(y, s') \<in> set_spmf ((left \<oplus>\<^sub>O right) s x)" and "I s" and "x \<in> outs_\<I> (\<I>l \<oplus>\<^sub>\<I> \<I>r)"
    then have "(projl y, s') \<in> set_spmf (left s (projl x)) \<and> projl x \<in> outs_\<I> \<I>l \<or>
      (projr y, s') \<in> set_spmf (right s (projr x)) \<and> projr x \<in> outs_\<I> \<I>r"
      by (cases x)  auto
    then show "I s'" using \<open>I s\<close>
      by (auto dest: left.callee_invariant right.callee_invariant)
  next
    show "\<I>l \<oplus>\<^sub>\<I> \<I>r \<turnstile>c (left \<oplus>\<^sub>O right) s \<surd>" if "I s" for s
      using left.WT_callee[OF that] right.WT_callee[OF that] by simp
  qed
qed

lemma callee_invariant_plus_oracle [simp]:
  "callee_invariant (left \<oplus>\<^sub>O right) I \<longleftrightarrow>
   callee_invariant left I \<and> callee_invariant right I"
  (is "?lhs \<longleftrightarrow>  ?rhs")
proof -
  have "?lhs \<longleftrightarrow> callee_invariant_on (left \<oplus>\<^sub>O right) I (\<I>_full \<oplus>\<^sub>\<I> \<I>_full)"
    by(rule callee_invariant_on_cong)(auto split: plus_oracle_split_asm)
  also have "\<dots> \<longleftrightarrow> ?rhs" by(rule callee_invariant_on_plus_oracle)
  finally show ?thesis .
qed

lemma plus_oracle_parametric [transfer_rule]:
  includes lifting_syntax shows
  "((S ===> A ===> rel_spmf (rel_prod B S))
   ===> (S ===> C ===> rel_spmf (rel_prod D S))
   ===> S ===> rel_sum A C ===> rel_spmf (rel_prod (rel_sum B D) S))
   plus_oracle plus_oracle"
unfolding plus_oracle_def[abs_def] by transfer_prover

lemma rel_spmf_plus_oracle:
  "\<lbrakk> \<And>q1' q2'. \<lbrakk> q1 = Inl q1'; q2 = Inl q2' \<rbrakk> \<Longrightarrow> rel_spmf (rel_prod B S) (left1 s1 q1') (left2 s2 q2');
    \<And>q1' q2'. \<lbrakk> q1 = Inr q1'; q2 = Inr q2' \<rbrakk> \<Longrightarrow> rel_spmf (rel_prod D S) (right1 s1 q1') (right2 s2 q2');
    S s1 s2; rel_sum A C q1 q2 \<rbrakk>
  \<Longrightarrow> rel_spmf (rel_prod (rel_sum B D) S) ((left1 \<oplus>\<^sub>O right1) s1 q1) ((left2 \<oplus>\<^sub>O right2) s2 q2)"
apply(erule rel_sum.cases; clarsimp)
 apply(erule meta_allE)+
 apply(erule meta_impE, rule refl)+
 subgoal premises [transfer_rule] by transfer_prover
apply(erule meta_allE)+
apply(erule meta_impE, rule refl)+
subgoal premises [transfer_rule] by transfer_prover
done

end

subsection \<open>Shared state with aborts\<close>

context
  fixes left :: "('s, 'a, 'b option) oracle'"
  and right :: "('s,'c, 'd option) oracle'"
  and s :: "'s"
begin

primrec plus_oracle_stop :: "'a + 'c \<Rightarrow> (('b + 'd) option \<times> 's) spmf"
where
  "plus_oracle_stop (Inl a) = map_spmf (apfst (map_option Inl)) (left s a)"
| "plus_oracle_stop (Inr b) = map_spmf (apfst (map_option Inr)) (right s b)"

lemma lossless_plus_oracle_stopI [intro, simp]:
  "\<lbrakk> \<And>a. x = Inl a \<Longrightarrow> lossless_spmf (left s a);
     \<And>b. x = Inr b \<Longrightarrow> lossless_spmf (right s b) \<rbrakk>
  \<Longrightarrow> lossless_spmf (plus_oracle_stop x)"
by(cases x) simp_all

lemma plus_oracle_stop_split:
  "P (plus_oracle_stop lr) \<longleftrightarrow>
  (\<forall>x. lr = Inl x \<longrightarrow> P (map_spmf (apfst (map_option Inl)) (left s x))) \<and>
  (\<forall>y. lr = Inr y \<longrightarrow> P (map_spmf (apfst (map_option Inr)) (right s y)))"
by(cases lr) auto

lemma plus_oracle_stop_split_asm:
  "P (plus_oracle_stop lr) \<longleftrightarrow>
  \<not> ((\<exists>x. lr = Inl x \<and> \<not> P (map_spmf (apfst (map_option Inl)) (left s x))) \<or>
     (\<exists>y. lr = Inr y \<and> \<not> P (map_spmf (apfst (map_option Inr)) (right s y))))"
by(cases lr) auto

end

notation plus_oracle_stop (infix "\<oplus>\<^sub>O\<^sup>S" 500)

subsection \<open>Disjoint state\<close>

context
  fixes left :: "('s1, 'a, 'b) oracle'"
  and right :: "('s2, 'c, 'd) oracle'"
begin

fun parallel_oracle :: "('s1 \<times> 's2, 'a + 'c, 'b + 'd) oracle'"
where
  "parallel_oracle (s1, s2) (Inl a) = map_spmf (map_prod Inl (\<lambda>s1'. (s1', s2))) (left s1 a)"
| "parallel_oracle (s1, s2) (Inr b) = map_spmf (map_prod Inr (Pair s1)) (right s2 b)"

lemma parallel_oracle_def:
  "parallel_oracle = (\<lambda>(s1, s2). case_sum (\<lambda>a. map_spmf (map_prod Inl (\<lambda>s1'. (s1', s2))) (left s1 a)) (\<lambda>b. map_spmf (map_prod Inr (Pair s1)) (right s2 b)))"
by(auto intro!: ext split: sum.split)

lemma lossless_parallel_oracle [simp]:
  "lossless_spmf (parallel_oracle s12 xy) \<longleftrightarrow>
   (\<forall>x. xy = Inl x \<longrightarrow> lossless_spmf (left (fst s12) x)) \<and>
   (\<forall>y. xy = Inr y \<longrightarrow> lossless_spmf (right (snd s12) y))"
by(cases s12; cases xy) simp_all

lemma parallel_oracle_split:
  "P (parallel_oracle s1s2 lr) \<longleftrightarrow>
  (\<forall>s1 s2 x. s1s2 = (s1, s2) \<longrightarrow> lr = Inl x \<longrightarrow> P (map_spmf (map_prod Inl (\<lambda>s1'. (s1', s2))) (left s1 x))) \<and>
  (\<forall>s1 s2 y. s1s2 = (s1, s2) \<longrightarrow> lr = Inr y \<longrightarrow> P (map_spmf (map_prod Inr (Pair s1)) (right s2 y)))"
by(cases s1s2; cases lr) auto

lemma parallel_oracle_split_asm:
  "P (parallel_oracle s1s2 lr) \<longleftrightarrow>
  \<not> ((\<exists>s1 s2 x. s1s2 = (s1, s2) \<and> lr = Inl x \<and> \<not> P (map_spmf (map_prod Inl (\<lambda>s1'. (s1', s2))) (left s1 x))) \<or>
     (\<exists>s1 s2 y. s1s2 = (s1, s2) \<and> lr = Inr y \<and> \<not> P (map_spmf (map_prod Inr (Pair s1)) (right s2 y))))"
by(cases s1s2; cases lr) auto

lemma WT_parallel_oracle [intro!, simp]:
  "\<lbrakk> \<I>l \<turnstile>c left sl \<surd>; \<I>r \<turnstile>c right sr \<surd> \<rbrakk> \<Longrightarrow> plus_\<I> \<I>l \<I>r \<turnstile>c parallel_oracle (sl, sr) \<surd>"
by(rule WT_calleeI)(auto elim!: WT_calleeD simp add: inj_image_mem_iff)

lemma callee_invariant_parallel_oracleI [simp, intro]:
  assumes "callee_invariant_on left Il \<I>l" "callee_invariant_on right Ir \<I>r"
  shows "callee_invariant_on parallel_oracle (pred_prod Il Ir) (\<I>l \<oplus>\<^sub>\<I> \<I>r)"
proof
  interpret left: callee_invariant_on left Il \<I>l by fact
  interpret right: callee_invariant_on right Ir \<I>r by fact

  show "pred_prod Il Ir s12'"
    if "(y, s12') \<in> set_spmf (parallel_oracle s12 x)" and "pred_prod Il Ir s12" and "x \<in> outs_\<I> (\<I>l \<oplus>\<^sub>\<I> \<I>r)"
    for s12 x y s12' using that
    by(cases s12; cases s12; cases x)(auto dest: left.callee_invariant right.callee_invariant)

  show "\<I>l \<oplus>\<^sub>\<I> \<I>r \<turnstile>c local.parallel_oracle s \<surd>" if "pred_prod Il Ir s" for s using that
    by(cases s)(simp add: left.WT_callee right.WT_callee)
qed

end

lemma parallel_oracle_parametric:
  includes lifting_syntax shows
  "((S1 ===> CALL1 ===> rel_spmf (rel_prod (=) S1))
  ===> (S2 ===> CALL2 ===> rel_spmf (rel_prod (=) S2))
  ===> rel_prod S1 S2 ===> rel_sum CALL1 CALL2 ===> rel_spmf (rel_prod (=) (rel_prod S1 S2)))
  parallel_oracle parallel_oracle"
unfolding parallel_oracle_def[abs_def] by (fold relator_eq)transfer_prover

subsection \<open>Indexed oracles\<close>

definition family_oracle :: "('i \<Rightarrow> ('s, 'a, 'b) oracle') \<Rightarrow> ('i \<Rightarrow> 's, 'i \<times> 'a, 'b) oracle'"
where "family_oracle f s = (\<lambda>(i, x). map_spmf (\<lambda>(y, s'). (y, s(i := s'))) (f i (s i) x))"

lemma family_oracle_apply [simp]:
  "family_oracle f s (i, x) = map_spmf (apsnd (fun_upd s i)) (f i (s i) x)"
by(simp add: family_oracle_def apsnd_def map_prod_def)

lemma lossless_family_oracle:
  "lossless_spmf (family_oracle f s ix) \<longleftrightarrow> lossless_spmf (f (fst ix) (s (fst ix)) (snd ix))"
by(simp add: family_oracle_def split_beta)

subsection \<open>State extension\<close>

definition extend_state_oracle :: "('call, 'ret, 's) callee \<Rightarrow> ('call, 'ret, 's' \<times> 's) callee" ("\<dagger>_" [1000] 1000)
where "extend_state_oracle callee = (\<lambda>(s', s) x. map_spmf (\<lambda>(y, s). (y, (s', s))) (callee s x))"

lemma extend_state_oracle_simps [simp]:
  "extend_state_oracle callee (s', s) x = map_spmf (\<lambda>(y, s). (y, (s', s))) (callee s x)"
by(simp add: extend_state_oracle_def)

context includes lifting_syntax begin
lemma extend_state_oracle_parametric [transfer_rule]:
  "((S ===> C ===> rel_spmf (rel_prod R S)) ===> rel_prod S' S ===> C ===> rel_spmf (rel_prod R (rel_prod S' S)))
  extend_state_oracle extend_state_oracle"
unfolding extend_state_oracle_def[abs_def] by transfer_prover

lemma extend_state_oracle_transfer:
  "((S ===> C ===> rel_spmf (rel_prod R S))
  ===> rel_prod2 S ===> C ===> rel_spmf (rel_prod R (rel_prod2 S)))
  (\<lambda>oracle. oracle) extend_state_oracle"
unfolding extend_state_oracle_def[abs_def]
apply(rule rel_funI)+
apply clarsimp
apply(drule (1) rel_funD)+
apply(auto simp add: spmf_rel_map split_def dest: rel_funD intro: rel_spmf_mono)
done
end

lemma callee_invariant_extend_state_oracle_const [simp]:
  "callee_invariant \<dagger>oracle (\<lambda>(s', s). I s')"
by unfold_locales auto

lemma callee_invariant_extend_state_oracle_const':
  "callee_invariant \<dagger>oracle (\<lambda>s. I (fst s))"
by unfold_locales auto

definition lift_stop_oracle :: "('call, 'ret, 's) callee \<Rightarrow> ('call, 'ret option, 's) callee"
where "lift_stop_oracle oracle s x = map_spmf (apfst Some) (oracle s x)"

lemma lift_stop_oracle_apply [simp]: "lift_stop_oracle  oracle s x = map_spmf (apfst Some) (oracle s x)"
  by(fact lift_stop_oracle_def)

context includes lifting_syntax begin

lemma lift_stop_oracle_transfer:
  "((S ===> C ===> rel_spmf (rel_prod R S)) ===> (S ===> C ===> rel_spmf (rel_prod (pcr_Some R) S)))
   (\<lambda>x. x) lift_stop_oracle"
unfolding lift_stop_oracle_def
apply(rule rel_funI)+
apply(drule (1) rel_funD)+
apply(simp add: spmf_rel_map apfst_def prod.rel_map)
done

end

section \<open>Combining GPVs\<close>

subsection \<open>Shared state without interrupts\<close>

context
  fixes left :: "'s \<Rightarrow> 'x1 \<Rightarrow> ('y1 \<times> 's, 'call, 'ret) gpv"
  and right :: "'s \<Rightarrow> 'x2 \<Rightarrow> ('y2 \<times> 's, 'call, 'ret) gpv"
begin

primrec plus_intercept :: "'s \<Rightarrow> 'x1 + 'x2 \<Rightarrow> (('y1 + 'y2) \<times> 's, 'call, 'ret) gpv"
where
  "plus_intercept s (Inl x) = map_gpv (apfst Inl) id (left s x)"
| "plus_intercept s (Inr x) = map_gpv (apfst Inr) id (right s x)"

end

lemma plus_intercept_parametric [transfer_rule]:
  includes lifting_syntax shows
  "((S ===> X1 ===> rel_gpv (rel_prod Y1 S) C)
  ===> (S ===> X2 ===> rel_gpv (rel_prod Y2 S) C)
  ===> S ===> rel_sum X1 X2 ===> rel_gpv (rel_prod (rel_sum Y1 Y2) S) C)
  plus_intercept plus_intercept"
unfolding plus_intercept_def[abs_def] by transfer_prover

lemma interaction_bounded_by_plus_intercept [interaction_bound]:
  fixes left right
  shows "\<lbrakk> \<And>x'. x = Inl x' \<Longrightarrow> interaction_bounded_by P (left s x') (n x');
    \<And>y. x = Inr y \<Longrightarrow> interaction_bounded_by P (right s y) (m y) \<rbrakk>
  \<Longrightarrow> interaction_bounded_by P (plus_intercept left right s x) (case x of Inl x \<Rightarrow> n x | Inr y \<Rightarrow> m y)"
by(simp split!: sum.split add: interaction_bounded_by_map_gpv_id)

subsection \<open>Shared state with interrupts\<close>

context
  fixes left :: "'s \<Rightarrow> 'x1 \<Rightarrow> ('y1 option \<times> 's, 'call, 'ret) gpv"
  and right :: "'s \<Rightarrow> 'x2 \<Rightarrow> ('y2 option \<times> 's, 'call, 'ret) gpv"
begin

primrec plus_intercept_stop :: "'s \<Rightarrow> 'x1 + 'x2 \<Rightarrow> (('y1 + 'y2) option \<times> 's, 'call, 'ret) gpv"
where
  "plus_intercept_stop s (Inl x) = map_gpv (apfst (map_option Inl)) id (left s x)"
| "plus_intercept_stop s (Inr x) = map_gpv (apfst (map_option Inr)) id (right s x)"

end

lemma plus_intercept_stop_parametric [transfer_rule]:
  includes lifting_syntax shows
  "((S ===> X1 ===> rel_gpv (rel_prod (rel_option Y1) S) C)
  ===> (S ===> X2 ===> rel_gpv (rel_prod (rel_option Y2) S) C)
  ===> S ===> rel_sum X1 X2 ===> rel_gpv (rel_prod (rel_option (rel_sum Y1 Y2)) S) C)
  plus_intercept_stop plus_intercept_stop"
unfolding plus_intercept_stop_def by transfer_prover

end


theory BorrowStack
  imports Defs
begin

fun collect_tags :: "(ref_kind * tag set) stack \<Rightarrow> tag set" where
  "collect_tags stack = \<Union>(set (map snd stack))"
lemma collect_tags_spec:
  "t \<in> collect_tags stack \<longleftrightarrow> (\<exists>entry \<in> set stack. t \<in> snd entry)"
proof (induction stack)
qed auto

inductive wf_reborrow :: "(ref_kind * tag set) stack \<Rightarrow> bool" where
  (* An allocation root is a Unique reference (Box) *)
  BorrowRoot: "wf_reborrow [(Unique, {t})]" |

  (* Reborrowing from a Unique reference *)
  ReborrowUniqueUnique:
    "\<lbrakk>wf_reborrow ((Unique, {t}) # tail); t' \<notin> insert t (collect_tags tail)\<rbrakk>
 \<Longrightarrow> wf_reborrow ((Unique, {t'}) # (Unique, {t}) # tail)" |
  ReborrowUniqueSRW:
    "\<lbrakk>wf_reborrow ((Unique, {t}) # tail); t' \<notin> insert t (collect_tags tail)\<rbrakk>
 \<Longrightarrow> wf_reborrow ((SharedReadWrite, {t'}) # (Unique, {t}) # tail)" |
  ReborrowUniqueSRO:
    "\<lbrakk>wf_reborrow ((Unique, {t}) # tail); t' \<notin> insert t (collect_tags tail)\<rbrakk>
 \<Longrightarrow> wf_reborrow ((SharedReadOnly, {t'}) # (Unique, {t}) # tail)" |

  (* Reborrowing from a SharedReadWrite *)
  ReborrowSRWUnique:
    "\<lbrakk>wf_reborrow ((SharedReadWrite, ts) # tail); t' \<notin> ts \<union> collect_tags tail\<rbrakk>
 \<Longrightarrow> wf_reborrow ((Unique, {t'}) # (SharedReadWrite, ts) # tail)" |
  ReborrowSRWSRW:
    "\<lbrakk>wf_reborrow ((SharedReadWrite, ts) # tail); t \<notin> ts \<union> collect_tags tail\<rbrakk>
 \<Longrightarrow> wf_reborrow ((SharedReadWrite, insert t ts) # tail)" |
  ReborrowSRWSRO:
    "\<lbrakk>wf_reborrow ((SharedReadWrite, ts) # tail); t' \<notin> ts \<union> collect_tags tail\<rbrakk>
 \<Longrightarrow> wf_reborrow ((SharedReadOnly, {t'}) # (SharedReadWrite, ts) # tail)" |

  (* Reborrowing from a SharedReadOnly gives only a shared reference *)
  ReborrowSROSRO:
    "\<lbrakk>wf_reborrow ((SharedReadOnly, ts) # tail); t \<notin> ts \<union> collect_tags tail\<rbrakk>
 \<Longrightarrow> wf_reborrow ((SharedReadOnly, insert t ts) # tail)"

inductive_cases wf_reborrow_elims: "wf_reborrow stack"

inductive_cases wf_reborrow_structure_elims:
  "wf_reborrow []"
  "wf_reborrow ((Unique, ts) # (Unique, ts') # tail)"
  "wf_reborrow ((SharedReadWrite, ts) # (Unique, ts') # tail)"

lemma wf_reborrow_nonempty:
  assumes "wf_reborrow stack"
  shows "stack \<noteq> []"
using assms proof (rule wf_reborrow_elims)
qed auto

lemma wf_reborrow_root: "wf_reborrow stack \<Longrightarrow> \<exists>t. last stack = (Unique, {t})"
proof (induction rule: wf_reborrow.induct)
qed auto

lemma unique_ref_head:
  assumes "wf_reborrow ((Unique, ts) # end)"
  shows "\<exists>t. ts = {t}"
using assms proof (rule wf_reborrow_elims)
qed auto

lemma unique_ref:
  assumes
    "wf_reborrow stack"
    "(Unique, ts) \<in> set stack"
  shows "\<exists>t. ts = {t}"
using assms proof (induction rule: wf_reborrow.induct)
qed auto

lemma wf_reborrow_pop:
  assumes
    "wf_reborrow stack"
    "stack = st1 # st2 # rest"
  shows "wf_reborrow (st2 # rest)"
using assms proof (induction arbitrary: st1 rule: wf_reborrow.induct)
qed auto

lemma wf_reborrow_pop':
  fixes top rest
  assumes
    "wf_reborrow (top # rest)"
    "rest \<noteq> []"
  shows "wf_reborrow rest"
using assms proof (induction "(top # rest)" arbitrary: top rule: wf_reborrow.induct)
qed auto

(* convenient intro rules *)
lemma BorrowRoot'[intro]:
  assumes
    "k = Unique"
    "is_singleton ts"
    "tail = []"
  shows "wf_reborrow ((k, ts) # tail)"
  using BorrowRoot assms is_singletonE by auto

lemma ReborrowUniqueUnique'[intro]:
  assumes
    "k = Unique"
    "is_singleton ts"
    "ts \<inter> collect_tags tail = {}"
    "wf_reborrow tail"
    "\<exists>t' tail'. tail = ((Unique, {t'}) # tail')"
  shows "wf_reborrow ((k, ts) # tail)"
proof -
  obtain t t' tail' where
    "ts = {t}"
    "tail = (Unique, {t'}) # tail'"
    using assms is_singletonE by metis
  moreover have "wf_reborrow ((Unique, {t}) # (Unique, {t'}) # tail')"
    using ReborrowUniqueUnique assms calculation by auto
  ultimately show ?thesis using assms by auto
qed

lemma ReborrowSRWUnique'[intro]:
  assumes
    "k = Unique"
    "is_singleton ts"
    "ts \<inter> collect_tags tail = {}"
    "wf_reborrow tail"
    "\<exists>ts' tail'. tail = ((SharedReadWrite, ts') # tail')"
  shows "wf_reborrow ((k, ts) # tail)"
proof -
  obtain t ts' tail' where
    "ts = {t}"
    "tail = (SharedReadWrite, ts') # tail'"
    using assms is_singletonE by metis
  moreover have "wf_reborrow ((Unique, {t}) # (SharedReadWrite, ts') # tail')"
    using ReborrowSRWUnique assms calculation by auto
  ultimately show ?thesis using assms by auto
qed

lemma ReborrowUniqueSRW'[intro]:
  assumes
    "k = SharedReadWrite"
    "ts \<inter> collect_tags tail = {}"
    "wf_reborrow tail"
    "\<exists>t' tail'. tail = ((Unique, {t'}) # tail')"
    "finite ts"
    "ts \<noteq> {}"
  shows "wf_reborrow ((k, ts) # tail)"
using assms(5) assms(6) assms proof (induction rule: finite_ne_induct)
  case (singleton t)
  then show ?case using ReborrowUniqueSRW by auto
next
  case (insert t ts)
  then show ?case using ReborrowSRWSRW by simp
qed

lemma ReborrowUniqueSRO'[intro]:
  assumes
    "k = SharedReadOnly"
    "ts \<inter> collect_tags tail = {}"
    "wf_reborrow tail"
    "\<exists>t' tail'. tail = ((Unique, {t'}) # tail')"
    "finite ts"
    "ts \<noteq> {}"
  shows "wf_reborrow ((k, ts) # tail)"
using assms(5) assms(6) assms proof (induction rule: finite_ne_induct)
  case (singleton t)
  then show ?case using ReborrowUniqueSRO by auto
next
  case (insert t ts)
  then show ?case using ReborrowSROSRO by simp
qed

lemma ReborrowSRWSRO'[intro]:
  assumes
    "k = SharedReadOnly"
    "ts \<inter> collect_tags tail = {}"
    "wf_reborrow tail"
    "\<exists>ts' tail'. tail = ((SharedReadWrite, ts') # tail')"
    "finite ts"
    "ts \<noteq> {}"
  shows "wf_reborrow ((k, ts) # tail)"
using assms(5) assms(6) assms proof (induction rule: finite_ne_induct)
  case (singleton t)
  then show ?case using ReborrowSRWSRO by auto
next
  case (insert t ts)
  then show ?case using ReborrowSROSRO by simp
qed

(* convenient elimination rules on structure of well formed borrow stack *)
lemma wf_reborrow_elims'[
  consumes 1,
  case_names Root UniqueUnique UniqueSRW UniqueSRO SRWUnique SRWSRO
  ]:
  fixes stack
  fixes P
  assumes
    "wf_reborrow stack"
    "\<And>t. stack = [(Unique, {t})] \<Longrightarrow> P"
    "\<And>t t' tail.
      \<lbrakk>stack = (Unique, {t'}) # (Unique, {t}) # tail;
      {t'} \<inter> ({t} \<union> collect_tags tail) = {};
      wf_reborrow ((Unique, {t}) # tail)\<rbrakk> \<Longrightarrow> P"
    "\<And>t ts' tail.
      \<lbrakk>stack = (SharedReadWrite, ts') # (Unique, {t}) # tail;
      ts' \<inter> ({t} \<union> collect_tags tail) = {};
      wf_reborrow ((Unique, {t}) # tail)\<rbrakk> \<Longrightarrow> P"
    "\<And>t ts' tail.
      \<lbrakk>stack = (SharedReadOnly, ts') # (Unique, {t}) # tail;
      ts' \<inter> ({t} \<union> collect_tags tail) = {};
      wf_reborrow ((Unique, {t}) # tail)\<rbrakk> \<Longrightarrow> P"
    "\<And>ts t' tail.
      \<lbrakk>stack = (Unique, {t'}) # (SharedReadWrite, ts) # tail;
      {t'} \<inter> (ts \<union> collect_tags tail) = {};
      wf_reborrow ((SharedReadWrite, ts) # tail)\<rbrakk> \<Longrightarrow> P"
    "\<And>ts ts' tail.
      \<lbrakk>stack = (SharedReadOnly, ts') # (SharedReadWrite, ts) # tail;
      ts' \<inter> (ts \<union> collect_tags tail) = {};
      wf_reborrow ((SharedReadWrite, ts) # tail)\<rbrakk> \<Longrightarrow> P"
  shows P
using assms proof (induction)
  case (BorrowRoot t)
  then show ?case by auto
next
  case (ReborrowUniqueUnique t tail t')
  then show ?case by blast
next
  case (ReborrowUniqueSRW t tail t')
  then show ?case by blast
next
  case (ReborrowUniqueSRO t tail t')
  then show ?case by blast
next
  case (ReborrowSRWUnique ts tail t')
  then show ?case by blast
next
  case (ReborrowSRWSRW ts tail t)
  then show ?case by fastforce
next
  case (ReborrowSRWSRO ts tail t')
  then show ?case by simp
next
  case (ReborrowSROSRO ts tail t)
  then show ?case by fastforce
qed

lemma wf_reborrow_induct'[
  consumes 1,
  case_names Root UniqueUnique UniqueSRW UniqueSRO SRWUnique SRWSRO
  ]:
  fixes stack
  fixes P
  assumes
    "wf_reborrow stack"
    "\<And>t. P [(Unique, {t})]"
    "\<And>t t' tail.
      \<lbrakk>P ((Unique, {t}) # tail);
      {t'} \<inter> ({t} \<union> collect_tags tail) = {};
      wf_reborrow ((Unique, {t}) # tail)\<rbrakk>
      \<Longrightarrow> P ((Unique, {t'}) # (Unique, {t}) # tail)"
    "\<And>t ts' tail.
      \<lbrakk>P ((Unique, {t}) # tail);
      ts' \<inter> ({t} \<union> collect_tags tail) = {};
      wf_reborrow ((Unique, {t}) # tail)\<rbrakk>
      \<Longrightarrow> P ((SharedReadWrite, ts') # (Unique, {t}) # tail)"
    "\<And>t ts' tail.
      \<lbrakk>P ((Unique, {t}) # tail);
      ts' \<inter> ({t} \<union> collect_tags tail) = {};
      wf_reborrow ((Unique, {t}) # tail)\<rbrakk>
      \<Longrightarrow> P ((SharedReadOnly, ts') # (Unique, {t}) # tail)"
    "\<And>ts t' tail.
      \<lbrakk>P ((SharedReadWrite, ts) # tail);
      {t'} \<inter> (ts \<union> collect_tags tail) = {};
      wf_reborrow ((SharedReadWrite, ts) # tail)\<rbrakk>
      \<Longrightarrow> P ((Unique, {t'}) # (SharedReadWrite, ts) # tail)"
    "\<And>ts ts' tail.
      \<lbrakk>P ((SharedReadWrite, ts) # tail);
      ts' \<inter> (ts \<union> collect_tags tail) = {};
      wf_reborrow ((SharedReadWrite, ts) # tail)\<rbrakk>
      \<Longrightarrow> P ((SharedReadOnly, ts') # (SharedReadWrite, ts) # tail)"
  shows "P stack"
proof -
  have "stack \<noteq> []"
    using assms(1) wf_reborrow_nonempty by simp
  then show ?thesis
  using assms proof (induction rule: list_nonempty_induct)
    case (single entry)
    then show ?case by (metis last_ConsL wf_reborrow_root)
  next
    case (cons entry stack)
    show ?case
    using cons.prems(1) proof (cases "(entry # stack)" rule: wf_reborrow_elims')
      case (Root t)
      then show ?thesis using assms by simp
    next
      case (UniqueUnique t t' tail)
      then show ?thesis using assms cons by simp
    next
      case (UniqueSRW t ts' tail)
      then show ?thesis using assms cons by simp
    next
      case (UniqueSRO t ts' tail)
      then show ?thesis using assms cons by simp
    next
      case (SRWUnique ts t' tail)
      then show ?thesis using assms cons by simp
    next
      case (SRWSRO ts ts' tail)
      then show ?thesis using assms cons by simp
    qed
  qed
qed

lemma shared_read_only_top:
  assumes
    "wf_reborrow stack"
    "\<exists>entry \<in> set stack. fst entry = SharedReadOnly"
  shows "fst (hd stack) = SharedReadOnly \<and> \<not>(\<exists>entry \<in> set (tl stack). fst entry = SharedReadOnly)"
using assms proof (induction stack rule: wf_reborrow.induct)
qed auto

lemma wf_reborrow_top_tag_notin:
  assumes
    "wf_reborrow stack"
    "target \<in> snd (hd stack)"
  shows "target \<notin> collect_tags (tl stack)"
using assms proof (induction stack rule: wf_reborrow.induct)
qed auto

lemma wf_reborrow_tag_position_inj_zero:
  assumes
    "wf_reborrow stack"
    "i < length stack"
    "target \<in> snd (stack ! i)"
    "target \<in> snd (stack ! 0)"
  shows "i = 0"
proof (cases i)
  case 0
  then show ?thesis by simp
next
  case (Suc i')
  have "target \<in> snd (hd stack)" using assms wf_reborrow_nonempty
    by (simp add: hd_conv_nth)
  moreover have "target \<in> collect_tags (tl stack)"
    using assms collect_tags_spec nth_tl wf_reborrow_nonempty
    by (metis Nitpick.size_list_simp(2) Suc Suc_less_SucD nth_mem)
  ultimately show ?thesis using wf_reborrow_top_tag_notin assms(1) by blast
qed

(* repetitive, obvious proof *)
lemma wf_reborrow_tag_position_inj:
  assumes
    "wf_reborrow stack"
    "i < length stack"
    "j < length stack"
    "target \<in> snd (stack ! i)"
    "target \<in> snd (stack ! j)"
  shows "i = j"
using assms proof (induction stack arbitrary: i j rule: wf_reborrow.induct)
  case (BorrowRoot t)
  then show ?case by simp
next
  case (ReborrowUniqueUnique t tail t')
  show ?case
  proof (cases i)
    case 0
    then show ?thesis
      using ReborrowUniqueUnique wf_reborrow.ReborrowUniqueUnique
        wf_reborrow_tag_position_inj_zero by blast
  next
    case (Suc i')
    note Suci = Suc
    then show ?thesis
    proof (cases j)
      case 0
      then show ?thesis
        using ReborrowUniqueUnique wf_reborrow.ReborrowUniqueUnique
          wf_reborrow_tag_position_inj_zero by blast
    next
      case (Suc j')
      then show ?thesis using Suc Suci ReborrowUniqueUnique by auto
    qed
  qed
next
  case (ReborrowUniqueSRW t tail t')
  then show ?case
  proof (cases i)
    case 0
    then show ?thesis
      using ReborrowUniqueSRW wf_reborrow.ReborrowUniqueSRW
        wf_reborrow_tag_position_inj_zero by blast
  next
    case (Suc i')
    note Suci = Suc
    then show ?thesis
    proof (cases j)
      case 0
      then show ?thesis
        using ReborrowUniqueSRW wf_reborrow.ReborrowUniqueSRW
          wf_reborrow_tag_position_inj_zero by blast
    next
      case (Suc j')
      then show ?thesis using Suc Suci ReborrowUniqueSRW by auto
    qed
  qed
next
  case (ReborrowUniqueSRO t tail t')
  then show ?case
  proof (cases i)
    case 0
    then show ?thesis
      using ReborrowUniqueSRO wf_reborrow.ReborrowUniqueSRO
        wf_reborrow_tag_position_inj_zero by blast
  next
    case (Suc i')
    note Suci = Suc
    then show ?thesis
    proof (cases j)
      case 0
      then show ?thesis
      using ReborrowUniqueSRO wf_reborrow.ReborrowUniqueSRO
        wf_reborrow_tag_position_inj_zero by blast
    next
      case (Suc j')
      then show ?thesis using Suc Suci ReborrowUniqueSRO by auto
    qed
  qed
next
  case (ReborrowSRWUnique ts tail t')
  then show ?case
  proof (cases i)
    case 0
    then show ?thesis
      using ReborrowSRWUnique wf_reborrow.ReborrowSRWUnique
        wf_reborrow_tag_position_inj_zero by blast
  next
    case (Suc i')
    note Suci = Suc
    then show ?thesis
    proof (cases j)
      case 0
      then show ?thesis
      using ReborrowSRWUnique wf_reborrow.ReborrowSRWUnique
        wf_reborrow_tag_position_inj_zero by blast
    next
      case (Suc j')
      then show ?thesis using Suc Suci ReborrowSRWUnique by auto
    qed
  qed
next
  case (ReborrowSRWSRW ts tail t)
  then show ?case
  proof (cases i)
    case 0
    then show ?thesis
      using ReborrowSRWSRW wf_reborrow.ReborrowSRWSRW
        wf_reborrow_tag_position_inj_zero by blast
  next
    case (Suc i')
    note Suci = Suc
    then show ?thesis
    proof (cases j)
      case 0
      then show ?thesis
      using ReborrowSRWSRW wf_reborrow.ReborrowSRWSRW
        wf_reborrow_tag_position_inj_zero by blast
    next
      case (Suc j')
      then show ?thesis using Suc Suci ReborrowSRWSRW
        by (metis length_Cons nth_Cons_Suc)
    qed
  qed
next
  case (ReborrowSRWSRO ts tail t')
  then show ?case
  proof (cases i)
    case 0
    then show ?thesis
      using ReborrowSRWSRO wf_reborrow.ReborrowSRWSRO
        wf_reborrow_tag_position_inj_zero by blast
  next
    case (Suc i')
    note Suci = Suc
    then show ?thesis
    proof (cases j)
      case 0
      then show ?thesis
      using ReborrowSRWSRO wf_reborrow.ReborrowSRWSRO
        wf_reborrow_tag_position_inj_zero by blast
    next
      case (Suc j')
      then show ?thesis using Suc Suci ReborrowSRWSRO by auto
    qed
  qed
next
  case (ReborrowSROSRO ts tail t)
  then show ?case
  proof (cases i)
    case 0
    then show ?thesis
      using ReborrowSROSRO wf_reborrow.ReborrowSROSRO
        wf_reborrow_tag_position_inj_zero by blast
  next
    case (Suc i')
    note Suci = Suc
    then show ?thesis
    proof (cases j)
      case 0
      then show ?thesis
      using ReborrowSROSRO wf_reborrow.ReborrowSROSRO
        wf_reborrow_tag_position_inj_zero by blast
    next
      case (Suc j')
      then show ?thesis using Suc Suci ReborrowSROSRO
        by (metis length_Cons nth_Cons_Suc)
    qed
  qed
qed

lemma wf_reborrow_tag_position_unique':
  assumes
    "wf_reborrow stack"
    "target \<in> collect_tags stack"
  shows "\<exists>i. (i < length stack \<and> target \<in> snd (stack ! i)) \<and>
  (\<forall>j. j < length stack \<and> target \<in> snd (stack ! j) \<longrightarrow> j = i)"
proof -
  have "\<exists>i < length stack. target \<in> snd (stack ! i)"
    using assms collect_tags_spec by (metis in_set_conv_nth)
  then obtain i where
    "i < length stack"
    "target \<in> snd (stack ! i)"
    by auto
  moreover
  note calc = calculation
  have "\<forall>j. j < length stack \<and> target \<in> snd (stack ! j) \<longrightarrow> j = i"
  proof
    fix j
    show "j < length stack \<and> target \<in> snd (stack ! j) \<longrightarrow> j = i"
    proof
      assume "j < length stack \<and> target \<in> snd (stack ! j)"
      then show "j = i" using calc assms wf_reborrow_tag_position_inj by auto
    qed
  qed
  ultimately show "\<exists>i. (i < length stack \<and> target \<in> snd (stack ! i)) \<and>
    (\<forall>j. j < length stack \<and> target \<in> snd (stack ! j) \<longrightarrow> j = i)"
    by blast
qed

lemma wf_reborrow_tag_position_unique:
  assumes
    "wf_reborrow stack"
    "target \<in> collect_tags stack"
  shows "\<exists>!i. i < length stack \<and> target \<in> snd (stack ! i)"
  using wf_reborrow_tag_position_unique' assms by blast

fun stack_finite :: "(ref_kind * tag set) stack \<Rightarrow> bool" where
  "stack_finite [] = True" |
  "stack_finite (s # stack) = (finite (snd s) \<and> stack_finite stack)"

lemma stack_finite_spec: "stack_finite stack \<longleftrightarrow> (\<forall>s \<in> set stack. finite (snd s))"
proof (induction stack)
qed auto

lemma stack_finite_wf_reborrow[intro]:
  assumes "wf_reborrow stack"
  shows "stack_finite stack"
using assms proof (induction rule: wf_reborrow.induct)
qed auto

lemma collect_tags_stack_finite:
  assumes "stack_finite stack"
  shows "finite (collect_tags stack)"
  using assms stack_finite_spec by auto

lemma stack_finite_finite_collect_tags:
  assumes "finite (collect_tags stack)"
  shows "stack_finite stack"
  using assms by (simp add: stack_finite_spec)

fun pop_tags :: "tag \<Rightarrow> (ref_kind * tag set) stack \<Rightarrow> (ref_kind * tag set) stack" where
  "pop_tags t stack = dropWhile (\<lambda>entry. t \<notin> snd entry) stack"

lemma hd_dropWhile_stack:
  assumes
    "pop_tags t stack = stack'"
    "\<exists>entry \<in> set stack. t \<in> snd entry"
  shows "t \<in> snd (hd stack')"
  by (metis assms(1) assms(2) pop_tags.simps dropWhile_eq_Nil_conv hd_dropWhile)

lemma dropWhile_stack_reborrow:
  "wf_reborrow stack \<and> dropWhile P stack \<noteq> [] \<Longrightarrow> wf_reborrow (dropWhile P stack)"
proof (induction stack)
  case Nil
  then show ?case using wf_reborrow_nonempty by simp
next
  case (Cons top rest)
  show ?case
  proof (cases "P top")
    case True
    moreover have "dropWhile P rest \<noteq> []" using Cons.prems calculation by auto
    moreover have "rest \<noteq> []" using calculation by auto
    moreover have "wf_reborrow rest" using calculation Cons.prems wf_reborrow_pop' by auto
    ultimately show ?thesis using Cons.IH by auto
  next
    case False
    then show ?thesis using Cons.prems by simp
  qed
qed

lemma dropWhile_stack_finite:
  "stack_finite stack \<Longrightarrow> stack_finite (dropWhile P stack)"
proof (induction stack)
  case Nil
  then show ?case by simp
next
  case (Cons st stack)
  then have *: "stack_finite (dropWhile P stack)" by simp
  then show ?case
  proof (cases "P st")
    case True
    then show ?thesis using * by simp
  next
    case False
    then show ?thesis using Cons.prems by simp
  qed
qed

fun readable :: "tag \<Rightarrow> (ref_kind * tag set) stack \<Rightarrow> bool" where
  "readable t [] \<longleftrightarrow> False" |
  "readable t ((k, ts) # stack) \<longleftrightarrow>
    (if t \<in> ts then True else readable t stack)"

fun readable_axiomatic :: "tag \<Rightarrow> (ref_kind * tag set) stack \<Rightarrow> bool" where
  "readable_axiomatic t stack \<longleftrightarrow> t \<in> collect_tags stack"

lemma readable_spec':
  "readable t stack \<longleftrightarrow> readable_axiomatic t stack"
proof (induction stack)
qed auto

lemma readable_spec[simp]:
  "readable t stack \<longleftrightarrow> t \<in> collect_tags stack"
proof (induction stack, auto)
qed

fun writable :: "tag \<Rightarrow> (ref_kind * tag set) stack \<Rightarrow> bool" where
  "writable t [] \<longleftrightarrow> False" |
  "writable t ((k, ts) # stack) \<longleftrightarrow>
    (if t \<in> ts then k = Unique \<or> k = SharedReadWrite else writable t stack)"

lemma writable_spec:
  assumes "wf_reborrow stack"
  shows "writable t stack \<longleftrightarrow> (\<exists>entry \<in> set stack.
    (fst entry = Unique \<or> fst entry = SharedReadWrite)
    \<and> t \<in> snd entry
  )"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume "?lhs"
  then show "?rhs"
  proof (induction stack)
    case Nil
    then show ?case by simp
  next
    case (Cons entry stack)
    consider "t \<in> snd entry" | "t \<notin> snd entry" by auto
    then show ?case
    proof (cases)
      case 1
      moreover have "fst entry = Unique \<or> fst entry = SharedReadWrite"
        using Cons by (metis calculation prod.collapse writable.simps(2))
      ultimately show ?thesis by simp
    next
      case 2
      then have "writable t (entry # stack) = writable t stack"
        by (metis prod.collapse writable.simps(2))
      then show ?thesis using Cons by simp
    qed
  qed
next
  assume "?rhs"
  then obtain i where
    "i < length stack"
    "fst (stack ! i) = Unique \<or> fst (stack ! i) = SharedReadWrite"
    "t \<in> snd (stack ! i)"
    by (metis in_set_conv_nth)
  moreover have "\<And>j. \<lbrakk>j < length stack; t \<in> snd (stack ! j)\<rbrakk> \<Longrightarrow> j = i"
    using wf_reborrow_tag_position_inj calculation assms by blast
  ultimately show "?lhs"
  proof (induction i)
    case 0
    then show ?case
      by (metis assms fst_conv nth_Cons_0 snd_conv wf_reborrow_nonempty writable.elims(3))
  next
    case (Suc i)
    then show ?case sorry
  qed
  oops

fun permission_is :: "ref_kind \<Rightarrow> tag \<Rightarrow> (ref_kind * tag set) stack \<Rightarrow> bool" where
  "permission_is k t [] \<longleftrightarrow> False" |
  "permission_is k t ((k', ts) # stack) \<longleftrightarrow>
    (if t \<in> ts then k = k' else permission_is k t stack)"

lemma permission_is_imp_readable[intro]:
  assumes "permission_is k t stack"
  shows "readable t stack"
using assms proof (induction stack)
  case Nil
  then show ?case by simp
next
  case (Cons entry stack)
  then show ?case
    by (metis list.sel(3) list.simps(3) permission_is.simps(2) readable.elims(3))
qed

lemma permission_is_imp_writable[intro]:
  assumes
    "permission_is k t stack"
    "k = Unique \<or> k = SharedReadWrite"
  shows "writable t stack"
using assms proof (induction stack)
  case Nil
  then show ?case by simp
next
  case (Cons entry stack)
  then show ?case
  proof (cases "t \<in> snd entry")
    case True
    then show ?thesis
      by (metis Cons list.sel(3) list.simps(3) permission_is.simps(2) writable.elims(3))
  next
    case False
    then show ?thesis
      by (metis Cons permission_is.simps(2) prod.collapse writable.simps(2))
  qed
qed

lemma writable_in_collect_tags:
  assumes "writable t stack"
  shows "t \<in> collect_tags stack"
using assms proof (induction stack)
  case (Cons entry stack)
  then show ?case using writable.elims(2) by fastforce
qed auto

lemma writable_tl:
  assumes
    "writable t stack"
    "t \<notin> snd (hd stack)"
  shows "writable t (tl stack)"
using assms proof (induction stack)
  case Nil
  then show ?case by simp
next
  case (Cons entry stack)
  then obtain k ts where
    "entry = (k, ts)"
    "t \<notin> ts"
    by (metis eq_snd_iff list.sel(1))
  then show ?case using writable.simps(2) Cons.prems(1) by auto
qed

lemma writable_implies_readable:
  assumes "writable t stack"
  shows "readable t stack"
  using assms readable_spec writable_in_collect_tags by auto

lemma writable_the_index:
  assumes
    "wf_reborrow stack"
    "writable t stack"
  shows "\<exists>!i. i < length stack \<and> t \<in> snd (stack ! i)"
  using wf_reborrow_tag_position_unique writable_in_collect_tags assms by simp

lemma writable_pop_tags:
  "writable t stack \<Longrightarrow> writable t (pop_tags t stack)"
proof (induction stack)
  case Nil
  then show ?case by simp
next
  case (Cons entry stack)
  then show ?case using writable.elims(2) by fastforce
qed

lemma writable_pop_tags':
  assumes
    "writable t stack"
    "pop_tags t stack = stack'"
  shows "(fst (hd stack') = Unique \<or> fst (hd stack') = SharedReadWrite)
      \<and> t \<in> snd (hd stack')"
    (is "?kind \<and> _")
proof
  show ?kind
    using assms
    by (metis hd_dropWhile list.collapse pop_tags.elims prod.collapse writable.simps(1)
        writable.simps(2) writable_pop_tags)
next
  show "t \<in> snd (hd stack')"
    using hd_dropWhile_stack assms writable_in_collect_tags by simp
qed

(* computational definition of reborrow *)
fun reborrow :: "ref_kind \<Rightarrow> tag \<Rightarrow> (ref_kind * tag set) stack \<Rightarrow> (ref_kind * tag set) stack"
  where
  (* reborrwing Unique *)
  "reborrow Unique t ((Unique, ts) # stack) = (Unique, {t}) # (Unique, ts) # stack" |
  "reborrow Unique t ((SharedReadWrite, ts) # stack) =
    (Unique, {t}) # (SharedReadWrite, ts) # stack" |
  (* reborrowing SharedReadWrite *)
  "reborrow SharedReadWrite t ((Unique, ts) # stack) =
    (SharedReadWrite, {t}) # (Unique, ts) # stack" |
  "reborrow SharedReadWrite t ((SharedReadWrite, ts) # stack) =
    (SharedReadWrite, insert t ts) # stack" |
  (* reborrwing SharedReadOnly *)
  "reborrow SharedReadOnly t ((Unique, ts) # stack) =
    (SharedReadOnly, {t}) # (Unique, ts) # stack" |
  "reborrow SharedReadOnly t ((SharedReadWrite, ts) # stack) =
    (SharedReadOnly, {t}) # (SharedReadWrite, ts) # stack" |
  "reborrow SharedReadOnly t ((SharedReadOnly, ts) # stack) =
    (SharedReadOnly, insert t ts) # stack" |
  (* other cases are uninteresting as reborrow is not well-formed *)
  "reborrow _ _ [] = []" |
  "reborrow Unique _ ((SharedReadOnly, _) # stack) = []" |
  "reborrow SharedReadWrite _ ((SharedReadOnly, _) # stack) = []"

fun reborrow_comp
  :: "ref_kind \<Rightarrow> tag \<Rightarrow> tag \<Rightarrow> (ref_kind * tag set) stack \<Rightarrow> (ref_kind * tag set) stack" where
  "reborrow_comp k child parent stack =
    reborrow k child (pop_tags parent stack)"

lemma reborrow_comp_pop:
  assumes "orig \<notin> snd entry"
  shows "reborrow_comp k deriv orig (entry # stack) = reborrow_comp k deriv orig stack"
using assms proof (induction stack, auto)
qed

lemma reborrow_hd:
  assumes
    "reborrow k t stack = stack'"
    "stack' \<noteq> []"
  shows "k = fst (hd stack') \<and> t \<in> snd (hd stack')"
using assms proof (cases rule: reborrow.elims)
qed auto

lemma reborrow_from_unique_new_layer:
  "reborrow k deriv ((Unique, ts) # stack) = (k, {deriv}) # (Unique, ts) # stack"
  by (metis (full_types) reborrow.simps(1) reborrow.simps(3) reborrow.simps(5) ref_kind.exhaust)

lemma nonempty_reborrow_comp_if_valid_reborrow:
  assumes
    "wf_reborrow stack"
    "writable orig stack \<or> (readable orig stack \<and> k = SharedReadOnly)"
    "reborrow_comp k deriv orig stack = stack'"
  shows "stack' \<noteq> []"
using assms proof (induction rule: wf_reborrow_induct')
  case (Root t)
  have "orig = t"
  proof (rule disjE[OF Root.prems(1)])
    assume "writable orig [(Unique, {t})]"
    then show ?thesis using writable.simps(1) by fastforce
  next
    assume "readable orig [(Unique, {t})] \<and> k = SharedReadOnly"
    then show ?thesis by simp
  qed
  then have "stack' = reborrow k deriv [(Unique, {t})]"
    using Root by simp
  then show ?case by (simp add: reborrow_from_unique_new_layer)
next
  case (UniqueUnique t t' tail)
  consider "t' = orig" | "t' \<noteq> orig" by auto
  then show ?case
  proof (cases)
    assume "t' = orig"
    then show ?thesis using UniqueUnique reborrow_from_unique_new_layer by auto
  next
    assume "t' \<noteq> orig"
    moreover have "stack' = reborrow_comp k deriv orig ((Unique, {t}) # tail)"
      using UniqueUnique.prems(2) calculation by auto
    ultimately show ?thesis
      using UniqueUnique by simp
  qed
next
  case (UniqueSRW t ts' tail)
  consider "orig \<in> ts'" | "orig \<notin> ts'" by auto
  then show ?case
  proof (cases)
    assume "orig \<in> ts'"
    then have *: "stack' = reborrow k deriv ((SharedReadWrite, ts') # (Unique, {t}) # tail)"
      using UniqueSRW by simp
    show ?thesis
    proof (cases k)
    qed (auto simp add: UniqueSRW *)
  next
    assume "orig \<notin> ts'"
    then show ?thesis using UniqueSRW by simp
  qed
next
  case (UniqueSRO t ts' tail)
  consider "orig \<in> ts'" | "orig \<notin> ts'" by auto
  then show ?case
  proof (cases)
    assume "orig \<in> ts'"
    moreover have "k = SharedReadOnly"
      using UniqueSRO calculation by simp
    ultimately show ?thesis using UniqueSRO by auto
  next
    assume "orig \<notin> ts'"
    then show ?thesis using UniqueSRO by simp
  qed
next
  case (SRWUnique ts t' tail)
  consider "orig = t'" | "orig \<noteq> t'" by auto
  then show ?case
  proof (cases)
    assume "orig = t'"
    then show ?thesis using SRWUnique reborrow_from_unique_new_layer by auto
  next
    assume "orig \<noteq> t'"
    then show ?thesis using SRWUnique by simp
  qed
next
  case (SRWSRO ts ts' tail)
  consider "orig \<in> ts'" | "orig \<notin> ts'" by auto
  then show ?case
  proof (cases)
    assume "orig \<in> ts'"
    moreover have "k = SharedReadOnly"
      using SRWSRO calculation by simp
    ultimately show ?thesis using SRWSRO by auto
  next
    assume "orig \<notin> ts'"
    then show ?thesis using SRWSRO by simp
  qed
qed

fun_cases reborrow_elims_Unique[case_names _ UniqueUnique UniqueSRW]:
  "reborrow Unique t stack = (Unique, ts) # stack'"
fun_cases reborrow_elims_SRW[case_names _ SRWUnique SRWSRW]:
  "reborrow SharedReadWrite t stack = (SharedReadWrite, ts) # stack'"
fun_cases reborrow_elims_SRO[case_names _ SROUnique SROSRW SROSRO]:
  "reborrow SharedReadOnly t stack = (SharedReadOnly, ts) # stack'"

lemma wf_reborrow_reborrow_Unique:
  assumes
    "wf_reborrow stack"
    "t \<notin> collect_tags stack"
    "reborrow Unique t stack = stack'"
    "stack' \<noteq> []"
  shows "wf_reborrow stack'"
proof -
  have p: "Unique = fst (hd stack') \<and> t \<in> snd (hd stack')"
    using assms reborrow_hd by simp
  then obtain ts rest where
    q: "stack' = (Unique, ts) # rest"
    using assms by (metis list.collapse prod.collapse)
  then have "wf_reborrow ((Unique, ts) # rest)"
  proof (cases t stack ts rest rule: reborrow_elims_Unique)
    case _
    then show ?case using assms(3) q by blast
  next
    case (UniqueUnique ts' stack)
    then show ?thesis using ReborrowUniqueUnique' assms(1) assms(2) unique_ref_head by simp
  next
    case (UniqueSRW ts' stack)
    then show ?thesis using ReborrowSRWUnique' assms(1) assms(2) by simp
  qed
  then show ?thesis by (simp add: q)
qed

lemma wf_reborrow_reborrow_SRW:
  assumes
    "wf_reborrow stack"
    "t \<notin> collect_tags stack"
    "reborrow SharedReadWrite t stack = stack'"
    "stack' \<noteq> []"
  shows "wf_reborrow stack'"
proof -
  have p: "SharedReadWrite = fst (hd stack') \<and> t \<in> snd (hd stack')"
    using assms reborrow_hd by simp
  then obtain ts rest where
    q: "stack' = (SharedReadWrite, ts) # rest"
    using assms by (metis list.collapse prod.collapse)
  then have "wf_reborrow ((SharedReadWrite, ts) # rest)"
  proof (cases t stack ts rest rule: reborrow_elims_SRW)
    case _
    then show ?case using assms(3) q by blast
  next
    case (SRWUnique ts' stack)
    then show ?thesis using assms(1) assms(2) ReborrowUniqueSRW' unique_ref_head by simp
  next
    case (SRWSRW ts')
    moreover have "wf_reborrow ((SharedReadWrite, insert t ts') # rest)"
    proof (rule ReborrowSRWSRW)
      show "wf_reborrow ((SharedReadWrite, ts') # rest)" using assms SRWSRW by simp
    next
      show "t \<notin> ts' \<union> collect_tags rest" using assms SRWSRW by simp
    qed
    ultimately show ?thesis by simp
  qed
  then show ?thesis by (simp add: q)
qed

lemma wf_reborrow_reborrow_SRO:
  assumes
    "wf_reborrow stack"
    "t \<notin> collect_tags stack"
    "reborrow SharedReadOnly t stack = stack'"
    "stack' \<noteq> []"
  shows "wf_reborrow stack'"
proof -
  have p: "SharedReadOnly = fst (hd stack') \<and> t \<in> snd (hd stack')"
    using assms reborrow_hd by simp
  then obtain ts rest where
    q: "stack' = (SharedReadOnly, ts) # rest"
    using assms by (metis list.collapse prod.collapse)
  then have "wf_reborrow ((SharedReadOnly, ts) # rest)"
  proof (cases t stack ts rest rule: reborrow_elims_SRO)
    case _
    then show ?case using assms(3) q by blast
  next
    case (SROUnique ts' stack)
    then show ?thesis using assms(1) assms(2) ReborrowUniqueSRO' unique_ref_head by simp
  next
    case (SROSRW ts' stack)
    then show ?thesis using assms(1) assms(2) ReborrowSRWSRO' by simp
  next
    case (SROSRO ts')
    moreover have "wf_reborrow ((SharedReadOnly, insert t ts') # rest)"
    proof (rule ReborrowSROSRO)
      show "wf_reborrow ((SharedReadOnly, ts') # rest)"
        using assms(1) calculation(1) by blast
    next
      show "t \<notin> ts' \<union> collect_tags rest" using assms SROSRO by simp
    qed
    ultimately show ?thesis by simp
  qed
  then show ?thesis by (simp add: q)
qed

lemma wf_reborrow_reborrow:
  assumes
    "wf_reborrow stack"
    "t \<notin> collect_tags stack"
    "reborrow k t stack = stack'"
    "stack' \<noteq> []"
  shows "wf_reborrow stack'"
proof (cases k)
  case Unique
  then show ?thesis using assms wf_reborrow_reborrow_Unique by simp
next
  case SharedReadWrite
  then show ?thesis using assms wf_reborrow_reborrow_SRW by simp
next
  case SharedReadOnly
  then show ?thesis using assms wf_reborrow_reborrow_SRO by simp
qed

lemma collect_tags_reborrow_subset:
  assumes "reborrow k t stack = stack'"
  shows "collect_tags stack' \<subseteq> {t} \<union> collect_tags stack"
using assms proof(cases rule: reborrow.elims)
qed auto

lemma stack_finite_reborrow:
  assumes
    "reborrow k t stack = stack'"
    "stack_finite stack"
  shows "stack_finite stack'"
using assms collect_tags_reborrow_subset stack_finite_finite_collect_tags
  by (meson collect_tags_stack_finite finite.emptyI finite.insertI finite_Un finite_subset)

lemma notin_pop_tags:
  assumes "pop_tags t stack = stack'"
  shows "collect_tags stack' \<subseteq> collect_tags stack"
using assms proof (induction stack arbitrary: stack')
  case Nil
  then show ?case by simp
next
  case (Cons entry stack)
  show ?case
  proof (cases "t \<in> snd entry")
    case True
    then have "stack' = entry # stack" using Cons.prems by simp
    then show ?thesis by simp
  next
    case False
    then have "stack' = pop_tags t stack" using Cons.prems by simp
    then show ?thesis using Cons.IH by auto
  qed
qed

lemma wf_reborrow_reborrow_comp:
  assumes
    "wf_reborrow stack"
    "writable old stack"
    "pop_tags old stack = popped"
    "reborrow k new popped = stack'"
    "new \<notin> collect_tags stack"
  shows "wf_reborrow stack'"
proof -
  have p: "wf_reborrow popped"
    using assms
    by (metis dropWhile_stack_reborrow BorrowStack.pop_tags.elims
        writable.simps(1) writable_pop_tags)
  have q: "new \<notin> collect_tags popped"
    using assms notin_pop_tags by fastforce
  have "(fst (hd popped) = Unique \<and> old \<in> snd (hd popped))
      \<or> (fst (hd popped) = SharedReadWrite \<and> old \<in> snd (hd popped))"
    using assms writable_pop_tags' by blast
  then show ?thesis
  proof
    assume "fst (hd popped) = Unique \<and> old \<in> snd (hd popped)"
    then obtain ts rest where
      "popped = (Unique, ts) # rest"
      "old \<in> ts"
      by (metis assms(2) assms(3) list.collapse prod.collapse
          writable.simps(1) writable_pop_tags)
    moreover have "ts = {old}" using calculation assms p unique_ref_head by fastforce
    moreover have "reborrow k new ((Unique, {old}) # rest) = stack'"
      using assms calculation by simp
    then show ?thesis
    proof (rule reborrow.elims, auto)
      show "wf_reborrow ((Unique, {new}) # (Unique, {old}) # rest)"
        using assms calculation p q ReborrowUniqueUnique by simp
    next
      show "wf_reborrow ((SharedReadWrite, {new}) # (Unique, {old}) # rest)"
        using assms calculation p q ReborrowUniqueSRW by simp
    next
      show "wf_reborrow ((SharedReadOnly, {new}) # (Unique, {old}) # rest)"
        using assms calculation p q ReborrowUniqueSRO by simp
    qed
  next
    assume "fst (hd popped) = SharedReadWrite \<and> old \<in> snd (hd popped)"
    then obtain ts rest where
      "popped = (SharedReadWrite, ts) # rest"
      "old \<in> ts"
      by (metis assms(2) assms(3) list.collapse prod.collapse
          writable.simps(1) writable_pop_tags)
    moreover have "reborrow k new ((SharedReadWrite, ts) # rest) = stack'"
      using assms calculation by simp
    then show ?thesis
    proof (rule reborrow.elims, auto)
      show "wf_reborrow ((Unique, {new}) # (SharedReadWrite, ts) # rest)"
        using assms calculation p q ReborrowSRWUnique by simp
    next
      show "wf_reborrow ((SharedReadWrite, insert new ts) # rest)"
        using assms calculation p q ReborrowSRWSRW by simp
    next
      show "wf_reborrow ((SharedReadOnly, {new}) # (SharedReadWrite, ts) # rest)"
        using assms calculation p q ReborrowSRWSRO by simp
    qed
  qed
qed

lemma reborrow_comp_subset:
  "collect_tags (reborrow_comp k child parent stack) \<subseteq> {child} \<union> collect_tags stack"
proof (induction stack arbitrary: child parent)
  case Nil
  then show ?case by simp
next
  case (Cons entry stack)
  then show ?case
    by (metis collect_tags_reborrow_subset insert_is_Un insert_mono
        notin_pop_tags reborrow_comp.elims subset_trans)
qed

lemma decomp_pop_tags_writable:
  assumes
    "writable t stack"
    "pop_tags t stack = stack'"
    "wf_reborrow stack"
  shows "(\<exists>rest. stack' = (Unique, {t}) # rest)
  \<or> (\<exists>rest ts. stack' = (SharedReadWrite, ts) # rest \<and> t \<in> ts)"
using assms proof (induction stack)
  case Nil
  then show ?case by simp
next
  case (Cons entry stack)
  then show ?case
  proof (cases "t \<in> snd entry")
    case True
    moreover have "stack' = entry # stack" using Cons.prems calculation by simp
    moreover have "fst entry = Unique \<or> fst entry = SharedReadWrite"
      using Cons.prems(1) Cons.prems(2) calculation(2) writable_pop_tags' by fastforce
    moreover have "entry = (Unique, {t}) \<or> (\<exists>ts. entry = (SharedReadWrite, ts) \<and> t \<in> ts)"
      using Cons calculation
      by (metis empty_iff insert_iff prod.collapse unique_ref_head)
    ultimately show ?thesis by simp
  next
    case False
    moreover have "writable t stack" using Cons.prems calculation
      by (metis eq_snd_iff list.inject writable.elims(2))
    moreover have "pop_tags t stack = stack'" using Cons.prems calculation by simp
    moreover have "wf_reborrow stack"
      using Cons.prems wf_reborrow_pop' calculation(2) writable.simps(1) by blast
    ultimately show ?thesis using Cons.IH by simp
  qed
qed

lemma decomp_pop_tags_writable_obtains:
  assumes
    "writable t stack"
    "pop_tags t stack = stack'"
    "wf_reborrow stack"
  obtains
    rest where "stack' = (Unique, {t}) # rest" |
    rest ts where "stack' = (SharedReadWrite, ts) # rest" "t \<in> ts"
  using assms decomp_pop_tags_writable by blast

lemma decomp_reborrow_comp_writable:
  assumes
    "writable t stack"
    "reborrow_comp k t' t stack = stack'"
    "wf_reborrow stack"
  shows "
  (\<exists>rest. k = Unique \<and> stack' = (Unique, {t'}) # (Unique, {t}) # rest)
  \<or> (\<exists>rest. k = SharedReadWrite \<and> stack' = (SharedReadWrite, {t'}) # (Unique, {t}) # rest)
  \<or> (\<exists>rest. k = SharedReadOnly \<and> stack' = (SharedReadOnly, {t'}) # (Unique, {t}) # rest)
  \<or> (\<exists>rest ts. k = Unique \<and>  stack' = (Unique, {t'}) # (SharedReadWrite, ts) # rest \<and> t \<in> ts)
  \<or> (\<exists>rest ts. k = SharedReadWrite \<and> stack' = (SharedReadWrite, insert t' ts) # rest \<and> t \<in> ts)
  \<or> (\<exists>rest ts. k = SharedReadOnly \<and> stack' = (SharedReadOnly, {t'}) # (SharedReadWrite, ts) # rest \<and> t \<in> ts)"
proof -
  have *: "reborrow k t' (pop_tags t stack) = stack'" (is "reborrow _ _ ?popped = _")
    using assms by simp
  then have "(\<exists>rest. ?popped = (Unique, {t}) # rest)
  \<or> (\<exists>rest ts. ?popped = (SharedReadWrite, ts) # rest \<and> t \<in> ts)"
    using assms decomp_pop_tags_writable by simp
  then show ?thesis
  proof
    assume "\<exists>rest. ?popped = (Unique, {t}) # rest"
    then show ?thesis
      using assms
      by (metis (full_types) "*" reborrow.simps(1) reborrow.simps(3)
          reborrow.simps(5) ref_kind.exhaust)
  next
    assume "\<exists>rest ts. ?popped = (SharedReadWrite, ts) # rest \<and> t \<in> ts"
    then show ?thesis
      using assms
      by (metis (full_types) * reborrow.simps(2) reborrow.simps(4)
          reborrow.simps(6) ref_kind.exhaust)
  qed
qed

lemma decomp_reborrow_comp_writable_elims'[
  consumes 3,
  case_names UniqueUnique SRWUnique SROUnique UniqueSRW SRWSRW SROSRW
  ]:
  assumes
    "writable t stack"
    "reborrow_comp k t' t stack = stack'"
    "wf_reborrow stack"
    "\<exists>rest. k = Unique \<and> stack' = (Unique, {t'}) # (Unique, {t}) # rest \<Longrightarrow> P"
    "\<exists>rest. k = SharedReadWrite \<and> stack' = (SharedReadWrite, {t'}) # (Unique, {t}) # rest \<Longrightarrow> P"
    "\<exists>rest. k = SharedReadOnly \<and> stack' = (SharedReadOnly, {t'}) # (Unique, {t}) # rest \<Longrightarrow> P"
    "\<exists>rest ts. k = Unique \<and> stack' = (Unique, {t'}) # (SharedReadWrite, ts) # rest \<and> t \<in> ts \<Longrightarrow> P"
    "\<exists>rest ts. k = SharedReadWrite \<and> stack' = (SharedReadWrite, insert t' ts) # rest \<and> t \<in> ts \<Longrightarrow> P"
    "\<exists>rest ts. k = SharedReadOnly \<and> stack' = (SharedReadOnly, {t'}) # (SharedReadWrite, ts) # rest \<and> t \<in> ts \<Longrightarrow> P"
  shows "P"
  using decomp_reborrow_comp_writable assms by blast

lemma decomp_reborrow_comp_writable_elims[
  consumes 3,
  case_names UniqueUnique SRWUnique SROUnique UniqueSRW SRWSRW SROSRW
  ]:
  assumes
    "writable t stack"
    "reborrow_comp k t' t stack = stack'"
    "wf_reborrow stack"
    "\<And>rest. k = Unique \<and> stack' = (Unique, {t'}) # (Unique, {t}) # rest \<Longrightarrow> P"
    "\<And>rest. k = SharedReadWrite \<and> stack' = (SharedReadWrite, {t'}) # (Unique, {t}) # rest \<Longrightarrow> P"
    "\<And>rest. k = SharedReadOnly \<and> stack' = (SharedReadOnly, {t'}) # (Unique, {t}) # rest \<Longrightarrow> P"
    "\<And>rest ts. k = Unique \<and> stack' = (Unique, {t'}) # (SharedReadWrite, ts) # rest \<and> t \<in> ts \<Longrightarrow> P"
    "\<And>rest ts. k = SharedReadWrite \<and> stack' = (SharedReadWrite, insert t' ts) # rest \<and> t \<in> ts \<Longrightarrow> P"
    "\<And>rest ts. k = SharedReadOnly \<and> stack' = (SharedReadOnly, {t'}) # (SharedReadWrite, ts) # rest \<and> t \<in> ts \<Longrightarrow> P"
  shows "P"
using assms proof (cases rule: decomp_reborrow_comp_writable_elims')
qed auto

lemma decomp_reborrow_comp_writable_elims''[
  consumes 3,
  case_names UniqueUnique SRWUnique SROUnique UniqueSRW SRWSRW SROSRW
  ]:
  assumes
    "writable t stack"
    "reborrow_comp k t' t stack = stack'"
    "wf_reborrow stack"
  obtains
    rest where "k = Unique" "stack' = (Unique, {t'}) # (Unique, {t}) # rest" |
    rest where "k = SharedReadWrite" "stack' = (SharedReadWrite, {t'}) # (Unique, {t}) # rest" |
    rest where "k = SharedReadOnly" "stack' = (SharedReadOnly, {t'}) # (Unique, {t}) # rest" |
    rest ts where "k = Unique" "stack' = (Unique, {t'}) # (SharedReadWrite, ts) # rest" "t \<in> ts" |
    rest ts where "k = SharedReadWrite" "stack' = (SharedReadWrite, insert t' ts) # rest" "t \<in> ts" |
    rest ts where "k = SharedReadOnly" "stack' = (SharedReadOnly, {t'}) # (SharedReadWrite, ts) # rest" "t \<in> ts"
  using assms
  sorry

lemma writable_reborrow_comp:
  assumes
    "writable t stack"
    "reborrow_comp k t' t stack = stack'"
    "wf_reborrow stack"
    "t' \<notin> collect_tags stack"
  shows "writable t stack'"
using assms proof (cases rule: decomp_reborrow_comp_writable_elims)
  case SROUnique
  then show ?thesis using assms writable_in_collect_tags by fastforce
next
  case SROSRW
  then show ?thesis using assms writable_in_collect_tags by fastforce
qed auto

lemma writable_reborrow_comp_derived:
  assumes
    "writable t stack"
    "reborrow_comp k t' t stack = stack'"
    "wf_reborrow stack"
    "k = Unique \<or> k = SharedReadWrite"
  shows "writable t' stack'"
using assms proof (cases rule: decomp_reborrow_comp_writable_elims)
qed auto

lemma writable_imp_in_tags[intro]:
  assumes "writable t stack"
  shows "\<exists>entry \<in>set stack. t \<in> snd entry"
  using assms writable_in_collect_tags by auto

fun in_same_layer :: "tag \<Rightarrow> tag \<Rightarrow> (ref_kind * tag set) stack \<Rightarrow> bool" where
  "in_same_layer p q [] = False"
| "in_same_layer p q (entry # stack) =
    ((p \<in> snd entry \<and> q \<in> snd entry) \<or> in_same_layer p q stack)"

lemma in_same_layer_collect_tags1:
  assumes "in_same_layer p q stack"
  shows "p \<in> collect_tags stack"
using assms proof (induction stack)
qed auto

lemma in_same_layer_collect_tags2:
  assumes "in_same_layer p q stack"
  shows "q \<in> collect_tags stack"
using assms proof (induction stack)
qed auto

lemma in_same_layer_same_pos:
  assumes
    "in_same_layer p q stack"
  shows "\<exists>i. i < length stack \<and> p \<in> snd (stack ! i) \<and> q \<in> snd (stack ! i)"
using assms proof (induction stack)
  case Nil
  then show ?case by simp
next
  case (Cons entry stack)
  then show ?case by fastforce
qed

lemma in_same_layer_cases:
  assumes
    "wf_reborrow stack"
    "in_same_layer p q stack"
  obtains
    "p \<in> snd (hd stack) \<and> q \<in> snd (hd stack)"
  | "p \<notin> snd (hd stack) \<and> q \<notin> snd (hd stack) \<and> in_same_layer p q (tl stack)"
using assms proof (induction rule: wf_reborrow_induct')
  case (Root t)
  then show ?case by simp
next
  case (UniqueUnique t t' tail)
  then show ?case
    by (metis ReborrowUniqueUnique in_same_layer.simps(2) in_same_layer_collect_tags1
        in_same_layer_collect_tags2 insert_disjoint(2) insert_is_Un list.sel(1) list.sel(3)
        wf_reborrow_top_tag_notin)
next
  case (UniqueSRW t ts' tail)
  then show ?case
    by (metis assms(1) assms(2) hd_Cons_tl in_same_layer.simps(1) in_same_layer.simps(2)
        in_same_layer_collect_tags1 in_same_layer_collect_tags2 that(1) that(2)
        wf_reborrow_top_tag_notin)
next
  case (UniqueSRO t ts' tail)
  then show ?case
    by (metis assms(1) assms(2) hd_Cons_tl in_same_layer.simps(1) in_same_layer.simps(2)
        in_same_layer_collect_tags1 in_same_layer_collect_tags2 that(1) that(2)
        wf_reborrow_top_tag_notin)
next
  case (SRWUnique ts t' tail)
  then show ?case
    by (metis Un_iff empty_iff in_same_layer.simps(2) in_same_layer_collect_tags1
        in_same_layer_collect_tags2 insert_disjoint(2) insert_iff list.sel(1) list.sel(3) snd_conv)
next
  case (SRWSRO ts ts' tail)
  then show ?case
    by (metis assms(1) assms(2) in_same_layer.elims(2) in_same_layer_collect_tags1
        in_same_layer_collect_tags2 list.sel(1) list.sel(3) that(1) that(2)
        wf_reborrow_top_tag_notin)
qed

lemma in_same_layer_pop_tags:
  "\<lbrakk>wf_reborrow stack; in_same_layer p q stack\<rbrakk> \<Longrightarrow> pop_tags p stack = pop_tags q stack"
proof (induction stack)
  case Nil
  then show ?case by simp
next
  case (Cons entry stack)
  consider "p \<in> snd entry \<and> q \<in> snd entry"
    | "p \<notin> snd entry \<and> q \<notin> snd entry \<and> in_same_layer p q stack"
    by (metis in_same_layer.simps(2) in_same_layer_cases Cons.prems list.sel(1))
  then show ?case
  proof (cases)
    assume "p \<in> snd entry \<and> q \<in> snd entry"
    then show ?thesis by simp
  next
    assume "p \<notin> snd entry \<and> q \<notin> snd entry \<and> in_same_layer p q stack"
    moreover have "wf_reborrow stack"
      using Cons.prems wf_reborrow_pop' calculation in_same_layer.simps(1) by blast
    ultimately show ?thesis using Cons.IH by simp
  qed
qed

end


(*  Title:       CCPO_Topology.thy
    Author:      Johannes Hölzl, TU Munich
*)

header {* CCPO topologies *}

theory CCPO_Topology
imports
  "~~/src/HOL/Multivariate_Analysis/Extended_Real_Limits"
  "../Coinductive_Nat"
begin

lemma dropWhile_append:
  "dropWhile P (xs @ ys) = (if \<forall>x\<in>set xs. P x then dropWhile P ys else dropWhile P xs @ ys)"
  by auto

lemma dropWhile_False: "(\<And>x. x \<in> set xs \<Longrightarrow> P x) \<Longrightarrow> dropWhile P xs = []"
  by simp

abbreviation (in order) "chain \<equiv> Complete_Partial_Order.chain op \<le>"

lemma (in linorder) chain_linorder: "chain C"
  by (simp add: chain_def linear)

lemma continuous_add_ereal:
  assumes "0 \<le> t"
  shows "continuous_on {-\<infinity>::ereal <..} (\<lambda>x. t + x)"
proof (subst continuous_on_open_vimage, (intro open_greaterThan allI impI)+)
  fix B :: "ereal set" assume "open B"
  show "open ((\<lambda>x. t + x) -` B \<inter> {- \<infinity><..})"
  proof (cases t)
    case (real t')
    then have *: "(\<lambda>x. t + x) -` B \<inter> {- \<infinity><..} = (\<lambda>x. 1 * x + (-t)) ` (B \<inter> {-\<infinity> <..})"
      apply (simp add: set_eq_iff image_iff Bex_def)
      apply (intro allI iffI)
      apply (rule_tac x= "x + ereal t'" in exI)
      apply (case_tac x)
      apply (auto simp: ac_simps)
      apply (case_tac xa)
      apply auto
      done
    show ?thesis
      unfolding *
      apply (rule ereal_open_affinity_pos)
      using `open B`
      apply (auto simp: real)
      done
  qed (insert `0 \<le> t`, auto)
qed

lemma tendsto_add_ereal:
  "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> (f ---> y) F \<Longrightarrow> ((\<lambda>z. x + f z :: ereal) ---> x + y) F"
  apply (rule tendsto_compose[where f=f])
  using continuous_add_ereal[where t=x]
  unfolding continuous_on_def
  apply (auto simp add: at_within_open[where S="{- \<infinity> <..}"])
  apply (erule ballE[where x=y])
  apply auto
  done

lemma tendsto_LimI: "(f ---> y) F \<Longrightarrow> (f ---> Lim F f) F"
  by (metis tendsto_Lim tendsto_bot)

subsection {* The filter @{text at'} *}

abbreviation (in ccpo) "compact_element \<equiv> Complete_Partial_Order2.compact Sup op \<le>"

lemma tendsto_unique_eventually:
  fixes x x' :: "'a :: t2_space"
  shows "F \<noteq> bot \<Longrightarrow> eventually (\<lambda>x. f x = g x) F \<Longrightarrow> (f ---> x) F \<Longrightarrow> (g ---> x') F \<Longrightarrow> x = x'"
  by (metis tendsto_unique filterlim_cong)

lemma (in ccpo) ccpo_Sup_upper2: "chain C \<Longrightarrow> x \<in> C \<Longrightarrow> y \<le> x \<Longrightarrow> y \<le> Sup C"
  by (blast intro: ccpo_Sup_upper order_trans)

lemma tendsto_open_vimage: "(\<And>B. open B \<Longrightarrow> open (f -` B)) \<Longrightarrow> f -- l --> f l"
  using continuous_on_open_vimage[of UNIV f] continuous_on_def[of UNIV f] by simp

lemma open_vimageI: "(\<And>x. f -- x --> f x) \<Longrightarrow> open A \<Longrightarrow> open (f -` A)"
  using continuous_on_open_vimage[of UNIV f] continuous_on_def[of UNIV f] by simp

lemma principal_bot: "principal x = bot \<longleftrightarrow> x = {}"
  by (auto simp: filter_eq_iff eventually_principal)

definition "at' x = (if open {x} then principal {x} else at x)"

lemma at'_bot: "at' x \<noteq> bot"
  by (simp add: at'_def at_eq_bot_iff principal_bot)

lemma tendsto_id_at'[simp, intro]: "((\<lambda>x. x) ---> x) (at' x)"
  by (simp add: at'_def topological_tendstoI eventually_principal tendsto_ident_at)

lemma cont_at': "(f ---> f x) (at' x) \<longleftrightarrow> f -- x --> f x"
  using at_eq_bot_iff[of x] by (auto split: split_if_asm intro!: topological_tendstoI simp: eventually_principal at'_def)

subsection {* The type class @{text ccpo_topology} *}

text {* Temporarily relax type constraints for @{term "open"}. *}
setup {* Sign.add_const_constraint
  (@{const_name "open"}, SOME @{typ "'a::open set \<Rightarrow> bool"}) *}

class ccpo_topology = "open" + ccpo +
  assumes open_ccpo: "open A \<longleftrightarrow> (\<forall>C. chain C \<longrightarrow> C \<noteq> {} \<longrightarrow> Sup C \<in> A \<longrightarrow> C \<inter> A \<noteq> {})"
begin

lemma open_ccpoD:
  assumes "open A" "chain C" "C \<noteq> {}" "Sup C \<in> A"
  shows "\<exists>c\<in>C. \<forall>c'\<in>C. c \<le> c' \<longrightarrow> c' \<in> A"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then have *: "\<And>c. c \<in> C \<Longrightarrow> \<exists>c'\<in>C. c \<le> c' \<and> c' \<notin> A"
    by auto
  with `chain C` `C \<noteq> {}` have "chain (C - A)" "C - A \<noteq> {}"
    by (auto intro: chain_Diff)
  moreover have "Sup C = Sup (C - A)"
  proof (safe intro!: antisym ccpo_Sup_least `chain C` chain_Diff)
    fix c assume "c \<in> C"
    with * obtain c' where "c' \<in> C" "c \<le> c'" "c' \<notin> A"
      by auto
    with `c\<in>C` show "c \<le> \<Squnion>(C - A)"
      by (intro ccpo_Sup_upper2 `chain (C - A)`) auto
  qed (auto intro: `chain C` ccpo_Sup_upper)
  ultimately show False
    using `open A` `Sup C \<in> A` by (auto simp: open_ccpo)
qed

lemma open_ccpo_Iic: "open {.. b}"
  by (auto simp: open_ccpo) (metis Int_iff atMost_iff ccpo_Sup_upper empty_iff order_trans)

subclass topological_space
proof
  show "open (UNIV::'a set)"
    unfolding open_ccpo by auto
next
  fix S T :: "'a set" assume "open S" "open T"
  show "open (S \<inter> T)"
    unfolding open_ccpo
  proof (intro allI impI)
    fix C assume C: "chain C" "C \<noteq> {}" and "\<Squnion>C \<in> S \<inter> T"
    with open_ccpoD[OF `open S` C] open_ccpoD[OF `open T` C]
    show "C \<inter> (S \<inter> T) \<noteq> {}"
      unfolding chain_def by blast
  qed
next
  fix K :: "'a set set" assume *: "\<forall>D\<in>K. open D"
  show "open (\<Union>K)"
    unfolding open_ccpo
  proof (intro allI impI)
    fix C assume "chain C" "C \<noteq> {}" "\<Squnion>C \<in> (\<Union>K)"
    with * obtain D where "D \<in> K" "\<Squnion>C \<in> D" "C \<inter> D \<noteq> {}"
      by (auto simp: open_ccpo)
    then show "C \<inter> (\<Union>K) \<noteq> {}"
      by auto
  qed
qed

lemma closed_ccpo: "closed A \<longleftrightarrow> (\<forall>C. chain C \<longrightarrow> C \<noteq> {} \<longrightarrow> C \<subseteq> A \<longrightarrow> Sup C \<in> A)"
  unfolding closed_def open_ccpo by auto

lemma closed_admissible: "closed {x. P x} \<longleftrightarrow> ccpo.admissible Sup op \<le> P"
  unfolding closed_ccpo ccpo.admissible_def by auto

lemma open_singletonI_compact: "compact_element x \<Longrightarrow> open {x}"
  using admissible_compact_neq[of Sup "op \<le>" x]
  by (simp add: closed_admissible[symmetric] open_closed Collect_neg_eq)

lemma closed_Ici: "closed {.. b}"
  by (auto simp: closed_ccpo intro: ccpo_Sup_least)

lemma closed_Iic: "closed {b ..}"
  by (auto simp: closed_ccpo intro: ccpo_Sup_upper2)

text {*
  @{class ccpo_topology}s are also @{class t2_space}s.
  This is necessary to have a unique continuous extension.
*}

subclass t2_space
proof
  fix x y :: 'a assume "x \<noteq> y"
  show "\<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {}"
  proof cases
    { fix x y assume "x \<noteq> y" "x \<le> y"
      then have "open {..x} \<and> open (- {..x}) \<and> x \<in> {..x} \<and> y \<in> - {..x} \<and> {..x} \<inter> - {..x} = {}"
        by (auto intro: open_ccpo_Iic closed_Ici) }
    moreover assume "x \<le> y \<or> y \<le> x"
    ultimately show ?thesis
      using `x \<noteq> y` by (metis Int_commute)
  next
    assume "\<not> (x \<le> y \<or> y \<le> x)"
    then have "open ({..x} \<inter> - {..y}) \<and> open ({..y} \<inter> - {..x}) \<and>
        x \<in> {..x} \<inter> - {..y} \<and> y \<in> {..y} \<inter> - {..x} \<and> ({..x} \<inter> - {..y}) \<inter> ({..y} \<inter> - {..x}) = {}"
      by (auto intro: open_ccpo_Iic closed_Ici)
    then show ?thesis by auto
  qed
qed

end

lemma tendsto_le_ccpo:
  fixes f g :: "'a \<Rightarrow> 'b::ccpo_topology"
  assumes F: "\<not> trivial_limit F"
  assumes x: "(f ---> x) F" and y: "(g ---> y) F"
  assumes ev: "eventually (\<lambda>x. g x \<le> f x) F"
  shows "y \<le> x"
proof (rule ccontr)
  assume "\<not> y \<le> x"

  show False
  proof cases
    assume "x \<le> y"
    with `\<not> y \<le> x`
    have "open {..x}" "open (- {..x})" "x \<in> {..x}" "y \<in> - {..x}" "{..x} \<inter> - {..x} = {}"
      by (auto intro: open_ccpo_Iic closed_Ici)
    with topological_tendstoD[OF x, of "{..x}"] topological_tendstoD[OF y, of "- {..x}"]
    have "eventually (\<lambda>z. f z \<le> x) F" "eventually (\<lambda>z. \<not> g z \<le> x) F"
      by auto
    with ev have "eventually (\<lambda>x. False) F" by eventually_elim (auto intro: order_trans)
    with F show False by (auto simp: eventually_False)
  next
    assume "\<not> x \<le> y"
    with `\<not> y \<le> x` have "open ({..x} \<inter> - {..y})" "open ({..y} \<inter> - {..x})"
        "x \<in> {..x} \<inter> - {..y}" "y \<in> {..y} \<inter> - {..x}" "({..x} \<inter> - {..y}) \<inter> ({..y} \<inter> - {..x}) = {}"
      by (auto intro: open_ccpo_Iic closed_Ici)
    with topological_tendstoD[OF x, of "{..x} \<inter> - {..y}"]
         topological_tendstoD[OF y, of "{..y} \<inter> - {..x}"]
    have "eventually (\<lambda>z. f z \<le> x \<and> \<not> f z \<le> y) F" "eventually (\<lambda>z. g z \<le> y \<and> \<not> g z \<le> x) F"
      by auto
    with ev have "eventually (\<lambda>x. False) F" by eventually_elim (auto intro: order_trans)
    with F show False by (auto simp: eventually_False)
  qed
qed

lemma tendsto_ccpoI:
  fixes f :: "'a::ccpo_topology \<Rightarrow> 'b::ccpo_topology"
  shows "(\<And>C. chain C \<Longrightarrow> C \<noteq> {} \<Longrightarrow> chain (f ` C) \<and> f (Sup C) = Sup (f`C)) \<Longrightarrow> f -- x --> f x"
  by (intro tendsto_open_vimage) (auto simp: open_ccpo simp del: Sup_image_eq)

lemma tendsto_mcont:
  assumes mcont: "mcont Sup op \<le> Sup op \<le> (f :: 'a :: ccpo_topology \<Rightarrow> 'b :: ccpo_topology)"
  shows "f -- l --> f l"
proof (intro tendsto_ccpoI conjI)
  fix C :: "'a set" assume C: "chain C" "C \<noteq> {}"
  show "chain (f`C)"
    using mcont
    by (intro chain_imageI[where le_a="op \<le>"] C) (simp add: mcont_def monotone_def)
  show "f (\<Squnion>C) = \<Squnion>(f ` C)"
    using mcont C by (simp add: mcont_def cont_def)
qed

subsection {* Instances for @{class ccpo_topology}s and continuity theorems *}

instantiation set :: (type) ccpo_topology
begin

definition open_set :: "'a set set \<Rightarrow> bool" where
  "open_set A \<longleftrightarrow> (\<forall>C. chain C \<longrightarrow> C \<noteq> {} \<longrightarrow> Sup C \<in> A \<longrightarrow> C \<inter> A \<noteq> {})"

instance
  by intro_classes (simp add: open_set_def)

end

instantiation enat :: ccpo_topology
begin

definition open_enat :: "enat set \<Rightarrow> bool" where
  "open_enat A \<longleftrightarrow> (\<forall>C. C \<noteq> {} \<longrightarrow> Sup C \<in> A \<longrightarrow> C \<inter> A \<noteq> {})"

instance
  by intro_classes (simp add: open_enat_def chain_linorder)

text {* We could also prove that @{type enat} is not only a @{class ccpo_topology} but also a
  @{class linorder_topology} *}

end

lemmas tendsto_inf2[THEN tendsto_compose, tendsto_intros] =
  tendsto_mcont[OF mcont_inf2]

lemma isCont_inf2[THEN isCont_o2[rotated]]:
  "isCont (\<lambda>x. x \<sqinter> y) (z :: _ :: {ccpo_topology, complete_distrib_lattice})"
  by(simp add: isCont_def tendsto_inf2 tendsto_ident_at)

lemmas tendsto_sup1[THEN tendsto_compose, tendsto_intros] =
  tendsto_mcont[OF mcont_sup1]

lemma isCont_If: "isCont f x \<Longrightarrow> isCont g x \<Longrightarrow> isCont (\<lambda>x. if Q then f x else g x) x"
  by (cases Q) auto

lemma isCont_enat_case: "isCont (f (epred n)) x \<Longrightarrow> isCont g x \<Longrightarrow> isCont (\<lambda>x. co.case_enat (g x) (\<lambda>n. f n x) n) x"
  by (cases n rule: enat_coexhaust) auto

end


theory Adequacy
imports "ResourcedAdequacy" "Denotational-Related"
begin

theorem adequacy:
  assumes "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<^esub> \<noteq> \<bottom>"
  shows "\<exists> \<Delta> v. \<Gamma> : e \<Down>\<^bsub>S\<^esub> \<Delta> : v"
proof-
  have "\<lbrace>\<Gamma>\<rbrace> \<triangleleft>\<triangleright>\<^sup>* \<N>\<lbrace>\<Gamma>\<rbrace>" by (rule heaps_similar)
  hence  "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<^esub> \<triangleleft>\<triangleright> (\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>C\<^sup>\<infinity>" by (rule denotational_semantics_similar)
  from bot_or_not_bot[OF this] assms
  have "(\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>C\<^sup>\<infinity> \<noteq> \<bottom>" by metis
  thus ?thesis by (rule resourced_adequacy)
qed

end