(*  Title:      HOL/Imperative_HOL/Heap_Monad.thy
    Author:     John Matthews, Galois Connections; Alexander Krauss, Lukas Bulwahn & Florian Haftmann, TU Muenchen
*)

section \<open>A monad with a polymorphic heap and primitive reasoning infrastructure\<close>

theory Heap_Monad
imports
  Heap
  "~~/src/HOL/Library/Monad_Syntax"
begin

subsection \<open>The monad\<close>

subsubsection \<open>Monad construction\<close>

text \<open>Monadic heap actions either produce values
  and transform the heap, or fail\<close>
datatype 'a Heap = Heap "heap \<Rightarrow> ('a \<times> heap) option"

lemma [code, code del]:
  "(Code_Evaluation.term_of :: 'a::typerep Heap \<Rightarrow> Code_Evaluation.term) = Code_Evaluation.term_of"
  ..

primrec execute :: "'a Heap \<Rightarrow> heap \<Rightarrow> ('a \<times> heap) option" where
  [code del]: "execute (Heap f) = f"

lemma Heap_cases [case_names succeed fail]:
  fixes f and h
  assumes succeed: "\<And>x h'. execute f h = Some (x, h') \<Longrightarrow> P"
  assumes fail: "execute f h = None \<Longrightarrow> P"
  shows P
  using assms by (cases "execute f h") auto

lemma Heap_execute [simp]:
  "Heap (execute f) = f" by (cases f) simp_all

lemma Heap_eqI:
  "(\<And>h. execute f h = execute g h) \<Longrightarrow> f = g"
    by (cases f, cases g) (auto simp: fun_eq_iff)

named_theorems execute_simps "simplification rules for execute"

lemma execute_Let [execute_simps]:
  "execute (let x = t in f x) = (let x = t in execute (f x))"
  by (simp add: Let_def)

subsubsection \<open>Specialised lifters\<close>

definition tap :: "(heap \<Rightarrow> 'a) \<Rightarrow> 'a Heap" where
  [code del]: "tap f = Heap (\<lambda>h. Some (f h, h))"

lemma execute_tap [execute_simps]:
  "execute (tap f) h = Some (f h, h)"
  by (simp add: tap_def)

definition heap :: "(heap \<Rightarrow> 'a \<times> heap) \<Rightarrow> 'a Heap" where
  [code del]: "heap f = Heap (Some \<circ> f)"

lemma execute_heap [execute_simps]:
  "execute (heap f) = Some \<circ> f"
  by (simp add: heap_def)

definition guard :: "(heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> 'a \<times> heap) \<Rightarrow> 'a Heap" where
  [code del]: "guard P f = Heap (\<lambda>h. if P h then Some (f h) else None)"

lemma execute_guard [execute_simps]:
  "\<not> P h \<Longrightarrow> execute (guard P f) h = None"
  "P h \<Longrightarrow> execute (guard P f) h = Some (f h)"
  by (simp_all add: guard_def)

subsubsection \<open>Predicate classifying successful computations\<close>

definition success :: "'a Heap \<Rightarrow> heap \<Rightarrow> bool" where
  "success f h \<longleftrightarrow> execute f h \<noteq> None"

lemma successI:
  "execute f h \<noteq> None \<Longrightarrow> success f h"
  by (simp add: success_def)

lemma successE:
  assumes "success f h"
  obtains r h' where "execute f h = Some (r, h')"
  using assms by (auto simp: success_def)

named_theorems success_intros "introduction rules for success"

lemma success_tapI [success_intros]:
  "success (tap f) h"
  by (rule successI) (simp add: execute_simps)

lemma success_heapI [success_intros]:
  "success (heap f) h"
  by (rule successI) (simp add: execute_simps)

lemma success_guardI [success_intros]:
  "P h \<Longrightarrow> success (guard P f) h"
  by (rule successI) (simp add: execute_guard)

lemma success_LetI [success_intros]:
  "x = t \<Longrightarrow> success (f x) h \<Longrightarrow> success (let x = t in f x) h"
  by (simp add: Let_def)

lemma success_ifI:
  "(c \<Longrightarrow> success t h) \<Longrightarrow> (\<not> c \<Longrightarrow> success e h) \<Longrightarrow>
    success (if c then t else e) h"
  by (simp add: success_def)

subsubsection \<open>Predicate for a simple relational calculus\<close>

text \<open>
  The \<open>effect\<close> predicate states that when a computation \<open>c\<close>
  runs with the heap \<open>h\<close> will result in return value \<open>r\<close>
  and a heap \<open>h'\<close>, i.e.~no exception occurs.
\<close>

definition effect :: "'a Heap \<Rightarrow> heap \<Rightarrow> heap \<Rightarrow> 'a \<Rightarrow> bool" where
  effect_def: "effect c h h' r \<longleftrightarrow> execute c h = Some (r, h')"

lemma effectI:
  "execute c h = Some (r, h') \<Longrightarrow> effect c h h' r"
  by (simp add: effect_def)

lemma effectE:
  assumes "effect c h h' r"
  obtains "r = fst (the (execute c h))"
    and "h' = snd (the (execute c h))"
    and "success c h"
proof (rule that)
  from assms have *: "execute c h = Some (r, h')" by (simp add: effect_def)
  then show "success c h" by (simp add: success_def)
  from * have "fst (the (execute c h)) = r" and "snd (the (execute c h)) = h'"
    by simp_all
  then show "r = fst (the (execute c h))"
    and "h' = snd (the (execute c h))" by simp_all
qed

lemma effect_success:
  "effect c h h' r \<Longrightarrow> success c h"
  by (simp add: effect_def success_def)

lemma success_effectE:
  assumes "success c h"
  obtains r h' where "effect c h h' r"
  using assms by (auto simp add: effect_def success_def)

lemma effect_deterministic:
  assumes "effect f h h' a"
    and "effect f h h'' b"
  shows "a = b" and "h' = h''"
  using assms unfolding effect_def by auto

named_theorems effect_intros "introduction rules for effect"
  and effect_elims "elimination rules for effect"

lemma effect_LetI [effect_intros]:
  assumes "x = t" "effect (f x) h h' r"
  shows "effect (let x = t in f x) h h' r"
  using assms by simp

lemma effect_LetE [effect_elims]:
  assumes "effect (let x = t in f x) h h' r"
  obtains "effect (f t) h h' r"
  using assms by simp

lemma effect_ifI:
  assumes "c \<Longrightarrow> effect t h h' r"
    and "\<not> c \<Longrightarrow> effect e h h' r"
  shows "effect (if c then t else e) h h' r"
  by (cases c) (simp_all add: assms)

lemma effect_ifE:
  assumes "effect (if c then t else e) h h' r"
  obtains "c" "effect t h h' r"
    | "\<not> c" "effect e h h' r"
  using assms by (cases c) simp_all

lemma effect_tapI [effect_intros]:
  assumes "h' = h" "r = f h"
  shows "effect (tap f) h h' r"
  by (rule effectI) (simp add: assms execute_simps)

lemma effect_tapE [effect_elims]:
  assumes "effect (tap f) h h' r"
  obtains "h' = h" and "r = f h"
  using assms by (rule effectE) (auto simp add: execute_simps)

lemma effect_heapI [effect_intros]:
  assumes "h' = snd (f h)" "r = fst (f h)"
  shows "effect (heap f) h h' r"
  by (rule effectI) (simp add: assms execute_simps)

lemma effect_heapE [effect_elims]:
  assumes "effect (heap f) h h' r"
  obtains "h' = snd (f h)" and "r = fst (f h)"
  using assms by (rule effectE) (simp add: execute_simps)

lemma effect_guardI [effect_intros]:
  assumes "P h" "h' = snd (f h)" "r = fst (f h)"
  shows "effect (guard P f) h h' r"
  by (rule effectI) (simp add: assms execute_simps)

lemma effect_guardE [effect_elims]:
  assumes "effect (guard P f) h h' r"
  obtains "h' = snd (f h)" "r = fst (f h)" "P h"
  using assms by (rule effectE)
    (auto simp add: execute_simps elim!: successE, cases "P h", auto simp add: execute_simps)

subsubsection \<open>Monad combinators\<close>

definition return :: "'a \<Rightarrow> 'a Heap" where
  [code del]: "return x = heap (Pair x)"

lemma execute_return [execute_simps]:
  "execute (return x) = Some \<circ> Pair x"
  by (simp add: return_def execute_simps)

lemma success_returnI [success_intros]:
  "success (return x) h"
  by (rule successI) (simp add: execute_simps)

lemma effect_returnI [effect_intros]:
  "h = h' \<Longrightarrow> effect (return x) h h' x"
  by (rule effectI) (simp add: execute_simps)

lemma effect_returnE [effect_elims]:
  assumes "effect (return x) h h' r"
  obtains "r = x" "h' = h"
  using assms by (rule effectE) (simp add: execute_simps)

definition raise :: "string \<Rightarrow> 'a Heap" where \<comment> \<open>the string is just decoration\<close>
  [code del]: "raise s = Heap (\<lambda>_. None)"

lemma execute_raise [execute_simps]:
  "execute (raise s) = (\<lambda>_. None)"
  by (simp add: raise_def)

lemma effect_raiseE [effect_elims]:
  assumes "effect (raise x) h h' r"
  obtains "False"
  using assms by (rule effectE) (simp add: success_def execute_simps)

