(* Title:     Error_Monad
   Author:    Christian Sternagel
   Author:    René Thiemann
*)

header \<open>The Sum Type as Error Monad\<close>

theory Error_Monad
imports
  "~~/src/HOL/Library/Monad_Syntax"
  Error_Syntax
begin

text \<open>Make monad syntax (including do-notation) available for the sum type.\<close>
definition bind :: "'e + 'a \<Rightarrow> ('a \<Rightarrow> 'e + 'b) \<Rightarrow> 'e + 'b"
where
  "bind m f = (case m of Inr x \<Rightarrow> f x | Inl e \<Rightarrow> Inl e)"

adhoc_overloading
  Monad_Syntax.bind bind

abbreviation (input) "return \<equiv> Inr"
abbreviation (input) "error \<equiv> Inl"
abbreviation (input) "run \<equiv> projr"

subsection \<open>Monad Laws\<close>

lemma return_bind [simp]:
  "(return x \<guillemotright>= f) = f x"
  by (simp add: bind_def)

lemma bind_return [simp]:
  "(m \<guillemotright>= return) = m"
  by (cases m) (simp_all add: bind_def)

lemma error_bind [simp]:
  "(error e \<guillemotright>= f) = error e"
  by (simp add: bind_def)

lemma bind_assoc [simp]:
  fixes m :: "'a + 'b"
  shows "((m \<guillemotright>= f) \<guillemotright>= g) = (m \<guillemotright>= (\<lambda>x. f x \<guillemotright>= g))"
  by (cases m) (simp_all add: bind_def)

definition catch_error :: "'e + 'a \<Rightarrow> ('e \<Rightarrow> 'f + 'a) \<Rightarrow> 'f + 'a"
where
  catch_def: "catch_error m f = (case m of Inl e \<Rightarrow> f e | Inr x \<Rightarrow> Inr x)"

adhoc_overloading
  Error_Syntax.catch catch_error

lemma catch_splits:
  "P (try m catch f) \<longleftrightarrow> (\<forall>e. m = Inl e \<longrightarrow> P (f e)) \<and> (\<forall>x. m = Inr x \<longrightarrow> P (Inr x))"
  "P (try m catch f) \<longleftrightarrow> (\<not> ((\<exists>e. m = Inl e \<and> \<not> P (f e)) \<or> (\<exists>x. m = Inr x \<and> \<not> P (Inr x))))"
  by (case_tac [!] m) (simp_all add: catch_def)

abbreviation update_error :: "'e + 'a \<Rightarrow> ('e \<Rightarrow> 'f) \<Rightarrow> 'f + 'a"
where
  "update_error m f \<equiv> try m catch (\<lambda>x. error (f x))"

adhoc_overloading
  Error_Syntax.update_error update_error

lemma catch_return [simp]:
  "(try return x catch f) = return x" by (simp add: catch_def)

lemma catch_error [simp]:
  "(try error e catch f) = f e" by (simp add: catch_def)

lemma update_error_return [simp]:
  "(m <+? c = return x) \<longleftrightarrow> (m = return x)"
  by (cases m) simp_all

definition "isOK m \<longleftrightarrow> (case m of Inl e \<Rightarrow> False | Inr x \<Rightarrow> True)"

lemma isOK_E [elim]:
  assumes "isOK m"
  obtains x where "m = return x"
  using assms by (cases m) (simp_all add: isOK_def)

lemma isOK_I [simp, intro]:
  "m = return x \<Longrightarrow> isOK m"
  by (cases m) (simp_all add: isOK_def)

lemma isOK_iff:
  "isOK m \<longleftrightarrow> (\<exists>x. m = return x)"
  by blast

lemma isOK_error [simp]:
  "isOK (error x) = False"
  by blast

lemma isOK_bind [simp]:
  "isOK (m \<guillemotright>= f) \<longleftrightarrow> isOK m \<and> isOK (f (run m))"
  by (cases m) simp_all

lemma isOK_update_error [simp]:
  "isOK (m <+? f) \<longleftrightarrow> isOK m"
  by (cases m) simp_all

lemma isOK_case_prod [simp]:
  "isOK (case lr of (l, r) \<Rightarrow> P l r) = (case lr of (l, r) \<Rightarrow> isOK (P l r))"
  by (rule case_prod_distrib)

lemma isOK_case_option [simp]:
  "isOK (case x of None \<Rightarrow> P | Some v \<Rightarrow> Q v) = (case x of None \<Rightarrow> isOK P | Some v \<Rightarrow> isOK (Q v))"
  by (cases x) (auto)

lemma isOK_Let [simp]:
  "isOK (Let s f) = isOK (f s)"
  by (simp add: Let_def)

lemma run_bind [simp]:
  "isOK m \<Longrightarrow> run (m \<guillemotright>= f) = run (f (run m))"
  by auto

lemma run_catch [simp]:
  "isOK m \<Longrightarrow> run (try m catch f) = run m"
  by auto

fun foldM :: "('a \<Rightarrow> 'b \<Rightarrow> 'e + 'a) \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> 'e + 'a"
where
  "foldM f d [] = return d" |
  "foldM f d (x # xs) = do { y \<leftarrow> f d x; foldM f y xs }"

fun forallM_index_aux :: "('a \<Rightarrow> nat \<Rightarrow> 'e + unit) \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> (('a \<times> nat) \<times> 'e) + unit"
where
  "forallM_index_aux P i [] = return ()" |
  "forallM_index_aux P i (x # xs) = do {
    P x i <+? Pair (x, i);
    forallM_index_aux P (Suc i) xs
  }"

lemma isOK_forallM_index_aux [simp]:
  "isOK (forallM_index_aux P n xs) = (\<forall>i < length xs. isOK (P (xs ! i) (i + n)))"
proof (induct xs arbitrary: n)
  case (Cons x xs)
  have "(\<forall>i < length (x # xs). isOK (P ((x # xs) ! i) (i + n))) \<longleftrightarrow>
    (isOK (P x n) \<and> (\<forall>i < length xs. isOK (P (xs ! i) (i + Suc n))))"
    by (auto, case_tac i) (simp_all)
  then show ?case
    unfolding Cons [of "Suc n", symmetric] by simp
qed auto

definition forallM_index :: "('a \<Rightarrow> nat \<Rightarrow> 'e + unit) \<Rightarrow> 'a list \<Rightarrow> (('a \<times> nat) \<times> 'e) + unit"
where
  "forallM_index P xs = forallM_index_aux P 0 xs"

lemma isOK_forallM_index [simp]:
  "isOK (forallM_index P xs) \<longleftrightarrow> (\<forall>i < length xs. isOK (P (xs ! i) i))"
  unfolding forallM_index_def isOK_forallM_index_aux by simp

lemma forallM_index [fundef_cong]:
  fixes c :: "'a \<Rightarrow> nat \<Rightarrow> 'e + unit"
  assumes "\<And>x i. x \<in> set xs \<Longrightarrow> c x i = d x i"
  shows "forallM_index c xs = forallM_index d xs"
proof -
  { fix n
    have "forallM_index_aux c n xs = forallM_index_aux d n xs"
      using assms by (induct xs arbitrary: n) simp_all }
  then show ?thesis by (simp add: forallM_index_def)
qed

hide_const forallM_index_aux

text \<open>
  Check whether @{term f} succeeds for all elements of a given list. In case it doesn't,
  return the first offending element together with the produced error.
\<close>
fun forallM :: "('a \<Rightarrow> 'e + unit) \<Rightarrow> 'a list \<Rightarrow> ('a * 'e) + unit"
where
  "forallM f [] = return ()" |
  "forallM f (x # xs) = f x <+? Pair x \<guillemotright> forallM f xs"

lemma isOK_forallM [simp]:
  "isOK (forallM f xs) \<longleftrightarrow> (\<forall>x \<in> set xs. isOK (f x))"
  by (induct xs) (simp_all)

text \<open>
  Check whether @{term f} succeeds for at least one element of a given list.
  In case it doesn't, return the list of produced errors.
\<close>
fun existsM :: "('a \<Rightarrow> 'e + unit) \<Rightarrow> 'a list \<Rightarrow> 'e list + unit"
where
  "existsM f [] = error []" |
  "existsM f (x # xs) = (try f x catch (\<lambda>e. existsM f xs <+? Cons e))"

lemma isOK_existsM [simp]:
  "isOK (existsM f xs) \<longleftrightarrow> (\<exists>x\<in>set xs. isOK (f x))"
proof (induct xs)
  case (Cons x xs)
  show ?case
  proof (cases "f x")
    case (Inl e)
    with Cons show ?thesis by simp
  qed (auto simp add: catch_def)
qed simp

lemma is_OK_if_return [simp]:
  "isOK (if b then return x else m) \<longleftrightarrow> b \<or> isOK m"
  "isOK (if b then m else return x) \<longleftrightarrow> \<not> b \<or> isOK m"
  by simp_all

lemma isOK_if_error [simp]:
  "isOK (if b then error e else m) \<longleftrightarrow> \<not> b \<and> isOK m"
  "isOK (if b then m else error e) \<longleftrightarrow> b \<and> isOK m"
  by simp_all

lemma isOK_if:
  "isOK (if b then x else y) \<longleftrightarrow> b \<and> isOK x \<or> \<not> b \<and> isOK y"
  by simp

fun sequence :: "('e + 'a) list \<Rightarrow> 'e + 'a list"
where
  "sequence [] = Inr []" |
  "sequence (m # ms) = do {
    x \<leftarrow> m;
    xs \<leftarrow> sequence ms;
    return (x # xs)
  }"

subsection \<open>Monadic Map for Error Monad\<close>

fun mapM :: "('a \<Rightarrow> 'e + 'b) \<Rightarrow> 'a list \<Rightarrow> 'e + 'b list"
where
  "mapM f [] = return []" |
  "mapM f (x#xs) = do {
    y \<leftarrow> f x;
    ys \<leftarrow> mapM f xs;
    Inr (y # ys)
  }"

lemma mapM_error:
  "(\<exists>e. mapM f xs = error e) \<longleftrightarrow> (\<exists>x\<in>set xs. \<exists>e. f x = error e)"
proof (induct xs)
  case (Cons x xs)
  then show ?case
    by (cases "f x", simp_all, cases "mapM f xs", simp_all)
qed simp

lemma mapM_return:
  assumes "mapM f xs = return ys"
  shows "ys = map (run \<circ> f) xs \<and> (\<forall>x\<in>set xs. \<forall>e. f x \<noteq> error e)"
using assms
proof (induct xs arbitrary: ys)
  case (Cons x xs ys)
  then show ?case
    by (cases "f x", simp, cases "mapM f xs", simp_all)
qed simp

lemma mapM_return_idx:
  assumes *: "mapM f xs = Inr ys" and "i < length xs"
  shows "\<exists>y. f (xs ! i) = Inr y \<and> ys ! i = y"
proof -
  note ** = mapM_return [OF *, unfolded set_conv_nth]
  with assms have "\<And>e. f (xs ! i) \<noteq> Inl e" by auto
  then obtain y where "f (xs ! i) = Inr y" by (cases "f (xs ! i)") auto
  then have "f (xs ! i) = Inr y \<and> ys ! i = y" unfolding ** [THEN conjunct1] using assms by auto
  then show ?thesis ..
qed

lemma mapM_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "mapM f xs = mapM g ys"
  unfolding assms(1) using assms(2) by (induct ys) auto

lemma bindE [elim]:
  assumes "(p \<guillemotright>= f) = return x"
  obtains y where "p = return y" and "f y = return x"
  using assms by (cases p) simp_all

lemma then_return_eq [simp]:
  "(p \<guillemotright> q) = return f \<longleftrightarrow> isOK p \<and> q = return f"
  by (cases p) simp_all

end


theory CorrectnessStacked
  imports "Denotational" LaunchburyStacked
begin

subsubsection {* The semantics of let only adds new bindings *}

text {*
The following lemma is not as general as possible and specialized to @{text "\<rho> = fempty"}, as that is
the only case required later on, and easier to prove.
*}

lemma HSem_unfold_let:
  assumes distinct: "distinctVars ((x, body) # \<Gamma>)"
  assumes fresh: "set (bn as) \<sharp>* (x, Let as body, \<Gamma>)"
  shows "\<lbrace>(x, Let as body) # \<Gamma>\<rbrace> = (\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>)f|` (insert x (heapVars \<Gamma>))"
