(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
header {* \isaheader{Additions to RB-Trees} *}
theory RBT_add
imports
  "~~/src/HOL/Library/RBT_Impl"
  "../Iterator/Iterator"
begin
text_raw {*\label{thy:RBT_add}*}

lemma tlt_trans: "\<lbrakk>l |\<guillemotleft> u; u\<le>v\<rbrakk> \<Longrightarrow> l |\<guillemotleft> v"
  by (induct l) auto

lemma trt_trans: "\<lbrakk> u\<le>v; v\<guillemotleft>|r \<rbrakk> \<Longrightarrow> u\<guillemotleft>|r"
  by (induct r) auto

lemmas tlt_trans' = tlt_trans[OF _ less_imp_le]
lemmas trt_trans' = trt_trans[OF less_imp_le]

primrec rm_iterateoi
  :: "('k,'v) RBT_Impl.rbt \<Rightarrow> ('k \<times> 'v, '\<sigma>) set_iterator"
  where
  "rm_iterateoi RBT_Impl.Empty c f \<sigma> = \<sigma>" |
  "rm_iterateoi (RBT_Impl.Branch col l k v r) c f \<sigma> = (
    if (c \<sigma>) then
      let \<sigma>' = rm_iterateoi l c f \<sigma> in
        if (c \<sigma>') then
          rm_iterateoi r c f (f (k, v) \<sigma>')
        else \<sigma>'
    else
      \<sigma>
  )"

lemma rm_iterateoi_abort :
  "\<not>(c \<sigma>) \<Longrightarrow> rm_iterateoi t c f \<sigma> = \<sigma>"
by (cases t) auto

lemma rm_iterateoi_alt_def :
  "rm_iterateoi RBT_Impl.Empty = set_iterator_emp"
  "rm_iterateoi (RBT_Impl.Branch col l k v r) =
   set_iterator_union (rm_iterateoi l)
     (set_iterator_union (set_iterator_sng (k, v)) (rm_iterateoi r))"
by (simp_all add: fun_eq_iff set_iterator_emp_def rm_iterateoi_abort
                  set_iterator_union_def set_iterator_sng_def Let_def)
declare rm_iterateoi.simps[simp del]

primrec rm_reverse_iterateoi
  :: "('k,'v) RBT_Impl.rbt \<Rightarrow> ('k \<times> 'v, '\<sigma>) set_iterator"
  where
  "rm_reverse_iterateoi RBT_Impl.Empty c f \<sigma> = \<sigma>" |
  "rm_reverse_iterateoi (Branch col l k v r) c f \<sigma> = (
    if (c \<sigma>) then
      let \<sigma>' = rm_reverse_iterateoi r c f \<sigma> in
        if (c \<sigma>') then
          rm_reverse_iterateoi l c f (f (k, v) \<sigma>')
        else \<sigma>'
    else
      \<sigma>
  )"

lemma rm_reverse_iterateoi_abort :
  "\<not>(c \<sigma>) \<Longrightarrow> rm_reverse_iterateoi t c f \<sigma> = \<sigma>"
by (cases t) auto

lemma rm_reverse_iterateoi_alt_def :
  "rm_reverse_iterateoi RBT_Impl.Empty = set_iterator_emp"
  "rm_reverse_iterateoi (RBT_Impl.Branch col l k v r) =
   set_iterator_union (rm_reverse_iterateoi r)
     (set_iterator_union (set_iterator_sng (k, v)) (rm_reverse_iterateoi l))"
by (simp_all add: fun_eq_iff set_iterator_emp_def rm_reverse_iterateoi_abort
                  set_iterator_union_def set_iterator_sng_def Let_def)
declare rm_reverse_iterateoi.simps[simp del]

(*
lemma finite_dom_lookup [simp, intro!]: "finite (dom (RBT.lookup t))"
by(simp add: RBT.lookup_def)

instantiation rbt :: ("{equal, linorder}", equal) equal begin

definition "equal_class.equal (r :: ('a, 'b) rbt) r' == RBT.impl_of r = RBT.impl_of r'"

instance
proof
qed (simp add: equal_rbt_def RBT.impl_of_inject)

end
*)

lemma (in linorder) map_to_set_lookup_entries:
   "rbt_sorted t \<Longrightarrow> map_to_set (rbt_lookup t) = set (RBT_Impl.entries t)"
  using map_of_entries[symmetric,of t]
  by (simp add: distinct_entries map_to_set_map_of)

lemma (in linorder) rm_iterateoi_correct:
  fixes t::"('a, 'v) RBT_Impl.rbt"
  assumes is_sort: "rbt_sorted t"
  defines "it \<equiv>
  RBT_add.rm_iterateoi::(('a, 'v) RBT_Impl.rbt \<Rightarrow> ('a \<times> 'v, '\<sigma>) set_iterator)"
  shows "map_iterator_linord (it t) (rbt_lookup t)"
  using is_sort
proof (induct t)
  case Empty
  show ?case unfolding it_def
    by (simp add: rm_iterateoi_alt_def
      map_iterator_linord_emp_correct rbt_lookup_Empty)
next
  case (Branch c l k v r)
  note is_sort_t = Branch(3)

  from Branch(1) is_sort_t have
    l_it: "map_iterator_linord (it l) (rbt_lookup l)" by simp
  from Branch(2) is_sort_t have
    r_it: "map_iterator_linord (it r) (rbt_lookup r)" by simp
  note kv_it = map_iterator_linord_sng_correct[of k v]

  have kv_r_it : "set_iterator_map_linord
     (set_iterator_union (set_iterator_sng (k, v)) (it r))
     (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup r))"
  proof (rule map_iterator_linord_union_correct [OF kv_it r_it])
    fix kv kv'
    assume pre: "kv \<in> map_to_set [k \<mapsto> v]" "kv' \<in> map_to_set (rbt_lookup r)"
    obtain k' v' where kv'_eq[simp]: "kv' = (k', v')" by (rule PairE)

    from pre is_sort_t show "fst kv < fst kv'"
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      apply (metis entry_in_tree_keys rbt_greater_prop)
      done
  qed

  have l_kv_r_it : "set_iterator_map_linord (it (Branch c l k v r))
     (map_to_set (rbt_lookup l)
      \<union> (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup r)))"
    unfolding it_def rm_iterateoi_alt_def
    unfolding it_def[symmetric]
  proof (rule map_iterator_linord_union_correct [OF l_it kv_r_it])
    fix kv1 kv2
    assume pre: "kv1 \<in> map_to_set (rbt_lookup l)"
                "kv2 \<in> map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup r)"

    obtain k1 v1 where kv1_eq[simp]: "kv1 = (k1, v1)" by (rule PairE)
    obtain k2 v2 where kv2_eq[simp]: "kv2 = (k2, v2)" by (rule PairE)

    from pre is_sort_t show "fst kv1 < fst kv2"
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      by (metis (lifting) map_of_entries neqE option.simps(3)
        ord.rbt_lookup_rbt_greater ord.rbt_lookup_rbt_less rbt_greater_trans
        rbt_less_trans weak_map_of_SomeI)
  qed

  from is_sort_t
  have map_eq: "map_to_set (rbt_lookup l)
    \<union> (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup r)) =
        map_to_set (rbt_lookup (Branch c l k v r))"
    by (simp add: set_eq_iff map_to_set_lookup_entries)

  from l_kv_r_it[unfolded map_eq]
  show ?case .
qed

lemma (in linorder) rm_reverse_iterateoi_correct:
  fixes t::"('a, 'v) RBT_Impl.rbt"
  assumes is_sort: "rbt_sorted t"
  defines "it \<equiv> RBT_add.rm_reverse_iterateoi
    ::(('a, 'v) RBT_Impl.rbt \<Rightarrow> ('a \<times> 'v, '\<sigma>) set_iterator)"
  shows "map_iterator_rev_linord (it t) (rbt_lookup t)"
  using is_sort
proof (induct t)
  case Empty
  show ?case unfolding it_def
    by (simp add: rm_reverse_iterateoi_alt_def
      map_iterator_rev_linord_emp_correct rbt_lookup_Empty)
next
  case (Branch c l k v r)
  note is_sort_t = Branch(3)

  from Branch(1) is_sort_t have
    l_it: "map_iterator_rev_linord (it l) (rbt_lookup l)" by simp
  from Branch(2) is_sort_t have
    r_it: "map_iterator_rev_linord (it r) (rbt_lookup r)" by simp
  note kv_it = map_iterator_rev_linord_sng_correct[of k v]

  have kv_l_it : "set_iterator_map_rev_linord
     (set_iterator_union (set_iterator_sng (k, v)) (it l))
     (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup l))"
  proof (rule map_iterator_rev_linord_union_correct [OF kv_it l_it])
    fix kv kv'
    assume pre: "kv \<in> map_to_set [k \<mapsto> v]" "kv' \<in> map_to_set (rbt_lookup l)"
    obtain k' v' where kv'_eq[simp]: "kv' = (k', v')" by (rule PairE)

    from pre is_sort_t show "fst kv > fst kv'"
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      apply (metis entry_in_tree_keys rbt_less_prop)
   done
  qed

  have r_kv_l_it : "set_iterator_map_rev_linord (it (Branch c l k v r))
     (map_to_set (rbt_lookup r)
      \<union> (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup l)))"
    unfolding it_def rm_reverse_iterateoi_alt_def
    unfolding it_def[symmetric]
  proof (rule map_iterator_rev_linord_union_correct [OF r_it kv_l_it])
    fix kv1 kv2
    assume pre: "kv1 \<in> map_to_set (rbt_lookup r)"
                "kv2 \<in> map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup l)"

    obtain k1 v1 where kv1_eq[simp]: "kv1 = (k1, v1)" by (rule PairE)
    obtain k2 v2 where kv2_eq[simp]: "kv2 = (k2, v2)" by (rule PairE)

    from pre is_sort_t show "fst kv1 > fst kv2"
      apply (simp add: map_to_set_lookup_entries split: prod.splits)
      by (metis (mono_tags) entry_in_tree_keys neq_iff option.simps(3)
        ord.rbt_greater_prop ord.rbt_lookup_rbt_less rbt_less_trans
        rbt_lookup_in_tree)
  qed

  from is_sort_t
  have map_eq: "map_to_set (rbt_lookup r)
    \<union> (map_to_set [k \<mapsto> v] \<union> map_to_set (rbt_lookup l)) =
        map_to_set (rbt_lookup (Branch c l k v r))"
    by (auto simp add: set_eq_iff map_to_set_lookup_entries)

  from r_kv_l_it[unfolded map_eq]
  show ?case .
qed

lemma pi_rm[icf_proper_iteratorI]:
  "proper_it (RBT_add.rm_iterateoi t) (RBT_add.rm_iterateoi t)"
  by (induct t) (simp_all add: rm_iterateoi_alt_def icf_proper_iteratorI)

lemma pi_rm_rev[icf_proper_iteratorI]:
  "proper_it (RBT_add.rm_reverse_iterateoi t) (RBT_add.rm_reverse_iterateoi t)"
  by (induct t) (simp_all add: rm_reverse_iterateoi_alt_def
    icf_proper_iteratorI)

primrec bheight_aux :: "('a,'b) RBT_Impl.rbt \<Rightarrow> nat \<Rightarrow> nat"
where
  "\<And>acc. bheight_aux RBT_Impl.Empty acc = acc"
| "\<And>acc. bheight_aux (RBT_Impl.Branch c lt k v rt) acc =
     bheight_aux lt (case c of RBT_Impl.B \<Rightarrow> Suc acc | RBT_Impl.R \<Rightarrow> acc)"

lemma bheight_aux_eq: "bheight_aux t a = bheight t + a"
  by (induct t arbitrary: a) (auto split: RBT_Impl.color.split)

definition [code_unfold]: "rbt_bheight t \<equiv> bheight_aux t 0"
lemma "rbt_bheight t = bheight t"
  unfolding rbt_bheight_def by (simp add: bheight_aux_eq)

(*definition "black_height t \<equiv> rbt_bheight (RBT.impl_of t)"*)

end


(* Title: Stream_Fusion_LList
  Author: Andreas Lochbihler, ETH Zurich *)

header {* Stream fusion for coinductive lists *}

theory Stream_Fusion_LList imports
  Stream_Fusion_List
  "../Coinductive/Coinductive_List"
begin

text {*
  There are two choices of how many @{const Skip}s may occur consecutively.
  \begin{itemize}
  \item A generator for @{typ "'a llist"} may return only finitely many @{const Skip}s before
    it has to decide on a @{const Done} or @{const Yield}. Then, we can define stream versions
    for all functions that can be defined by corecursion up-to. This in particular excludes
    @{const lfilter}. Moreover, we have to prove that every generator satisfies this
    restriction.
  \item A generator for @{typ "'a llist"} may return infinitely many @{const Skip}s in a row.
    Then, the @{text lunstream} function suffers from the same difficulties as @{const lfilter} with
    definitions, but we can define it using the least fixpoint approach described in
    \cite{LochbihlerHoelzl2014ITP}. Consequently, we can only fuse transformers that are monotone and
    continuous with respect to the ccpo ordering. This in particular excludes @{const lappend}.
  \end{itemize}
  Here, we take the both approaches where we consider the first preferable to the second.
  Consequently, we define producers such that they produce generators of the first kind, if possible.
  There will be multiple equations for transformers and consumers that deal with all the different
  combinations for their parameter generators. Transformers should yield generators of the first
  kind whenever possible. Consumers can be defined using @{text lunstream} and refined with custom
  code equations, i.e., they can operate with infinitely many @{text Skip}s in a row. We just
  have to lift the fusion equation to the first kind, too.
*}

type_synonym ('a, 's) lgenerator = "'s \<Rightarrow> ('a, 's) step"

inductive_set productive_on :: "('a, 's) lgenerator \<Rightarrow> 's set"
for g :: "('a, 's) lgenerator"
where
  Done: "g s = Done \<Longrightarrow> s \<in> productive_on g"
| Skip: "\<lbrakk> g s = Skip s'; s' \<in> productive_on g \<rbrakk> \<Longrightarrow> s \<in> productive_on g"
| Yield: "g s = Yield x s' \<Longrightarrow> s \<in> productive_on g"

definition productive :: "('a, 's) lgenerator \<Rightarrow> bool"
where "productive g \<longleftrightarrow> productive_on g = UNIV"

lemma productiveI [intro?]:
  "(\<And>s. s \<in> productive_on g) \<Longrightarrow> productive g"
by(auto simp add: productive_def)

lemma productive_onI [dest?]: "productive g \<Longrightarrow> s \<in> productive_on g"
by(simp add: productive_def)

text {* A type of generators that eventually will yield something else than a skip. *}

typedef ('a, 's) lgenerator' = "{g :: ('a, 's) lgenerator. productive g}"
  morphisms lgenerator Abs_lgenerator'
proof
  show "(\<lambda>_. Done) \<in> ?lgenerator'" by(auto intro: productive_on.intros productiveI)
qed

setup_lifting type_definition_lgenerator'

section {* Conversions to @{typ "'a llist"} *}

subsection {* Infinitely many consecutive @{term Skip}s *}

context fixes g :: "('a, 's) lgenerator" begin

partial_function (llist) lunstream :: "'s \<Rightarrow> 'a llist"
where
  "lunstream s = (case g s of
     Done \<Rightarrow> LNil | Skip s' \<Rightarrow> lunstream s' | Yield x s' \<Rightarrow> LCons x (lunstream s'))"