definition bind :: "'a Heap \<Rightarrow> ('a \<Rightarrow> 'b Heap) \<Rightarrow> 'b Heap" where
  [code del]: "bind f g = Heap (\<lambda>h. case execute f h of
                  Some (x, h') \<Rightarrow> execute (g x) h'
                | None \<Rightarrow> None)"

adhoc_overloading
  Monad_Syntax.bind Heap_Monad.bind

lemma execute_bind [execute_simps]:
  "execute f h = Some (x, h') \<Longrightarrow> execute (f \<bind> g) h = execute (g x) h'"
  "execute f h = None \<Longrightarrow> execute (f \<bind> g) h = None"
  by (simp_all add: bind_def)

lemma execute_bind_case:
  "execute (f \<bind> g) h = (case (execute f h) of
    Some (x, h') \<Rightarrow> execute (g x) h' | None \<Rightarrow> None)"
  by (simp add: bind_def)

lemma execute_bind_success:
  "success f h \<Longrightarrow> execute (f \<bind> g) h = execute (g (fst (the (execute f h)))) (snd (the (execute f h)))"
  by (cases f h rule: Heap_cases) (auto elim: successE simp add: bind_def)

lemma success_bind_executeI:
  "execute f h = Some (x, h') \<Longrightarrow> success (g x) h' \<Longrightarrow> success (f \<bind> g) h"
  by (auto intro!: successI elim: successE simp add: bind_def)

lemma success_bind_effectI [success_intros]:
  "effect f h h' x \<Longrightarrow> success (g x) h' \<Longrightarrow> success (f \<bind> g) h"
  by (auto simp add: effect_def success_def bind_def)

lemma effect_bindI [effect_intros]:
  assumes "effect f h h' r" "effect (g r) h' h'' r'"
  shows "effect (f \<bind> g) h h'' r'"
  using assms
  apply (auto intro!: effectI elim!: effectE successE)
  apply (subst execute_bind, simp_all)
  done

lemma effect_bindE [effect_elims]:
  assumes "effect (f \<bind> g) h h'' r'"
  obtains h' r where "effect f h h' r" "effect (g r) h' h'' r'"
  using assms by (auto simp add: effect_def bind_def split: option.split_asm)

lemma execute_bind_eq_SomeI:
  assumes "execute f h = Some (x, h')"
    and "execute (g x) h' = Some (y, h'')"
  shows "execute (f \<bind> g) h = Some (y, h'')"
  using assms by (simp add: bind_def)

lemma return_bind [simp]: "return x \<bind> f = f x"
  by (rule Heap_eqI) (simp add: execute_simps)

lemma bind_return [simp]: "f \<bind> return = f"
  by (rule Heap_eqI) (simp add: bind_def execute_simps split: option.splits)

lemma bind_bind [simp]: "(f \<bind> g) \<bind> k = (f :: 'a Heap) \<bind> (\<lambda>x. g x \<bind> k)"
  by (rule Heap_eqI) (simp add: bind_def execute_simps split: option.splits)

lemma raise_bind [simp]: "raise e \<bind> f = raise e"
  by (rule Heap_eqI) (simp add: execute_simps)

subsection \<open>Generic combinators\<close>

subsubsection \<open>Assertions\<close>

definition assert :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a Heap" where
  "assert P x = (if P x then return x else raise ''assert'')"

lemma execute_assert [execute_simps]:
  "P x \<Longrightarrow> execute (assert P x) h = Some (x, h)"
  "\<not> P x \<Longrightarrow> execute (assert P x) h = None"
  by (simp_all add: assert_def execute_simps)

lemma success_assertI [success_intros]:
  "P x \<Longrightarrow> success (assert P x) h"
  by (rule successI) (simp add: execute_assert)

lemma effect_assertI [effect_intros]:
  "P x \<Longrightarrow> h' = h \<Longrightarrow> r = x \<Longrightarrow> effect (assert P x) h h' r"
  by (rule effectI) (simp add: execute_assert)

lemma effect_assertE [effect_elims]:
  assumes "effect (assert P x) h h' r"
  obtains "P x" "r = x" "h' = h"
  using assms by (rule effectE) (cases "P x", simp_all add: execute_assert success_def)

lemma assert_cong [fundef_cong]:
  assumes "P = P'"
  assumes "\<And>x. P' x \<Longrightarrow> f x = f' x"
  shows "(assert P x \<bind> f) = (assert P' x \<bind> f')"
  by (rule Heap_eqI) (insert assms, simp add: assert_def)

subsubsection \<open>Plain lifting\<close>

definition lift :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b Heap" where
  "lift f = return o f"

lemma lift_collapse [simp]:
  "lift f x = return (f x)"
  by (simp add: lift_def)

lemma bind_lift:
  "(f \<bind> lift g) = (f \<bind> (\<lambda>x. return (g x)))"
  by (simp add: lift_def comp_def)

subsubsection \<open>Iteration -- warning: this is rarely useful!\<close>

primrec fold_map :: "('a \<Rightarrow> 'b Heap) \<Rightarrow> 'a list \<Rightarrow> 'b list Heap" where
  "fold_map f [] = return []"
| "fold_map f (x # xs) = do {
     y \<leftarrow> f x;
     ys \<leftarrow> fold_map f xs;
     return (y # ys)
   }"

lemma fold_map_append:
  "fold_map f (xs @ ys) = fold_map f xs \<bind> (\<lambda>xs. fold_map f ys \<bind> (\<lambda>ys. return (xs @ ys)))"
  by (induct xs) simp_all

lemma execute_fold_map_unchanged_heap [execute_simps]:
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> \<exists>y. execute (f x) h = Some (y, h)"
  shows "execute (fold_map f xs) h =
    Some (List.map (\<lambda>x. fst (the (execute (f x) h))) xs, h)"
using assms proof (induct xs)
  case Nil show ?case by (simp add: execute_simps)
next
  case (Cons x xs)
  from Cons.prems obtain y
    where y: "execute (f x) h = Some (y, h)" by auto
  moreover from Cons.prems Cons.hyps have "execute (fold_map f xs) h =
    Some (map (\<lambda>x. fst (the (execute (f x) h))) xs, h)" by auto
  ultimately show ?case by (simp, simp only: execute_bind(1), simp add: execute_simps)
qed

subsection \<open>Partial function definition setup\<close>

definition Heap_ord :: "'a Heap \<Rightarrow> 'a Heap \<Rightarrow> bool" where
  "Heap_ord = img_ord execute (fun_ord option_ord)"

definition Heap_lub :: "'a Heap set \<Rightarrow> 'a Heap" where
  "Heap_lub = img_lub execute Heap (fun_lub (flat_lub None))"

lemma Heap_lub_empty: "Heap_lub {} = Heap Map.empty"
by(simp add: Heap_lub_def img_lub_def fun_lub_def flat_lub_def)

lemma heap_interpretation: "partial_function_definitions Heap_ord Heap_lub"
proof -
  have "partial_function_definitions (fun_ord option_ord) (fun_lub (flat_lub None))"
    by (rule partial_function_lift) (rule flat_interpretation)
  then have "partial_function_definitions (img_ord execute (fun_ord option_ord))
      (img_lub execute Heap (fun_lub (flat_lub None)))"
    by (rule partial_function_image) (auto intro: Heap_eqI)
  then show "partial_function_definitions Heap_ord Heap_lub"
    by (simp only: Heap_ord_def Heap_lub_def)
qed

interpretation heap: partial_function_definitions Heap_ord Heap_lub
  rewrites "Heap_lub {} \<equiv> Heap Map.empty"
by (fact heap_interpretation)(simp add: Heap_lub_empty)