proof-
  from fresh
  have fresh_Gamma: "atom ` heapVars (asToHeap as) \<sharp>* \<Gamma>"
    by (metis fresh_star_Pair set_bn_to_atom_heapVars)

  from fresh
  have "set (bn as) \<sharp>* ((x, Let as body) # \<Gamma>)"
    by (auto simp add: fresh_star_def fresh_Pair fresh_Cons)
  from fresh_assn_distinct[OF this]
  have disjoint: "heapVars (asToHeap as) \<inter> insert x (heapVars \<Gamma>) = {}"
     by auto
  hence x_not_as: "x \<notin> heapVars (asToHeap as)"
    by auto

  {
    fix x' e
    assume "e \<in> snd ` set \<Gamma>"

    have simp1: " fdom (\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>) \<inter> insert x (heapVars \<Gamma>) = insert x (heapVars \<Gamma>)"
      by auto

    have simp2: "fdom (\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>) - insert x (heapVars \<Gamma>) = heapVars (asToHeap as)"
      using disjoint
      by auto

    have fresh_e: "atom ` heapVars (asToHeap as) \<sharp>* e"
      by (rule fresh_star_heap_expr'[OF fresh_Gamma `_ \<in> snd\` set \<Gamma>`])

    have "\<lbrakk> e \<rbrakk>\<^bsub>fmap_restr (insert x (heapVars \<Gamma>)) (\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>)\<^esub> = \<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>\<^esub>"
      apply (rule ESem_ignores_fresh_restr'[symmetric])
      apply (subst simp2)
      apply (rule fresh_e)
      done
  } note Gamma_eq = this

case goal1
  have "\<lbrace>(x, Let as body) # \<Gamma>\<rbrace> = fmap_restr (insert x (heapVars \<Gamma>)) (\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>)"
  proof(rule below_antisym)
    show "\<lbrace>(x, Let as body) # \<Gamma>\<rbrace> \<sqsubseteq> fmap_restr (insert x (heapVars \<Gamma>)) (\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>)" (is "_ \<sqsubseteq> ?r")
    proof (rule HSem_fempty_below)
      fix x'
      assume "x' \<in> heapVars ((x, Terms.Let as body) # \<Gamma>)"
      hence x': "x' \<in> insert x (heapVars \<Gamma>)" by simp

      hence x'_not_as:"x' \<notin> heapVars (asToHeap as)"
        using disjoint
        by auto
      show "\<lbrakk> the (map_of ((x, Terms.Let as body) # \<Gamma>) x') \<rbrakk>\<^bsub>?r\<^esub> \<sqsubseteq> ?r f! x'"
      proof(cases "x' = x")
      case True
        have "\<lbrakk> Terms.Let as body \<rbrakk>\<^bsub>?r\<^esub> = \<lbrakk> body \<rbrakk>\<^bsub>\<lbrace>asToHeap as\<rbrace>?r\<^esub>" by simp
        also have "... = \<lbrakk> body \<rbrakk>\<^bsub>\<lbrace>asToHeap as\<rbrace>(fmap_restr (insert x (heapVars \<Gamma>)) (\<lbrace>asToHeap as @ ((x, body) # \<Gamma>)\<rbrace>))\<^esub>"
          by (rule arg_cong[OF HSem_reorder_head_append[OF x_not_as]])
        also have "... = \<lbrakk> body \<rbrakk>\<^bsub>\<lbrace>asToHeap as @ ((x, body) # \<Gamma>)\<rbrace>\<^esub>"
          by (rule arg_cong[OF HSem_redo[where \<rho> = "f\<emptyset>" and \<Delta> = "(x, body) # \<Gamma>", simplified]])
        also have "... = \<lbrakk> body \<rbrakk>\<^bsub>\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>\<^esub>"
          by (rule arg_cong[OF HSem_reorder_head_append[OF x_not_as], symmetric])
        finally
        show ?thesis using True x' by (simp add: lookup_HSem_heap)
      next
        case False thus ?thesis
        apply (subst (2) HSem_eq)
        using x'
        apply (simp add: lookupHeapToEnvNotAppend[OF x'_not_as] lookupHeapToEnv Gamma_eq[OF the_map_of_snd])
        done
      qed
    qed auto

    have "(\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>) \<sqsubseteq> \<lbrace>asToHeap as\<rbrace>\<lbrace>(x, Let as body) # \<Gamma>\<rbrace>" (is "_ \<sqsubseteq> ?r")
    proof (rule HSem_fempty_below)
      fix x'
      assume "x' \<in> heapVars ((x, body) # asToHeap as @ \<Gamma>)"
      hence x': "x' = x \<or> x' \<in> heapVars (asToHeap as) \<or> x' \<in> heapVars \<Gamma>" by simp

      show "\<lbrakk> the (map_of ((x, body) # asToHeap as @ \<Gamma>) x') \<rbrakk>\<^bsub>?r\<^esub> \<sqsubseteq> ?r f! x'"
      proof(cases "x' = x")
        assume "x' = x"
        thus ?thesis
          by (simp add: lookup_HSem_other[OF x_not_as] lookup_HSem_heap)
      next
        have merged_r: "?r = \<lbrace>asToHeap as @ ((x, Let as body) # \<Gamma>)\<rbrace>"
          apply (rule HSem_merge)
            using disjoint distinct apply (auto simp add: distinctVars_Cons distinctVars_append)[1]
            using fresh apply (metis fresh_star_list(2) fresh_star_Pair set_bn_to_atom_heapVars)
          done

        assume "x' \<noteq> x"

        hence map_of_reorder: "map_of ((x, body) # asToHeap as @ \<Gamma>) x' = map_of (asToHeap as @ ((x, Let as body) # \<Gamma>)) x'"
          apply simp
          apply (subst map_add_upd_left)
          apply (metis dom_map_of_conv_heapVars x_not_as)
          apply simp
          done

        show ?thesis
          unfolding merged_r
          apply (subst lookup_HSem_heap)
          using x' apply simp[1]
          unfolding map_of_reorder
          apply (rule below_refl)
          done
      qed
    qed auto
    thus "fmap_restr (insert x (heapVars \<Gamma>)) (\<lbrace>(x, body) # asToHeap as @ \<Gamma>\<rbrace>) \<sqsubseteq> \<lbrace>(x, Let as body) # \<Gamma>\<rbrace>"
      apply (rule below_trans[OF cont2monofunE[OF fmap_restr_cont] eq_imp_below])
      apply (rule fmap_restr_HSem_noop[of _ "\<lbrace>(x, Terms.Let as body) # \<Gamma>\<rbrace>", simplified (no_asm)])
      using disjoint apply auto
      done
  qed
  thus ?case
    by (rule subst[where s = "insert q Q", standard, rotated], auto)
qed

text {* This is the main correctness theorem for the stacked semantics. *}

theorem correctness:
  assumes "\<Gamma> : \<Gamma>' \<Down> \<Delta> : \<Delta>'"
  and "distinctVars (\<Gamma>' @ \<Gamma>)"
  shows "\<lbrace>\<Gamma>'@\<Gamma>\<rbrace> \<le> \<lbrace>\<Delta>'@\<Delta>\<rbrace>"
  using assms
proof(induct rule:reds_distinct_ind)

case (Lambda x y e \<Gamma> \<Gamma>')
  show ?case by simp
  -- "The lambda-case is trival"
next

case (Application n \<Gamma> \<Gamma>' \<Delta> \<Delta>' x e y \<Theta> \<Theta>' z  e')
  let "?restr \<rho>" = "fmap_restr (insert x (heapVars \<Gamma>' \<union> heapVars \<Gamma>)) (\<rho>::Env)"
  let "?restr2 \<rho>" = "fmap_restr (insert x (heapVars \<Delta>' \<union> heapVars \<Delta>)) (\<rho>::Env)"

  have "n \<noteq> z" using Application by (simp add: fresh_Pair fresh_at_base)

  from stack_unchanged[OF distinct_redsD1[OF Application.hyps(8)]]
  have "\<Delta>' = \<Gamma>'" by simp
  hence [simp]:"atom n \<sharp> \<Delta>'"  using Application by (simp add: fresh_Pair)+

  have "atom n \<sharp> (\<Gamma>, e)" using Application by (simp add: fresh_Pair)
  note reds_fresh[OF Application(8) this]
  hence "atom n \<sharp> (\<Delta>, Lam [z]. e')"
    using Application(5)
    by (metis (hide_lams, no_types) Application(1) fresh_Pair heapVars_not_fresh)
  with `n \<noteq> z`
  have [simp]: "atom n \<sharp> \<Delta>" "atom n \<sharp> e'"
    by (auto simp add: fresh_Pair)

  note subset1 = reds_doesnt_forget'(1)[OF Application.hyps(8), unfolded append_Cons]
  from reds_doesnt_forget'(2)[OF Application.hyps(8), unfolded append_Cons]
  have subset2: "heapVars ((x, App (Var n) y) # \<Gamma>') \<subseteq> heapVars ((x, App (Var n) y) # \<Delta>')"
    apply (rule distinctVars_Cons_subset)
    apply (metis Application(4) distinctVars_appendD1)
    apply (metis Application(5) distinctVars_appendD1)
    done

  have "n \<noteq> x"
    by (metis Application(1) fresh_PairD(1) fresh_PairD(2) not_self_fresh)

  have "\<lbrace>((x, App e y) # \<Gamma>') @ \<Gamma>\<rbrace> = (\<lbrace>(x, App e y) # \<Gamma>' @ \<Gamma>\<rbrace>)"
    by simp
  also
  have "... = ?restr (\<lbrace>(n, e) # (x, App e y) # \<Gamma>' @ \<Gamma>\<rbrace>)"
    -- {* Adding a fresh variable *}
    apply (subst HSem_add_fresh[of n "(x, App e y) # \<Gamma>' @ \<Gamma>" "f\<emptyset>"  e , symmetric])
    using Application(1) apply (simp add: fresh_Pair fresh_Cons fresh_append)
    apply simp
    apply simp
    done
  also have  "... = ?restr (\<lbrace>(x, App e y) # (n, e) # \<Gamma>' @ \<Gamma>\<rbrace>)"
    by (rule arg_cong[OF HSem_reorder_head[OF `n \<noteq> x`]])
  also
  have "... = ?restr (\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>' @ \<Gamma>\<rbrace>)"
    -- {* Substituting the variable *}
    apply (rule arg_cong[OF HSem_subst_var_app[symmetric]])
    using Application(1) apply (simp add: fresh_Pair)
    apply simp
    done
  also
  have "... = ?restr (\<lbrace>(n, e) # (x, App (Var n) y) # \<Gamma>' @ \<Gamma>\<rbrace>)"
    by (simp add: HSem_reorder_head[OF `n \<noteq> x`])
  also
  have "... \<le> ?restr2  (\<lbrace>(n, Lam [z]. e') # (x, App (Var n) y) # \<Delta>' @ \<Delta>\<rbrace>)"
    -- "Induction hypothesis"
    apply (rule fmap_restr_le[OF Application.hyps(9)[simplified]])
    using subset1 subset2 by auto
  also
  have "... \<le> ?restr2  (\<lbrace>(x, App (Var n) y) # (n, Lam [z]. e') # \<Delta>' @ \<Delta>\<rbrace>)"
    by (simp add: HSem_reorder_head[OF `n \<noteq> x`])
  also
  have "... = ?restr2 (\<lbrace>(x, App (Lam [z]. e') y) # (n, Lam [z]. e') # \<Delta>' @ \<Delta>\<rbrace>)"
    -- "Substituting the variable again"
    apply (rule arg_cong[OF HSem_subst_var_app])
    using Application(1) apply (simp add: fresh_Pair)
    apply simp
    done
  also
  have "... = ?restr2 (\<lbrace>(n, Lam [z]. e') # (x, App (Lam [z]. e') y) # \<Delta>' @ \<Delta>\<rbrace>)"
    by (simp add: HSem_reorder_head[OF `n \<noteq> x`])
  also
  have "... = (\<lbrace>(x, App (Lam [z]. e') y) # \<Delta>' @ \<Delta>\<rbrace>)"
    -- "Removing the fresh variable"
    apply (subst HSem_add_fresh[of n  "(x, App (Lam [z]. e') y) # \<Delta>' @ \<Delta>" fempty "Lam [z]. e'", symmetric])
    using Application(1) apply (simp add: fresh_Pair fresh_Cons fresh_append)
    apply simp
    apply simp
    done
  also
  have "... =  \<lbrace>(x, e'[z::=y]) # \<Delta>' @ \<Delta>\<rbrace>"
    -- "Semantics of application"
    apply (rule HSem_subst_exp)
    apply simp
    apply (rule ESem_subst[simplified])
      using Application(2)
      apply (auto simp add: fresh_Pair heapVars_not_fresh)
    done
  also
  have "... \<le> \<lbrace>\<Theta>' @ \<Theta>\<rbrace>"
    -- "Induction hypothesis"
    by (rule Application.hyps(11)[simplified])
  finally
  show "\<lbrace>((x, App e y) # \<Gamma>') @ \<Gamma>\<rbrace> \<le> \<lbrace>\<Theta>' @ \<Theta>\<rbrace>".

next
case (Variable y e \<Gamma> x \<Gamma>' z \<Delta>' \<Delta>)
  have "x \<noteq> y" using Variable(3) by (auto simp add: distinctVars_Cons distinctVars_append)
  have [simp]: "y \<notin> heapVars \<Delta>'" using Variable(4) by (simp add: distinctVars_Cons)

  have map_of_eq1: "map_of (((x, Var y) # \<Gamma>') @ \<Gamma>) =  map_of (((y, e) # (x, Var y) # \<Gamma>') @ delete y \<Gamma>)"
    apply (subst distinctVars_map_of_delete_insert[symmetric,OF Variable(2), where x = y and e = e])
    using `(y, e) \<in> set \<Gamma>` Variable(3)
    by (auto simp add: distinctVars_Cons delete_no_there)
  have map_of_eq2: "map_of (((y, z) # (x, z) # \<Delta>') @ \<Delta>) = map_of (((x, z) # \<Delta>') @ (y, z) # \<Delta>)"
    by (auto simp add: map_add_upd_left dom_map_of_conv_heapVars)

  have "\<lbrace>((x, Var y) # \<Gamma>') @ \<Gamma>\<rbrace> = \<lbrace>((y, e) # (x, Var y) # \<Gamma>') @ delete y \<Gamma>\<rbrace>"
    by (rule HSem_reorder[OF map_of_eq1])
  also
  have "... \<le>  \<lbrace>((y, z) # (x, Var y) # \<Delta>') @ \<Delta>\<rbrace>"
    -- "Induction hypothesis"
    by fact
  also
  have "... =  \<lbrace>(y, z) # (x, Var y) # \<Delta>' @ \<Delta>\<rbrace>"
    by simp
  also
  have "... =  \<lbrace>(x, Var y) # (y, z) # \<Delta>' @ \<Delta>\<rbrace>"
    by (simp add: HSem_reorder_head[OF `x \<noteq> y`])
  also
  have "... =  \<lbrace>(x, z) # (y, z) # \<Delta>' @ \<Delta>\<rbrace>"
    -- {* Substituting the variable @{term y} *}
    apply (rule HSem_subst_var_var)
    using `x \<noteq> y` apply (simp add: fresh_Pair fresh_at_base)
    apply simp
    done
  also
  have "... =  \<lbrace>(y, z) # (x, z) # \<Delta>' @ \<Delta>\<rbrace>"
    by (simp add: HSem_reorder_head[OF `x \<noteq> y`])
  also
  have "... =  \<lbrace>((y, z) # (x, z) # \<Delta>') @ \<Delta>\<rbrace>"
    by simp
  also
  have "... = \<lbrace>((x, z) # \<Delta>') @ (y, z) # \<Delta>\<rbrace>"
    -- "Induction hypothesis"
    by (rule HSem_reorder[OF map_of_eq2])
  finally
  show "\<lbrace>((x, Var y) # \<Gamma>') @ \<Gamma>\<rbrace> \<le> \<lbrace>((x, z) # \<Delta>') @ (y, z) # \<Delta>\<rbrace>".

next
case (Let as \<Gamma> x \<Gamma>' body \<Delta>' \<Delta>)
  have d1: "distinctVars (asToHeap as @ ((x, Terms.Let as body) # \<Gamma>') @ \<Gamma>)"
    by (metis Let(1) Let(2) distinctVars_append_asToHeap fresh_star_list(1,2) fresh_star_Pair let_binders_fresh)
  hence d3: "distinctVars ((x, body) # asToHeap as @ \<Gamma>' @ \<Gamma>)"
    and d4: "distinctVars (((x, body) # \<Gamma>') @ asToHeap as @ \<Gamma>)"
    and d5: "distinctVars ((x, body) # \<Gamma>' @ \<Gamma>)"
    by (auto simp add: distinctVars_Cons distinctVars_append)

  have map_of_eq: "map_of ((x, body) # asToHeap as @ \<Gamma>' @ \<Gamma>) = map_of (((x, body) # \<Gamma>') @ asToHeap as @ \<Gamma>)"
    apply (auto simp add: map_add_upd_left dom_map_of_conv_heapVars)
    apply (subst (1 2) map_add_assoc[symmetric])
    apply (rule arg_cong[OF map_add_comm])
    using d1 by (auto simp add: distinctVars_append distinctVars_Cons dom_map_of_conv_heapVars[symmetric])

  have "\<lbrace>((x, Let as body) # \<Gamma>') @ \<Gamma>\<rbrace> = \<lbrace>(x, Let as body) # \<Gamma>' @ \<Gamma>\<rbrace>"
    by simp
  also
  have "... \<le> \<lbrace>(x, body) # asToHeap as @ \<Gamma>' @ \<Gamma>\<rbrace>"
    -- "Semantics of let"
    apply (rule HSem_unfold_let[OF d5])
    using Let(1) by (auto simp add: fresh_star_Pair fresh_star_list)
  also
  have "... = \<lbrace>((x, body) # \<Gamma>') @ asToHeap as @ \<Gamma>\<rbrace>"
    by (rule HSem_reorder[OF map_of_eq])
  also
  have "... \<le>  \<lbrace>\<Delta>' @ \<Delta>\<rbrace>"
    -- "Induction hypothesis"
    by fact
  finally
  show "\<lbrace>((x, Terms.Let as body) # \<Gamma>') @ \<Gamma>\<rbrace> \<le> \<lbrace>\<Delta>' @ \<Delta>\<rbrace>".
qed
end


theory List_Examples
imports
  Main
  "~~/src/HOL/Library/Predicate_Compile_Quickcheck"
  "~~/src/HOL/Library/Code_Prolog"
begin

setup {*
  Context.theory_map
    (Quickcheck.add_tester ("prolog", (Code_Prolog.active, Code_Prolog.test_goals)))
*}

setup {* Code_Prolog.map_code_options (K
  {ensure_groundness = true,
   limit_globally = NONE,
   limited_types = [(@{typ nat}, 2), (@{typ "nat list"}, 4)],
   limited_predicates = [(["appendP"], 4), (["revP"], 4)],
   replacing =
     [(("appendP", "limited_appendP"), "quickcheck"),
      (("revP", "limited_revP"), "quickcheck"),
      (("appendP", "limited_appendP"), "lim_revP")],
   manual_reorder = []}) *}

lemma "(xs :: nat list) = ys @ ys --> rev xs = xs"
quickcheck[tester = random, iterations = 10000]
quickcheck[tester = smart_exhaustive, iterations = 1, expect = counterexample]
quickcheck[tester = prolog, expect = counterexample]
oops

end


(*  Title:      Coinductive/Coinductive_Stream.thy
    Author:     Peter Gammie and Andreas Lochbihler
*)
section {* Infinite lists as a codatatype *}

theory Coinductive_Stream
imports
  "HOL-Library.Stream"
  "HOL-Library.Linear_Temporal_Logic_on_Streams"
  Coinductive_List
begin

lemma eq_onpI: "P x \<Longrightarrow> eq_onp P x x"
by(simp add: eq_onp_def)

primcorec unfold_stream :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b stream" where
  "unfold_stream g1 g2 a = g1 a ## unfold_stream g1 g2 (g2 a)"

text {*
  The following setup should be done by the BNF package.
*}

text {* congruence rule *}

declare stream.map_cong [cong]

text {* lemmas about generated constants *}

lemma eq_SConsD: "xs = SCons y ys \<Longrightarrow> shd xs = y \<and> stl xs = ys"
by auto

declare stream.map_ident[simp]

lemma smap_eq_SCons_conv:
  "smap f xs = y ## ys \<longleftrightarrow>
  (\<exists>x xs'. xs = x ## xs' \<and> y = f x \<and> ys = smap f xs')"
by(cases xs)(auto)

lemma smap_unfold_stream:
  "smap f (unfold_stream SHD STL b) = unfold_stream (f \<circ> SHD) STL b"
by(coinduction arbitrary: b) auto

lemma smap_corec_stream:
  "smap f (corec_stream SHD endORmore STL_end STL_more b) =
   corec_stream (f \<circ> SHD) endORmore (smap f \<circ> STL_end) STL_more b"
by(coinduction arbitrary: b rule: stream.coinduct_strong) auto

lemma unfold_stream_ltl_unroll:
  "unfold_stream SHD STL (STL b) = unfold_stream (SHD \<circ> STL) STL b"
by(coinduction arbitrary: b) auto

lemma unfold_stream_eq_SCons [simp]:
  "unfold_stream SHD STL b = x ## xs \<longleftrightarrow>
  x = SHD b \<and> xs = unfold_stream SHD STL (STL b)"
by(subst unfold_stream.ctr) auto

lemma unfold_stream_id [simp]: "unfold_stream shd stl xs = xs"
by(coinduction arbitrary: xs) simp_all

lemma sset_neq_empty [simp]: "sset xs \<noteq> {}"
by(cases xs) simp_all

declare stream.set_sel(1)[simp]

lemma sset_stl: "sset (stl xs) \<subseteq> sset xs"
by(cases xs) auto

text {* induction rules *}

lemmas stream_set_induct = sset_induct

subsection {* Lemmas about operations from @{theory Stream} *}

lemma szip_iterates:
  "szip (siterate f a) (siterate g b) = siterate (map_prod f g) (a, b)"
by(coinduction arbitrary: a b) auto

lemma szip_smap1: "szip (smap f xs) ys = smap (apfst f) (szip xs ys)"
by(coinduction arbitrary: xs ys) auto

lemma szip_smap2: "szip xs (smap g ys) = smap (apsnd g) (szip xs ys)"
by(coinduction arbitrary: xs ys) auto

lemma szip_smap [simp]: "szip (smap f xs) (smap g ys) = smap (map_prod f g) (szip xs ys)"
by(coinduction arbitrary: xs ys) auto

lemma smap_fst_szip [simp]: "smap fst (szip xs ys) = xs"
by(coinduction arbitrary: xs ys) auto

lemma smap_snd_szip [simp]: "smap snd (szip xs ys) = ys"
by(coinduction arbitrary: xs ys) auto

lemma snth_shift: "snth (shift xs ys) n = (if n < length xs then xs ! n else snth ys (n - length xs))"
by simp

declare szip_unfold [simp, nitpick_simp]

lemma szip_shift:
  "length xs = length us
  \<Longrightarrow> szip (xs @- ys) (us @- zs) = zip xs us @- szip ys zs"
by(induct xs arbitrary: us)(auto simp add: Suc_length_conv)

subsection {* Link @{typ "'a stream"} to @{typ "'a llist"} *}

definition llist_of_stream :: "'a stream \<Rightarrow> 'a llist"
where "llist_of_stream = unfold_llist (\<lambda>_. False) shd stl"

definition stream_of_llist :: "'a llist \<Rightarrow> 'a stream"
where "stream_of_llist = unfold_stream lhd ltl"

lemma lnull_llist_of_stream [simp]: "\<not> lnull (llist_of_stream xs)"
by(simp add: llist_of_stream_def)

lemma ltl_llist_of_stream [simp]: "ltl (llist_of_stream xs) = llist_of_stream (stl xs)"
by(simp add: llist_of_stream_def)

lemma stl_stream_of_llist [simp]: "stl (stream_of_llist xs) = stream_of_llist (ltl xs)"
by(simp add: stream_of_llist_def)

lemma shd_stream_of_llist [simp]: "shd (stream_of_llist xs) = lhd xs"
by(simp add: stream_of_llist_def)

lemma lhd_llist_of_stream [simp]: "lhd (llist_of_stream xs) = shd xs"
by(simp add: llist_of_stream_def)

lemma stream_of_llist_llist_of_stream [simp]:
  "stream_of_llist (llist_of_stream xs) = xs"
by(coinduction arbitrary: xs) simp_all

lemma llist_of_stream_stream_of_llist [simp]:
  "\<not> lfinite xs \<Longrightarrow> llist_of_stream (stream_of_llist xs) = xs"
by(coinduction arbitrary: xs) auto

lemma lfinite_llist_of_stream [simp]: "\<not> lfinite (llist_of_stream xs)"
proof
  assume "lfinite (llist_of_stream xs)"
  thus False
    by(induct "llist_of_stream xs" arbitrary: xs rule: lfinite_induct) auto
qed

lemma stream_from_llist: "type_definition llist_of_stream stream_of_llist {xs. \<not> lfinite xs}"
by(unfold_locales) simp_all

interpretation stream: type_definition llist_of_stream stream_of_llist "{xs. \<not> lfinite xs}"
by(fact stream_from_llist)

declare stream.exhaust[cases type: stream]

locale stream_from_llist_setup
begin
setup_lifting stream_from_llist
end

context
begin

interpretation stream_from_llist_setup .

lemma cr_streamI: "\<not> lfinite xs \<Longrightarrow> cr_stream xs (stream_of_llist xs)"
by(simp add: cr_stream_def Abs_stream_inverse)

lemma llist_of_stream_unfold_stream [simp]:
  "llist_of_stream (unfold_stream SHD STL x) = unfold_llist (\<lambda>_. False) SHD STL x"
by(coinduction arbitrary: x) auto

lemma llist_of_stream_corec_stream [simp]:
  "llist_of_stream (corec_stream SHD endORmore STL_more STL_end x) =
   corec_llist (\<lambda>_. False) SHD endORmore (llist_of_stream \<circ> STL_more) STL_end x"
by(coinduction arbitrary: x rule: llist.coinduct_strong) auto

lemma LCons_llist_of_stream [simp]: "LCons x (llist_of_stream xs) = llist_of_stream (x ## xs)"
by(rule sym)(simp add: llist_of_stream_def)

lemma lmap_llist_of_stream [simp]:
  "lmap f (llist_of_stream xs) = llist_of_stream (smap f xs)"
by(coinduction arbitrary: xs) auto

lemma lset_llist_of_stream [simp]: "lset (llist_of_stream xs) = sset xs" (is "?lhs = ?rhs")
proof(intro set_eqI iffI)
  fix x
  assume "x \<in> ?lhs"
  thus "x \<in> ?rhs"
    by(induct "llist_of_stream xs" arbitrary: xs rule: llist_set_induct)
      (auto dest: stream.set_sel(2))
next
  fix x
  assume "x \<in> ?rhs"
  thus "x \<in> ?lhs"
  proof(induct)
    case (shd xs)
    thus ?case using llist.set_sel(1)[of "llist_of_stream xs"] by simp
  next
    case stl
    thus ?case
      by(auto simp add: ltl_llist_of_stream[symmetric] simp del: ltl_llist_of_stream dest: in_lset_ltlD)
  qed
qed

lemma lnth_list_of_stream [simp]:
  "lnth (llist_of_stream xs) = snth xs"
proof
  fix n
  show "lnth (llist_of_stream xs) n = snth xs n"
    by(induction n arbitrary: xs)(simp_all add: lnth_0_conv_lhd lnth_ltl[symmetric])
qed

lemma llist_of_stream_siterates [simp]: "llist_of_stream (siterate f x) = iterates f x"
by(coinduction arbitrary: x) auto

lemma lappend_llist_of_stream_conv_shift [simp]:
  "lappend (llist_of xs) (llist_of_stream ys) = llist_of_stream (xs @- ys)"
by(induct xs) simp_all

lemma lzip_llist_of_stream [simp]:
  "lzip (llist_of_stream xs) (llist_of_stream ys) = llist_of_stream (szip xs ys)"
by(coinduction arbitrary: xs ys) auto

context includes lifting_syntax
begin

lemma lmap_infinite_transfer [transfer_rule]:
  "(op = ===> eq_onp (\<lambda>xs. \<not> lfinite xs) ===> eq_onp (\<lambda>xs. \<not> lfinite xs)) lmap lmap"
by(simp add: rel_fun_def eq_onp_def)

lemma lset_infinite_transfer [transfer_rule]:
  "(eq_onp (\<lambda>xs. \<not> lfinite xs) ===> op =) lset lset"
by(simp add: rel_fun_def eq_onp_def)

lemma unfold_stream_transfer [transfer_rule]:
  "(op = ===> op = ===> op = ===> pcr_stream op =) (unfold_llist (\<lambda>_. False)) unfold_stream"
by(auto simp add: stream.pcr_cr_eq cr_stream_def intro!: rel_funI)

lemma corec_stream_transfer [transfer_rule]:
  "(op = ===> op = ===> (op = ===> pcr_stream op =) ===> op = ===> op = ===> pcr_stream op=)
   (corec_llist (\<lambda>_. False)) corec_stream"
apply(auto intro!: rel_funI simp add: cr_stream_def stream.pcr_cr_eq)
apply(rule fun_cong) back
apply(rule_tac x=yc in fun_cong)
apply(rule_tac x=xb in arg_cong)
apply(auto elim: rel_funE)
done

lemma shd_transfer [transfer_rule]: "(pcr_stream A ===> A) lhd shd"
by(auto simp add: pcr_stream_def cr_stream_def intro!: rel_funI relcomppI)(frule llist_all2_lhdD, auto dest: llist_all2_lnullD)

lemma stl_transfer [transfer_rule]: "(pcr_stream A ===> pcr_stream A) ltl stl"
by(auto simp add: pcr_stream_def cr_stream_def intro!: rel_funI relcomppI dest: llist_all2_ltlI)

lemma llist_of_stream_transfer [transfer_rule]: "(pcr_stream op = ===> op =) id llist_of_stream"
by(simp add: rel_fun_def stream.pcr_cr_eq cr_stream_def)

lemma stream_of_llist_transfer [transfer_rule]:
  "(eq_onp (\<lambda>xs. \<not> lfinite xs) ===> pcr_stream op =) (\<lambda>xs. xs) stream_of_llist"
by(simp add: eq_onp_def rel_fun_def stream.pcr_cr_eq cr_stream_def)

lemma SCons_transfer [transfer_rule]:
  "(A ===> pcr_stream A ===> pcr_stream A) LCons op ##"
by(auto simp add: cr_stream_def pcr_stream_def intro!: rel_funI relcomppI intro: llist_all2_expand)

lemma sset_transfer [transfer_rule]: "(pcr_stream A ===> rel_set A) lset sset"
by(auto 4 3 simp add: pcr_stream_def cr_stream_def intro!: rel_funI relcomppI rel_setI dest: llist_all2_lsetD1 llist_all2_lsetD2)

lemma smap_transfer [transfer_rule]:
  "((A ===> B) ===> pcr_stream A ===> pcr_stream B) lmap smap"
by(auto simp add: cr_stream_def pcr_stream_def intro!: rel_funI relcomppI dest: lmap_transfer[THEN rel_funD] elim: rel_funD)

lemma snth_transfer [transfer_rule]: "(pcr_stream op = ===> op =) lnth snth"
by(rule rel_funI)(clarsimp simp add: stream.pcr_cr_eq cr_stream_def fun_eq_iff)

lemma siterate_transfer [transfer_rule]:
  "(op = ===> op = ===> pcr_stream op =) iterates siterate"
by(rule rel_funI)+(clarsimp simp add: stream.pcr_cr_eq cr_stream_def)

context
  fixes xs
  assumes inf: "\<not> lfinite xs"
  notes [transfer_rule] = eq_onpI[where P="\<lambda>xs. \<not> lfinite xs", OF inf]
begin

lemma sset_stream_of_llist [simp]:
  assumes "\<not> lfinite xs"
  shows "sset (stream_of_llist xs) = lset xs"
by transfer simp

end

lemma llist_all2_llist_of_stream [simp]:
  "llist_all2 P (llist_of_stream xs) (llist_of_stream ys) = stream_all2 P xs ys"
apply(cases xs ys rule: stream.Abs_cases[case_product stream.Abs_cases])
apply(simp add: llist_all2_def stream_all2_def)
apply(safe elim!: GrpE)
 apply(rule_tac b="stream_of_llist b" in relcomppI; auto intro!: GrpI)
apply(rule_tac b="llist_of_stream b" in relcomppI; auto intro!: GrpI)
done

lemma stream_all2_transfer [transfer_rule]:
  "(op = ===> pcr_stream op = ===> pcr_stream op = ===> op =) llist_all2 stream_all2"
by(simp add: rel_fun_def stream.pcr_cr_eq cr_stream_def)

lemma stream_all2_coinduct:
  assumes "X xs ys"
  and "\<And>xs ys. X xs ys \<Longrightarrow> P (shd xs) (shd ys) \<and> (X (stl xs) (stl ys) \<or> stream_all2 P (stl xs) (stl ys))"
  shows "stream_all2 P xs ys"
using assms
apply transfer
apply(rule_tac X="\<lambda>xs ys. \<not> lfinite xs \<and> \<not> lfinite ys \<and> X xs ys" in llist_all2_coinduct)
apply auto
done

lemma shift_transfer [transfer_rule]:
  "(op = ===> pcr_stream op = ===> pcr_stream op =) (lappend \<circ> llist_of) shift"
by(clarsimp simp add: rel_fun_def stream.pcr_cr_eq cr_stream_def)

lemma szip_transfer [transfer_rule]:
  "(pcr_stream op = ===> pcr_stream op = ===> pcr_stream op =) lzip szip"
by(simp add: stream.pcr_cr_eq cr_stream_def rel_fun_def)

subsection {* Link @{typ "'a stream"} with @{typ "nat \<Rightarrow> 'a"} *}

lift_definition of_seq :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a stream" is "inf_llist" by simp

lemma of_seq_rec [code]: "of_seq f = f 0 ## of_seq (f \<circ> Suc)"
by transfer (subst inf_llist_rec, simp add: o_def)

lemma snth_of_seq [simp]: "snth (of_seq f) = f"
by transfer (simp add: fun_eq_iff)

lemma snth_SCons: "snth (x ## xs) n = (case n of 0 \<Rightarrow> x | Suc n' \<Rightarrow> snth xs n')"
by(simp split: nat.split)

lemma snth_SCons_simps [simp]:
  shows snth_SCons_0: "(x ## xs) !! 0 = x"
  and snth_SCons_Suc: "(x ## xs) !! Suc n = xs !! n"
by(simp_all add: snth_SCons)

lemma of_seq_snth [simp]: "of_seq (snth xs) = xs"
by transfer simp

lemma shd_of_seq [simp]: "shd (of_seq f) = f 0"
by transfer simp

lemma stl_of_seq [simp]: "stl (of_seq f) = of_seq (\<lambda>n. f (Suc n))"
by transfer simp

lemma sset_of_seq [simp]: "sset (of_seq f) = range f"
by transfer simp

lemma smap_of_seq [simp]: "smap f (of_seq g) = of_seq (f \<circ> g)"
by transfer simp
end

subsection{* Function iteration @{const siterate}  and @{term sconst} *}

lemmas siterate [nitpick_simp] = siterate.code

lemma smap_iterates: "smap f (siterate f x) = siterate f (f x)"
by transfer (rule lmap_iterates)

lemma siterate_smap: "siterate f x = x ## (smap f (siterate f x))"
by transfer (rule iterates_lmap)

lemma siterate_conv_of_seq: "siterate f a = of_seq (\<lambda>n. (f ^^ n) a)"
by transfer (rule iterates_conv_inf_llist)

lemma szip_sconst1 [simp]: "szip (sconst a) xs = smap (Pair a) xs"
by(coinduction arbitrary: xs) auto

lemma szip_sconst2 [simp]: "szip xs (sconst b) = smap (\<lambda>x. (x, b)) xs"
by(coinduction arbitrary: xs) auto

end

subsection \<open> Counting elements \<close>

partial_function (lfp) scount :: "('s stream \<Rightarrow> bool) \<Rightarrow> 's stream \<Rightarrow> enat" where
  "scount P \<omega> = (if P \<omega> then eSuc (scount P (stl \<omega>)) else scount P (stl \<omega>))"

lemma scount_simps:
  "P \<omega> \<Longrightarrow> scount P \<omega> = eSuc (scount P (stl \<omega>))"
  "\<not> P \<omega> \<Longrightarrow> scount P \<omega> = scount P (stl \<omega>)"
  using scount.simps[of P \<omega>] by auto

lemma scount_eq_0I: "alw (not P) \<omega> \<Longrightarrow> scount P \<omega> = 0"
  by (induct arbitrary: \<omega> rule: scount.fixp_induct)
     (auto simp: bot_enat_def intro!: admissible_all admissible_imp admissible_eq_mcontI mcont_const)

lemma scount_eq_0_iff: "scount P \<omega> = 0 \<longleftrightarrow> alw (not P) \<omega>"
  by (metis scount_eq_0D scount_eq_0I)

lemma
  assumes "ev (alw (not P)) \<omega>"
  shows scount_eq_card: "scount P \<omega> = enat (card {i. P (sdrop i \<omega>)})"
    and ev_alw_not_HLD_finite: "finite {i. P (sdrop i \<omega>)}"
  using assms
proof (induction \<omega>)
  case (step \<omega>)
  have eq: "{i. P (sdrop i \<omega>)} = (if P \<omega> then {0} else {}) \<union> (Suc ` {i. P (sdrop i (stl \<omega>))})"
    apply (intro set_eqI)
    apply (case_tac x)
    apply (auto simp: image_iff)
    done
  { case 1 show ?case
      using step unfolding eq by (auto simp: scount_simps card_image zero_notin_Suc_image eSuc_enat) }
  { case 2 show ?case
      using step unfolding eq by auto }
next
   case (base \<omega>)
   then have [simp]: "{i. P (sdrop i \<omega>)} = {}"
     by (simp add: not_HLD alw_iff_sdrop)
   { case 1 show ?case using base by (simp add: scount_eq_0I enat_0) }
   { case 2 show ?case by simp }
qed

lemma scount_finite: "ev (alw (not P)) \<omega> \<Longrightarrow> scount P \<omega> < \<infinity>"
  using scount_eq_card[of P \<omega>] by auto

lemma scount_infinite:
  "alw (ev P) \<omega> \<Longrightarrow> scount P \<omega> = \<infinity>"
proof (coinduction arbitrary: \<omega> rule: enat_coinduct)
  case (Eq_enat \<omega>)
  then have "ev P \<omega>" "alw (ev P) \<omega>"
    by auto
  then show ?case
    by (induction rule: ev_induct_strong) (auto simp add: scount_simps)
qed

lemma scount_infinite_iff: "scount P \<omega> = \<infinity> \<longleftrightarrow> alw (ev P) \<omega>"
  by (metis enat_ord_simps(4) not_alw_not scount_finite scount_infinite)

lemma scount_eq:
  "scount P \<omega> = (if alw (ev P) \<omega> then \<infinity> else enat (card {i. P (sdrop i \<omega>)}))"
  by (auto simp: scount_infinite_iff scount_eq_card not_alw_iff not_ev_iff)

subsection \<open> First index of an element \<close>

partial_function (gfp) sfirst :: "('s stream \<Rightarrow> bool) \<Rightarrow> 's stream \<Rightarrow> enat" where
  "sfirst P \<omega> = (if P \<omega> then 0 else eSuc (sfirst P (stl \<omega>)))"

lemma sfirst_eq_0: "sfirst P \<omega> = 0 \<longleftrightarrow> P \<omega>"
  by (subst sfirst.simps) auto

lemma sfirst_0[simp]: "P \<omega> \<Longrightarrow> sfirst P \<omega> = 0"
  by (subst sfirst.simps) auto

lemma sfirst_eSuc[simp]: "\<not> P \<omega> \<Longrightarrow> sfirst P \<omega> = eSuc (sfirst P (stl \<omega>))"
  by (subst sfirst.simps) auto

lemma less_sfirstD:
  fixes n :: nat
  assumes "enat n < sfirst P \<omega>" shows "\<not> P (sdrop n \<omega>)"
  using assms
proof (induction n arbitrary: \<omega>)
  case (Suc n) then show ?case
    by (auto simp: sfirst.simps[of _ \<omega>] eSuc_enat[symmetric] split: if_split_asm)
qed (simp add: enat_0 sfirst_eq_0)

lemma sfirst_finite: "sfirst P \<omega> < \<infinity> \<longleftrightarrow> ev P \<omega>"
proof
  assume "sfirst P \<omega> < \<infinity>"
  then obtain n where "sfirst P \<omega> = enat n" by auto
  then show "ev P \<omega>"
  proof (induction n arbitrary: \<omega>)
    case (Suc n) then show ?case
      by (auto simp add: eSuc_enat[symmetric] sfirst.simps[of P \<omega>] split: if_split_asm)
  qed (auto simp add: enat_0 sfirst_eq_0)
next
  assume "ev P \<omega>" then show "sfirst P \<omega> < \<infinity>"
    by (induction rule: ev_induct_strong) (auto simp: eSuc_enat)
qed

lemma sfirst_Stream: "sfirst P (s ## x) = (if P (s ## x) then 0 else eSuc (sfirst P x))"
  by (subst sfirst.simps) (simp add: HLD_iff)

lemma less_sfirst_iff: "(not P until (alw P)) \<omega> \<Longrightarrow> enat n < sfirst P \<omega> \<longleftrightarrow> \<not> P (sdrop n \<omega>)"
proof (induction n arbitrary: \<omega>)
  case 0 then show ?case
    by (simp add: enat_0 sfirst_eq_0 HLD_iff)
next
  case (Suc n)
  from Suc.prems have **: "P \<omega> \<Longrightarrow> P (stl \<omega>)"
    by (auto elim: UNTIL.cases)
  have *: "\<not> P (sdrop n (stl \<omega>)) \<longleftrightarrow> enat n < sfirst P (stl \<omega>)"
    using Suc.prems by (intro Suc.IH[symmetric]) (auto intro: UNTIL.intros elim: UNTIL.cases)
  show ?case
    unfolding sdrop.simps * by (cases "P \<omega>") (simp_all add: ** eSuc_enat[symmetric])
qed

lemma sfirst_eq_Inf: "sfirst P \<omega> = Inf {enat i | i. P (sdrop i \<omega>)}"
proof (rule antisym)
  show "sfirst P \<omega> \<le> \<Sqinter>{enat i |i. P (sdrop i \<omega>)}"
  proof (safe intro!: Inf_greatest)
    fix \<omega> i assume "P (sdrop i \<omega>)" then show "sfirst P \<omega> \<le> enat i"
    proof (induction i arbitrary: \<omega>)
      case (Suc i) then show ?case
       by (auto simp add: sfirst.simps[of P \<omega>] eSuc_enat[symmetric])
    qed auto
  qed
  show "\<Sqinter>{enat i |i. P (sdrop i \<omega>)} \<le> sfirst P \<omega>"
  proof (induction arbitrary: \<omega> rule: sfirst.fixp_induct)
    case (3 f)
    have "{enat i |i. P (sdrop i \<omega>)} = (if P \<omega> then {0} else {}) \<union> eSuc ` {enat i |i. P (sdrop i (stl \<omega>))}"
      apply (intro set_eqI)
      apply (case_tac x rule: enat_coexhaust)
      apply (auto simp add: enat_0_iff image_iff eSuc_enat_iff)
      done
    with 3[of "stl \<omega>"] show ?case
      by (auto simp: inf.absorb1 eSuc_Inf[symmetric])
  qed simp_all
qed

lemma sfirst_eq_enat_iff: "sfirst P \<omega> = enat n \<longleftrightarrow> ev_at P n \<omega>"
  by (induction n arbitrary: \<omega>)
     (simp_all add: eSuc_enat[symmetric] sfirst.simps enat_0)

subsection {* @{text stakeWhile} *}

definition stakeWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a stream \<Rightarrow> 'a llist"
where "stakeWhile P xs = ltakeWhile P (llist_of_stream xs)"

lemma stakeWhile_SCons [simp]:
  "stakeWhile P (x ## xs) = (if P x then LCons x (stakeWhile P xs) else LNil)"
by(simp add: stakeWhile_def LCons_llist_of_stream[symmetric] del: LCons_llist_of_stream)

lemma lnull_stakeWhile [simp]: "lnull (stakeWhile P xs) \<longleftrightarrow> \<not> P (shd xs)"
by(simp add: stakeWhile_def)

lemma lhd_stakeWhile [simp]: "P (shd xs) \<Longrightarrow> lhd (stakeWhile P xs) = shd xs"
by(simp add: stakeWhile_def)

lemma ltl_stakeWhile [simp]:
  "ltl (stakeWhile P xs) = (if P (shd xs) then stakeWhile P (stl xs) else LNil)"
by(simp add: stakeWhile_def)

lemma stakeWhile_K_False [simp]: "stakeWhile (\<lambda>_. False) xs = LNil"
by(simp add: stakeWhile_def)

lemma stakeWhile_K_True [simp]: "stakeWhile (\<lambda>_. True) xs = llist_of_stream xs"
by(simp add: stakeWhile_def)

lemma stakeWhile_smap: "stakeWhile P (smap f xs) = lmap f (stakeWhile (P \<circ> f) xs)"
by(simp add: stakeWhile_def ltakeWhile_lmap[symmetric] del: o_apply)

lemma lfinite_stakeWhile [simp]: "lfinite (stakeWhile P xs) \<longleftrightarrow> (\<exists>x\<in>sset xs. \<not> P x)"
by(simp add: stakeWhile_def lfinite_ltakeWhile)

end


(*
 * Copyright 2020, The University of Melbourne (ABN 84 002 705 224)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *
 * Developers of future substantial additions to this tutorial may wish to
 * append their names to the author list in its document root.tex file.
 *)

theory EquivValidTutorial
imports Lib.EquivValid
begin

text \<open>
This tutorial provides a basic introduction to the seL4 verification repository's
EquivValid library, which formalises proof machinery first
introduced by the CPP'12 paper:
  ``Noninterference for Operating System Kernels''
  by Murray, Matichuk, Brassil, Gammie, and Klein \cite{Murray_MBGK_12}.
This mostly comes in the form of worked examples.

EquivValid statements are used to phrase seL4's information-flow security lemmas,
because they can be used to assert that a function preserves (or establishes)
``observable equivalence'' of system state, as seen by some attacker model.
The ``Valid'' part of EquivValid is based on the fact that the Isabelle definition
for Hoare triples in the seL4 proof base is called \<open>valid\<close>. The EquivValid statements
\<open>equiv_valid\<close>, \<open>equiv_valid_2\<close> are therefore the ``equivalence'' versions of \<open>valid\<close>.
In \cite{Murray_MBGK_12},
EquivValid statements are referred to as ``ev'' or ``ev2'' statements.
These roughly (but not exactly) correspond to \<open>equiv_valid\<close> and \<open>equiv_valid_2\<close>
(resp.) in the Isabelle theories.

This tutorial will assume that the reader knows how to use the weakest precondition tool,
``wp'', to discharge Hoare triples. More information on this is available in the
Lib.WPTutorial theory in the seL4 verification repo.
\<close>

section \<open> Preliminaries \<close>

text \<open> It will be best to think of an EquivValid statement as akin to a Hoare triple.
Recall that a Hoare triple consists of a precondition, function, and postcondition.
This following basic example of a Hoare triple asserts that, for any \<^emph>\<open>single\<close> run
of the function \<open>f\<close>, assuming the precondition \<open>P\<close> holds prior to that run,
the postcondition \<open>Q\<close> will hold afterwards. \<close>

term "\<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>"
thm valid_def

text \<open> Similarly to a Hoare triple, an EquivValid statement makes an assertion
about the possible executions (or ``runs'') of some function.
However, rather than making an assertion about single runs of the function,
it instead makes assertions about \<^emph>\<open>relations between\<close> runs of that function.
In this sense, EquivValid statements could be thought of as \<^emph>\<open>relational\<close> Hoare triples. \<close>

text \<open> This tutorial will introduce some syntactic sugar to emphasise the similarity
between Hoare triples and EquivValid statements.
(Here, \<open>\<top>\<top>\<close> is an alias provided by Monads.NonDetMonad for the trivial binary predicate,
which always returns \<open>True\<close>; similarly, there is also \<open>\<bottom>\<bottom>\<close> for \<open>False\<close>.) \<close>

abbreviation
  equiv_valid_sugar ::
  "('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('s,'b) nondet_monad \<Rightarrow> ('s \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>|_|, _\<rbrace>/ _ /\<lbrace>|_|\<rbrace>")
where
  "\<lbrace>|A|, P\<rbrace> f \<lbrace>|B|\<rbrace> \<equiv> equiv_valid \<top>\<top> A B P f"

text \<open> This most basic form of an EquivValid statement asserts that,
for any \<^emph>\<open>pair\<close> of runs of the function \<open>f\<close>,
assuming the \<^emph>\<open>pre-equivalence\<close> \<open>A\<close> relates the initial states of the two runs
(and the precondition \<open>P\<close> holds initially for both runs),
the \<^emph>\<open>post-equivalence\<close> \<open>B\<close> will relate the final states of the two runs afterwards. \<close>

term "\<lbrace>|A|, P\<rbrace> f \<lbrace>|B|\<rbrace>"
term "equiv_valid \<top>\<top> A B P f"

text \<open> The following Isabelle theorem in the EquivValid library gives
a definition for \<open>equiv_valid\<close> that is closest to that of ``ev'' as presented in
\cite{Murray_MBGK_12};
this is what we will use to unfold \<open>equiv_valid\<close> statements in this tutorial: \<close>

thm equiv_valid_def2[simplified equiv_valid_2_def]

text \<open> In the seL4 EquivValid library, the \<open>equiv_valid\<close> definition also includes,
as a convenience, an \<^emph>\<open>invariant equivalence\<close> \<open>I\<close> that it asserts as both pre- and
post-equivalence. We will ignore this convenience for the rest of this tutorial. \<close>

lemma "equiv_valid I \<top>\<top> \<top>\<top> P f = equiv_valid \<top>\<top> I I P f"
  unfolding equiv_valid_def2 equiv_valid_2_def
  by simp

text \<open> Furthermore, the library version of \<open>equiv_valid\<close> is defined in terms of a
version \<open>spec_equiv_valid\<close> that supports restricting the attention of the statement to
a particular initial state. We will avoid encountering \<open>spec_equiv_valid\<close> for the rest
of this tutorial, by unfolding \<open>equiv_valid_def2\<close> instead of \<open>equiv_valid_def\<close>. \<close>

\<comment> \<open>Specialised\<close>
thm equiv_valid_def
    equiv_valid_def[simplified spec_equiv_valid_def equiv_valid_2_def]

text \<open> Finally, the library also contains both simplified and more general forms of
EquivValid statement; the more general forms allow proof engineers to specify the
equivalences and functions on which they are asserted in a more fine-grained fashion
than is allowed by \<open>equiv_valid\<close>. These will be addressed further later in this tutorial. \<close>

\<comment> \<open>Simplified for A = B.\<close>
lemma "equiv_valid_inv I A P f" unfolding equiv_valid_def2 oops
\<comment> \<open>Generalised to allow specifying equivalence R on return values.\<close>
lemma "equiv_valid_rv_inv I A R P f" unfolding equiv_valid_2_def oops
\<comment> \<open>Generalised further.\<close>
lemma "equiv_valid_rv I A B R P f" unfolding equiv_valid_2_def oops
lemma "equiv_valid_2 I A B R P P' f f'" unfolding equiv_valid_2_def oops

section \<open> Example setting: a room with a view \<close>

text \<open> EquivValid statements assert equivalences between system states in alternative runs
of a given program; for this tutorial we define a basic structure for the system state: \<close>

record 'val Room =
  desk :: 'val
  window :: 'val
  outbox :: 'val
  inbox :: 'val
  job :: "'val \<Rightarrow> 'val"

text \<open> The state equivalences of interest will then be of the kind
``\<open>desk\<close> has the same value in both states'', and so forth.
We will typically use these to specify the attacker's assumed ability to make
observations of (or otherwise know) the contents of those parts of the state. \<close>

definition desk_equivalence :: "'val Room \<Rightarrow> 'val Room \<Rightarrow> bool"
where
  "desk_equivalence r1 r2 \<equiv> desk r1 = desk r2"

definition window_equivalence :: "'val Room \<Rightarrow> 'val Room \<Rightarrow> bool"
where
  "window_equivalence r1 r2 \<equiv> window r1 = window r2"

text \<open> We could just as well define equivalences similarly for
\<open>inbox\<close>, \<open>outbox\<close>, or \<open>job\<close> -- we omit these here. \<close>

text \<open> Furthermore, you can use the \<open>and\<close> alias provided by @{theory Monads.Fun_Pred_Syntax}
to write the conjunction of two binary predicates.
(Similarly, there is also an \<open>or\<close> alias for disjunction.)\<close>

lemma
  "(desk_equivalence and window_equivalence) r1 r2 =
   (desk r1 = desk r2 \<and> window r1 = window r2)"
  unfolding desk_equivalence_def window_equivalence_def
  by simp

text \<open> In this setting, we might consider a trivial program that just returns
the contents of \<open>desk\<close>; note, there is no difference between these two ways
of expressing it: \<close>
lemma "gets desk = do document \<leftarrow> gets desk; return document od"
  by simp

text \<open> Or, we might consider some programs that transfer values from one part
of the state to another, write constants to state, execute functions
that can themselves be found in state, or some combination of these: \<close>

definition reveal_desk_to_window :: "('val Room, unit) nondet_monad"
where
  "reveal_desk_to_window \<equiv> modify (\<lambda>s. s\<lparr>window := desk s\<rparr>)"

definition sanitise_desk :: "('val::zero Room, unit) nondet_monad"
where
  "sanitise_desk \<equiv> modify (\<lambda>s. s\<lparr>desk := 0\<rparr>)"

definition work_at_desk :: "('val Room, unit) nondet_monad"
where
  "work_at_desk \<equiv>
     do modify (\<lambda>s. s\<lparr>desk := inbox s\<rparr>);
        modify (\<lambda>s. s\<lparr>desk := (job s) (desk s)\<rparr>);
        modify (\<lambda>s. s\<lparr>outbox := desk s\<rparr>)
     od"

definition work_sanitise_reveal :: "('val::zero Room, unit) nondet_monad"
where
  "work_sanitise_reveal \<equiv>
     do work_at_desk;
        sanitise_desk;
        reveal_desk_to_window
     od"

section \<open> Attacker models expressible using EquivValid statements \<close>

subsection \<open> An attacker with access to return values \<close>

text \<open> The most basic form of \<open>equiv_valid\<close> asserts an information-flow security property
that would be appropriate against an attacker that can see only the program's return value:
that any two runs of this program will give the same return value.\footnote{If you think
this doesn't sound like a very useful program, you'd be spot on: Our goal here is
to prove that the program would be stubbornly uninformative to such an attacker.}

Of course, we will find that we can't expect to prove this unless we place some
restrictions on the runs under consideration.
Consider the case where we are maximally permissive with the pre- and post-equivalences
(by supplying \<open>\<top>\<top>\<close>) and precondition (by supplying \<open>\<top>\<close>): \<close>

lemma gets_desk_return_leak:
  \<comment> \<open> No restrictions on pre-equivalence, precondition, or post-equivalence. \<close>
  "\<lbrace>|\<top>\<top>|, \<top>\<rbrace> gets desk \<lbrace>|\<top>\<top>|\<rbrace>"
  find_theorems intro
  \<comment> \<open> There happens to be an applicable \<open>gets\<close> rule for \<open>equiv_valid_inv\<close>. \<close>
  thm gets_ev''
  apply(rule gets_ev'')
  \<comment> \<open> \<open>equiv_valid\<close> requires the return value to be the same in both runs.
     As expected, we are stuck, as we don't know that the contents of \<open>desk\<close>
     were initially the same for both runs. \<close>
  nitpick
  oops

text \<open> How might we know that \<open>gets desk\<close> will return the same value for each of
a given pair of runs?

One way we might know this is if the pre-equivalence tells us that we can assume
that \<open>desk\<close> initially has the same value in both runs.
This might be appropriate to assume, for example:
(1) after executing some function that equalises the value of \<open>desk\<close> between
   all runs under consideration, or
(2) when the attacker already knows the contents of \<open>desk\<close>.
Note that these are just two ways of saying that we consider it to be acceptable
for the attacker to know the initial contents of \<open>desk\<close>.

We can specify this formally by setting \<open>desk_equivalence\<close> as the pre-equivalence.%
\footnote{To avoid complicating things for now, we'll also set the post-equivalence
to be the same as the pre-equivalence. Examples of proving \<open>equiv_valid\<close> statements
with a different pre- and post-equivalence will be addressed later in this tutorial.}
The resulting EquivValid statement's demand for equal return values is easily provable
for \<open>gets desk\<close>, using the \<open>gets\<close> rule for \<open>equiv_valid\<close> we found earlier: \<close>

lemma gets_desk_equiv_return:
  \<comment> \<open> Pre-equivalence (and post-equivalence):
      The value of \<open>desk\<close> is equal initially (and finally) for both runs. \<close>
  "\<lbrace>|desk_equivalence|, \<top>\<rbrace>
     gets desk
   \<lbrace>|desk_equivalence|\<rbrace>"
  find_theorems intro
  apply(rule gets_ev'')
  unfolding desk_equivalence_def
  by simp

text \<open> Note that the \<open>equiv_valid_rv\<close> form of EquivValid allows you to customise the
relationship demanded between return values to be something other than equality: \<close>
lemma "\<lbrace>|\<top>\<top>|, \<top>\<rbrace> f \<lbrace>|\<top>\<top>|\<rbrace> = equiv_valid_rv \<top>\<top> \<top>\<top> \<top>\<top> (=) \<top> f"
  by (simp add:equiv_valid_def2) \<comment> \<open> Try replacing the \<open>(=)\<close> here. \<close>

subsection \<open> An attacker with a window into the system state \<close>

text \<open> As a rule of thumb, we use an EquivValid statement's pre-equivalence to specify
the secrecy (or initial attacker knowledge) of values in system state, and use the
post-equivalence to specify the attacker's powers of observation.

Suppose now a scenario where the desk in our room initially contains secrets,
and we wish to prevent these secrets from affecting what is observable to an attacker
with binoculars pointed at the window. In this case:
\begin{enumerate}
\item We \<^emph>\<open>do not\<close> include \<open>desk_equivalence\<close> in the pre-equivalence, as we
      do not consider it acceptable for the attacker to know the initial contents of \<open>desk\<close>.

\item Furthermore, we \<^emph>\<open>do\<close> include \<open>window_equivalence\<close> in the post-equivalence, as we
      do consider that the attacker will be able to observe the final contents of \<open>window\<close>.
\end{enumerate}

Clearly, in this situation, using \<open>modify\<close> to transfer the contents of \<open>desk\<close>
to \<open>window\<close> would constitute an unacceptable information leak.
So we should be encouraged to see that the following \<open>equiv_valid\<close>
statement is not provable: \<close>

lemma reveal_desk_window_leak:
  \<comment> \<open> Pre-equivalence and post-equivalence:
      The value of \<open>window\<close> is equal initially and finally for both runs. \<close>
  "\<lbrace>|window_equivalence|, \<top>\<rbrace>
     reveal_desk_to_window
   \<lbrace>|window_equivalence|\<rbrace>"
  unfolding reveal_desk_to_window_def
  \<comment> \<open> We find an applicable \<open>modify\<close> rule for \<open>equiv_valid_inv\<close>. \<close>
  find_theorems intro
  apply(rule modify_ev'')
  \<comment> \<open> Applying it, we see that it demands that \<open>window_equivalence\<close> holds
      between the final states of both runs. \<close>
  unfolding window_equivalence_def
  apply clarsimp
  \<comment> \<open> We should not expect to be able to prove this, because we have
      said nothing about the initial value of desk in these runs. \<close>
  oops (* Try: nitpick *)

text \<open> As before, however, we should expect this to hold with a pre-equivalence
that includes \<open>desk_equivalence\<close>. \<close>

lemma reveal_desk_equiv_window_equiv:
  "\<lbrace>|desk_equivalence and window_equivalence|, \<top>\<rbrace>
     reveal_desk_to_window
   \<lbrace>|desk_equivalence and window_equivalence|\<rbrace>"
  unfolding reveal_desk_to_window_def
  apply(rule modify_ev'')
  unfolding desk_equivalence_def window_equivalence_def
  by clarsimp

section \<open> The typical toolkit \<close>

subsection \<open> Using and customising the \<open>wp\<close> tool's rule set \<close>

text \<open> Recall the lemma we proved for \<open>gets desk\<close>: \<close>
thm gets_desk_equiv_return
text \<open> Instead of using any of the \<open>gets\<close> rules for \<open>equiv_valid\<close> directly, we can
also try using the \<open>wp\<close> tool to see if it has any applicable rules in its rule set: \<close>
thm wp_ev

text \<open>Before applying \<open>wp\<close> to EquivValid statements in this fashion, we may need
to use the rule \<open>pre_ev\<close> to weaken their precondition.
This allows us to apply rules that are designed to be applied when the precondition
is a schematic variable, so as to infer a weakest precondition for the statement to hold.
It then leaves a goal for later to show that our original precondition implies
the weaker one that was inferred.\<close>
thm pre_ev
\<comment> \<open> Note: \<open>pre_ev\<close> is just the standard \<open>hoare_pre\<close> + \<open>equiv_valid_guard_imp\<close> \<close>
thm hoare_pre
thm equiv_valid_guard_imp

text \<open> Applying the \<open>wp\<close> tactic then works because the \<open>gets_ev\<close> rule happens to be
in the \<open>wp\<close> tool's rule set: \<close>
thm gets_ev

lemma gets_desk_equiv_return_using_wp:
  "\<lbrace>|desk_equivalence|, \<top>\<rbrace>
     gets desk
   \<lbrace>|desk_equivalence|\<rbrace>"
  \<comment> \<open> Use \<open>pre_ev\<close> to weaken the precondition of the \<open>equiv_valid\<close> statement
       and make the \<open>wp\<close> method applicable. \<close>
  apply(rule pre_ev)
   apply wp
  unfolding desk_equivalence_def
  by simp

text \<open> You can freely customise the \<open>wp\<close> rule set as needed, whether to
add new rules, or to replace rules with ones that are more applicable
in a given situation.

For example, the \<open>modify_ev\<close> rule is not part of the default \<open>wp\<close> rule set: \<close>

thm reveal_desk_equiv_window_equiv
  modify_ev

lemma reveal_desk_equiv_window_equiv_using_wp:
  "\<lbrace>|desk_equivalence and window_equivalence|, \<top>\<rbrace>
     reveal_desk_to_window
   \<lbrace>|desk_equivalence and window_equivalence|\<rbrace>"
  unfolding reveal_desk_to_window_def
  apply(rule pre_ev)
   apply(wp add:modify_ev)
  unfolding desk_equivalence_def window_equivalence_def
  by clarsimp

text \<open> As another example:
It might be the \<^emph>\<open>precondition\<close> for both runs that tells us that \<open>desk\<close> has
a fixed initial constant value \<open>c\<close> that is common to both runs.
(This might be the case if, even if we might normally use \<open>desk\<close> for
secrets, we happen to have just executed a ``flush'' function that writes \<open>c\<close> to
\<open>desk\<close> before this point in the program, for all pairs of runs we care to compare.)

Here we can modify the wp rule set to invoke \<open>gets_ev''\<close> for \<open>equiv_valid\<close>,
which is better than the default \<open>gets_ev\<close> rule for situations like this
where we actually need to use the precondition: \<close>
thm gets_ev''

lemma example_precond_desk_return:
  \<comment> \<open> Precondition: The value of desk is some fixed value \<open>c\<close>.
      \<open>equiv_valid\<close> then assumes that this precondition applies to both runs. \<close>
  "\<lbrace>|\<top>\<top>|, (\<lambda>s. desk s = c)\<rbrace>
     gets desk
   \<lbrace>|\<top>\<top>|\<rbrace>"
  apply(wp del:gets_ev add:gets_ev'')
  by force

text \<open> Relying on such a precondition, a similar argument is possible
when proving that \<open>reveal_desk_to_window\<close> preserves \<open>window_equivalence\<close>: \<close>
thm modify_ev''

lemma reveal_const_desk_preserves_window_equiv:
  \<comment> \<open> Precondition: Desk initially has a fixed constant \<open>c\<close>.
      \<open>equiv_valid\<close> then assumes that this precondition applies to both runs. \<close>
  "\<lbrace>|window_equivalence|, (\<lambda>s. desk s = c)\<rbrace>
     reveal_desk_to_window
   \<lbrace>|window_equivalence|\<rbrace>"
  unfolding reveal_desk_to_window_def
  apply(wp add:modify_ev'')
  unfolding window_equivalence_def
  by clarsimp

text \<open> Finally, new EquivValid rules that we expect to be exercised
often can be added to the \<open>wp\<close> rule set using a declaration: \<close>
declare modify_ev[wp]

subsection \<open> Remainder of worked example using \<open>wp\<close> tool \<close>

text \<open> Let's use all this to prove that our overarching program,
\<open>work_sanitise_reveal\<close>, is secure against the attacker at the window
with the binoculars (i.e. preserves \<open>window_equivalence\<close>). \<close>

thm work_sanitise_reveal_def

text \<open> First, we expect these two statements to be provable, because
\<open>work_at_desk\<close> and \<open>sanitise_desk\<close> have nothing to do with the window. \<close>

lemma work_at_desk_preserves_window_equiv:
  "\<lbrace>|window_equivalence|, P\<rbrace>
     work_at_desk
   \<lbrace>|window_equivalence|\<rbrace>"
  unfolding work_at_desk_def
  apply wp \<comment> \<open> Instead of \<open>apply(wp add:modify_ev)\<close> \<close>
  unfolding window_equivalence_def
  by force

lemma sanitise_desk_preserves_window_equiv:
  "\<lbrace>|window_equivalence|, P\<rbrace>
     sanitise_desk
   \<lbrace>|window_equivalence|\<rbrace>"
  unfolding sanitise_desk_def
  apply(rule pre_ev)
   apply wp \<comment> \<open> Instead of \<open>apply(wp add:modify_ev)\<close> \<close>
  unfolding window_equivalence_def
  by force

text \<open> The consequence of all this is that \<open>work_at_desk\<close> might freely
shuttle secrets between \<open>inbox\<close> and \<open>outbox\<close> via \<open>desk\<close>, and execute
a secret \<open>job\<close> on them, but it does not allow any of these secrets
to affect what is visible at \<open>window\<close>.

The mere fact of \<^emph>\<open>excluding\<close> any equivalences on \<open>inbox\<close>, \<open>outbox\<close>, or
\<open>job\<close> from the pre- and post-equivalence of these statements
implies both:
\begin{enumerate}
\item We \<^emph>\<open>do not\<close> consider it acceptable for the attacker to know the
      initial values of \<open>inbox\<close> and \<open>outbox\<close> in these locations;
      even the \<open>job\<close> to be executed may differ between the runs.
      All of these are therefore secrets to be protected by the property.

\item We \<^emph>\<open>do\<close> consider it acceptable for \<open>inbox\<close>, \<open>outbox\<close>, and \<open>job\<close>
      to contain secret values after the program has finished executing.
\end{enumerate} \<close>

text \<open> We will, however, need that \<open>sanitise_desk\<close> establishes the precondition
demanded by our recently proved lemma: that \<open>desk\<close> contains a constant. \<close>
thm reveal_const_desk_preserves_window_equiv

text \<open> Note that this is a regular (non-EquivValid) Hoare triple: \<close>
lemma sanitise_desk_sets_zero:
  "\<lbrace>P\<rbrace> sanitise_desk \<lbrace>\<lambda>r s. desk s = 0\<rbrace>"
  unfolding sanitise_desk_def
  apply(rule pre_ev)
   apply wp
  by force

text \<open> We can now use all these lemmas to have \<open>wp\<close> discharge that
our overarching program \<open>work_sanitise_reveal\<close> preserves \<open>window_equivalence\<close>. \<close>

lemma work_sanitise_reveal_preserves_window_equiv:
  "\<lbrace>|window_equivalence|, \<top>\<rbrace>
     work_sanitise_reveal
   \<lbrace>|window_equivalence|\<rbrace>"
  unfolding work_sanitise_reveal_def
  apply(wp add:reveal_const_desk_preserves_window_equiv[where c=0]
               sanitise_desk_preserves_window_equiv
               sanitise_desk_sets_zero
               work_at_desk_preserves_window_equiv)
  by force

section \<open> The advanced toolkit \<close>

subsection \<open> More general forms of EquivValid statements \<close>

text \<open> Lib.EquivValid provides rules for discharging \<open>equiv_valid_inv\<close> statements for
the basic monad primitives \<open>return\<close> and \<open>bind\<close>, and some of the more basic functions
like \<open>gets\<close> (already seen); potentially in a number of variants. \<close>

thm return_ev
  bind_ev
  gets_ev gets_ev' gets_ev''
  modify_ev modify_ev' modify_ev''

text \<open> On rare occasions you may find a need to use some of the more general
forms of EquivValid. These are all defined in terms of the most general form,
\<open>equiv_valid_2\<close>, which allows full customisation of
(1) return value equivalence \<open>R\<close>,
(2) differing pre-equivalence \<open>A\<close> vs post-equivalence \<open>B\<close>, and even
(3) differing preconditions \<open>P,P'\<close> and functions \<open>f,f'\<close> for each run.
(In \cite{Murray_MBGK_12}, \<open>equiv_valid_2\<close> is referred to as ``ev2''.) \<close>

\<comment> \<open>Generalised to allow specifying equivalence R on return values.\<close>
lemma "equiv_valid_rv_inv I A R P f" unfolding equiv_valid_2_def oops
\<comment> \<open>Generalised further.\<close>
lemma "equiv_valid_rv I A B R P f" unfolding equiv_valid_2_def oops
lemma "equiv_valid_2 I A B R P P' f f'" unfolding equiv_valid_2_def oops

text \<open> If you ever have a need to unfold an \<open>equiv_valid\<close> statement to its
\<open>equiv_valid_2\<close> form -- perhaps as part of a more involved manual proof --
it is often better to unfold \<open>equiv_valid_def2\<close> rather than \<open>equiv_valid_def\<close>.

Lib.EquivValid also provides various rules for discharging \<open>equiv_valid_2\<close>
statements for the basic monad primitives. For example: \<close>

thm return_ev2
  equiv_valid_2_bind equiv_valid_2_bind_pre equiv_valid_2_bind_general
  modify_ev2

lemma reveal_desk_equiv_window_equiv_using_ev2:
  "\<lbrace>|desk_equivalence and window_equivalence|, \<top>\<rbrace>
     reveal_desk_to_window
   \<lbrace>|desk_equivalence and window_equivalence|\<rbrace>"
  unfolding reveal_desk_to_window_def
  apply(clarsimp simp:equiv_valid_def2)
  \<comment> \<open> After peeling back to \<open>equiv_valid_2\<close> form, we can use its \<open>modify\<close> rule. \<close>
  find_theorems intro
  apply(rule modify_ev2)
  unfolding desk_equivalence_def window_equivalence_def
  by simp

text \<open> The basic \<open>equiv_valid\<close> form and its rule set may sometimes
be too restrictive, due to their demand for return values to be equal.

For example, if we ever needed to prove an \<open>equiv_valid\<close> statement about
\<open>do s \<leftarrow> get; return (f s) od\<close>, we would need to unfold it to \<open>equiv_valid_2\<close> form.
This is because \<open>equiv_valid\<close> and its bind rule \<open>bind_ev_pre\<close> will both demand
that the return value of \<open>get\<close> (the entire state) be the same for both runs;
however, we might only need (or know) the parts of the state inspected
by the function \<open>f\<close> to be the same. Say \<open>f\<close> was \<open>desk\<close>: \<close>

thm bind_ev_pre
    equiv_valid_def2[simplified equiv_valid_2_def]

lemma pitfall1_using_bind_ev:
  "\<lbrace>|\<top>\<top>|, (\<lambda>s. desk s = c)\<rbrace>
     do
       s \<leftarrow> get;
       return (desk s)
     od
   \<lbrace>|\<top>\<top>|\<rbrace>"
  \<comment> \<open> Using the bind rule for \<open>equiv_valid\<close> splits the goal into
      two \<open>equiv_valid\<close> statements, one for each of \<open>get\<close> and \<open>return\<close>.
      It will ask us to prove them in reverse order. \<close>
  apply(rule bind_ev_pre)
     \<comment> \<open> The \<open>wp\<close> tool discharges the \<open>return (desk s)\<close> part trivially: \<close>
     apply wp
    \<comment> \<open> But the return value of \<open>get\<close> is the entire state: \<close>
    apply(clarsimp simp:equiv_valid_def2 equiv_valid_2_def)
    apply(clarsimp simp add:get_def)
    \<comment> \<open> This causes us to get stuck, because we have no idea whether the state
        is equivalent for parts of the room other than the desk. \<close>
    oops

text \<open> Therefore we need to use \<open>equiv_valid_2\<close> and its bind rule \<open>equiv_valid_2_bind_pre\<close>;
these will allow us to specify the equivalence \<open>R\<close> to be asserted between
the return values of the \<open>get\<close>. \<close>

thm equiv_valid_2_bind_pre
  equiv_valid_2_def

text \<open> Another anti-pattern to avoid when applying the bind rules directly is leaving
intermediate preconditions unspecified; the automation is liable to guess \<open>False\<close>,
which will later be unprovable.

Here, the \<open>force\<close> tactic correctly infers that \<open>desk_equivalence\<close> is the equivalence \<open>R\<close>
that we need between the return values from \<open>get\<close>.
However, it guesses an incorrect postcondition: \<close>

lemma pitfall2_using_bind_ev2:
  "\<lbrace>|\<top>\<top>|, (\<lambda>s. desk s = c)\<rbrace>
     do
       s \<leftarrow> get;
       return (desk s)
     od
   \<lbrace>|\<top>\<top>|\<rbrace>"
  \<comment> \<open> First we need to peel it back to \<open>equiv_valid_2\<close> form, so we can apply its bind rule. \<close>
  apply(clarsimp simp:equiv_valid_def2)
  apply(rule equiv_valid_2_bind_pre)
       \<comment> \<open> Here \<open>wp\<close> infers correctly that the equivalence between the
          intermediate return values needs to be \<open>\<lambda>rv rv'. desk rv = desk rv'\<close>,
          i.e. that \<open>desk\<close> has the same value in the state returned by \<open>get\<close> in both runs. \<close>
       apply(wp add:return_ev2)
      apply(clarsimp simp:equiv_valid_def spec_equiv_valid_def equiv_valid_2_def)
      \<comment> \<open> The \<open>force\<close> tactic just guesses \<open>False\<close> for the postcondition for both steps. \<close>
      apply(force simp add:get_def)
     \<comment> \<open> As these next two goals are Hoare triples, we use the \<open>wp\<close> tool, as usual for
         Hoare triples in the seL4 proof base. See Lib.WPTutorial for more information. \<close>
     apply wp
    apply wp
   \<comment> \<open> Now we are stuck because \<open>force\<close> guessed \<open>False\<close> as a premise
      to discharge the goal earlier, giving us an unsatisfiable goal here. \<close>
   oops

text \<open> We can avoid this by giving \<open>equiv_valid_2\<close>'s bind rule a little more information. \<close>

lemma precond_get_return_desk:
  "\<lbrace>|\<top>\<top>|, (\<lambda>s. desk s = c)\<rbrace>
     do
       s \<leftarrow> get;
       return (desk s)
     od
   \<lbrace>|\<top>\<top>|\<rbrace>"
  apply(clarsimp simp:equiv_valid_def2)
  \<comment> \<open> We want to use the fact that \<open>desk\<close> contains \<open>c\<close> initially for both runs.
    So we give it here. \<close>
  apply(rule_tac P="(\<lambda>s. desk s = c)" and P'="(\<lambda>s. desk s = c)" in equiv_valid_2_bind_pre)
       apply(wp add:return_ev2)
      apply(clarsimp simp:equiv_valid_def2 equiv_valid_2_def)
      \<comment> \<open> No need to guess anything. \<close>
      apply(force simp add:get_def)
     \<comment> \<open> Use \<open>wp\<close> tactic to discharge the two Hoare triples; see Lib.WPTutorial for more info. \<close>
     apply wp
    apply wp
   apply force
  apply force
  done

subsection \<open> A note on what is currently available and why \<close>

text \<open> As noted in \cite{Murray_MBGK_12}, the machinery developed of this kind
(available in Lib.EquivValid's default \<open>wp\<close> rule set) is mostly geared
towards \<open>equiv_valid_inv\<close>; this is an abbrevation for the simplified case of
\<open>equiv_valid\<close> where the post-equivalence is the same as the pre-equivalence: \<close>

lemma "equiv_valid_inv I A P f" unfolding equiv_valid_def2 equiv_valid_2_def oops

text \<open> The reason for this is that the seL4 infoflow proofs take the approach of defining an
\emph{unwinding} relation \cite{Goguen_Meseguer_84}: an equivalence relation
flexible enough to describe what we think ought to continue to look the same between
all possible pairs of executions as seen by a given attacker model.%
\footnote{If every pair of executions being compared is like a wound-up rope ladder thrown
over the side of a ship, then the rungs of those ladders would be the unwinding relation.}

However, the EquivValid library merely provides a way to reason about equivalences,
so it is not prescriptive about taking this approach.

Furthermore, the overall unwinding relation for a system may be composed from a number of
equivalences, which may each hold or not at different times, in a manner that depends on
where we are in the system.%
\footnote{This is like saying that the first six rungs of the ladder may be made of wood,
but the next seven rungs may be made of aluminium, and so on.}
As it happens, this is the case for seL4's unwinding relation, but the number of ev sub-lemmas
needing to be proved for differing pre-/post-equivalences is rather limited at current time of
writing, hence the lack of machinery.%
\footnote{This may perhaps be the lemma covering the step between the sixth and seventh
rung of our imaginary wood-and-aluminium--runged ladder.} \<close>

subsection \<open> Proving EquivValid with differing pre- and post-equivalences \<close>

text \<open> So far we have only proved \<open>equiv_valid\<close> statements
whose pre-equivalence is the same as their post-equivalence.

We will now attempt to prove an \<open>equiv_valid\<close> statement where they differ.

This allows us to say, for example, that although usually we use the desk
for secrets:
(1) at this point in the program we happened to make sure that
    desk contains the same value for any two runs we care to check, and
(2) we don't care if desk contains the same value for both runs afterwards. \<close>

lemma reveal_desk_equiv_to_window_equiv:
  "\<lbrace>|desk_equivalence|, \<top>\<rbrace>  \<comment> \<open> Pre-equivalence: The value of \<open>desk\<close> is
                                 the same initially in both runs. \<close>
     reveal_desk_to_window
   \<lbrace>|window_equivalence|\<rbrace>" \<comment> \<open> Post-equivalence: The value of \<open>window\<close> is required to be
                                the same at the end of both runs; no longer so for \<open>desk\<close>. \<close>
  unfolding reveal_desk_to_window_def
  apply(rule modify_ev'')
  unfolding window_equivalence_def desk_equivalence_def
  by simp

text \<open> This is handy, because we might subsequently copy secrets into the desk,
in which case \<open>desk_equivalence\<close> would no longer hold in the post-equivalence.

As before, the mere fact of \<^emph>\<open>excluding\<close> any equivalence on \<open>inbox\<close> from the
pre-equivalence implies we \<^emph>\<open>do not\<close> consider it acceptable for the attacker
to know \<open>inbox\<close>'s initial value; it is therefore a secret to be protected by this property.
Conversely, the absence of \<open>desk_equivalence\<close> from the post-equivalence implies
that we \<^emph>\<open>do\<close> consider it acceptable for the desk to contain secrets after the program
has finished executing.

Consequently, this \<open>equiv_valid\<close> statement is provable: \<close>

lemma desk_equiv_no_longer_needed:
  "\<lbrace>|desk_equivalence|, \<top>\<rbrace>
       do reveal_desk_to_window;
          modify (\<lambda>r. r\<lparr>desk := inbox r\<rparr>)
       od
   \<lbrace>|window_equivalence|\<rbrace>"
  \<comment> \<open> Use \<open>pre_ev\<close> to weaken the precondition of the \<open>equiv_valid\<close> statement. \<close>
  apply(rule pre_ev)
   \<comment> \<open> Use \<open>bind_ev_general\<close> to split the goal into \<open>equiv_valid\<close> statements for
       each of the two \<open>modify\<close> commands. It will ask us to prove them in reverse order. \<close>
   apply(rule bind_ev_general)
     \<comment> \<open> Prove \<open>equiv_valid\<close> for \<open>desk := inbox\<close> manually. \<close>
     apply clarsimp
     apply(rule modify_ev'')
     \<comment> \<open> The \<open>force\<close> tactic has enough information here to figure out that
         the intermediate equivalence \<open>B\<close> needs to be \<open>window_equivalence\<close>. \<close>
     apply(force simp:window_equivalence_def desk_equivalence_def)
    \<comment> \<open> This happens to be the post-equivalence for the \<open>equiv_valid\<close> lemma
        we just proved for \<open>window := desk\<close>, so we can reuse that lemma here. \<close>
    using reveal_desk_equiv_to_window_equiv
    unfolding window_equivalence_def
    apply force
   apply wp
  apply force
  done

end


theory "Env-HOLCF"
  imports Env "HOLCF-Utils"
begin

subsubsection {* Continuity and pcpo-valued functions *}

lemma  override_on_belowI:
  assumes "\<And> a. a \<in> S \<Longrightarrow> y a \<sqsubseteq> z a"
  and "\<And> a. a \<notin> S \<Longrightarrow> x a \<sqsubseteq> z a"
  shows  "x ++\<^bsub>S\<^esub> y \<sqsubseteq> z"
  using assms
  apply -
  apply (rule fun_belowI)
  apply (case_tac "xa \<in> S")
  apply auto
  done

lemma override_on_cont1: "cont (\<lambda> x. x ++\<^bsub>S\<^esub> m)"
  by (rule cont2cont_lambda) (auto simp add: override_on_def)

lemma override_on_cont2: "cont (\<lambda> x. m ++\<^bsub>S\<^esub> x)"
  by (rule cont2cont_lambda) (auto simp add: override_on_def)

lemma override_on_cont2cont[simp, cont2cont]:
  assumes "cont f"
  assumes "cont g"
  shows "cont (\<lambda> x. f x ++\<^bsub>S\<^esub> g x)"
by (rule cont_apply[OF assms(1) override_on_cont1 cont_compose[OF override_on_cont2 assms(2)]])

lemma override_on_mono:
  assumes "x1 \<sqsubseteq> (x2 :: 'a\<Colon>type \<Rightarrow> 'b\<Colon>cpo)"
  assumes "y1 \<sqsubseteq> y2"
  shows "x1 ++\<^bsub>S\<^esub> y1 \<sqsubseteq> x2 ++\<^bsub>S\<^esub> y2"
by (rule below_trans[OF cont2monofunE[OF override_on_cont1 assms(1)] cont2monofunE[OF override_on_cont2 assms(2)]])

lemma fun_upd_belowI:
  assumes "\<And> z . z \<noteq> x \<Longrightarrow> \<rho> z \<sqsubseteq> \<rho>' z"
  assumes "y \<sqsubseteq> \<rho>' x"
  shows  "\<rho>(x := y) \<sqsubseteq> \<rho>'"
  apply (rule fun_belowI)
  using assms
  apply (case_tac "xa = x")
  apply auto
  done

lemma fun_upd_belowI2:
  assumes "\<And> z . z \<noteq> x \<Longrightarrow> \<rho> z \<sqsubseteq> \<rho>' z"
  assumes "\<rho> x \<sqsubseteq> y"
  shows  "\<rho> \<sqsubseteq> \<rho>'(x := y)"
  apply (rule fun_belowI)
  using assms by auto

lemma env_restr_belowI:
  assumes  "\<And> x. x \<in> S \<Longrightarrow> (m1 f|` S) x \<sqsubseteq> (m2 f|` S) x"
  shows "m1 f|` S \<sqsubseteq> m2 f|` S"
  apply (rule fun_belowI)
  by (metis assms below_bottom_iff lookup_env_restr_not_there)

lemma env_restr_below_itself:
  shows "m f|` S \<sqsubseteq> m"
  apply (rule fun_belowI)
  apply (case_tac "x \<in> S")
  apply auto
  done

lemma env_restr_cont:  "cont (env_restr S)"
  apply (rule cont2cont_lambda)
  apply (case_tac "y \<in> S")
  apply (auto simp add: assms)
  done

lemma env_restr_eqD:
  assumes "m1 f|` S = m2 f|` S"
  assumes "x \<in> S"
  shows "m1 x = m2  x"
  by (metis assms(1) assms(2) lookup_env_restr)

lemma env_restr_below_subset:
  assumes "S \<subseteq> S'"
  and "m1 f|` S' \<sqsubseteq> m2 f|` S'"
  shows "m1 f|` S \<sqsubseteq> m2 f|` S"
using assms
by (auto intro!: env_restr_belowI dest: env_restr_belowD)

lemma  override_on_below_restrI:
  assumes " x f|` (-S) \<sqsubseteq> z f|` (-S)"
  and "y f|` S \<sqsubseteq> z f|` S"
  shows  "x ++\<^bsub>S\<^esub> y \<sqsubseteq> z"
using assms
by (auto intro: override_on_belowI dest:env_restr_belowD)

lemma  fmap_below_add_restrI:
  assumes "x f|` (-S) \<sqsubseteq> y f|` (-S)"
  and     "x f|` S \<sqsubseteq> z f|` S"
  shows  "x \<sqsubseteq> y ++\<^bsub>S\<^esub> z"
using assms
by (auto intro!: fun_belowI dest:env_restr_belowD simp add: lookup_override_on_eq)

lemmas env_restr_cont2cont[simp,cont2cont] = cont_compose[OF env_restr_cont]

lemma env_delete_cont:  "cont (env_delete x)"
  apply (rule cont2cont_lambda)
  apply (case_tac "y = x")
  apply (auto simp add: assms)
  done
lemmas env_delete_cont2cont[simp,cont2cont] = cont_compose[OF env_delete_cont]

end