declare lunstream.simps[code]

lemma lunstream_simps:
  "g s = Done \<Longrightarrow> lunstream s = LNil"
  "g s = Skip s' \<Longrightarrow> lunstream s = lunstream s'"
  "g s = Yield x s' \<Longrightarrow> lunstream s = LCons x (lunstream s')"
by(simp_all add: lunstream.simps)

lemma lunstream_sels:
  shows lnull_lunstream: "lnull (lunstream s) \<longleftrightarrow>
  (case g s of Done \<Rightarrow> True | Skip s' \<Rightarrow> lnull (lunstream s') | Yield _ _ \<Rightarrow> False)"
  and lhd_lunstream: "lhd (lunstream s) =
  (case g s of Skip s' \<Rightarrow> lhd (lunstream s') | Yield x _ \<Rightarrow> x)"
  and ltl_lunstream: "ltl (lunstream s) =
  (case g s of Done \<Rightarrow> LNil | Skip s' \<Rightarrow> ltl (lunstream s') | Yield _ s' \<Rightarrow> lunstream s')"
by(simp_all add: lhd_def lunstream_simps split: step.split)

end

subsection {* Finitely many consecutive @{term Skip}s *}

lift_definition lunstream' :: "('a, 's) lgenerator' \<Rightarrow> 's \<Rightarrow> 'a llist"
is lunstream .

lemma lunstream'_simps:
  "lgenerator g s = Done \<Longrightarrow> lunstream' g s = LNil"
  "lgenerator g s = Skip s' \<Longrightarrow> lunstream' g s = lunstream' g s'"
  "lgenerator g s = Yield x s' \<Longrightarrow> lunstream' g s = LCons x (lunstream' g s')"
by(transfer, simp add: lunstream_simps)+

lemma lunstream'_sels:
  shows lnull_lunstream': "lnull (lunstream' g s) \<longleftrightarrow>
  (case lgenerator g s of Done \<Rightarrow> True | Skip s' \<Rightarrow> lnull (lunstream' g s') | Yield _ _ \<Rightarrow> False)"
  and lhd_lunstream': "lhd (lunstream' g s) =
  (case lgenerator g s of Skip s' \<Rightarrow> lhd (lunstream' g s') | Yield x _ \<Rightarrow> x)"
  and ltl_lunstream': "ltl (lunstream' g s) =
  (case lgenerator g s of Done \<Rightarrow> LNil | Skip s' \<Rightarrow> ltl (lunstream' g s') | Yield _ s' \<Rightarrow> lunstream' g s')"
by(transfer, simp add: lunstream_sels)+

setup {* Context.theory_map (fold
  Stream_Fusion.add_unstream [@{const_name lunstream}, @{const_name lunstream'}]) *}

section {* Producers *}

subsection {* Conversion to streams *}

fun lstream :: "('a, 'a llist) lgenerator"
where
  "lstream LNil = Done"
| "lstream (LCons x xs) = Yield x xs"

lemma case_lstream_conv_case_llist:
  "(case lstream xs of Done \<Rightarrow> done | Skip xs' \<Rightarrow> skip xs' | Yield x xs' \<Rightarrow> yield x xs') =
   (case xs of LNil \<Rightarrow> done | LCons x xs' \<Rightarrow> yield x xs')"
by(simp split: llist.split)

lemma mcont2mcont_lunstream[THEN llist.mcont2mcont, simp, cont_intro]:
  shows mcont_lunstream: "mcont lSup lprefix lSup lprefix (lunstream lstream)"
by(rule llist.fixp_preserves_mcont1[OF lunstream.mono lunstream_def])(simp add: case_lstream_conv_case_llist)

lemma lunstream_lstream: "lunstream lstream xs = xs"
by(induction xs)(simp_all add: lunstream_simps)

lift_definition lstream' :: "('a, 'a llist) lgenerator'"
is lstream
proof
  fix s :: "'a llist"
  show "s \<in> productive_on lstream" by(cases s)(auto intro: productive_on.intros)
qed

lemma lunstream'_lstream: "lunstream' lstream' xs = xs"
by(transfer)(rule lunstream_lstream)

subsection {* @{const iterates} *}

definition iterates_raw :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a, 'a) lgenerator"
where "iterates_raw f s = Yield s (f s)"

lemma lunstream_iterates_raw: "lunstream (iterates_raw f) x = iterates f x"
by(coinduction arbitrary: x)(auto simp add: iterates_raw_def lunstream_sels)

lift_definition iterates_prod :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a, 'a) lgenerator'" is iterates_raw
by(auto 4 3 intro: productiveI productive_on.intros simp add: iterates_raw_def)

lemma lunstream'_iterates_prod [stream_fusion]: "lunstream' (iterates_prod f) x = iterates f x"
by transfer(rule lunstream_iterates_raw)

subsection {* @{const unfold_llist} *}

definition unfold_llist_raw :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('b, 'a) lgenerator"
where
  "unfold_llist_raw stop head tail s = (if stop s then Done else Yield (head s) (tail s))"

lemma lunstream_unfold_llist_raw:
  "lunstream (unfold_llist_raw stop head tail) s = unfold_llist stop head tail s"
by(coinduction arbitrary: s)(auto simp add: lunstream_sels unfold_llist_raw_def)

lift_definition unfold_llist_prod :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('b, 'a) lgenerator'"
is unfold_llist_raw
proof(rule productiveI)
  fix stop and head :: "'a \<Rightarrow> 'b" and tail s
  show "s \<in> productive_on (unfold_llist_raw stop head tail)"
    by(cases "stop s")(auto intro: productive_on.intros simp add: unfold_llist_raw_def)
qed

lemma lunstream'_unfold_llist_prod [stream_fusion]:
  "lunstream' (unfold_llist_prod stop head tail) s = unfold_llist stop head tail s"
by transfer(rule lunstream_unfold_llist_raw)

subsection {* @{const inf_llist} *}

definition inf_llist_raw :: "(nat \<Rightarrow> 'a) \<Rightarrow> ('a, nat) lgenerator"
where "inf_llist_raw f n = Yield (f n) (Suc n)"

lemma lunstream_inf_llist_raw: "lunstream (inf_llist_raw f) n = ldropn n (inf_llist f)"
by(coinduction arbitrary: n)(auto simp add: lunstream_sels inf_llist_raw_def)

lift_definition inf_llist_prod :: "(nat \<Rightarrow> 'a) \<Rightarrow> ('a, nat) lgenerator'" is inf_llist_raw
by(auto 4 3 intro: productiveI productive_on.intros simp add: inf_llist_raw_def)

section {* Consumers *}

subsection {* @{const lhd} *}

context fixes g :: "('a, 's) lgenerator" begin

definition lhd_cons :: "'s \<Rightarrow> 'a"
where [stream_fusion]: "lhd_cons s = lhd (lunstream g s)"

lemma lhd_cons_code[code]:
  "lhd_cons s = (case g s of Done \<Rightarrow> undefined | Skip s' \<Rightarrow> lhd_cons s' | Yield x _ \<Rightarrow> x)"
by(simp add: lhd_cons_def lunstream_simps lhd_def split: step.split)

end

lemma lhd_cons_fusion2 [stream_fusion]:
  "lhd_cons (lgenerator g) s = lhd (lunstream' g s)"
by transfer(rule lhd_cons_def)

subsection {* @{const llength} *}

context fixes g :: "('a, 's) lgenerator" begin

definition gen_llength_cons :: "enat \<Rightarrow> 's \<Rightarrow> enat"
where "gen_llength_cons n s = n + llength (lunstream g s)"

lemma gen_llength_cons_code [code]:
  "gen_llength_cons n s = (case g s of
    Done \<Rightarrow> n | Skip s' \<Rightarrow> gen_llength_cons n s' | Yield _ s' \<Rightarrow> gen_llength_cons (eSuc n) s')"
by(simp add: gen_llength_cons_def lunstream_simps iadd_Suc_right iadd_Suc split: step.split)

lemma gen_llength_cons_fusion [stream_fusion]:
  "gen_llength_cons 0 s = llength (lunstream g s)"
by(simp add: gen_llength_cons_def)

end

context fixes g :: "('a, 's) lgenerator'" begin

definition gen_llength_cons' :: "enat \<Rightarrow> 's \<Rightarrow> enat"
where "gen_llength_cons' = gen_llength_cons (lgenerator g)"

lemma gen_llength_cons'_code [code]:
  "gen_llength_cons' n s = (case lgenerator g s of
    Done \<Rightarrow> n | Skip s' \<Rightarrow> gen_llength_cons' n s' | Yield _ s' \<Rightarrow> gen_llength_cons' (eSuc n) s')"
by(simp add: gen_llength_cons'_def cong: step.case_cong)(rule gen_llength_cons_code)

lemma gen_llength_cons'_fusion [stream_fusion]:
  "gen_llength_cons' 0 s = llength (lunstream' g s)"
by(simp add: gen_llength_cons'_def gen_llength_cons_fusion lunstream'.rep_eq)

end

subsection {* @{const lnull} *}

context fixes g :: "('a, 's) lgenerator" begin

definition lnull_cons :: "'s \<Rightarrow> bool"
where [stream_fusion]: "lnull_cons s \<longleftrightarrow> lnull (lunstream g s)"

lemma lnull_cons_code [code]:
  "lnull_cons s \<longleftrightarrow> (case g s of
    Done \<Rightarrow> True | Skip s' \<Rightarrow> lnull_cons s' | Yield _ _ \<Rightarrow> False)"
by(simp add: lnull_cons_def lunstream_simps split: step.split)

end

context fixes g :: "('a, 's) lgenerator'" begin

definition lnull_cons' :: "'s \<Rightarrow> bool"
where "lnull_cons' = lnull_cons (lgenerator g)"

lemma lnull_cons'_code [code]:
  "lnull_cons' s \<longleftrightarrow> (case lgenerator g s of
    Done \<Rightarrow> True | Skip s' \<Rightarrow> lnull_cons' s' | Yield _ _ \<Rightarrow> False)"
by(simp add: lnull_cons'_def cong: step.case_cong)(rule lnull_cons_code)

lemma lnull_cons'_fusion [stream_fusion]:
  "lnull_cons' s \<longleftrightarrow> lnull (lunstream' g s)"
by(simp add: lnull_cons'_def lnull_cons_def lunstream'.rep_eq)

end

subsection {* @{const llist_all2} *}

context
  fixes g :: "('a, 'sg) lgenerator"
  and h :: "('b, 'sh) lgenerator"
  and P :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
begin

definition llist_all2_cons :: "'sg \<Rightarrow> 'sh \<Rightarrow> bool"
where [stream_fusion]: "llist_all2_cons sg sh \<longleftrightarrow> llist_all2 P (lunstream g sg) (lunstream h sh)"

definition llist_all2_cons1 :: "'a \<Rightarrow> 'sg \<Rightarrow> 'sh \<Rightarrow> bool"
where "llist_all2_cons1 x sg' sh = llist_all2 P (LCons x (lunstream g sg')) (lunstream h sh)"

lemma llist_all2_cons_code [code]:
  "llist_all2_cons sg sh =
  (case g sg of
     Done \<Rightarrow> lnull_cons h sh
   | Skip sg' \<Rightarrow> llist_all2_cons sg' sh
   | Yield a sg' \<Rightarrow> llist_all2_cons1 a sg' sh)"
by(simp split: step.split add: llist_all2_cons_def lnull_cons_def llist_all2_cons1_def lunstream_simps lnull_def)

lemma llist_all2_cons1_code [code]:
  "llist_all2_cons1 x sg' sh =
  (case h sh of
     Done \<Rightarrow> False
   | Skip sh' \<Rightarrow> llist_all2_cons1 x sg' sh'
   | Yield y sh' \<Rightarrow> P x y \<and> llist_all2_cons sg' sh')"
by(simp split: step.split add: llist_all2_cons_def lnull_cons_def lnull_def llist_all2_cons1_def lunstream_simps)

end

lemma llist_all2_cons_fusion2 [stream_fusion]:
  "llist_all2_cons (lgenerator g) (lgenerator h) P sg sh \<longleftrightarrow> llist_all2 P (lunstream' g sg) (lunstream' h sh)"
by transfer(rule llist_all2_cons_def)

lemma llist_all2_cons_fusion3 [stream_fusion]:
  "llist_all2_cons g (lgenerator h) P sg sh \<longleftrightarrow> llist_all2 P (lunstream g sg) (lunstream' h sh)"
by transfer(rule llist_all2_cons_def)

lemma llist_all2_cons_fusion4 [stream_fusion]:
  "llist_all2_cons (lgenerator g) h P sg sh \<longleftrightarrow> llist_all2 P (lunstream' g sg) (lunstream h sh)"
by transfer(rule llist_all2_cons_def)

subsection {* @{const lnth} *}

context fixes g :: "('a, 's) lgenerator" begin

definition lnth_cons :: "nat \<Rightarrow> 's \<Rightarrow> 'a"
where [stream_fusion]: "lnth_cons n s = lnth (lunstream g s) n"

lemma lnth_cons_code [code]:
  "lnth_cons n s = (case g s of
    Done \<Rightarrow> undefined n
  | Skip s' \<Rightarrow> lnth_cons n s'
  | Yield x s' \<Rightarrow> (if n = 0 then x else lnth_cons (n - 1) s'))"
by(cases n)(simp_all add: lnth_cons_def lunstream_simps lnth_LNil split: step.split)

end

subsection {* @{const lprefix} *}

context
  fixes g :: "('a, 'sg) lgenerator"
  and h :: "('a, 'sh) lgenerator"
begin

definition lprefix_cons :: "'sg \<Rightarrow> 'sh \<Rightarrow> bool"
where [stream_fusion]: "lprefix_cons sg sh \<longleftrightarrow> lprefix (lunstream g sg) (lunstream h sh)"

definition lprefix_cons1 :: "'a \<Rightarrow> 'sg \<Rightarrow> 'sh \<Rightarrow> bool"
where "lprefix_cons1 x sg' sh \<longleftrightarrow> lprefix (LCons x (lunstream g sg')) (lunstream h sh)"

lemma lprefix_cons_code [code]:
  "lprefix_cons sg sh \<longleftrightarrow> (case g sg of
     Done \<Rightarrow> True | Skip sg' \<Rightarrow> lprefix_cons sg' sh | Yield x sg' \<Rightarrow> lprefix_cons1 x sg' sh)"
by(simp add: lprefix_cons_def lprefix_cons1_def lunstream_simps split: step.split)

lemma lprefix_cons1_code [code]:
  "lprefix_cons1 x sg' sh \<longleftrightarrow> (case h sh of
     Done \<Rightarrow> False | Skip sh' \<Rightarrow> lprefix_cons1 x sg' sh'
   | Yield y sh' \<Rightarrow> x = y \<and> lprefix_cons sg' sh')"
by(simp add: lprefix_cons_def lprefix_cons1_def lunstream_simps split: step.split)

end

lemma lprefix_cons_fusion2 [stream_fusion]:
  "lprefix_cons (lgenerator g) (lgenerator h) sg sh \<longleftrightarrow> lprefix (lunstream' g sg) (lunstream' h sh)"
by transfer(rule lprefix_cons_def)

lemma lprefix_cons_fusion3 [stream_fusion]:
  "lprefix_cons g (lgenerator h) sg sh \<longleftrightarrow> lprefix (lunstream g sg) (lunstream' h sh)"
by transfer(rule lprefix_cons_def)

lemma lprefix_cons_fusion4 [stream_fusion]:
  "lprefix_cons (lgenerator g) h sg sh \<longleftrightarrow> lprefix (lunstream' g sg) (lunstream h sh)"
by transfer(rule lprefix_cons_def)

section {* Transformers *}

subsection {* @{const lmap} *}

definition lmap_trans :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 's) lgenerator \<Rightarrow> ('b, 's) lgenerator"
where "lmap_trans = map_raw"

lemma lunstream_lmap_trans [stream_fusion]: fixes f g s
  defines [simp]: "g' \<equiv> lmap_trans f g"
  shows "lunstream g' s = lmap f (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
  proof(induction g' arbitrary: s rule: lunstream.fixp_induct)
    case (3 lunstream_g')
    then show ?case
      by(cases "g s")(simp_all add: lmap_trans_def map_raw_def lunstream_simps)
  qed simp_all
next
  note [cont_intro] = ccpo.admissible_leI[OF llist_ccpo]
  show "lprefix ?rhs ?lhs"
  proof(induction g arbitrary: s rule: lunstream.fixp_induct)
    case (3 lunstream_g)
    thus ?case by(cases "g s")(simp_all add: lmap_trans_def map_raw_def lunstream_simps)
  qed simp_all
qed

lift_definition lmap_trans' :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 's) lgenerator' \<Rightarrow> ('b, 's) lgenerator'"
is lmap_trans
proof
  fix f :: "'a \<Rightarrow> 'b" and g :: "('a, 's) lgenerator" and s
  assume "productive g"
  hence "s \<in> productive_on g" ..
  thus "s \<in> productive_on (lmap_trans f g)"
    by induction(auto simp add: lmap_trans_def map_raw_def intro: productive_on.intros)
qed

lemma lunstream'_lmap_trans' [stream_fusion]:
  "lunstream' (lmap_trans' f g) s = lmap f (lunstream' g s)"
by transfer(rule lunstream_lmap_trans)

subsection {* @{const ltake} *}

fun ltake_trans :: "('a, 's) lgenerator \<Rightarrow> ('a, (enat \<times> 's)) lgenerator"
where
  "ltake_trans g (n, s) =
  (if n = 0 then Done else case g s of
    Done \<Rightarrow> Done | Skip s' \<Rightarrow> Skip (n, s') | Yield a s' \<Rightarrow> Yield a (epred n, s'))"