lemma heap_step_admissible:
  "option.admissible
      (\<lambda>f:: 'a => ('b * 'c) option. \<forall>h h' r. f h = Some (r, h') \<longrightarrow> P x h h' r)"
proof (rule ccpo.admissibleI)
  fix A :: "('a \<Rightarrow> ('b * 'c) option) set"
  assume ch: "Complete_Partial_Order.chain option.le_fun A"
    and IH: "\<forall>f\<in>A. \<forall>h h' r. f h = Some (r, h') \<longrightarrow> P x h h' r"
  from ch have ch': "\<And>x. Complete_Partial_Order.chain option_ord {y. \<exists>f\<in>A. y = f x}" by (rule chain_fun)
  show "\<forall>h h' r. option.lub_fun A h = Some (r, h') \<longrightarrow> P x h h' r"
  proof (intro allI impI)
    fix h h' r assume "option.lub_fun A h = Some (r, h')"
    from flat_lub_in_chain[OF ch' this[unfolded fun_lub_def]]
    have "Some (r, h') \<in> {y. \<exists>f\<in>A. y = f h}" by simp
    then have "\<exists>f\<in>A. f h = Some (r, h')" by auto
    with IH show "P x h h' r" by auto
  qed
qed

lemma admissible_heap:
  "heap.admissible (\<lambda>f. \<forall>x h h' r. effect (f x) h h' r \<longrightarrow> P x h h' r)"
proof (rule admissible_fun[OF heap_interpretation])
  fix x
  show "ccpo.admissible Heap_lub Heap_ord (\<lambda>a. \<forall>h h' r. effect a h h' r \<longrightarrow> P x h h' r)"
    unfolding Heap_ord_def Heap_lub_def
  proof (intro admissible_image partial_function_lift flat_interpretation)
    show "option.admissible ((\<lambda>a. \<forall>h h' r. effect a h h' r \<longrightarrow> P x h h' r) \<circ> Heap)"
      unfolding comp_def effect_def execute.simps
      by (rule heap_step_admissible)
  qed (auto simp add: Heap_eqI)
qed

lemma fixp_induct_heap:
  fixes F :: "'c \<Rightarrow> 'c" and
    U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a Heap" and
    C :: "('b \<Rightarrow> 'a Heap) \<Rightarrow> 'c" and
    P :: "'b \<Rightarrow> heap \<Rightarrow> heap \<Rightarrow> 'a \<Rightarrow> bool"
  assumes mono: "\<And>x. monotone (fun_ord Heap_ord) Heap_ord (\<lambda>f. U (F (C f)) x)"
  assumes eq: "f \<equiv> C (ccpo.fixp (fun_lub Heap_lub) (fun_ord Heap_ord) (\<lambda>f. U (F (C f))))"
  assumes inverse2: "\<And>f. U (C f) = f"
  assumes step: "\<And>f x h h' r. (\<And>x h h' r. effect (U f x) h h' r \<Longrightarrow> P x h h' r)
    \<Longrightarrow> effect (U (F f) x) h h' r \<Longrightarrow> P x h h' r"
  assumes defined: "effect (U f x) h h' r"
  shows "P x h h' r"
  using step defined heap.fixp_induct_uc[of U F C, OF mono eq inverse2 admissible_heap, of P]
  unfolding effect_def execute.simps
  by blast

declaration \<open>Partial_Function.init "heap" @{term heap.fixp_fun}
  @{term heap.mono_body} @{thm heap.fixp_rule_uc} @{thm heap.fixp_induct_uc}
  (SOME @{thm fixp_induct_heap})\<close>

abbreviation "mono_Heap \<equiv> monotone (fun_ord Heap_ord) Heap_ord"

lemma Heap_ordI:
  assumes "\<And>h. execute x h = None \<or> execute x h = execute y h"
  shows "Heap_ord x y"
  using assms unfolding Heap_ord_def img_ord_def fun_ord_def flat_ord_def
  by blast

lemma Heap_ordE:
  assumes "Heap_ord x y"
  obtains "execute x h = None" | "execute x h = execute y h"
  using assms unfolding Heap_ord_def img_ord_def fun_ord_def flat_ord_def
  by atomize_elim blast

lemma bind_mono [partial_function_mono]:
  assumes mf: "mono_Heap B" and mg: "\<And>y. mono_Heap (\<lambda>f. C y f)"
  shows "mono_Heap (\<lambda>f. B f \<bind> (\<lambda>y. C y f))"
proof (rule monotoneI)
  fix f g :: "'a \<Rightarrow> 'b Heap" assume fg: "fun_ord Heap_ord f g"
  from mf
  have 1: "Heap_ord (B f) (B g)" by (rule monotoneD) (rule fg)
  from mg
  have 2: "\<And>y'. Heap_ord (C y' f) (C y' g)" by (rule monotoneD) (rule fg)

  have "Heap_ord (B f \<bind> (\<lambda>y. C y f)) (B g \<bind> (\<lambda>y. C y f))"
    (is "Heap_ord ?L ?R")
  proof (rule Heap_ordI)
    fix h
    from 1 show "execute ?L h = None \<or> execute ?L h = execute ?R h"
      by (rule Heap_ordE[where h = h]) (auto simp: execute_bind_case)
  qed
  also
  have "Heap_ord (B g \<bind> (\<lambda>y'. C y' f)) (B g \<bind> (\<lambda>y'. C y' g))"
    (is "Heap_ord ?L ?R")
  proof (rule Heap_ordI)
    fix h
    show "execute ?L h = None \<or> execute ?L h = execute ?R h"
    proof (cases "execute (B g) h")
      case None
      then have "execute ?L h = None" by (auto simp: execute_bind_case)
      thus ?thesis ..
    next
      case Some
      then obtain r h' where "execute (B g) h = Some (r, h')"
        by (metis surjective_pairing)
      then have "execute ?L h = execute (C r f) h'"
        "execute ?R h = execute (C r g) h'"
        by (auto simp: execute_bind_case)
      with 2[of r] show ?thesis by (auto elim: Heap_ordE)
    qed
  qed
  finally (heap.leq_trans)
  show "Heap_ord (B f \<bind> (\<lambda>y. C y f)) (B g \<bind> (\<lambda>y'. C y' g))" .
qed

subsection \<open>Code generator setup\<close>

subsubsection \<open>Logical intermediate layer\<close>

definition raise' :: "String.literal \<Rightarrow> 'a Heap" where
  [code del]: "raise' s = raise (String.explode s)"

lemma [code_abbrev]: "raise' (STR s) = raise s"
  unfolding raise'_def by (simp add: STR_inverse)

lemma raise_raise': (* FIXME delete candidate *)
  "raise s = raise' (STR s)"
  unfolding raise'_def by (simp add: STR_inverse)

code_datatype raise' \<comment> \<open>avoid @{const "Heap"} formally\<close>

subsubsection \<open>SML and OCaml\<close>

code_printing type_constructor Heap \<rightharpoonup> (SML) "(unit/ ->/ _)"
code_printing constant bind \<rightharpoonup> (SML) "!(fn/ f'_/ =>/ fn/ ()/ =>/ f'_/ (_/ ())/ ())"
code_printing constant return \<rightharpoonup> (SML) "!(fn/ ()/ =>/ _)"
code_printing constant Heap_Monad.raise' \<rightharpoonup> (SML) "!(raise/ Fail/ _)"

code_printing type_constructor Heap \<rightharpoonup> (OCaml) "(unit/ ->/ _)"
code_printing constant bind \<rightharpoonup> (OCaml) "!(fun/ f'_/ ()/ ->/ f'_/ (_/ ())/ ())"
code_printing constant return \<rightharpoonup> (OCaml) "!(fun/ ()/ ->/ _)"
code_printing constant Heap_Monad.raise' \<rightharpoonup> (OCaml) "failwith"

subsubsection \<open>Haskell\<close>

text \<open>Adaption layer\<close>

code_printing code_module "Heap" \<rightharpoonup> (Haskell)
\<open>import qualified Control.Monad;
import qualified Control.Monad.ST;
import qualified Data.STRef;
import qualified Data.Array.ST;

type RealWorld = Control.Monad.ST.RealWorld;
type ST s a = Control.Monad.ST.ST s a;
type STRef s a = Data.STRef.STRef s a;
type STArray s a = Data.Array.ST.STArray s Integer a;

newSTRef = Data.STRef.newSTRef;
readSTRef = Data.STRef.readSTRef;
writeSTRef = Data.STRef.writeSTRef;

newArray :: Integer -> a -> ST s (STArray s a);
newArray k = Data.Array.ST.newArray (0, k - 1);

newListArray :: [a] -> ST s (STArray s a);
newListArray xs = Data.Array.ST.newListArray (0, (fromInteger . toInteger . length) xs - 1) xs;

newFunArray :: Integer -> (Integer -> a) -> ST s (STArray s a);
newFunArray k f = Data.Array.ST.newListArray (0, k - 1) (map f [0..k-1]);

lengthArray :: STArray s a -> ST s Integer;
lengthArray a = Control.Monad.liftM (\(_, l) -> l + 1) (Data.Array.ST.getBounds a);

readArray :: STArray s a -> Integer -> ST s a;
readArray = Data.Array.ST.readArray;

writeArray :: STArray s a -> Integer -> a -> ST s ();
writeArray = Data.Array.ST.writeArray;\<close>

code_reserved Haskell Heap

text \<open>Monad\<close>

code_printing type_constructor Heap \<rightharpoonup> (Haskell) "Heap.ST/ Heap.RealWorld/ _"
code_monad bind Haskell
code_printing constant return \<rightharpoonup> (Haskell) "return"
code_printing constant Heap_Monad.raise' \<rightharpoonup> (Haskell) "error"

subsubsection \<open>Scala\<close>

code_printing code_module "Heap" \<rightharpoonup> (Scala)
\<open>object Heap {
  def bind[A, B](f: Unit => A, g: A => Unit => B): Unit => B = (_: Unit) => g (f ()) ()
}

class Ref[A](x: A) {
  var value = x
}

object Ref {
  def apply[A](x: A): Ref[A] =
    new Ref[A](x)
  def lookup[A](r: Ref[A]): A =
    r.value
  def update[A](r: Ref[A], x: A): Unit =
    { r.value = x }
}

object Array {
  import collection.mutable.ArraySeq
  def alloc[A](n: BigInt)(x: A): ArraySeq[A] =
    ArraySeq.fill(n.toInt)(x)
  def make[A](n: BigInt)(f: BigInt => A): ArraySeq[A] =
    ArraySeq.tabulate(n.toInt)((k: Int) => f(BigInt(k)))
  def len[A](a: ArraySeq[A]): BigInt =
    BigInt(a.length)
  def nth[A](a: ArraySeq[A], n: BigInt): A =
    a(n.toInt)
  def upd[A](a: ArraySeq[A], n: BigInt, x: A): Unit =
    a.update(n.toInt, x)
  def freeze[A](a: ArraySeq[A]): List[A] =
    a.toList
}
\<close>

code_reserved Scala Heap Ref Array

code_printing type_constructor Heap \<rightharpoonup> (Scala) "(Unit/ =>/ _)"
code_printing constant bind \<rightharpoonup> (Scala) "Heap.bind"
code_printing constant return \<rightharpoonup> (Scala) "('_: Unit)/ =>/ _"
code_printing constant Heap_Monad.raise' \<rightharpoonup> (Scala) "!sys.error((_))"

subsubsection \<open>Target variants with less units\<close>

setup \<open>

let

open Code_Thingol;

val imp_program =
  let
    val is_bind = curry (op =) @{const_name bind};
    val is_return = curry (op =) @{const_name return};
    val dummy_name = "";
    val dummy_case_term = IVar NONE;
    (*assumption: dummy values are not relevant for serialization*)
    val unitT = @{type_name unit} `%% [];
    val unitt =
      IConst { sym = Code_Symbol.Constant @{const_name Unity}, typargs = [], dicts = [], dom = [],
        annotation = NONE };
    fun dest_abs ((v, ty) `|=> t, _) = ((v, ty), t)
      | dest_abs (t, ty) =
          let
            val vs = fold_varnames cons t [];
            val v = singleton (Name.variant_list vs) "x";
            val ty' = (hd o fst o unfold_fun) ty;
          in ((SOME v, ty'), t `$ IVar (SOME v)) end;
    fun force (t as IConst { sym = Code_Symbol.Constant c, ... } `$ t') = if is_return c
          then t' else t `$ unitt
      | force t = t `$ unitt;
    fun tr_bind'' [(t1, _), (t2, ty2)] =
      let
        val ((v, ty), t) = dest_abs (t2, ty2);
      in ICase { term = force t1, typ = ty, clauses = [(IVar v, tr_bind' t)], primitive = dummy_case_term } end
    and tr_bind' t = case unfold_app t
     of (IConst { sym = Code_Symbol.Constant c, dom = ty1 :: ty2 :: _, ... }, [x1, x2]) => if is_bind c
          then tr_bind'' [(x1, ty1), (x2, ty2)]
          else force t
      | _ => force t;
    fun imp_monad_bind'' ts = (SOME dummy_name, unitT) `|=>
      ICase { term = IVar (SOME dummy_name), typ = unitT, clauses = [(unitt, tr_bind'' ts)], primitive = dummy_case_term }
    fun imp_monad_bind' (const as { sym = Code_Symbol.Constant c, dom = dom, ... }) ts = if is_bind c then case (ts, dom)
       of ([t1, t2], ty1 :: ty2 :: _) => imp_monad_bind'' [(t1, ty1), (t2, ty2)]
        | ([t1, t2, t3], ty1 :: ty2 :: _) => imp_monad_bind'' [(t1, ty1), (t2, ty2)] `$ t3
        | (ts, _) => imp_monad_bind (eta_expand 2 (const, ts))
      else IConst const `$$ map imp_monad_bind ts
    and imp_monad_bind (IConst const) = imp_monad_bind' const []
      | imp_monad_bind (t as IVar _) = t
      | imp_monad_bind (t as _ `$ _) = (case unfold_app t
         of (IConst const, ts) => imp_monad_bind' const ts
          | (t, ts) => imp_monad_bind t `$$ map imp_monad_bind ts)
      | imp_monad_bind (v_ty `|=> t) = v_ty `|=> imp_monad_bind t
      | imp_monad_bind (ICase { term = t, typ = ty, clauses = clauses, primitive = t0 }) =
          ICase { term = imp_monad_bind t, typ = ty,
            clauses = (map o apply2) imp_monad_bind clauses, primitive = imp_monad_bind t0 };

  in (Code_Symbol.Graph.map o K o map_terms_stmt) imp_monad_bind end;

in

Code_Target.add_derived_target ("SML_imp", [("SML", imp_program)])
#> Code_Target.add_derived_target ("OCaml_imp", [("OCaml", imp_program)])
#> Code_Target.add_derived_target ("Scala_imp", [("Scala", imp_program)])

end

\<close>

hide_const (open) Heap heap guard raise' fold_map

end


theory Transfer_Euclidean_Space_Vector
imports
  "../Refinement/Refine_Vector_List"
  Transfer_ODE
begin

type_synonym 'n rvec = "(real, 'n) vec"
type_synonym 'n vec1 = "(real, 'n) vec \<times> ((real, 'n) vec, 'n) vec" \<comment> \<open>vector with C1 information\<close>
type_synonym 'a c1_info = "'a \<times> ('a \<Rightarrow>\<^sub>L 'a)"
type_synonym 'n eucl1 = "'n rvec c1_info" \<comment> \<open>abstract C1 information\<close>

subsection \<open>Casting function\<close>

definition "cast = eucl_of_list o list_of_eucl"

lemma cast_eqI: "cast x = y" if "list_of_eucl x = list_of_eucl y"
  using that by (auto simp: cast_def)

lemma cast_eqI2: "cast (x::'a) = (y::'b)"
  if "x = cast y" and "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)"
  apply (rule cast_eqI)
  using that
  by (auto intro!: nth_equalityI simp: cast_def)

lemma cast_Basis_list_nth[simp]: "cast (Basis_list ! i::'a) = (Basis_list ! i::'b)"
  if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)" "i < DIM('b)"
  apply (rule cast_eqI)
  using that
  by (auto simp: inner_Basis nth_eq_iff_index_eq intro!: nth_equalityI)

lemma cast_inner[simp]:
  "cast x \<bullet> (cast y::'b) = x \<bullet> (y::'a)"
  if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)"
  using that
  by (subst (2) euclidean_inner)
     (auto simp: cast_def eucl_of_list_inner_eq inner_lv_rel_def sum_Basis_sum_nth_Basis_list
      sum_list_sum_nth atLeast0LessThan)

lemma cast_inner_Basis_list_nth[simp]:
  "cast x \<bullet> (Basis_list::'a list) ! i = x \<bullet> (Basis_list::'b list) ! i"
  if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)" "i < DIM('b)"
  using that
  by (auto simp: cast_def eucl_of_list_inner)

lemma cast_eucl_of_list[simp]:
  "cast (eucl_of_list xs::'a) = (eucl_of_list xs::'b)"
  if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)" "length xs = DIM('b)"
  using that
  by (auto simp: intro!: euclidean_eqI[where 'a='b])
     (auto simp: cast_def eucl_of_list_inner dest!: in_Basis_index_Basis_list)

lemma norm_cast[simp]: "norm (cast x::'a) = norm (x::'b)"
  if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)"
  unfolding norm_conv_dist
  apply (subst (1 2) euclidean_dist_l2)
  using that
  apply (auto simp: L2_set_def sum_Basis_sum_nth_Basis_list  cong: sum.cong)
  apply (subst sum.cong[OF refl])
   apply (subst cast_inner_Basis_list_nth)
     apply auto
  done

lemma linear_cast: "linear (cast::'a\<Rightarrow>'b)"
  if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)"
  apply standard
  using that
  by (auto simp: inner_simps intro!: cast_eqI nth_equalityI exI[where x=1])

lemma bounded_linear_cast: "bounded_linear (cast::'a\<Rightarrow>'b)"
  if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)"
  apply standard
  using that
  by (auto simp: inner_simps intro!: cast_eqI nth_equalityI exI[where x=1])

lemmas [bounded_linear_intros] = bounded_linear_compose[OF bounded_linear_cast]

lemma cast_id[simp]: "cast i = i"
  by (simp add: cast_eqI)

definition cast_bl where "cast_bl f = Blinfun (cast o blinfun_apply f o cast)"

lemma cast_bl_rep: "cast_bl (f::'a \<Rightarrow>\<^sub>L 'b) x = (cast (f (cast (x::'c)))::'d)"
  if [bounded_linear_intros]:
    "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
     "DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
  unfolding cast_bl_def o_def
  apply (subst bounded_linear_Blinfun_apply)
   apply (rule bounded_linear_intros)+
  apply auto
  done

definition "cast_eucl1 x = (cast (fst x), cast_bl (snd x))"

definition [simp]: "op_cast_image = (`) cast"
definition [simp]: "op_cast_eucl1_image = (`) cast_eucl1"
context includes autoref_syntax begin
lemma [autoref_op_pat_def]:
  "(`) cast \<equiv> OP op_cast_image"
  "(`) cast_eucl1 \<equiv> OP op_cast_eucl1_image"
  by auto
end

lemma cast_idem[simp]:
  "cast (cast (x::'c)::'b) = (cast x::'a)"
  if "DIM('a::executable_euclidean_space) = DIM('c::executable_euclidean_space)"
    "DIM('b::executable_euclidean_space) = DIM('c)"
  using that
  by (auto simp: cast_def intro!: )

lemma cast_bl_idem[simp]:
  "cast_bl (cast_bl (x::'c\<Rightarrow>\<^sub>L'c)::'b\<Rightarrow>\<^sub>L'b) = (cast_bl x::'a\<Rightarrow>\<^sub>L'a)"
  if "DIM('a::executable_euclidean_space) = DIM('c::executable_euclidean_space)"
    "DIM('b::executable_euclidean_space) = DIM('c)"
  using that
  by (auto simp: cast_bl_rep o_def intro!: blinfun_eqI)

lemma cast_eucl1_idem[simp]:
  "cast_eucl1 (cast_eucl1 (x::'c c1_info)::'b c1_info) = (cast_eucl1 x::'a c1_info)"
  if "DIM('a::executable_euclidean_space) = DIM('c::executable_euclidean_space)"
    "DIM('b::executable_euclidean_space) = DIM('c)"
  using that
  by (auto simp: cast_def cast_eucl1_def intro!: )

lemma linear_cast_bl:
  "linear (cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd))"
  if "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
     "DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
  by standard
    (auto intro!: blinfun_eqI
      simp: cast_bl_rep that blinfun.bilinear_simps linear_cast linear_add linear.scaleR)