lemma ltake_trans_fusion [stream_fusion]:
  fixes g' g
  defines [simp]: "g' \<equiv> ltake_trans g"
  shows "lunstream g' (n, s) = ltake n (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
  proof(induction g' arbitrary: n s rule: lunstream.fixp_induct)
    case (3 lunstream_g')
    thus ?case
      by(cases "g s")(auto simp add: lunstream_simps neq_zero_conv_eSuc)
  qed simp_all
  show "lprefix ?rhs ?lhs"
  proof(induction g arbitrary: s n rule: lunstream.fixp_induct)
    case (3 lunstream_g)
    thus ?case by(cases "g s" n rule: step.exhaust[case_product enat_coexhaust])(auto simp add: lunstream_simps)
  qed simp_all
qed

lift_definition ltake_trans' :: "('a, 's) lgenerator' \<Rightarrow> ('a, (enat \<times> 's)) lgenerator'"
is "ltake_trans"
proof
  fix g :: "('a, 's) lgenerator" and s :: "enat \<times> 's"
  obtain n sg where s: "s = (n, sg)" by(cases s)
  assume "productive g"
  hence "sg \<in> productive_on g" ..
  then show "s \<in> productive_on (ltake_trans g)" unfolding \<open>s = (n, sg)\<close>
    apply(induction arbitrary: n)
    apply(case_tac [!] n rule: enat_coexhaust)
    apply(auto intro: productive_on.intros)
    done
qed

lemma ltake_trans'_fusion [stream_fusion]:
  "lunstream' (ltake_trans' g) (n, s) = ltake n (lunstream' g s)"
by transfer(rule ltake_trans_fusion)

subsection {* @{const ldropn} *}

abbreviation (input) ldropn_trans :: "('b, 'a) lgenerator \<Rightarrow> ('b, nat \<times> 'a) lgenerator"
where "ldropn_trans \<equiv> drop_raw"

lemma ldropn_trans_fusion [stream_fusion]:
  fixes g defines [simp]: "g' \<equiv> ldropn_trans g"
  shows "lunstream g' (n, s) = ldropn n (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
  proof(induction g' arbitrary: n s rule: lunstream.fixp_induct)
    case (3 lunstream_g')
    thus ?case
      by(cases "g s" n rule: step.exhaust[case_product nat.exhaust])
        (auto simp add: lunstream_simps elim: meta_allE[where x=0])
  qed simp_all
  note [cont_intro] = ccpo.admissible_leI[OF llist_ccpo]
  show "lprefix ?rhs ?lhs"
  proof(induction g arbitrary: n s rule: lunstream.fixp_induct)
    case (3 lunstream_g)
    thus ?case by(cases n)(auto split: step.split simp add: lunstream_simps elim: meta_allE[where x=0])
  qed simp_all
qed

lift_definition ldropn_trans' :: "('a, 's) lgenerator' \<Rightarrow> ('a, nat \<times> 's) lgenerator'"
is ldropn_trans
proof
  fix g :: "('a, 's) lgenerator" and ns :: "nat \<times> 's"
  obtain n s where ns: "ns = (n, s)" by(cases ns)
  assume g: "productive g"
  show "ns \<in> productive_on (ldropn_trans g)" unfolding ns
  proof(induction n arbitrary: s)
    case 0
    from g have "s \<in> productive_on g" ..
    thus ?case by induction(auto intro: productive_on.intros)
  next
    case (Suc n)
    from g have "s \<in> productive_on g" ..
    thus ?case by induction(auto intro: productive_on.intros Suc.IH)
  qed
qed

lemma ldropn_trans'_fusion [stream_fusion]:
  "lunstream' (ldropn_trans' g) (n, s) = ldropn n (lunstream' g s)"
by transfer(rule ldropn_trans_fusion)

subsection {* @{const ldrop} *}

fun ldrop_trans :: "('a, 's) lgenerator \<Rightarrow> ('a, enat \<times> 's) lgenerator"
where
  "ldrop_trans g (n, s) = (case g s of
    Done \<Rightarrow> Done | Skip s' \<Rightarrow> Skip (n, s')
  | Yield x s' \<Rightarrow> (if n = 0 then Yield x (n, s') else Skip (epred n, s')))"

lemma ldrop_trans_fusion [stream_fusion]:
  fixes g g' defines [simp]: "g' \<equiv> ldrop_trans g"
  shows "lunstream g' (n, s) = ldrop n (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
    by(induction g' arbitrary: n s rule: lunstream.fixp_induct)
      (auto simp add: lunstream_simps neq_zero_conv_eSuc elim: meta_allE[where x=0] split: step.split)
  show "lprefix ?rhs ?lhs"
  proof(induction g arbitrary: n s rule: lunstream.fixp_induct)
    case (3 lunstream_g)
    thus ?case
      by(cases n rule: enat_coexhaust)(auto simp add: lunstream_simps split: step.split elim: meta_allE[where x=0])
  qed simp_all
qed

lemma ldrop_trans_fusion2 [stream_fusion]:
  "lunstream (ldrop_trans (lgenerator g)) (n, s) = ldrop n (lunstream' g s)"
by transfer (rule ldrop_trans_fusion)

subsection {* @{const ltakeWhile} *}

abbreviation (input) ltakeWhile_trans :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 's) lgenerator \<Rightarrow> ('a, 's) lgenerator"
where "ltakeWhile_trans \<equiv> takeWhile_raw"

lemma ltakeWhile_trans_fusion [stream_fusion]:
  fixes P g g' defines [simp]: "g' \<equiv> ltakeWhile_trans P g"
  shows "lunstream g' s = ltakeWhile P (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
    by(induction g' arbitrary: s rule: lunstream.fixp_induct)(auto simp add: lunstream_simps takeWhile_raw_def split: step.split)
  show "lprefix ?rhs ?lhs"
    by(induction g arbitrary: s rule: lunstream.fixp_induct)(auto split: step.split simp add: lunstream_simps takeWhile_raw_def)
qed

lift_definition ltakeWhile_trans' :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 's) lgenerator' \<Rightarrow> ('a, 's) lgenerator'"
is ltakeWhile_trans
proof
  fix P and g :: "('a, 's) lgenerator" and s
  assume "productive g"
  hence "s \<in> productive_on g" ..
  thus "s \<in> productive_on (ltakeWhile_trans P g)"
    apply(induction)
    apply(case_tac [3] "P x")
    apply(auto intro: productive_on.intros simp add: takeWhile_raw_def)
    done
qed

lemma ltakeWhile_trans'_fusion [stream_fusion]:
  "lunstream' (ltakeWhile_trans' P g) s = ltakeWhile P (lunstream' g s)"
by transfer(rule ltakeWhile_trans_fusion)

subsection {* @{const ldropWhile} *}

abbreviation (input) ldropWhile_trans :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) lgenerator \<Rightarrow> ('a, bool \<times> 'b) lgenerator"
where "ldropWhile_trans \<equiv> dropWhile_raw"

lemma ldropWhile_trans_fusion [stream_fusion]:
  fixes P g g' defines [simp]: "g' \<equiv> ldropWhile_trans P g"
  shows "lunstream g' (True, s) = ldropWhile P (lunstream g s)" (is "?lhs = ?rhs")
proof -
  have "lprefix ?lhs ?rhs" "lprefix (lunstream g' (False, s)) (lunstream g s)"
    by(induction g' arbitrary: s rule: lunstream.fixp_induct)(simp_all add: lunstream_simps split: step.split)
  moreover have "lprefix ?rhs ?lhs" "lprefix (lunstream g s) (lunstream g' (False, s))"
    by(induction g arbitrary: s rule: lunstream.fixp_induct)(simp_all add: lunstream_simps split: step.split)
  ultimately show ?thesis by(blast intro: lprefix_antisym)
qed

lemma ldropWhile_trans_fusion2 [stream_fusion]:
  "lunstream (ldropWhile_trans P (lgenerator g)) (True, s) = ldropWhile P (lunstream' g s)"
by transfer(rule ldropWhile_trans_fusion)

subsection {* @{const lzip} *}

abbreviation (input) lzip_trans :: "('a, 's1) lgenerator \<Rightarrow> ('b, 's2) lgenerator \<Rightarrow> ('a \<times> 'b, 's1 \<times> 's2 \<times> 'a option) lgenerator"
where "lzip_trans \<equiv> zip_raw"

lemma lzip_trans_fusion [stream_fusion]:
  fixes g h gh defines [simp]: "gh \<equiv> lzip_trans g h"
  shows "lunstream gh (sg, sh, None) = lzip (lunstream g sg) (lunstream h sh)"
  (is "?lhs = ?rhs")
proof -
  have "lprefix ?lhs ?rhs"
    and "\<And>x. lprefix (lunstream gh (sg, sh, Some x)) (lzip (LCons x (lunstream g sg)) (lunstream h sh))"
  proof(induction gh arbitrary: sg sh rule: lunstream.fixp_induct)
    case (3 lunstream)
    { case 1 show ?case using 3
        by(cases "g sg")(simp_all add: lunstream_simps) }
    { case 2 show ?case using 3
        by(cases "h sh")(simp_all add: lunstream_simps) }
  qed simp_all
  moreover
  note [cont_intro] = ccpo.admissible_leI[OF llist_ccpo]
  have "lprefix ?rhs ?lhs"
    and "\<And>x. lprefix (lzip (LCons x (lunstream g sg)) (lunstream h sh)) (lunstream gh (sg, sh, Some x))"
  proof(induction g arbitrary: sg sh rule: lunstream.fixp_induct)
    case (3 lunstream_g)
    note IH = "3.IH"
    { case 1 show ?case using 3
        by(cases "g sg")(simp_all add: lunstream_simps fun_ord_def) }
    { case 2 show ?case
      proof(induction h arbitrary: sh sg x rule: lunstream.fixp_induct)
        case (3 unstream_h)
        thus ?case
        proof(cases "h sh")
          case (Yield y sh')
          thus ?thesis using "3.prems" IH "3.hyps"
            by(cases "g sg")(auto 4 3 simp add: lunstream_simps fun_ord_def intro: monotone_lzip2[THEN monotoneD] lprefix_trans)
        qed(simp_all add: lunstream_simps)
      qed simp_all }
  next
    case 2 case 2
    show ?case
      by(induction h arbitrary: sh rule: lunstream.fixp_induct)(simp_all add: lunstream_simps split: step.split)
  qed simp_all
  ultimately show ?thesis by(blast intro: lprefix_antisym)
qed

lemma lzip_trans_fusion2 [stream_fusion]:
  "lunstream (lzip_trans (lgenerator g) h) (sg, sh, None) = lzip (lunstream' g sg) (lunstream h sh)"
by transfer(rule lzip_trans_fusion)

lemma lzip_trans_fusion3 [stream_fusion]:
  "lunstream (lzip_trans g (lgenerator h)) (sg, sh, None) = lzip (lunstream g sg) (lunstream' h sh)"
by transfer(rule lzip_trans_fusion)

lift_definition lzip_trans' :: "('a, 's1) lgenerator' \<Rightarrow> ('b, 's2) lgenerator' \<Rightarrow> ('a \<times> 'b, 's1 \<times> 's2 \<times> 'a option) lgenerator'"
is "lzip_trans"
proof
  fix g :: "('a, 's1) lgenerator" and h :: "('b, 's2) lgenerator" and s :: "'s1 \<times> 's2 \<times> 'a option"
  assume "productive g" and "productive h"
  obtain sg sh mx where s: "s = (sg, sh, mx)" by(cases s)
  { fix x sg
    from \<open>productive h\<close> have "sh \<in> productive_on h" ..
    hence "(sg, sh, Some x) \<in> productive_on (lzip_trans g h)"
      by(induction)(auto simp add: intro: productive_on.intros) }
  moreover
  from \<open>productive g\<close> have "sg \<in> productive_on g" ..
  then have "(sg, sh, None) \<in> productive_on (lzip_trans g h)"
    by induction(auto intro: productive_on.intros calculation)
  ultimately show "s \<in> productive_on (lzip_trans g h)" unfolding s
    by(cases mx) auto
qed

lemma lzip_trans'_fusion [stream_fusion]:
  "lunstream' (lzip_trans' g h) (sg, sh, None) = lzip (lunstream' g sg) (lunstream' h sh)"
by transfer(rule lzip_trans_fusion)

subsection {* @{const lappend} *}

lift_definition lappend_trans :: "('a, 'sg) lgenerator' \<Rightarrow> ('a, 'sh) lgenerator \<Rightarrow> 'sh \<Rightarrow> ('a, 'sg + 'sh) lgenerator"
is append_raw .

lemma lunstream_append_raw:
  fixes g h sh gh defines [simp]: "gh \<equiv> append_raw g h sh"
  assumes "productive g"
  shows "lunstream gh (Inl sg) = lappend (lunstream g sg) (lunstream h sh)"
proof(coinduction arbitrary: sg rule: llist.coinduct_strong)
  case (Eq_llist sg)
  { fix sh'
    have "lprefix (lunstream gh (Inr sh')) (lunstream h sh')"
      by(induction gh arbitrary: sh' rule: lunstream.fixp_induct)(simp_all add: lunstream_simps split: step.split)
    moreover have "lprefix (lunstream h sh') (lunstream gh (Inr sh'))"
      by(induction h arbitrary: sh' rule: lunstream.fixp_induct)(simp_all add: lunstream_simps split: step.split)
    ultimately have "lunstream gh (Inr sh') = lunstream h sh'"
      by(blast intro: lprefix_antisym) }
  note Inr = this[unfolded gh_def]
  from \<open>productive g\<close> have sg: "sg \<in> productive_on g" ..
  then show ?case by induction(auto simp add: lunstream_sels Inr)
qed

lemma lappend_trans_fusion [stream_fusion]:
  "lunstream (lappend_trans g h sh) (Inl sg) = lappend (lunstream' g sg) (lunstream h sh)"
by transfer(rule lunstream_append_raw)

lift_definition lappend_trans' :: "('a, 'sg) lgenerator' \<Rightarrow> ('a, 'sh) lgenerator' \<Rightarrow> 'sh \<Rightarrow> ('a, 'sg + 'sh) lgenerator'"
is append_raw
proof
  fix g :: "('a, 'sg) lgenerator" and h :: "('a, 'sh) lgenerator" and sh s
  assume "productive g" "productive h"
  { fix sh'
    from \<open>productive h\<close> have "sh' \<in> productive_on h" ..
    then have "Inr sh' \<in> productive_on (append_raw g h sh)"
      by induction (auto intro: productive_on.intros)
  } moreover {
    fix sg
    from \<open>productive g\<close> have "sg \<in> productive_on g" ..
    then have "Inl sg \<in> productive_on (append_raw g h sh)"
      by induction(auto intro: productive_on.intros calculation) }
  ultimately show "s \<in> productive_on (append_raw g h sh)" by(cases s) auto
qed

lemma lappend_trans'_fusion [stream_fusion]:
  "lunstream' (lappend_trans' g h sh) (Inl sg) = lappend (lunstream' g sg) (lunstream' h sh)"
by transfer(rule lunstream_append_raw)

subsection {* @{const lfilter} *}

definition lfilter_trans :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 's) lgenerator \<Rightarrow> ('a, 's) lgenerator"
where "lfilter_trans = filter_raw"

lemma lunstream_lfilter_trans [stream_fusion]:
  fixes P g g' defines [simp]: "g' \<equiv> lfilter_trans P g"
  shows "lunstream g' s = lfilter P (lunstream g s)" (is "?lhs = ?rhs")
proof(rule lprefix_antisym)
  show "lprefix ?lhs ?rhs"
    by(induction g' arbitrary: s rule: lunstream.fixp_induct)
      (simp_all add: lfilter_trans_def filter_raw_def lunstream_simps split: step.split)
  show "lprefix ?rhs ?lhs"
  by(induction g arbitrary: s rule: lunstream.fixp_induct)
    (simp_all add: lfilter_trans_def filter_raw_def lunstream_simps split: step.split)
qed

lemma lunstream_lfilter_trans2 [stream_fusion]:
  "lunstream (lfilter_trans P (lgenerator g)) s = lfilter P (lunstream' g s)"
by transfer(rule lunstream_lfilter_trans)

subsection {* @{const llist_of} *}

lift_definition llist_of_trans :: "('a, 's) generator \<Rightarrow> ('a, 's) lgenerator'"
is "\<lambda>x. x"
proof
  fix g :: "('a, 's) raw_generator" and s
  assume "terminates g"
  hence "s \<in> terminates_on g" by(simp add: terminates_def)
  then show "s \<in> productive_on g"
    by(induction)(auto intro: productive_on.intros)
qed

lemma lunstream_llist_of_trans [stream_fusion]:
  "lunstream' (llist_of_trans g) s = llist_of (unstream g s)"
apply(induction s taking: g rule: unstream.induct)
apply(rule llist.expand)
apply(auto intro: llist.expand simp add: llist_of_trans.rep_eq lunstream_sels lunstream'.rep_eq split: step.split)
done

text {* We cannot define a stream version of @{const list_of} because we would have to test
  for finiteness first and therefore traverse the list twice. *}

end


theory UnionFind_Intf
imports  "SeprefTime.Sepref" UnionFind
begin

section "Union find Implementation"

subsection "MOP interface"

context
  fixes t ::  "nat \<Rightarrow> nat"
begin

  definition "mop_per_init n = SPECT [ per_init' n \<mapsto> enat (t n) ]"

  lemma progress_mop_per_init[progress_rules]: "t n > 0 \<Longrightarrow> progress (mop_per_init n)"
    unfolding mop_per_init_def by (auto intro!: progress_rules simp add:   zero_enat_def)

  lemma mop_per_init: "tt \<le> lst (SPECT [ per_init' n \<mapsto> t n]) Q \<Longrightarrow> tt
           \<le> lst (mop_per_init n) Q" unfolding mop_per_init_def by simp

  sepref_register "mop_per_init"
end

context
  fixes t ::  "('a \<times> 'a) set \<Rightarrow> nat"
begin

  definition "mop_per_compare R a b = SPECT [ per_compare R a b \<mapsto> enat (t R) ]"

  sepref_register "mop_per_compare"
end

context
  fixes t ::  "('a \<times> 'a) set \<Rightarrow> nat"
begin

  definition "mop_per_union R a b = SPECT [ per_union R a b \<mapsto> enat (t R) ]"

  sepref_register "mop_per_union"
end

subsection "Implementation Locale"

type_synonym uf = "nat array \<times> nat array"

locale UnionFind_Impl =
  fixes is_uf :: "(nat\<times>nat) set \<Rightarrow> uf \<Rightarrow> assn"
      and uf_init :: "nat \<Rightarrow> uf Heap"
      and uf_init_time :: "nat \<Rightarrow> nat"
      and uf_cmp :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool Heap"
      and uf_cmp_time :: "nat \<Rightarrow> nat"
      and uf_union :: "uf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> uf Heap"
      and uf_union_time :: "nat \<Rightarrow> nat"
    assumes
per_init'_sepref_rule[sepref_fr_rules]:  "\<And>t x' x. uf_init_time x' \<le> t x' \<Longrightarrow>
     hn_refine (hn_ctxt nat_assn x' x) (uf_init x)
         (hn_ctxt nat_assn x' x)
             is_uf (PR_CONST (mop_per_init t) $  x' )"

  and

per_compare_sepref_rule[sepref_fr_rules]:  "\<And>t R' R a' a b' b . uf_cmp_time (card (Domain R')) \<le> t R' \<Longrightarrow>
     hn_refine (hn_ctxt is_uf R' R * hn_ctxt nat_assn a' a * hn_ctxt nat_assn b' b) (uf_cmp R a b)
         (hn_ctxt is_uf R' R * hn_ctxt nat_assn a' a * hn_ctxt nat_assn b' b)
             bool_assn (PR_CONST (mop_per_compare t) $  R' $ a' $ b' )"

  and

per_union_sepref_rule[sepref_fr_rules]:  "\<And>t R' R a' a b' b . a' \<in> Domain R' \<Longrightarrow> b' \<in> Domain R'
  \<Longrightarrow> uf_union_time (card (Domain R')) \<le> t R' \<Longrightarrow>
     hn_refine (hn_ctxt is_uf R' R * hn_ctxt nat_assn a' a * hn_ctxt nat_assn b' b) (uf_union R a b)
         (hn_invalid is_uf R' R * hn_ctxt nat_assn a' a * hn_ctxt nat_assn b' b)
             is_uf (PR_CONST (mop_per_union t) $  R' $ a' $ b' )"

begin

thm per_init'_sepref_rule[to_hfref]
thm per_compare_sepref_rule[to_hfref]
thm per_union_sepref_rule[to_hfref]

end

end


(*  Title:      HOL/Auth/Guard/Guard_Public.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2002  University of Cambridge

Lemmas on guarded messages for public protocols.
*)

theory Guard_Public imports Guard "../Public" Extensions begin

subsection\<open>Extensions to Theory \<open>Public\<close>\<close>

declare initState.simps [simp del]

subsubsection\<open>signature\<close>

definition sign :: "agent => msg => msg" where
"sign A X == \<lbrace>Agent A, X, Crypt (priK A) (Hash X)\<rbrace>"

lemma sign_inj [iff]: "(sign A X = sign A' X') = (A=A' & X=X')"
by (auto simp: sign_def)

subsubsection\<open>agent associated to a key\<close>

definition agt :: "key => agent" where
"agt K == @A. K = priK A | K = pubK A"

lemma agt_priK [simp]: "agt (priK A) = A"
by (simp add: agt_def)

lemma agt_pubK [simp]: "agt (pubK A) = A"
by (simp add: agt_def)

subsubsection\<open>basic facts about @{term initState}\<close>

lemma no_Crypt_in_parts_init [simp]: "Crypt K X ~:parts (initState A)"
by (cases A, auto simp: initState.simps)

lemma no_Crypt_in_analz_init [simp]: "Crypt K X ~:analz (initState A)"
by auto

lemma no_priK_in_analz_init [simp]: "A ~:bad
==> Key (priK A) ~:analz (initState Spy)"
by (auto simp: initState.simps)

lemma priK_notin_initState_Friend [simp]: "A ~= Friend C
==> Key (priK A) ~: parts (initState (Friend C))"
by (auto simp: initState.simps)

lemma keyset_init [iff]: "keyset (initState A)"
by (cases A, auto simp: keyset_def initState.simps)

subsubsection\<open>sets of private keys\<close>

definition priK_set :: "key set => bool" where
"priK_set Ks == ALL K. K:Ks --> (EX A. K = priK A)"

lemma in_priK_set: "[| priK_set Ks; K:Ks |] ==> EX A. K = priK A"
by (simp add: priK_set_def)

lemma priK_set1 [iff]: "priK_set {priK A}"
by (simp add: priK_set_def)

lemma priK_set2 [iff]: "priK_set {priK A, priK B}"
by (simp add: priK_set_def)

subsubsection\<open>sets of good keys\<close>

definition good :: "key set => bool" where
"good Ks == ALL K. K:Ks --> agt K ~:bad"

lemma in_good: "[| good Ks; K:Ks |] ==> agt K ~:bad"
by (simp add: good_def)

lemma good1 [simp]: "A ~:bad ==> good {priK A}"
by (simp add: good_def)

lemma good2 [simp]: "[| A ~:bad; B ~:bad |] ==> good {priK A, priK B}"
by (simp add: good_def)

subsubsection\<open>greatest nonce used in a trace, 0 if there is no nonce\<close>

primrec greatest :: "event list => nat"
where
  "greatest [] = 0"
| "greatest (ev # evs) = max (greatest_msg (msg ev)) (greatest evs)"

lemma greatest_is_greatest: "Nonce n:used evs ==> n <= greatest evs"
apply (induct evs, auto simp: initState.simps)
apply (drule used_sub_parts_used, safe)
apply (drule greatest_msg_is_greatest, arith)
by simp

subsubsection\<open>function giving a new nonce\<close>

definition new :: "event list => nat" where
"new evs == Suc (greatest evs)"

lemma new_isnt_used [iff]: "Nonce (new evs) ~:used evs"
by (clarify, drule greatest_is_greatest, auto simp: new_def)

subsection\<open>Proofs About Guarded Messages\<close>

subsubsection\<open>small hack necessary because priK is defined as the inverse of pubK\<close>

lemma pubK_is_invKey_priK: "pubK A = invKey (priK A)"
by simp

lemmas pubK_is_invKey_priK_substI = pubK_is_invKey_priK [THEN ssubst]

lemmas invKey_invKey_substI = invKey [THEN ssubst]

lemma "Nonce n:parts {X} ==> Crypt (pubK A) X:guard n {priK A}"
apply (rule pubK_is_invKey_priK_substI, rule invKey_invKey_substI)
by (rule Guard_Nonce, simp+)

subsubsection\<open>guardedness results\<close>

lemma sign_guard [intro]: "X:guard n Ks ==> sign A X:guard n Ks"
by (auto simp: sign_def)

lemma Guard_init [iff]: "Guard n Ks (initState B)"
by (induct B, auto simp: Guard_def initState.simps)

lemma Guard_knows_max': "Guard n Ks (knows_max' C evs)
==> Guard n Ks (knows_max C evs)"
by (simp add: knows_max_def)

lemma Nonce_not_used_Guard_spies [dest]: "Nonce n ~:used evs
==> Guard n Ks (spies evs)"
by (auto simp: Guard_def dest: not_used_not_known parts_sub)

lemma Nonce_not_used_Guard [dest]: "[| evs:p; Nonce n ~:used evs;
Gets_correct p; one_step p |] ==> Guard n Ks (knows (Friend C) evs)"
by (auto simp: Guard_def dest: known_used parts_trans)

lemma Nonce_not_used_Guard_max [dest]: "[| evs:p; Nonce n ~:used evs;
Gets_correct p; one_step p |] ==> Guard n Ks (knows_max (Friend C) evs)"
by (auto simp: Guard_def dest: known_max_used parts_trans)

lemma Nonce_not_used_Guard_max' [dest]: "[| evs:p; Nonce n ~:used evs;
Gets_correct p; one_step p |] ==> Guard n Ks (knows_max' (Friend C) evs)"
apply (rule_tac H="knows_max (Friend C) evs" in Guard_mono)
by (auto simp: knows_max_def)

subsubsection\<open>regular protocols\<close>

definition regular :: "event list set => bool" where
"regular p == ALL evs A. evs:p --> (Key (priK A):parts (spies evs)) = (A:bad)"

lemma priK_parts_iff_bad [simp]: "[| evs:p; regular p |] ==>
(Key (priK A):parts (spies evs)) = (A:bad)"
by (auto simp: regular_def)

lemma priK_analz_iff_bad [simp]: "[| evs:p; regular p |] ==>
(Key (priK A):analz (spies evs)) = (A:bad)"
by auto

lemma Guard_Nonce_analz: "[| Guard n Ks (spies evs); evs:p;
priK_set Ks; good Ks; regular p |] ==> Nonce n ~:analz (spies evs)"
apply (clarify, simp only: knows_decomp)
apply (drule Guard_invKey_keyset, simp+, safe)
apply (drule in_good, simp)
apply (drule in_priK_set, simp+, clarify)
apply (frule_tac A=A in priK_analz_iff_bad)
by (simp add: knows_decomp)+

end


(******************************************************************************
 * Orca: A Functional Correctness Verifier for Imperative Programs
 *       Based on Isabelle/UTP
 *
 * Copyright (c) 2016-2018 Virginia Tech, USA
 *               2016-2018 Technische Universität München, Germany
 *               2016-2018 University of York, UK
 *               2016-2018 Université Paris-Saclay, Univ. Paris-Sud, France
 *
 * This software may be distributed and modified according to the terms of
 * the GNU Lesser General Public License version 3.0 or any later version.
 * Note that NO WARRANTY is provided.
 *
 * See CONTRIBUTORS, LICENSE and CITATION files for details.
 ******************************************************************************)

theory utp_rec_total_des
  imports "../AlgebraicLaws/Algebraic_laws_design"
begin
section {*Total correctness for recursion*}

subsection {*AUX lemmas on healthy fixed points*}

lemma nu_design_is_healthy_des[simp]: (*This should be generated automatically in utp_theory*)
  "\<nu>\<^sub>D F is \<H>\<^bsub>DES\<^esub>"
  by (simp add: is_Hcarrier_is_hdesigns)

lemma nu_normal_design_is_healthy_des[simp]: (*This should be generated automatically in utp_theory*)
  "\<nu>\<^sub>N F is \<H>\<^bsub>NDES\<^esub>"
  by (simp add: is_Ncarrier_is_ndesigns)

lemma mu_design_is_healthy_des[simp]: (*This should be generated automatically in utp_theory*)
  "\<mu>\<^sub>D F is \<H>\<^bsub>DES\<^esub>"
  by (simp add: is_Hcarrier_is_hdesigns)

lemma mu_normal_design_is_healthy_des[simp]: (*This should be generated automatically in utp_theory*)
  "\<mu>\<^sub>N F is \<H>\<^bsub>NDES\<^esub>"
  by (simp add: is_Ncarrier_is_ndesigns)

lemma  design_nu_wf_refine_intro:
  assumes   WF: "wf R"
    and      M: "Mono\<^bsub>uthy_order DES\<^esub> F"
    and      H: "F \<in> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H"
    and      Okey1:"$ok\<acute> \<sharp> p"
    and      Okey2:"$ok\<acute> \<sharp> e"
    and  induct_step:
    "\<And>st. ((p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile> q) \<sqsubseteq> (F((p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile> q))"
  shows "(p \<turnstile> q) \<sqsubseteq> \<nu>\<^sub>D F"
proof -
  {
    fix st
    have "(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile> q \<sqsubseteq> \<nu>\<^sub>D F"
      using WF proof (induction rule: wf_induct_rule)
      case (less st)
      hence 0: "(p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile> q \<sqsubseteq> \<nu>\<^sub>D F"
        by rel_blast
      from M H design_theory_continuous.GFP_lemma2 mono_Monotone_utp_order
      have 1: " (\<nu>\<^sub>D F) \<sqsubseteq> F(\<nu>\<^sub>D F)"
        by blast
      from 0 1 have 2:" (p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile> q \<sqsubseteq> F (\<nu>\<^sub>D F)"
        by simp
      have 3: "F ((p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile> q) \<sqsubseteq> F (\<nu>\<^sub>D F)"
      proof (rule Mono_utp_orderD[OF M "nu_design_is_healthy_des" "design_is_healthy_DES_intro" 0], goal_cases)
        case 1
        then show ?case by (simp add: Okey1 Okey2 unrest)
      qed
      have 4:"(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile> q \<sqsubseteq> \<dots>"
        by (rule induct_step)
      show ?case
        using order_trans[OF 3 4] Okey1 H M design_theory_continuous.GFP_lemma3 dual_order.trans mono_Monotone_utp_order
        by blast
    qed
  }
  thus ?thesis
    by pred_simp
qed

lemma  design_mu_wf_refine_intro:
  assumes   WF: "wf R"
    and      M: "Mono\<^bsub>uthy_order DES\<^esub> F"
    and      H: "F \<in> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H"
    and      Okey1:"$ok\<acute> \<sharp> p"
    and      Okey2:"$ok\<acute> \<sharp> e"
    and  induct_step:
    "\<And>st. ((p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile> q) \<sqsubseteq> (F((p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile> q))"
  shows "(p \<turnstile> q) \<sqsubseteq> \<mu>\<^sub>D  F"
proof -
  {
    fix st
    have "(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile> q \<sqsubseteq> \<mu>\<^sub>D F"
      using WF proof (induction rule: wf_induct_rule)
      case (less st)
      hence 0: "(p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile> q \<sqsubseteq> \<mu>\<^sub>D F"
        by rel_blast
      from M H design_theory_continuous.LFP_lemma3 mono_Monotone_utp_order
      have 1: "\<mu>\<^sub>D F \<sqsubseteq>  F (\<mu>\<^sub>D F)"
        by blast
      from 0 1 have 2:"(p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile> q \<sqsubseteq> F (\<mu>\<^sub>D F)"
        by simp
      have 3: "F ((p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile> q) \<sqsubseteq> F (\<mu>\<^sub>D F)"
      proof (rule Mono_utp_orderD[OF M "mu_design_is_healthy_des" "design_is_healthy_DES_intro" 0], goal_cases)
        case 1
        then show ?case by (simp add: Okey2 Okey1 unrest)
      qed
      have 4:"(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile> q \<sqsubseteq> \<dots>"
        by (rule induct_step)
      show ?case
        using order_trans[OF 3 4] Okey1 H M design_theory_continuous.LFP_lemma2 dual_order.trans mono_Monotone_utp_order
        by blast
    qed
  }
  thus ?thesis
    by pred_simp
qed

lemma rdesign_nu_wf_refine_intro:
  assumes   WF: "wf R"
    and      M: "Mono\<^bsub>uthy_order DES\<^esub> F"
    and      H: "F \<in> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H"
    and  induct_step:
    "\<And>st. ((p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>r q) \<sqsubseteq> (F ((p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q))"
  shows "(p \<turnstile>\<^sub>r q) \<sqsubseteq> \<nu>\<^sub>D F"
proof -
  {
  fix st
  have "(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> \<nu>\<^sub>D F"
    using WF proof (induction rule: wf_induct_rule)
    case (less st)
    hence 0: "(p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> \<nu>\<^sub>D F"
      by rel_blast
    from M H design_theory_continuous.GFP_lemma2 mono_Monotone_utp_order
    have 1: "\<nu>\<^sub>D F \<sqsubseteq>  F (\<nu>\<^sub>D F)"
      by blast
    from 0 1 have 2:"(p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> F (\<nu>\<^sub>D F)"
      by simp
    have 3: "F ((p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q) \<sqsubseteq> F (\<nu>\<^sub>D F)"
      by (auto intro: Mono_utp_orderD M 0)
    have 4:"(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> \<dots>"
      by (rule induct_step)
    show ?case
      using order_trans[OF 3 4] H M design_theory_continuous.GFP_lemma3 dual_order.trans mono_Monotone_utp_order
      by blast
  qed
  }
  thus ?thesis
    by pred_simp
qed

lemma rdesign_mu_wf_refine_intro:
  assumes   WF: "wf R"
    and      M: "Mono\<^bsub>uthy_order DES\<^esub> F"
    and      H: "F \<in> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H"
    and  induct_step:
    "\<And>st. ((p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>r q) \<sqsubseteq> (F ((p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q))"
  shows "(p \<turnstile>\<^sub>r q) \<sqsubseteq> \<mu>\<^sub>D F"
proof -
  {
  fix st
  have "(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> \<mu>\<^sub>D F"
    using WF proof (induction rule: wf_induct_rule)
    case (less st)
    hence 0: "(p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> \<mu>\<^sub>D F"
      by rel_blast
    from M H design_theory_continuous.LFP_lemma3 mono_Monotone_utp_order
    have 1: "\<mu>\<^sub>D F \<sqsubseteq>  F (\<mu>\<^sub>D F)"
      by blast
    from 0 1 have 2:"(p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> F (\<mu>\<^sub>D F)"
      by simp
    have 3: "F ((p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q) \<sqsubseteq> F (\<mu>\<^sub>D F)"
      by (auto intro: Mono_utp_orderD M 0)
    have 4:"(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> \<dots>"
      by (rule induct_step)
    show ?case
      using order_trans[OF 3 4] H M design_theory_continuous.LFP_lemma2 dual_order.trans mono_Monotone_utp_order
      by blast
  qed
  }
  thus ?thesis
    by pred_simp
qed

lemma ndesign_nu_wf_refine_intro:
  assumes   WF: "wf R"
    and      M: "Mono\<^bsub>uthy_order NDES\<^esub> F"
    and      H: "F \<in> \<lbrakk>\<^bold>N\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>N\<rbrakk>\<^sub>H"
    and  induct_step:
    "\<And>st. ((p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n q) \<sqsubseteq> (F ((p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q))"
  shows "(p \<turnstile>\<^sub>n q) \<sqsubseteq> \<nu>\<^sub>N F"
proof -
  {
  fix st
  have "(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> \<nu>\<^sub>N F"
    using WF proof (induction rule: wf_induct_rule)
    case (less st)
    hence 0: "(p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> \<nu>\<^sub>N F"
      by rel_blast
    from M H normal_design_theory_continuous.GFP_lemma2 mono_Monotone_utp_order
    have 1: "\<nu>\<^sub>N F \<sqsubseteq>  F (\<nu>\<^sub>N F)"
      by blast
    from 0 1 have 2:"(p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> F (\<nu>\<^sub>N F)"
      by simp
    have 3: "F((p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q) \<sqsubseteq> F (\<nu>\<^sub>N F)"
      by (auto intro: Mono_utp_orderD M 0)
    have 4:"(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> \<dots>"
      by (rule induct_step)
    show ?case
      using order_trans[OF 3 4] H M normal_design_theory_continuous.GFP_lemma3 dual_order.trans mono_Monotone_utp_order
      by blast
  qed
  }
  thus ?thesis
    by pred_simp
qed

lemma ndesign_mu_wf_refine_intro:
  assumes   WF: "wf R"
    and      M: "Mono\<^bsub>uthy_order NDES\<^esub> F"
    and      H: "F \<in> \<lbrakk>\<^bold>N\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>N\<rbrakk>\<^sub>H"
    and  induct_step:
    "\<And>st. ((p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n q) \<sqsubseteq> (F ((p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q))"
  shows "(p \<turnstile>\<^sub>n q) \<sqsubseteq> \<mu>\<^sub>N F"
proof -
  {
  fix st
  have "(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> \<mu>\<^sub>N F"
    using WF proof (induction rule: wf_induct_rule)
    case (less st)
    hence 0: "(p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> \<mu>\<^sub>N F"
      by rel_blast
    from M H normal_design_theory_continuous.LFP_lemma3 mono_Monotone_utp_order
    have 1: "\<mu>\<^sub>N F \<sqsubseteq>  F (\<mu>\<^sub>N F)"
      by blast
    from 0 1 have 2:"(p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> F (\<mu>\<^sub>N F)"
      by simp
    have 3: "F((p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q) \<sqsubseteq> F (\<mu>\<^sub>N F)"
      by (auto intro: Mono_utp_orderD M 0)
    have 4:"(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> \<dots>"
      by (rule induct_step)
    show ?case
      using order_trans[OF 3 4] H M normal_design_theory_continuous.LFP_lemma2 dual_order.trans mono_Monotone_utp_order
      by blast
  qed
  }
  thus ?thesis
    by pred_simp
qed
end


(*  Title:       Compose
    Authors:     Jasmin Blanchette, Andrei Popescu, Dmitriy Traytel
    Maintainer:  Dmitriy Traytel <traytel at inf.ethz.ch>
*)

section \<open>Normalized Composition of BNFs\<close>

text \<open>Expected normal form: outer m-ary BNF is composed with m inner n-ary BNFs.\<close>

(*<*)
theory Compose
  imports "HOL-Library.BNF_Axiomatization"
begin
(*>*)

unbundle cardinal_syntax

declare [[bnf_internals]]
bnf_axiomatization (dead 'p1, F1set1: 'a1, F1set2: 'a2) F1
  [wits: "('p1, 'a1, 'a2) F1"]
  for map: F1map rel: F1rel
bnf_axiomatization (dead 'p2, F2set1: 'a1, F2set2: 'a2) F2
  [wits: "'a1 \<Rightarrow> ('p2, 'a1, 'a2) F2" "'a2 \<Rightarrow> ('p2, 'a1, 'a2) F2"]
  for map: F2map rel: F2rel
bnf_axiomatization (dead 'p3, F3set1: 'a1, F3set2: 'a2) F3
  [wits: "'a1 \<Rightarrow> 'a2 \<Rightarrow> ('p3, 'a1, 'a2) F3"]
  for map: F3map rel: F3rel
bnf_axiomatization (dead 'p, Gset1: 'b1, Gset2: 'b2, Gset3: 'b3) G
  [wits: "'b1 \<Rightarrow> 'b3 \<Rightarrow> ('p, 'b1, 'b2, 'b3) G" "'b2 \<Rightarrow> 'b3 \<Rightarrow> ('p, 'b1, 'b2, 'b3) G"]
  for map: Gmap rel: Grel
type_synonym ('p1, 'p2, 'p3, 'p, 'a1, 'a2) H =
  "('p, ('p1, 'a1, 'a2) F1, ('p2, 'a1, 'a2) F2, ('p3, 'a1, 'a2) F3) G"
type_synonym ('p1, 'p2, 'p3, 'p) Hbd_type =
  "('p1 bd_type_F1 + 'p2 bd_type_F2 + 'p3 bd_type_F3) \<times> 'p bd_type_G"

abbreviation F1in where "F1in A1 A2 \<equiv> {x. F1set1 x \<subseteq> A1 \<and> F1set2 x \<subseteq> A2}"
abbreviation F2in where "F2in A1 A2 \<equiv> {x. F2set1 x \<subseteq> A1 \<and> F2set2 x \<subseteq> A2}"
abbreviation F3in where "F3in A1 A2 \<equiv> {x. F3set1 x \<subseteq> A1 \<and> F3set2 x \<subseteq> A2}"
abbreviation Gin where "Gin A1 A2 A3 \<equiv> {x. Gset1 x \<subseteq> A1 \<and> Gset2 x \<subseteq> A2 \<and> Gset3 x \<subseteq> A3}"

abbreviation Gset where
  "Gset \<equiv> BNF_Def.collect {Gset1, Gset2, Gset3}"

abbreviation Hmap :: "('a1 \<Rightarrow> 'b1) \<Rightarrow> ('a2 \<Rightarrow> 'b2) \<Rightarrow>
  ('p1, 'p2, 'p3, 'p, 'a1, 'a2) H \<Rightarrow> ('p1, 'p2, 'p3, 'p, 'b1, 'b2) H" where
  "Hmap f g \<equiv> Gmap (F1map f g) (F2map f g) (F3map f g)"

abbreviation Hset1 :: "('p1, 'p2, 'p3, 'p, 'a1, 'a2) H \<Rightarrow> 'a1 set" where
  "Hset1 \<equiv> Union o Gset o Gmap F1set1 F2set1 F3set1"

abbreviation Hset2 :: "('p1, 'p2, 'p3, 'p, 'a1, 'a2) H \<Rightarrow> 'a2 set" where
  "Hset2 \<equiv> Union o Gset o Gmap F1set2 F2set2 F3set2"

lemma Hset1_alt:
  "Hset1 = Union o BNF_Def.collect {image F1set1 o Gset1, image F2set1 o Gset2, image F3set1 o Gset3}"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_set_alt_tac @{context} @{thm G.collect_set_map}\<close>)

lemma Hset2_alt:
  "Hset2 = Union o BNF_Def.collect {image F1set2 o Gset1, image F2set2 o Gset2, image F3set2 o Gset3}"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_set_alt_tac @{context} @{thm G.collect_set_map}\<close>)

abbreviation Hbd where
  "Hbd \<equiv> (bd_F1 +c bd_F2 +c bd_F3) *c bd_G"

theorem Hmap_id: "Hmap id id = id"
  unfolding G.map_id0 F1.map_id0 F2.map_id0 F3.map_id0 ..

theorem Hmap_cong: "\<lbrakk>\<And>z. z \<in> Hset1 x \<Longrightarrow> f1 z = g1 z; \<And>z. z \<in> Hset2 x \<Longrightarrow> f2 z = g2 z\<rbrakk> \<Longrightarrow>
  Hmap f1 f2 x = Hmap g1 g2 x"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_map_cong0_tac @{context}
  [] @{thms Hset1_alt Hset2_alt} @{thm G.map_cong0} @{thms F1.map_cong0 F2.map_cong0 F3.map_cong0}\<close>)

theorem Hset1_natural: "Hset1 o Hmap f1 f2 = image f1 o Hset1"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_set_map0_tac @{context} @{thm refl} @{thm G.map_comp0} @{thm G.map_cong0}
  @{thm G.collect_set_map} @{thms F1.set_map0(1) F2.set_map0(1) F3.set_map0(1)}\<close>)

theorem Hbd_card_order: "card_order Hbd"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_bd_card_order_tac @{context}
  @{thms F1.bd_card_order F2.bd_card_order F3.bd_card_order} @{thm G.bd_card_order}\<close>)

theorem Hbd_cinfinite: "cinfinite Hbd"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_bd_cinfinite_tac @{context}
  @{thm F1.bd_cinfinite} @{thm G.bd_cinfinite}\<close>)

theorem Hset1_bd: "|Hset1 (x :: ('p1, 'p2, 'p3, 'p, 'a1, 'a2) H )| \<le>o
  (Hbd :: ('p1, 'p2, 'p3, 'p) Hbd_type rel)"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_set_bd_tac @{context} @{thm refl} NONE @{thm Hset1_alt}
      @{thms comp_single_set_bd[OF F1.bd_Card_order F1.set_bd(1) G.set_bd(1)]
             comp_single_set_bd[OF F2.bd_Card_order F2.set_bd(1) G.set_bd(2)]
             comp_single_set_bd[OF F3.bd_Card_order F3.set_bd(1) G.set_bd(3)]}\<close>)

theorem Hset2_bd: "|Hset2 (x :: ('p1, 'p2, 'p3, 'p, 'a1, 'a2) H )| \<le>o
  (Hbd :: ('p1, 'p2, 'p3, 'p) Hbd_type rel)"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_set_bd_tac @{context} @{thm refl} NONE @{thm Hset2_alt}
      @{thms comp_single_set_bd[OF F1.bd_Card_order F1.set_bd(2) G.set_bd(1)]
             comp_single_set_bd[OF F2.bd_Card_order F2.set_bd(2) G.set_bd(2)]
             comp_single_set_bd[OF F3.bd_Card_order F3.set_bd(2) G.set_bd(3)]}\<close>)

abbreviation Hin where "Hin A1 A2 \<equiv> {x. Hset1 x \<subseteq> A1 \<and> Hset2 x \<subseteq> A2}"

lemma Hin_alt: "Hin A1 A2 = Gin (F1in A1 A2) (F2in A1 A2) (F3in A1 A2)"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_in_alt_tac @{context} @{thms Hset1_alt Hset2_alt}\<close>)

definition Hwit1 where "Hwit1 b c = wit1_G wit_F1 (wit_F3 b c)"
definition Hwit21 where "Hwit21 b c = wit2_G (wit1_F2 b) (wit_F3 b c)"
definition Hwit22 where "Hwit22 b c = wit2_G (wit2_F2 c) (wit_F3 b c)"

lemma Hwit1:
  "\<And>x. x \<in> Hset1 (Hwit1 b c) \<Longrightarrow> x = b"
  "\<And>x. x \<in> Hset2 (Hwit1 b c) \<Longrightarrow> x = c"
  unfolding Hwit1_def
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_wit_tac @{context} [] @{thms G.wit1 G.wit2}
  @{thm G.collect_set_map} @{thms F1.wit F2.wit1 F2.wit2 F3.wit}\<close>)

lemma Hwit21:
  "\<And>x. x \<in> Hset1 (Hwit21 b c) \<Longrightarrow> x = b"
  "\<And>x. x \<in> Hset2 (Hwit21 b c) \<Longrightarrow> x = c"
  unfolding Hwit21_def
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_wit_tac @{context} [] @{thms G.wit1 G.wit2}
  @{thm G.collect_set_map} @{thms F1.wit F2.wit1 F2.wit2 F3.wit}\<close>)

lemma Hwit22:
  "\<And>x. x \<in> Hset1 (Hwit22 b c) \<Longrightarrow> x = b"
  "\<And>x. x \<in> Hset2 (Hwit22 b c) \<Longrightarrow> x = c"
  unfolding Hwit22_def
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_wit_tac @{context} [] @{thms G.wit1 G.wit2}
  @{thm G.collect_set_map} @{thms F1.wit F2.wit1 F2.wit2 F3.wit}\<close>)

(* Relator structure for H *)

lemma Grel_cong: "\<lbrakk>R1 = S1; R2 = S2; R3 = S3\<rbrakk> \<Longrightarrow> Grel R1 R2 R3 = Grel S1 S2 S3"
  by hypsubst (rule refl)

definition Hrel where
  "Hrel R1 R2 = (BNF_Def.Grp (Hin (Collect (case_prod R1)) (Collect (case_prod R2))) (Hmap fst fst))^--1 OO
                (BNF_Def.Grp (Hin (Collect (case_prod R1)) (Collect (case_prod R2))) (Hmap snd snd))"

lemmas Hrel_unfold = trans[OF Hrel_def trans[OF OO_Grp_cong[OF Hin_alt]
      trans[OF arg_cong2[of _ _ _ _ relcompp, OF trans[OF arg_cong[of _ _ conversep, OF sym[OF G.rel_Grp]] G.rel_conversep[symmetric]] sym[OF G.rel_Grp]]
        trans[OF G.rel_compp[symmetric] Grel_cong[OF sym[OF F1.rel_compp_Grp] sym[OF F2.rel_compp_Grp] sym[OF F3.rel_compp_Grp]]]]]]

bnf H: "('p1, 'p2, 'p3, 'p, 'a1, 'a2) H"
  map: Hmap
  sets: Hset1 Hset2
  bd: "Hbd :: ('p1, 'p2, 'p3, 'p) Hbd_type rel"
  rel: Hrel
            apply -
            apply (rule Hmap_id)
           apply (rule Hmap_comp)
          apply (erule Hmap_cong) apply assumption
         apply (rule Hset1_natural)
        apply (rule Hset2_natural)
       apply (rule Hbd_card_order)
      apply (rule Hbd_cinfinite)
     apply (rule Hset1_bd)
    apply (rule Hset2_bd)
   apply (unfold Hrel_unfold G.rel_compp[symmetric] F1.rel_compp[symmetric] F2.rel_compp[symmetric] F3.rel_compp[symmetric] eq_OO) [1] apply (rule order_refl)
  apply (rule Hrel_def[unfolded OO_Grp_alt mem_Collect_eq])
  done

(*<*)
end
(*>*)


(*
   Copyright 2016 Yoichi Hirai

   Licensed under the Apache License, Version 2.0 (the "License");
   you may not use this file except in compliance with the License.
   You may obtain a copy of the License at

       http://www.apache.org/licenses/LICENSE-2.0

   Unless required by applicable law or agreed to in writing, software
   distributed under the License is distributed on an "AS IS" BASIS,
   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
   See the License for the specific language governing permissions and
   limitations under the License.
*)

section {* What can Happen during a Contract Invocation *}

text {* This section defines a set of sequence of account states that can appeear during an
invocation of a countract.  The invocation can be a nested reentrancy, but we focus on one
invocation.  This means we do not look into details of further reentrancy, but just assume
that the inner reentrancy keeps the invariant of the contract.  Of course we need to prove
that the invariant holds for the code, but when we do that we can assume that the inner
nested calls keep the invariants (we can say we are doing mathematical induction on the depth
of reentrancy)\footnote{This poses troubles dealing with DELEGATECALL and CALLCODE instructions.
Currently execution of these instructions causes an immediate annotation failure.}.  *}

theory RelationalSem

imports Main "./ContractSem"

begin

subsection {* Some Possible Changes on Our Account State *}

text {* The account state might change even when the account's code is not executing. *}

text {* Between blocks, the account might gain balances because somebody mines
Eth for the account.  Even within a single block,
the balance might increase also while other contracts execute
because they might destroy themselves and send their balance to our account.
When a transaction finishes, if our contract is marked as killed, it is destroyed.
The following relation captures these possibilities.
*}

inductive account_state_natural_change :: "account_state \<Rightarrow> account_state \<Rightarrow> bool"
where
natural: -- {* The balance of this account might increase
whenever the code in our contract is not executing.  Some other account might
destroy itself and give its balance to our account.  *}
 "old_bal \<le> new_bal \<Longrightarrow>
  account_state_natural_change
   \<lparr> account_address = addr
   , account_storage = str
   , account_code = code
   , account_balance = old_bal
   , account_ongoing_calls = going
   , account_killed = killed
   \<rparr>
   \<lparr> account_address = addr
   , account_storage = str
   , account_code = code
   , account_balance = new_bal
   , account_ongoing_calls = going
   , account_killed = killed
   \<rparr>"
| cleaned: -- {* This happens only at the end of a transaction, but we don't know
              the transaction boundaries.
              So this can happen at any moment when there are no ongoing calls.  *}
  "account_state_natural_change
  \<lparr> account_address = addr
  , account_storage = str
  , account_code = code
  , account_balance = old_bal
  , account_ongoing_calls = []
  , account_killed = True
  \<rparr>
  (empty_account addr)"

declare account_state_natural_change.simps [simp]

text {* When the execution comes back from an external call, the account state might have changed
arbitrarily.  Our strategy is to assume that an invariant is kept here; and later prove that
the invariant actually holds (that is, for fewer depth of reentrancy).
The whole argument can be seen as a mathematical induction over depths of reentrancy, though
this idea has not been formalized yet. *}

inductive account_state_return_change ::
"(account_state \<Rightarrow> bool) \<Rightarrow> account_state \<Rightarrow> account_state \<Rightarrow> bool"
where
account_return:
"invariant
 \<lparr> account_address = addr
 , account_storage = new_str
 , account_code = code
 , account_balance = new_bal
 , account_ongoing_calls = ongoing
 , account_killed = new_killed
 \<rparr>
 \<Longrightarrow>
 account_state_return_change
 invariant
 \<lparr> account_address = addr
 , account_storage = old_str
 , account_code = code
 , account_balance = old_bal
 , account_ongoing_calls = ongoing
 , account_killed = killed
 \<rparr>
 \<lparr> account_address = addr
 , account_storage = new_str
 , account_code = code
 , account_balance = new_bal
 , account_ongoing_calls = ongoing
 , account_killed = new_killed
 \<rparr>
 "

declare account_state_return_change.simps [simp]

text "Next we specify which program results might see a return."

fun returnable_result :: "instruction_result \<Rightarrow> bool"
where
  "returnable_result (InstructionContinue _) = False"
| "returnable_result (InstructionToEnvironment (ContractCall _) _ _) = True"
| "returnable_result (InstructionToEnvironment (ContractDelegateCall _) _ _) = False"
| "returnable_result (InstructionToEnvironment (ContractCreate _) _ _) = True"
| "returnable_result (InstructionToEnvironment (ContractSuicide _) _ _) = False"
| "returnable_result (InstructionToEnvironment (ContractFail _) _ _) = False"
-- {* because we are not modeling nested calls here, the effect of the nested calls are modeled in
      account\_state\_return\_change *}
| "returnable_result (InstructionToEnvironment (ContractReturn _) _ _) = False"

fun returnable_from_delegate_call :: "instruction_result \<Rightarrow> bool"
where
  "returnable_from_delegate_call (InstructionContinue _) = False"
| "returnable_from_delegate_call (InstructionToEnvironment (ContractCall _) _ _) = False"
| "returnable_from_delegate_call (InstructionToEnvironment (ContractDelegateCall _) _ _) = True"
| "returnable_from_delegate_call (InstructionToEnvironment (ContractCreate _) _ _) = False"
| "returnable_from_delegate_call (InstructionToEnvironment (ContractSuicide _) _ _) = False"
| "returnable_from_delegate_call (InstructionToEnvironment (ContractFail _) _ _) = False"
-- {* because we are not modeling nested calls here, the effect of the nested calls are modeled in
      account\_state\_return\_change *}
| "returnable_from_delegate_call (InstructionToEnvironment (ContractReturn _) _ _) = False"

subsection {* A Round of the Game *}

text {* Now we are ready to specify the environment's turn. *}

datatype environment_input =
    Execution "instruction_result"
  | Init "call_env"

inductive environment_turn ::
"(account_state \<Rightarrow> bool) (* The invariant of our contract*)
\<Rightarrow> (account_state * environment_input)
   (* the account state before the environment's move
      and the last thing our account did *)
\<Rightarrow> (account_state * variable_ctx)
   (* the account state after the environment's move
      and the variable environment from which our contract must start. *)
\<Rightarrow> bool (* a boolean indicating if that is a possible environment's move. *)"
where
  environment_call: -- {* the environment might call our contract.  We only consider the initial invocation here
  because the deeper reentrant invocations are considered as a part of the adversarial environment.
  The deeper reentrant invocations are performed without the environment replying to the contract. *}
  "(* If a variable environment is built from the old account state *)
   (* and the call arguments, *)
   build_vctx_called old_state callargs next_vctx \<Longrightarrow>

   (* the environment makes a move, showing the variable environment. *)
   environment_turn I (old_state, Init callargs) (old_state, next_vctx)"
| environment_return: -- {* the environment might return to our contract. *}
  "(* If the account state can be changed during reentrancy,*)
   account_state_return_change I account_state_going_out account_state_back \<Longrightarrow>

   (* and a variable environment can be recovered from the changed account state,*)
   build_vctx_returned account_state_back result new_v \<Longrightarrow>

   (* and the previous move of the contract was a call-like action, *)
   returnable_result program_r \<Longrightarrow>

   (* the environment can make a move, telling the contract to continue with *)
   (* the variable environment. *)
   environment_turn I (account_state_going_out, Execution program_r)
                (account_state_pop_ongoing_call account_state_back, new_v)"

| environment_return_after_delegate_call: -- {* the environment might return to our contract. *}
  "(* If the account state can be changed during reentrancy,*)
   (* the account state might be completely broken *)
   build_vctx_returned account_state_back result new_v \<Longrightarrow>

   (* and the previous move of the contract was a call-like action, *)
   returnable_from_delegate_call program_r \<Longrightarrow>

   (* the environment can make a move, telling the contract to continue with *)
   (* the variable environment. *)
   environment_turn I (account_state_going_out, Execution program_r)
                (account_state_pop_ongoing_call account_state_back, new_v)"

| environment_fail: -- {* the environment might fail from an account into our contract. *}
  "(* If a variable environment can be recovered from the previous account state,*)
   build_vctx_failed account_state_going_out = Some new_v \<Longrightarrow>

   (* and if the previous action from the contract was a call, *)
   returnable_result result = True \<Longrightarrow>

   (* the environment can make a move, telling the contract to continue with *)
   (* the variable environment. *)
   environment_turn I (account_state_going_out, Execution result)
                (account_state_pop_ongoing_call account_state_going_out, new_v)"

text {* As a reply, our contract might make a move, or report an annotation failure.*}

inductive contract_turn ::
"network \<Rightarrow> (account_state * variable_ctx) \<Rightarrow> (account_state * environment_input) \<Rightarrow> bool"
where
  contract_to_environment:
  "(* Under a constant environment built from the old account state, *)
   build_cctx old_account = cctx \<Longrightarrow>

   (* if the program behaves like this, *)
   program_sem k cctx steps net (InstructionContinue old_vctx)
      = InstructionToEnvironment act v opt_v \<Longrightarrow>

   (* and if the account state is updated from the program's result, *)
   account_state_going_out
     = update_account_state old_account act v opt_v \<Longrightarrow>

   (* the contract makes a move and udates the account state. *)
   contract_turn net (old_account, old_vctx)
      (account_state_going_out, Execution (InstructionToEnvironment act v opt_v))"

text {* When we combine the environment's turn and the contract's turn, we get one round.
The round is a binary relation over a single set.
*}

inductive one_round ::
"network \<Rightarrow> (account_state \<Rightarrow> bool) \<Rightarrow>
(account_state * environment_input) \<Rightarrow>
(account_state * environment_input) \<Rightarrow> bool"
where
round:
"environment_turn I a b \<Longrightarrow> contract_turn net b c \<Longrightarrow> one_round net I a c"

subsection {* Repetitions of rounds *}

text {* So, we can repeat rounds and see where they bring us.  *}
text {* The definition is taken from the book Concrete Semantics, and then modified *}
inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

text {* The repetition of rounds is either zero-times or once and a repetition. *}
lemma star_case :
"star r a c \<Longrightarrow>
 (a = c \<or> (\<exists> b. r a b \<and> star r b c))"
apply(induction rule: star.induct; auto)
done

text {* The next lemma is purely for convenience.
Actually the rounds can go nowhere after this invocation fails.
*}
lemma no_entry_fail [dest!]:
"star (one_round net I)
      (a, Execution (InstructionToEnvironment (ContractFail x) v v_opt))
      (b, c) \<Longrightarrow> b = a \<and> c = Execution (InstructionToEnvironment (ContractFail x) v v_opt)"
apply(drule star_case; simp)
apply(simp add: one_round.simps add: environment_turn.simps)
done

text {* Similarly, the rounds can go nowhere after this invocation returns. *}
lemma no_entry_return [dest!]:
"star (one_round net I)
      (a, Execution (InstructionToEnvironment (ContractReturn data) v v_opt))
      (b, c) \<Longrightarrow> b = a \<and> c = Execution (InstructionToEnvironment (ContractReturn data) v v_opt)"
apply(drule star_case; simp)
apply(simp add: one_round.simps add: environment_turn.simps)
done

text {* Also similarly, the rounds can go nowhere after this invocation
causes our contract to destroy itself.
*}
lemma no_entry_suicide [dest!]:
"star (one_round net I)
      (a, Execution (InstructionToEnvironment (ContractSuicide dst) v v_opt))
      (b, c) \<Longrightarrow> b = a \<and> c = Execution (InstructionToEnvironment (ContractSuicide dst) v v_opt)"
apply(drule star_case; simp)
apply(simp add: one_round.simps add: environment_turn.simps)
done

subsection {* How to State an Invariant *}

text {* For any invariant @{term I} over account states, now @{term "star net (one_round I)"}
relation shows all possibilities during one invocation\footnote{More precisely,
this transitive closure of rounds guides us through all the possible states when the contract loses the control flow.}, assuming that the
invariant is kept during external calls\footnote{This assumption about deeper reentrancy should
be considered as an induction hypothesis.  There has to be a lemma actually perform
such induction.}.
The following template traverses the states and states that the invariant is actually kept
after every possible round.  Also the template states that no annotation failures happen.
When I state something, I will be then obliged to prove the statement.  This happens in the next section.
*}

text {* I define the conjunction of the properties requested at the final states.
The whole thing is more readable when I inline-expand @{term invariant_holds_post},
but if I do that, the @{text auto} tactic splits out a subgoal for each conjunct.
This doubles the already massive number of subgoals.
*}

definition invariant_holds_post ::
  "(account_state \<Rightarrow> bool) \<Rightarrow> (account_state \<times> environment_input) \<Rightarrow> bool"
where
"invariant_holds_post I fin =
 (I (fst fin)(* The invariant holds. *))
"

lemma invariant_holds_in_fail [simp] :
"I state \<Longrightarrow>
 invariant_holds_post I (state, Execution (InstructionToEnvironment (ContractFail x) v v_opt))"
apply(simp add: invariant_holds_post_def)
done

text {* @{term "invariant_holds"} is a template for statements.
It takes a single argument @{term I} for the invariant.
The invariant is assumed to hold at the initial state.
The initial state is when the contract is called (this can be the first
invocation of this contract in this transaction, or a reentrancy).
The statement will request us to prove that the invariant also
holds whenever the invocation loses the control flow.
The invocation loses the control flow when the contract returns or fails
from the invocation, and also when it calls an account.
When the contract calls an account, the invocation does not finish so
I need to verify further final states against the postconditions, after
the call finishes.
The repetition is captured by the transitive closure
@{term "star (one_round net I)"}.

We prove the invariant when our contract calls out,
and we assume that reentrancy into this contract will
keep the invariant.
The whole argument can be seen as a mathematical induction
over the depth of reentrancy.  So we can assume that
reentrancy of a fewer depth keeps the invariant.
This idea comes from Christian Reitwiessner's treatment of
reentrancy in Why ML.
I have not justified the idea in Isabelle/HOL.
*}

definition invariant_holds :: "network \<Rightarrow> (account_state \<Rightarrow> bool) \<Rightarrow> bool"
where
"invariant_holds net (I :: account_state \<Rightarrow> bool) \<equiv>
  (\<forall> addr str code bal ongoing killed callenv.
    I \<lparr> account_address = addr, account_storage = str, account_code = code,
       account_balance = bal,
       account_ongoing_calls = ongoing,
       account_killed = killed \<rparr> \<longrightarrow>
  (\<forall> fin. star (one_round net I) (
    \<lparr> account_address = addr, account_storage = str, account_code = code,
      account_balance = bal,
      account_ongoing_calls = ongoing,
      account_killed = killed \<rparr>
  , Init callenv) fin \<longrightarrow>
  invariant_holds_post I fin))"

subsection {* How to State a Pre-Post Condition Pair *}

text {* After proving a theorem of the above form, I might be interested in
a more specific case (e.g.\,if the caller is not this particular account, nothing should change).
For that purpose, here is another template statement.  This contains everything above plus
an assumption about the initial call, and a conclusion about the state after the invocation.
*}

text {* I pack everything that I want when the contract fails or returns.
This definition reduces the number of goals that I need to prove.
Without this definition, the @{text auto} tactic
splits a goal @{prop "A \<Longrightarrow> B \<and> D"} into two subgoals @{prop "A \<Longrightarrow> B"} and @{prop "A \<Longrightarrow> D"}.
When I do complicated case analysis on @{prop A}, the number of subgoals grow rapidly.
So, I define @{term packed} to be @{prop "B \<and> D"} and prevent the @{text auto} tactic from noticing that it is a conjunction.
*}

text {* The following snippet says the invariant still holds in the observed final state%
\footnote{After the invocation finishes, some miner can credit Eth to the account under
verification.  The ``observed'' final state is an arbitrary state
after such possible balance increases.}
and the postconditions hold there. *}

definition postcondition_pack
where
"postcondition_pack I postcondition fin_observed initial_account initial_call fin
=
  (I fin_observed \<and>
  postcondition initial_account initial_call (fin_observed, snd fin))"

text {* The whole template takes an invariant @{term I}, a @{term precondition}
and a @{term postcondition}. The statement is about one invocation of the contract.
This invocation can be a reentrancy.  The initial state is when the contract is invoked,
and the final states\footnote{Since I am considering all possible executions, there are multiple
final states.  Also, even when I concetrate on a single execution, every time the contract calls an
account, I have to check the invariants.  Otherwise, I have no knowledge about what happens
during the following reentrancy. } are
when this invocation makes a call to an account, returns or fails.
We further consider natural balance increases\footnote{The balnace of an Ethereum account increases
naturally when a contract destroys itself and sends its balance to our account, for instance.}
and use the ``observed final state'' to
evaluate the post condition.
Of course, in between, there might be nesting reentrant invocations, that might alter
the storage and the balance of the contract.

At the time of invocation, the invariant and the preconditions are assumed.
During reentrant calls (that are deeper than the current invocation),
the statement will request us to prove that the invariant holds at any moment when
the contract loses the control flow (when the contract returns, fails or calls an account).
Also we will be requested to prove that the postcondition holds on these occasions.
The contract regains the control flow after a deeper call finishes, and the contract
would lose the control flow again.
All these requirements are captured by the transitive closure of @{term one_round} relation.
*}

definition pre_post_conditions ::
"network \<Rightarrow> (account_state \<Rightarrow> bool) \<Rightarrow> (account_state \<Rightarrow> call_env \<Rightarrow> bool) \<Rightarrow>
 (account_state \<Rightarrow> call_env \<Rightarrow> (account_state \<times> environment_input) \<Rightarrow> bool) \<Rightarrow> bool"
where
"pre_post_conditions
  net
  (I :: account_state \<Rightarrow> bool)
  (precondition :: account_state \<Rightarrow> call_env\<Rightarrow> bool)
  (postcondition :: account_state \<Rightarrow> call_env \<Rightarrow>
                    (account_state \<times> environment_input) \<Rightarrow> bool) \<equiv>

  (* for any initial call and initial account state that satisfy *)
  (* the invariant and the precondition, *)
  (\<forall> initial_account initial_call. I initial_account \<longrightarrow>
     precondition initial_account initial_call \<longrightarrow>

  (* for any final state that are reachable from these initial conditions, *)
  (\<forall> fin. star (one_round net I) (initial_account, Init initial_call) fin \<longrightarrow>

  (* and for any observed final state after this final state, *)
  (\<forall> fin_observed. account_state_natural_change (fst fin) fin_observed \<longrightarrow>

  (* the postcondition and the invariant holds. *)
  postcondition_pack
  I postcondition fin_observed initial_account initial_call fin)))
"

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

section "Signed Words"

theory Signed_Words
imports "HOL-Word.Word"
begin

text \<open>Signed words as separate (isomorphic) word length class. Useful for tagging words in C.\<close>

typedef ('a::len0) signed = "UNIV :: 'a set" ..

lemma card_signed [simp]: "CARD (('a::len0) signed) = CARD('a)"
  unfolding type_definition.card [OF type_definition_signed]
  by simp

instantiation signed :: (len0) len0
begin

definition
  len_signed [simp]: "len_of (x::'a::len0 signed itself) = LENGTH('a)"

instance ..

end

instance signed :: (len) len
  by (intro_classes, simp)

type_synonym 'a sword = "'a signed word"
type_synonym  sword8 =  "8 sword"
type_synonym sword16 = "16 sword"
type_synonym sword32 = "32 sword"
type_synonym sword64 = "64 sword"

end