lemma norm_cast_bl_le: "norm ((cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) x) \<le> norm x"
  if "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
  "DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
  apply (rule norm_blinfun_bound)
  using that
   apply (auto simp: cast_bl_rep)
  apply (rule norm_blinfun[THEN order_trans])
  apply auto
  done

lemma norm_cast_bl_idem[simp]: "cast_bl ((cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) x) = x"
  if "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
     "DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
  by (auto intro!: blinfun_eqI simp: that cast_bl_rep)

lemma norm_cast_bl[simp]: "norm ((cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) x) = norm x"
  if "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
     "DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
proof (rule antisym)
  show "norm ((cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) x) \<le> norm x"
    by (rule norm_cast_bl_le; fact)
  have "norm x = norm ((cast_bl::('c \<Rightarrow>\<^sub>L'd) \<Rightarrow> ('a \<Rightarrow>\<^sub>L 'b)) ((cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) x))"
    by (simp add: that)
  also note norm_cast_bl_le[OF that, of "cast_bl x"]
  finally show "norm x \<le> norm ((cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) x)"
    apply (rule order_trans)
     defer
     apply (rule norm_cast_bl_le)
    using that by auto
qed

lemma bounded_linear_cast_bl:
  "bounded_linear (cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd))"
  if "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
     "DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
  by standard
    (auto intro!: blinfun_eqI exI[where x=1]
      simp: cast_bl_rep that blinfun.bilinear_simps linear_cast linear_add linear.scaleR)

lemma cast_bl_has_derivative[derivative_intros]:
  "((\<lambda>a. (cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) (g a)) has_derivative (\<lambda>x. (cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) (g' x))) (at x within X)"
  if "(g has_derivative g') (at x within X)"
     "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
     "DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
  apply (rule has_derivative_compose[of g _ _ _ cast_bl, THEN has_derivative_eq_rhs])
    defer apply (rule bounded_linear_imp_has_derivative)
    apply (rule bounded_linear_cast_bl)
  using that
     apply auto
  done

lemma cast_bl_has_vector_derivative[derivative_intros]:
  "((\<lambda>a. (cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) (g a)) has_vector_derivative cast_bl g') (at x within X)"
  if "(g has_vector_derivative g') (at x within X)"
  "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
  "DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
  using that
  by (auto simp: has_vector_derivative_def blinfun.bilinear_simps cast_bl_rep linear.scaleR
      linear_cast_bl
      intro!: cast_bl_has_derivative derivative_eq_intros ext blinfun_eqI)

lemma cast_bl_has_vderiv_on:
  "((\<lambda>a. (cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) (g a)) has_vderiv_on vd) X"
  if "(g has_vderiv_on g') X" "\<And>t. t \<in> X \<Longrightarrow> vd t = cast_bl (g' t)"
  "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
  "DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
  using that
  by (auto simp: has_vderiv_on_def intro!: derivative_eq_intros)

lemma cast_bl_compose:
  "(cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) (g  o\<^sub>L h) =
    ((cast_bl:: 'e \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'f \<Rightarrow>\<^sub>L 'd) g o\<^sub>L (cast_bl:: 'a \<Rightarrow>\<^sub>L 'e \<Rightarrow> 'c \<Rightarrow>\<^sub>L 'f) h)"
  if "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
  "DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
  "DIM('e::executable_euclidean_space) = DIM('f::executable_euclidean_space)"
  by (auto intro!: blinfun_eqI simp: cast_bl_rep that)

locale transfer_eucl_vec =
  fixes a::"'a::executable_euclidean_space" and n::"'n::enum"
  assumes dim[simp]: "DIM('a) = CARD('n)"
begin

context includes lifting_syntax begin

subsection \<open>Transfer from euclidean space to vector\<close>

definition "rel_ve (x::(real, 'n)vec) (y::'a) \<longleftrightarrow> list_of_eucl x = list_of_eucl y"

lemma [transfer_rule]: "bi_unique rel_ve"
  by (auto intro!: bi_uniqueI left_uniqueI right_uniqueI simp: rel_ve_def )
    (metis eucl_of_list_list_of_eucl)+

text \<open>@{const Inf} is underspecified\<close>
text \<open>@{const Sup} is underspecified\<close>

lemma inf_transfer[transfer_rule]:
  "(rel_ve ===> rel_ve ===> rel_ve) inf inf"
  by (auto simp: rel_ve_def nth_eq_iff_index inner_Basis_inf_left
      list_of_eucl_eq_iff intro!: rel_funI)

lemma sup_transfer[transfer_rule]:
  "(rel_ve ===> rel_ve ===> rel_ve) sup sup"
  by (auto simp: rel_ve_def nth_eq_iff_index inner_Basis_sup_left
      list_of_eucl_eq_iff intro!: rel_funI)

lemma abs_transfer[transfer_rule]:
  "(rel_ve ===> rel_ve) abs abs"
  by (auto simp: rel_ve_def nth_eq_iff_index inner_Basis_sup_left abs_inner
      list_of_eucl_eq_iff intro!: rel_funI)

lemma less_eq_transfer[transfer_rule]:
  "(rel_ve ===> rel_ve ===> (=)) less_eq less_eq"
  by (auto simp: rel_ve_def nth_eq_iff_index eucl_le_Basis_list_iff[where 'a='a]
      eucl_le_Basis_list_iff[where 'a="'n rvec"]
      list_of_eucl_eq_iff intro!: rel_funI )

lemma scaleR_transfer[transfer_rule]:
  "((=) ===> rel_ve ===> rel_ve) scaleR scaleR"
  by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
      list_of_eucl_eq_iff intro!: rel_funI)

lemma Basis_transfer[transfer_rule]:
  "(rel_set rel_ve) Basis Basis"
  apply (rule rel_setI)
  subgoal for x by (auto simp: rel_ve_def list_of_eucl_eq_iff inner_Basis nth_eq_iff_index
        intro!: bexI[where x="Basis_list ! index Basis_list x"])
  subgoal for x by (auto simp: rel_ve_def list_of_eucl_eq_iff inner_Basis nth_eq_iff_index
        intro!: bexI[where x="Basis_list ! index Basis_list x"])
  done

lemma zero_transfer[transfer_rule]:
  "rel_ve 0 0"
  by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
      list_of_eucl_eq_iff intro!: rel_funI)

lemma uminus_transfer[transfer_rule]:
  "(rel_ve ===> rel_ve) uminus uminus"
  by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
      list_of_eucl_eq_iff intro!: rel_funI)

lemma plus_transfer[transfer_rule]:
  "(rel_ve ===> rel_ve ===> rel_ve) (+) (+)"
  by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
      list_of_eucl_eq_iff intro!: rel_funI)

lemma minus_transfer[transfer_rule]:
  "(rel_ve ===> rel_ve ===> rel_ve) (-) (-)"
  by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
      list_of_eucl_eq_iff intro!: rel_funI)

lemma Basis_list_transfer[transfer_rule]:
  "(list_all2 rel_ve) Basis_list Basis_list"
  by (auto simp: list_all2_iff in_set_zip rel_ve_def inner_Basis
      nth_eq_iff_index intro!: nth_equalityI)

lemma eucl_down_transfer[transfer_rule]:
  "((=) ===> rel_ve ===> rel_ve) eucl_down eucl_down"
  unfolding eucl_down_def
  by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
      list_of_eucl_eq_iff intro!: rel_funI)

lemma eucl_truncate_up_transfer[transfer_rule]:
  "((=) ===> rel_ve ===> rel_ve) eucl_truncate_up eucl_truncate_up"
  by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
      list_of_eucl_eq_iff intro!: rel_funI)

lemma eucl_truncate_down_transfer[transfer_rule]:
  "((=) ===> rel_ve ===> rel_ve) eucl_truncate_down eucl_truncate_down"
  by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
      list_of_eucl_eq_iff intro!: rel_funI)

lemma inner_transfer[transfer_rule]:
  "(rel_ve ===> rel_ve ===> (=)) inner inner"
  apply (subst euclidean_inner[where 'a="'a", abs_def])
  apply (subst euclidean_inner[where 'a="'n rvec", abs_def])
  by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index inner_simps nth_eq_iff_index
      sum_Basis_sum_nth_Basis_list list_of_eucl_eq_iff intro!: rel_funI)

lemma rel_ve_cast: "rel_ve (x::'n rvec) (y::'a) \<longleftrightarrow> x = cast y"
  apply (auto simp: rel_ve_def cast_def intro!: rel_funI)
  by (metis eucl_of_list_list_of_eucl)

lemma rel_ve_cast': "rel_ve (x::'n rvec) (y::'a) \<longleftrightarrow> cast x = y"
  by (auto simp: rel_ve_def cast_def)

lemma cast_transfer[transfer_rule]: "(rel_ve ===> (=)) (\<lambda>x. x) cast"
  by (auto simp: rel_ve_cast)

lemma cast_transfer'[transfer_rule]: "((=) ===> rel_ve) (\<lambda>x. x) cast"
  by (auto simp: rel_ve_cast')

lemma bounded_linear_cast: "bounded_linear (cast::'a \<Rightarrow> 'n rvec)"
  by transfer (rule bounded_linear_ident)

lemma bounded_linear_cast': "bounded_linear (cast::'n rvec \<Rightarrow> 'a)"
  by transfer (rule bounded_linear_ident)

context includes blinfun.lifting begin

lemmas [simp] = cast_bl_rep

lemma eucl_of_list_transfer[transfer_rule]: "(list_all2 (=) ===> rel_ve) eucl_of_list eucl_of_list"
  unfolding eucl_of_list_def
  by transfer_prover

lemma list_of_eucl_transfer[transfer_rule]: "(rel_ve ===> list_all2 (=)) list_of_eucl list_of_eucl"
  unfolding list_of_eucl_def
  by transfer_prover

lemma blinfun_of_matrix_transfer[transfer_rule]:
  "((rel_ve ===> rel_ve ===> (=)) ===> (rel_blinfun rel_ve rel_ve)) blinfun_of_matrix blinfun_of_matrix"
  apply (rule rel_funI)
  apply transfer
  apply (rule rel_funI)
  unfolding rel_blinfun_def
  unfolding sum_Basis_sum_nth_Basis_list
  apply simp
  unfolding rel_ve_def list_of_eucl_eq_iff inner_sum_left
  apply simp
  apply (intro allI impI sum.cong refl)
  apply (rule arg_cong2[where f="(*)"])
  subgoal for a b c d e f g
    apply (rule arg_cong2[where f="(*)"])
    subgoal by simp
    apply (drule rel_funD[where x="Basis_list ! f"]) defer
     apply (drule rel_funD[where x="Basis_list ! g"]) defer
      apply assumption
    subgoal
      by (clarsimp simp: inner_Basis)
        (metis Basis_list_transfer dim index_Basis_list_nth length_Basis_list list_all2_lengthD)
    subgoal
      by (clarsimp simp: inner_Basis)
        (metis Basis_list_transfer dim index_Basis_list_nth length_Basis_list list_all2_lengthD)
    done
  subgoal for a b c d e f g
    apply (clarsimp simp: inner_Basis)
    by (metis (full_types, hide_lams) Basis_list_transfer dim index_Basis_list_nth length_Basis_list
        list_all2_conv_all_nth)
  done

lemma transfer_cast[transfer_rule]: "(rel_ve ===> rel_ve) (\<lambda>x. x) cast"
  by (auto simp:)

end

end

end

lemma
  assumes [simp]: "DIM('a::executable_euclidean_space) = CARD('n::enum)"
  shows cast_cast[simp]: "cast (cast x::'n rvec) = (x::'a)" "cast (cast y::'a) = (y::'n rvec)"
  by (auto simp: cast_def cast_def)

lifting_update blinfun.lifting
lifting_forget blinfun.lifting

locale transfer_eucl_vec_ll_on_open = transfer_eucl_vec a n + ll_on_open T f X
  for a::"'a::executable_euclidean_space" and n::"'n::enum" and T f and X::"'a set" +
  fixes vf vX
  defines "vf \<equiv> \<lambda>t x::'n rvec. cast (f t (cast x))::'n rvec"
  defines "vX \<equiv> cast ` X::'n rvec set"
begin

lemma transfer_X[transfer_rule]: "rel_set rel_ve vX X"
  and transfer_f[transfer_rule]: "(rel_fun (=) (rel_fun rel_ve rel_ve)) vf f"
  by (auto simp: rel_ve_cast cast_eqI vX_def vf_def intro!: rel_setI rel_funI)

sublocale v: ll_on_open T vf vX
  by (rule ll_on_open_axioms[untransferred])

context includes lifting_syntax begin

lemma transfer_csols[transfer_rule]:
  "((=) ===> rel_ve ===> rel_set (rel_prod ((=) ===> rel_ve) (=))) v.csols csols"
  unfolding csols_def v.csols_def
  by transfer_prover

lemma transfer_existence_ivl[transfer_rule]:
  "((=) ===> rel_ve ===> rel_set (=)) v.existence_ivl existence_ivl"
  unfolding existence_ivl_def v.existence_ivl_def
  by transfer_prover

lemma cast_v_flow_cast_eq:
  assumes "t \<in> existence_ivl t0 x0"
  shows "cast (v.flow t0 (cast x0) t) = flow t0 x0 t"
  apply (rule equals_flowI[OF _ _ order_refl])
  subgoal
    apply (rule existence_ivl_initial_time)
    using assms mem_existence_ivl_iv_defined(1) apply blast
    using assms mem_existence_ivl_iv_defined(2) by blast
  subgoal by (rule is_interval_existence_ivl)
  subgoal
    apply (rule solves_odeI)
    subgoal using assms
     by (transfer) (rule v.flow_has_vderiv_on[OF v.mem_existence_ivl_iv_defined])
   subgoal using assms
     by transfer (rule v.flow_in_domain)
   done
  subgoal
    using mem_existence_ivl_iv_defined[OF assms]
    apply (auto simp: )
    apply (subst v.flow_initial_time)
    subgoal by simp
    subgoal by transfer
    subgoal by transfer simp
    done
  subgoal by fact
  done

lemma transfer_flow[transfer_rule]:
  "((=) ===> rel_ve ===> (=) ===> rel_ve) v.flow flow"
  apply (auto intro!: rel_funI simp: rel_ve_cast)
  subgoal for t0 x0 t
    apply (cases "t \<in> existence_ivl t0 (cast x0)")
    subgoal by (simp add: cast_eqI cast_v_flow_cast_eq[symmetric])
    subgoal
      apply (subst v.flow_def) apply (subst flow_def)
      apply (auto simp: cast_eqI)
      subgoal by transfer simp
      subgoal by transfer simp
      done
    done
  done

end

end

locale transfer_c1_on_open_euclidean = transfer_eucl_vec a n + c1_on_open_euclidean f f' X
  for a::"'a::executable_euclidean_space" and n::"'n::enum" and f f' and X::"'a set" +
  fixes vf and vf'::"'n rvec \<Rightarrow> 'n rvec \<Rightarrow>\<^sub>L 'n rvec" and vX
  defines "vf \<equiv> \<lambda>x::'n rvec. cast (f (cast x))::'n rvec"
  defines  vf'_def: "vf' \<equiv> \<lambda>x. cast_bl (f' (cast x))"
  defines "vX \<equiv> cast ` X::'n rvec set"
begin

context includes lifting_syntax begin

lemma transfer_X[transfer_rule]: "rel_set rel_ve vX X"
  and transfer_f[transfer_rule]: "(rel_fun rel_ve rel_ve) vf f"
  by (auto simp: rel_ve_cast vX_def vf_def cast_eqI intro!: rel_setI rel_funI)

lemma transfer_f'[transfer_rule]: "(rel_ve ===> (rel_blinfun rel_ve rel_ve)) vf' f'"
  by (auto intro!: rel_funI simp: cast_eqI rel_blinfun_def rel_ve_cast vf'_def)

end

sublocale v: c1_on_open_euclidean vf vf' vX
  unfolding c1_on_open_euclidean_def
  by (rule c1_on_open_axioms[unfolded c1_on_open_euclidean_def, untransferred])

context includes lifting_syntax begin

lemma transfer_csols[transfer_rule]:
  "((=) ===> rel_ve ===> rel_set (rel_prod ((=) ===> rel_ve) (=))) v.csols csols"
  unfolding csols_def v.csols_def
  by transfer_prover

lemma transfer_existence_ivl[transfer_rule]:
  "((=) ===> rel_ve ===> rel_set (=)) v.existence_ivl existence_ivl"
  unfolding existence_ivl_def v.existence_ivl_def
  by transfer_prover

lemma transfer_existence_ivl0[transfer_rule]:
  "(rel_ve ===> rel_set (=)) v.existence_ivl0 existence_ivl0"
proof -
  interpret ll: transfer_eucl_vec_ll_on_open a n UNIV "\<lambda>_. f" X "\<lambda>_. vf" vX
    by unfold_locales (auto simp: vf_def)
  show ?thesis
    unfolding existence_ivl0_def v.existence_ivl0_def
    by transfer_prover
qed

lemma transfer_flow0[transfer_rule]:
  "(rel_ve ===> (=) ===> rel_ve) v.flow0 flow0"
proof -
  interpret ll: transfer_eucl_vec_ll_on_open a n UNIV "\<lambda>_. f" X "\<lambda>_. vf" vX
    by unfold_locales (auto simp: vf_def)
  show ?thesis
    unfolding flow0_def v.flow0_def
    by transfer_prover
qed

lemma cast_v_Dflow_cast_eq:
  assumes "t \<in> existence_ivl0 x0"
  shows "cast_bl (v.Dflow (cast x0) t) = Dflow x0 t"
proof -
  have "x0 \<in> X"
    using assms mem_existence_ivl_iv_defined(1) by blast
  have "0 \<in> existence_ivl0 x0"
    apply (rule existence_ivl_initial_time)
    apply simp
    apply fact
    done
  show ?thesis
  unfolding Dflow_def
  apply (rule mvar.equals_flowI[OF _ _ order_refl])
  subgoal
    apply (rule mvar.existence_ivl_initial_time)
     apply fact
    apply blast
    done
  subgoal by (rule mvar.is_interval_existence_ivl)
  subgoal
    apply (rule solves_odeI)
    subgoal
    proof -
      have *: "mvar.existence_ivl x0 0 1\<^sub>L = (v.mvar.existence_ivl (cast x0) 0 1\<^sub>L)"
        apply (subst mvar_existence_ivl_eq_existence_ivl, fact)
        apply (subst v.mvar_existence_ivl_eq_existence_ivl)
        subgoal using \<open>0 \<in> existence_ivl0 x0\<close> by (transfer)
        subgoal by transfer simp
        done
      have D: "(v.Dflow (cast x0) has_vderiv_on (\<lambda>t. v.vareq (cast x0) t o\<^sub>L v.mvar.flow (cast x0) 0 1\<^sub>L t))
        (mvar.existence_ivl x0 0 1\<^sub>L)"
        unfolding * v.Dflow_def
        apply (rule v.mvar.flow_has_vderiv_on[of 0 "cast x0" "1\<^sub>L"])
        subgoal using \<open>0 \<in> existence_ivl0 x0\<close> by (transfer)
        subgoal by transfer simp
        done
      have vareq_transfer: "vareq x0 x = cast_bl (v.vareq (cast x0) x)"
        if "x \<in> mvar.existence_ivl x0 0 1\<^sub>L"
        for x
        using that
        apply (subst (asm) mvar_existence_ivl_eq_existence_ivl)
        using \<open>0 \<in> existence_ivl0 x0\<close> apply simp
        unfolding vareq_def v.vareq_def
        apply (auto simp: blinfun_ext)
        apply transfer
        apply simp
        done
      show ?thesis
        apply (rule cast_bl_has_vderiv_on)
           apply (rule D)
          apply (simp_all add: v.Dflow_def blinfun_compose_assoc vareq_transfer)
        apply (subst cast_bl_compose)
           apply (auto simp: cast_bl_compose)
        done
    qed
    subgoal by simp
    done
  subgoal
    unfolding Dflow_def[symmetric]
    apply (subst Dflow_zero)
     apply fact
    apply (subst v.Dflow_zero)
    subgoal using \<open>x0 \<in> X\<close> by transfer simp
    subgoal by (auto simp: blinfun_ext)
    done
  subgoal
    by (subst mvar_existence_ivl_eq_existence_ivl; fact)
  done
qed

lemma transfer_Dflow[transfer_rule]:
  "(rel_ve ===> (=) ===> rel_blinfun rel_ve rel_ve) v.Dflow Dflow"
  apply (auto intro!: rel_funI simp: rel_ve_cast rel_blinfun_def)
  subgoal for x0 t d
    apply (cases "t \<in> mvar.existence_ivl (cast x0) 0 1\<^sub>L")
    subgoal
      apply (subst cast_v_Dflow_cast_eq[symmetric])
      using mvar.existence_ivl_subset[of "cast x0" 0 id_blinfun]
      by auto
    subgoal premises prems
    proof -
      have x0: "x0 \<notin> X \<longleftrightarrow> cast x0 \<notin> vX"
        by transfer simp
      have mvars: "mvar.existence_ivl x0 0 1\<^sub>L = v.mvar.existence_ivl (cast x0) 0 1\<^sub>L"
        apply (cases "cast x0 \<in> X")
        subgoal
          apply (subst mvar_existence_ivl_eq_existence_ivl)
           apply simp
          apply (subst v.mvar_existence_ivl_eq_existence_ivl)
           apply simp
           apply transfer apply simp
          apply transfer apply simp
          done
        subgoal premises prems
        proof -
          have "mvar.existence_ivl (cast x0) 0 1\<^sub>L = {}"
            apply (subst mvar.existence_ivl_empty_iff)
            using prems
            by simp
          moreover have "v.mvar.existence_ivl (cast x0) 0 1\<^sub>L = {}"
            apply (subst v.mvar.existence_ivl_empty_iff)
            using prems
            apply simp
            apply transfer apply simp
            done
          ultimately show ?thesis
            apply simp
            using \<open>mvar.existence_ivl (cast x0) 0 1\<^sub>L = {}\<close> \<open>v.mvar.existence_ivl (cast x0) 0 1\<^sub>L = {}\<close> by auto
        qed
        done
      show ?thesis
        using prems
        apply (subst v.Dflow_def) apply (subst Dflow_def)
        apply (subst v.mvar.flow_def) apply (subst mvar.flow_def)
        unfolding mvars
        apply (auto simp: blinfun.bilinear_simps)
        using mvars apply blast
        subgoal premises apply transfer by simp
        done
    qed
    done
  done

lemma returns_to_transfer[transfer_rule]:
  "(rel_set rel_ve ===> rel_ve ===> (=)) v.returns_to returns_to"
  unfolding returns_to_def v.returns_to_def
  by transfer_prover

lemma return_time_transfer[transfer_rule]:
  "(rel_set rel_ve ===> rel_ve ===> (=)) v.return_time return_time"
  unfolding return_time_def v.return_time_def
  by transfer_prover

lemma poincare_map_transfer[transfer_rule]:
  "(rel_set rel_ve ===> rel_ve ===> rel_ve) v.poincare_map poincare_map"
  unfolding v.poincare_map_def poincare_map_def
  by transfer_prover

lemma poincare_mapsto_transfer[transfer_rule]:
  "(rel_set rel_ve
   ===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve))
   ===> rel_set rel_ve
   ===> rel_set rel_ve
   ===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve))
   ===> (=)) v.poincare_mapsto poincare_mapsto"
  unfolding poincare_mapsto_def v.poincare_mapsto_def
    has_derivative_within differentiable_def
  by transfer_prover

lemma flowsto_transfer[transfer_rule]:
  "(rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve))
   ===> rel_set (=)
   ===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve))
   ===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve))
   ===> (=)) v.flowsto flowsto"
  unfolding flowsto_def v.flowsto_def
  by transfer_prover

end

end

end


(*  Title:      HOL/Auth/OtwayRees_Bad.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge
*)

section\<open>The Otway-Rees Protocol: The Faulty BAN Version\<close>

theory OtwayRees_Bad imports Public begin

text\<open>The FAULTY version omitting encryption of Nonce NB, as suggested on
page 247 of
  Burrows, Abadi and Needham (1988).  A Logic of Authentication.
  Proc. Royal Soc. 426

This file illustrates the consequences of such errors.  We can still prove
impressive-looking properties such as \<open>Spy_not_see_encrypted_key\<close>, yet
the protocol is open to a middleperson attack.  Attempting to prove some key
lemmas indicates the possibility of this attack.\<close>

inductive_set otway :: "event list set"
  where
   Nil: \<comment>\<open>The empty trace\<close>
        "[] \<in> otway"

 | Fake: \<comment>\<open>The Spy may say anything he can say.  The sender field is correct,
            but agents don't use that information.\<close>
         "[| evsf \<in> otway;  X \<in> synth (analz (knows Spy evsf)) |]
          ==> Says Spy B X  # evsf \<in> otway"

 | Reception: \<comment>\<open>A message that has been sent can be received by the
                  intended recipient.\<close>
              "[| evsr \<in> otway;  Says A B X \<in>set evsr |]
               ==> Gets B X # evsr \<in> otway"

 | OR1:  \<comment>\<open>Alice initiates a protocol run\<close>
         "[| evs1 \<in> otway;  Nonce NA \<notin> used evs1 |]
          ==> Says A B \<lbrace>Nonce NA, Agent A, Agent B,
                         Crypt (shrK A) \<lbrace>Nonce NA, Agent A, Agent B\<rbrace>\<rbrace>
                 # evs1 \<in> otway"

 | OR2:  \<comment>\<open>Bob's response to Alice's message.
             This variant of the protocol does NOT encrypt NB.\<close>
         "[| evs2 \<in> otway;  Nonce NB \<notin> used evs2;
             Gets B \<lbrace>Nonce NA, Agent A, Agent B, X\<rbrace> \<in> set evs2 |]
          ==> Says B Server
                  \<lbrace>Nonce NA, Agent A, Agent B, X, Nonce NB,
                    Crypt (shrK B) \<lbrace>Nonce NA, Agent A, Agent B\<rbrace>\<rbrace>
                 # evs2 \<in> otway"

 | OR3:  \<comment>\<open>The Server receives Bob's message and checks that the three NAs
           match.  Then he sends a new session key to Bob with a packet for
           forwarding to Alice.\<close>
         "[| evs3 \<in> otway;  Key KAB \<notin> used evs3;
             Gets Server
                  \<lbrace>Nonce NA, Agent A, Agent B,
                    Crypt (shrK A) \<lbrace>Nonce NA, Agent A, Agent B\<rbrace>,
                    Nonce NB,
                    Crypt (shrK B) \<lbrace>Nonce NA, Agent A, Agent B\<rbrace>\<rbrace>
               \<in> set evs3 |]
          ==> Says Server B
                  \<lbrace>Nonce NA,
                    Crypt (shrK A) \<lbrace>Nonce NA, Key KAB\<rbrace>,
                    Crypt (shrK B) \<lbrace>Nonce NB, Key KAB\<rbrace>\<rbrace>
                 # evs3 \<in> otway"

 | OR4:  \<comment>\<open>Bob receives the Server's (?) message and compares the Nonces with
             those in the message he previously sent the Server.
             Need @{term "B \<noteq> Server"} because we allow messages to self.\<close>
         "[| evs4 \<in> otway;  B \<noteq> Server;
             Says B Server \<lbrace>Nonce NA, Agent A, Agent B, X', Nonce NB,
                             Crypt (shrK B) \<lbrace>Nonce NA, Agent A, Agent B\<rbrace>\<rbrace>
               \<in> set evs4;
             Gets B \<lbrace>Nonce NA, X, Crypt (shrK B) \<lbrace>Nonce NB, Key K\<rbrace>\<rbrace>
               \<in> set evs4 |]
          ==> Says B A \<lbrace>Nonce NA, X\<rbrace> # evs4 \<in> otway"

 | Oops: \<comment>\<open>This message models possible leaks of session keys.  The nonces
             identify the protocol run.\<close>
         "[| evso \<in> otway;
             Says Server B \<lbrace>Nonce NA, X, Crypt (shrK B) \<lbrace>Nonce NB, Key K\<rbrace>\<rbrace>
               \<in> set evso |]
          ==> Notes Spy \<lbrace>Nonce NA, Nonce NB, Key K\<rbrace> # evso \<in> otway"

declare Says_imp_knows_Spy [THEN analz.Inj, dest]
declare parts.Body  [dest]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un  [dest]

text\<open>A "possibility property": there are traces that reach the end\<close>
lemma "[| B \<noteq> Server; Key K \<notin> used [] |]
      ==> \<exists>NA. \<exists>evs \<in> otway.
            Says B A \<lbrace>Nonce NA, Crypt (shrK A) \<lbrace>Nonce NA, Key K\<rbrace>\<rbrace>
              \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] otway.Nil
                    [THEN otway.OR1, THEN otway.Reception,
                     THEN otway.OR2, THEN otway.Reception,
                     THEN otway.OR3, THEN otway.Reception, THEN otway.OR4])
apply (possibility, simp add: used_Cons)
done

lemma Gets_imp_Says [dest!]:
     "[| Gets B X \<in> set evs; evs \<in> otway |] ==> \<exists>A. Says A B X \<in> set evs"
apply (erule rev_mp)
apply (erule otway.induct, auto)
done

subsection\<open>For reasoning about the encrypted portion of messages\<close>

lemma OR2_analz_knows_Spy:
     "[| Gets B \<lbrace>N, Agent A, Agent B, X\<rbrace> \<in> set evs;  evs \<in> otway |]
      ==> X \<in> analz (knows Spy evs)"
by blast

lemma OR4_analz_knows_Spy:
     "[| Gets B \<lbrace>N, X, Crypt (shrK B) X'\<rbrace> \<in> set evs;  evs \<in> otway |]
      ==> X \<in> analz (knows Spy evs)"
by blast

lemma Oops_parts_knows_Spy:
     "Says Server B \<lbrace>NA, X, Crypt K' \<lbrace>NB,K\<rbrace>\<rbrace> \<in> set evs
      ==> K \<in> parts (knows Spy evs)"
by blast

text\<open>Forwarding lemma: see comments in OtwayRees.thy\<close>
lemmas OR2_parts_knows_Spy =
    OR2_analz_knows_Spy [THEN analz_into_parts]

text\<open>Theorems of the form @{term "X \<notin> parts (spies evs)"} imply that
NOBODY sends messages containing X!\<close>

text\<open>Spy never sees a good agent's shared key!\<close>
lemma Spy_see_shrK [simp]:
     "evs \<in> otway ==> (Key (shrK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
by (erule otway.induct, force,
    drule_tac [4] OR2_parts_knows_Spy, simp_all, blast+)

lemma Spy_analz_shrK [simp]:
     "evs \<in> otway ==> (Key (shrK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "[|Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> otway|] ==> A \<in> bad"
by (blast dest: Spy_see_shrK)

subsection\<open>Proofs involving analz\<close>

text\<open>Describes the form of K and NA when the Server sends this message.  Also
  for Oops case.\<close>
lemma Says_Server_message_form:
     "[| Says Server B \<lbrace>NA, X, Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs;
         evs \<in> otway |]
      ==> K \<notin> range shrK & (\<exists>i. NA = Nonce i) & (\<exists>j. NB = Nonce j)"
apply (erule rev_mp)
apply (erule otway.induct, simp_all)
done

(****
 The following is to prove theorems of the form

  Key K \<in> analz (insert (Key KAB) (knows Spy evs)) ==>
  Key K \<in> analz (knows Spy evs)

 A more general formula must be proved inductively.
****)

text\<open>Session keys are not used to encrypt other session keys\<close>

text\<open>The equality makes the induction hypothesis easier to apply\<close>
lemma analz_image_freshK [rule_format]:
 "evs \<in> otway ==>
   \<forall>K KK. KK <= -(range shrK) -->
          (Key K \<in> analz (Key`KK Un (knows Spy evs))) =
          (K \<in> KK | Key K \<in> analz (knows Spy evs))"
apply (erule otway.induct)
apply (frule_tac [8] Says_Server_message_form)
apply (drule_tac [7] OR4_analz_knows_Spy)
apply (drule_tac [5] OR2_analz_knows_Spy, analz_freshK, spy_analz, auto)
done

lemma analz_insert_freshK:
  "[| evs \<in> otway;  KAB \<notin> range shrK |] ==>
      (Key K \<in> analz (insert (Key KAB) (knows Spy evs))) =
      (K = KAB | Key K \<in> analz (knows Spy evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

text\<open>The Key K uniquely identifies the Server's  message.\<close>
lemma unique_session_keys:
     "[| Says Server B \<lbrace>NA, X, Crypt (shrK B) \<lbrace>NB, K\<rbrace>\<rbrace>   \<in> set evs;
         Says Server B' \<lbrace>NA',X',Crypt (shrK B') \<lbrace>NB',K\<rbrace>\<rbrace> \<in> set evs;
         evs \<in> otway |] ==> X=X' & B=B' & NA=NA' & NB=NB'"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule otway.induct, simp_all)
apply blast+  \<comment>\<open>OR3 and OR4\<close>
done

text\<open>Crucial secrecy property: Spy does not see the keys sent in msg OR3
    Does not in itself guarantee security: an attack could violate
    the premises, e.g. by having @{term "A=Spy"}\<close>
lemma secrecy_lemma:
 "[| A \<notin> bad;  B \<notin> bad;  evs \<in> otway |]
  ==> Says Server B
        \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
          Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs -->
      Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs -->
      Key K \<notin> analz (knows Spy evs)"
apply (erule otway.induct, force)
apply (frule_tac [7] Says_Server_message_form)
apply (drule_tac [6] OR4_analz_knows_Spy)
apply (drule_tac [4] OR2_analz_knows_Spy)
apply (simp_all add: analz_insert_eq analz_insert_freshK pushes)
apply spy_analz  \<comment>\<open>Fake\<close>
apply (blast dest: unique_session_keys)+  \<comment>\<open>OR3, OR4, Oops\<close>
done

lemma Spy_not_see_encrypted_key:
     "[| Says Server B
          \<lbrace>NA, Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs;
         Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> otway |]
      ==> Key K \<notin> analz (knows Spy evs)"
by (blast dest: Says_Server_message_form secrecy_lemma)

subsection\<open>Attempting to prove stronger properties\<close>

text\<open>Only OR1 can have caused such a part of a message to appear. The premise
  @{term "A \<noteq> B"} prevents OR2's similar-looking cryptogram from being picked
  up. Original Otway-Rees doesn't need it.\<close>
lemma Crypt_imp_OR1 [rule_format]:
     "[| A \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
      ==> Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace> \<in> parts (knows Spy evs) -->
          Says A B \<lbrace>NA, Agent A, Agent B,
                     Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace>  \<in> set evs"
by (erule otway.induct, force,
    drule_tac [4] OR2_parts_knows_Spy, simp_all, blast+)

text\<open>Crucial property: If the encrypted message appears, and A has used NA
  to start a run, then it originated with the Server!
  The premise @{term "A \<noteq> B"} allows use of \<open>Crypt_imp_OR1\<close>\<close>
text\<open>Only it is FALSE.  Somebody could make a fake message to Server
          substituting some other nonce NA' for NB.\<close>
lemma "[| A \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
       ==> Crypt (shrK A) \<lbrace>NA, Key K\<rbrace> \<in> parts (knows Spy evs) -->
           Says A B \<lbrace>NA, Agent A, Agent B,
                      Crypt (shrK A) \<lbrace>NA, Agent A, Agent B\<rbrace>\<rbrace>
            \<in> set evs -->
           (\<exists>B NB. Says Server B
                \<lbrace>NA,
                  Crypt (shrK A) \<lbrace>NA, Key K\<rbrace>,
                  Crypt (shrK B) \<lbrace>NB, Key K\<rbrace>\<rbrace> \<in> set evs)"
apply (erule otway.induct, force,
       drule_tac [4] OR2_parts_knows_Spy, simp_all)
apply blast  \<comment>\<open>Fake\<close>
apply blast  \<comment>\<open>OR1: it cannot be a new Nonce, contradiction.\<close>
txt\<open>OR3 and OR4\<close>
apply (simp_all add: ex_disj_distrib)
 prefer 2 apply (blast intro!: Crypt_imp_OR1)  \<comment>\<open>OR4\<close>
txt\<open>OR3\<close>
apply clarify
(*The hypotheses at this point suggest an attack in which nonce NB is used
  in two different roles:
          Gets Server
           \<lbrace>Nonce NA, Agent Aa, Agent A,
             Crypt (shrK Aa) \<lbrace>Nonce NA, Agent Aa, Agent A\<rbrace>, Nonce NB,
             Crypt (shrK A) \<lbrace>Nonce NA, Agent Aa, Agent A\<rbrace>\<rbrace>
          \<in> set evs3
          Says A B
           \<lbrace>Nonce NB, Agent A, Agent B,
             Crypt (shrK A) \<lbrace>Nonce NB, Agent A, Agent B\<rbrace>\<rbrace>
          \<in> set evs3;
*)

(*Thus the key property A_can_trust probably fails too.*)
oops

end