(* Author: Andrew Boyton, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

header "Defining some separation logic maps-to predicates on top of the instantiation."

theory Separation_D
imports Abstract_Separation_D
begin

type_synonym sep_pred = "sep_state \<Rightarrow> bool"

definition
  state_sep_projection :: "cdl_state \<Rightarrow> sep_state"
where
  "state_sep_projection \<equiv> \<lambda>s. SepState (cdl_objects s) (cdl_ghost_state s)"

(* This turns a separation logic predicate into a predicate on the capDL state. *)
abbreviation
  lift' :: "(sep_state \<Rightarrow> 'a) \<Rightarrow> cdl_state \<Rightarrow> 'a" ("<_>")
where
  "<P> s \<equiv> P (state_sep_projection s)"

(* The generalisation of the maps to operator for separation logic. *)
definition
  sep_map_general :: "cdl_object_id \<Rightarrow> cdl_object \<Rightarrow> cdl_components \<Rightarrow> sep_pred"
where
  "sep_map_general p obj gs \<equiv> \<lambda>s. sep_heap s = [p \<mapsto> obj] \<and> sep_ghost_state s p = gs"

(* Alternate definition without the [p \<mapsto> obj] notation. *)
lemma sep_map_general_def2:
  "sep_map_general p obj gs s =
   (dom (sep_heap s) = {p} \<and> ko_at obj p (sep_heap s) \<and> sep_ghost_state s p = gs)"
  apply (clarsimp simp: sep_map_general_def object_at_def)
  apply (rule)
   apply clarsimp
  apply (clarsimp simp: fun_upd_def)
  apply (rule ext)
  apply (fastforce simp: dom_def split:split_if)
  done

(* There is an object there. *)
definition
  sep_map_i :: "cdl_object_id \<Rightarrow> cdl_object \<Rightarrow> sep_pred" ("_ \<mapsto>i _" [76,71] 76)
where
  "p \<mapsto>i obj \<equiv> sep_map_general p obj UNIV"

(* The fields are there (and there are no caps). *)
definition
  sep_map_f :: "cdl_object_id \<Rightarrow> cdl_object \<Rightarrow> sep_pred" ("_ \<mapsto>f _" [76,71] 76)
where
  "p \<mapsto>f obj \<equiv> sep_map_general p (update_slots empty obj) {None}"

(* There is that cap there. *)
definition
  sep_map_c :: "cdl_cap_ref \<Rightarrow> cdl_cap \<Rightarrow> sep_pred" ("_ \<mapsto>c _" [76,71] 76)
where
  "p \<mapsto>c cap \<equiv> \<lambda>s. let (obj_id, slot) = p; heap = sep_heap s in
  \<exists>obj. sep_map_general obj_id obj {Some slot} s \<and> object_slots obj = [slot \<mapsto> cap]"

definition
  sep_any :: "('a \<Rightarrow> 'b \<Rightarrow> sep_pred) \<Rightarrow> ('a \<Rightarrow> sep_pred)" where
  "sep_any m \<equiv> (\<lambda>p s. \<exists>v. (m p v) s)"

abbreviation "sep_any_map_i \<equiv> sep_any sep_map_i"
notation sep_any_map_i ("_ \<mapsto>i -" 76)

abbreviation "sep_any_map_c \<equiv> sep_any sep_map_c"
notation sep_any_map_c ("_ \<mapsto>c -" 76)

end


(* Author: Julian Brunner *)
(* This is originally a part of the CAVA model checker *)
theory Sequence
imports
  Basic
  "HOL-Library.Stream"
begin

  (* list basics *)

  declare upt_Suc[simp del]
  declare last.simps[simp del]
  declare butlast.simps[simp del]
  declare Cons_nth_drop_Suc[simp]

  lemma list_pred_cases:
    assumes "list_all P xs"
    obtains (nil) "xs = []" | (cons) y ys where "xs = y # ys" "P y" "list_all P ys"
    using assms by (cases xs) (auto)

  lemma fold_const: "fold const xs a = last (a # xs)"
    by (induct xs arbitrary: a) (auto simp: last.simps)

  lemma take_Suc: "take (Suc n) xs = (if xs = [] then [] else hd xs # take n (tl xs))"
    by (simp add: take_Suc)

  (* stream basics *)

  declare stream.map_id[simp]
  declare stream.set_map[simp]
  declare stream.set_sel(1)[intro!, simp]
  declare stream.pred_map[iff]
  declare stream.rel_map[iff]
  declare shift_simps[simp del]
  declare stake_sdrop[simp]
  declare stake_siterate[simp del]
  declare sdrop_snth[simp]

  lemma stream_pred_cases:
    assumes "pred_stream P xs"
    obtains (scons) y ys where "xs = y ## ys" "P y" "pred_stream P ys"
    using assms by (cases xs) (auto)

  lemma stream_rel_coinduct[case_names stream_rel, coinduct pred: stream_all2]:
    assumes "R u v"
    assumes "\<And> a u b v. R (a ## u) (b ## v) \<Longrightarrow> P a b \<and> R u v"
    shows "stream_all2 P u v"
    using assms by (coinduct) (metis stream.collapse)
  lemma stream_rel_coinduct_shift[case_names stream_rel, consumes 1]:
    assumes "R u v"
    assumes "\<And> u v. R u v \<Longrightarrow>
      \<exists> u\<^sub>1 u\<^sub>2 v\<^sub>1 v\<^sub>2. u = u\<^sub>1 @- u\<^sub>2 \<and> v = v\<^sub>1 @- v\<^sub>2 \<and> u\<^sub>1 \<noteq> [] \<and> v\<^sub>1 \<noteq> [] \<and> list_all2 P u\<^sub>1 v\<^sub>1 \<and> R u\<^sub>2 v\<^sub>2"
    shows "stream_all2 P u v"
  proof -
    have "\<exists> u\<^sub>1 u\<^sub>2 v\<^sub>1 v\<^sub>2. u = u\<^sub>1 @- u\<^sub>2 \<and> v = v\<^sub>1 @- v\<^sub>2 \<and> list_all2 P u\<^sub>1 v\<^sub>1 \<and> R u\<^sub>2 v\<^sub>2"
      using assms(1) by force
    then show ?thesis using assms(2) by (coinduct) (force elim: list.rel_cases)
  qed

  lemmas stream_eq_coinduct[case_names stream_eq, coinduct pred: HOL.eq] =
    stream_rel_coinduct[where ?P = HOL.eq, unfolded stream.rel_eq]
  lemmas stream_eq_coinduct_shift[case_names stream_eq, consumes 1] =
    stream_rel_coinduct_shift[where ?P = HOL.eq, unfolded stream.rel_eq list.rel_eq]

  lemma sset_subset_stream_pred: "sset w \<subseteq> A \<longleftrightarrow> pred_stream (\<lambda> a. a \<in> A) w"
    unfolding stream.pred_set by auto
  lemma stream_pred_snth: "pred_stream P w \<longleftrightarrow> (\<forall> i. P (w !! i))"
    unfolding stream.pred_set sset_range by simp

  lemma stream_pred_shift[iff]: "pred_stream P (u @- v) \<longleftrightarrow> list_all P u \<and> pred_stream P v"
    by (induct u) (auto)
  lemma stream_rel_shift[iff]:
    assumes "length u\<^sub>1 = length v\<^sub>1"
    shows "stream_all2 P (u\<^sub>1 @- u\<^sub>2) (v\<^sub>1 @- v\<^sub>2) \<longleftrightarrow> list_all2 P u\<^sub>1 v\<^sub>1 \<and> stream_all2 P u\<^sub>2 v\<^sub>2"
    using assms by (induct rule: list_induct2) (auto)

  lemma eq_scons: "w = a ## v \<longleftrightarrow> a = shd w \<and> v = stl w" by auto

  lemma stream_all2_sset1:
    assumes "stream_all2 P xs ys"
    shows "\<forall> x \<in> sset xs. \<exists> y \<in> sset ys. P x y"
  proof -
    have "pred_stream (\<lambda> x. \<exists> y \<in> S. P x y) xs" if "sset ys \<subseteq> S" for S
      using assms that by (coinduction arbitrary: xs ys) (force elim: stream.rel_cases)
    then show ?thesis unfolding stream.pred_set by auto
  qed
  lemma stream_all2_sset2:
    assumes "stream_all2 P xs ys"
    shows "\<forall> y \<in> sset ys. \<exists> x \<in> sset xs. P x y"
  proof -
    have "pred_stream (\<lambda> y. \<exists> x \<in> S. P x y) ys" if "sset xs \<subseteq> S" for S
      using assms that by (coinduction arbitrary: xs ys) (force elim: stream.rel_cases)
    then show ?thesis unfolding stream.pred_set by auto
  qed

  lemma smap_eq_scons[iff]: "smap f xs = y ## ys \<longleftrightarrow> f (shd xs) = y \<and> smap f (stl xs) = ys"
    using smap_ctr by metis
  lemma scons_eq_smap[iff]: "y ## ys = smap f xs \<longleftrightarrow> y = f (shd xs) \<and> ys = smap f (stl xs)"
    using smap_ctr by metis
  lemma smap_eq_shift[iff]:
    "smap f w = u @- v \<longleftrightarrow> (\<exists> w\<^sub>1 w\<^sub>2. w = w\<^sub>1 @- w\<^sub>2 \<and> map f w\<^sub>1 = u \<and> smap f w\<^sub>2 = v)"
    using sdrop_smap eq_shift stake_sdrop stake_smap by metis
  lemma shift_eq_smap[iff]:
    "u @- v = smap f w \<longleftrightarrow> (\<exists> w\<^sub>1 w\<^sub>2. w = w\<^sub>1 @- w\<^sub>2 \<and> u = map f w\<^sub>1 \<and> v = smap f w\<^sub>2)"
    using sdrop_smap eq_shift stake_sdrop stake_smap by metis

  lemma siterate_eq_scons[iff]: "siterate f s = a ## w \<longleftrightarrow> s = a \<and> siterate f (f s) = w"
    using siterate.ctr stream.inject by metis
  lemma scons_eq_siterate[iff]: "a ## w = siterate f s \<longleftrightarrow> a = s \<and> w = siterate f (f s)"
    using siterate.ctr stream.inject by metis

  lemma eqI_snth:
    assumes "\<And> i. u !! i = v !! i"
    shows "u = v"
    using assms by (coinduction arbitrary: u v) (metis stream.sel snth.simps)

  lemma set_sset_stake[intro!, simp]: "set (stake n xs) \<subseteq> sset xs"
    by (metis sset_shift stake_sdrop sup_ge1)
  lemma sset_sdrop[intro!, simp]: "sset (sdrop n xs) \<subseteq> sset xs"
    by (metis sset_shift stake_sdrop sup_ge2)

  lemma set_stake_snth: "x \<in> set (stake n xs) \<longleftrightarrow> (\<exists> i < n. xs !! i = x)"
    unfolding in_set_conv_nth by auto

  lemma split_stream_first:
    assumes "x \<in> sset xs"
    obtains ys zs
    where "xs = ys @- x ## zs" "x \<notin> set ys"
  proof
    let ?n = "LEAST n. xs !! n = x"
    have 1: "xs !! ?n = x" using assms unfolding sset_range by (auto intro: LeastI)
    have 2: "xs !! n \<noteq> x" if "n < ?n" for n using that by (metis (full_types) not_less_Least)
    show "xs = stake ?n xs @- x ## sdrop (Suc ?n) xs" using 1 by (metis id_stake_snth_sdrop)
    show "x \<notin> set (stake ?n xs)" using 2 by (meson set_stake_snth)
  qed

  (* scans *)

  fun scan :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b list" where
    "scan f [] a = []" | "scan f (x # xs) a = f x a # scan f xs (f x a)"

  lemma scan_append[simp]: "scan f (xs @ ys) a = scan f xs a @ scan f ys (fold f xs a)"
    by (induct xs arbitrary: a) (auto)

  lemma scan_eq_nil[iff]: "scan f xs a = [] \<longleftrightarrow> xs = []" by (cases xs) (auto)
  lemma scan_eq_cons[iff]:
    "scan f xs a = b # w \<longleftrightarrow> (\<exists> y ys. xs = y # ys \<and> f y a = b \<and> scan f ys (f y a) = w)"
    by (cases xs) (auto)
  lemma scan_eq_append[iff]:
    "scan f xs a = u @ v \<longleftrightarrow> (\<exists> ys zs. xs = ys @ zs \<and> scan f ys a = u \<and> scan f zs (fold f ys a) = v)"
    by (induct u arbitrary: xs a) (auto, metis append_Cons fold_simps(2), blast)

  lemma scan_length[simp]: "length (scan f xs a) = length xs"
    by (induct xs arbitrary: a) (auto)
  lemma scan_last: "last (a # scan f xs a) = fold f xs a"
    by (induct xs arbitrary: a) (auto simp: last.simps)

  lemma scan_const[simp]: "scan const xs a = xs"
    by (induct xs arbitrary: a) (auto)
  lemma scan_nth[simp]:
    assumes "i < length (scan f xs a)"
    shows "scan f xs a ! i = fold f (take (Suc i) xs) a"
    using assms by (cases xs, simp, induct i arbitrary: xs a, auto simp: take_Suc neq_Nil_conv)
  lemma scan_map[simp]: "scan f (map g xs) a = scan (f \<circ> g) xs a"
    by (induct xs arbitrary: a) (auto)
  lemma scan_take[simp]: "take k (scan f xs a) = scan f (take k xs) a"
    by (induct k arbitrary: xs a) (auto simp: take_Suc neq_Nil_conv)
  lemma scan_drop[simp]: "drop k (scan f xs a) = scan f (drop k xs) (fold f (take k xs) a)"
    by (induct k arbitrary: xs a) (auto simp: take_Suc neq_Nil_conv)

  primcorec sscan :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a stream \<Rightarrow> 'b \<Rightarrow> 'b stream" where
    "sscan f xs a = f (shd xs) a ## sscan f (stl xs) (f (shd xs) a)"

  lemma sscan_scons[simp]: "sscan f (x ## xs) a = f x a ## sscan f xs (f x a)"
    by (simp add: stream.expand)
  lemma sscan_shift[simp]: "sscan f (xs @- ys) a = scan f xs a @- sscan f ys (fold f xs a)"
    by (induct xs arbitrary: a) (auto)

  lemma sscan_eq_scons[iff]:
    "sscan f xs a = b ## w \<longleftrightarrow> f (shd xs) a = b \<and> sscan f (stl xs) (f (shd xs) a) = w"
    using sscan.ctr stream.inject by metis
  lemma scons_eq_sscan[iff]:
    "b ## w = sscan f xs a \<longleftrightarrow> b = f (shd xs) a \<and> w = sscan f (stl xs) (f (shd xs) a)"
    using sscan.ctr stream.inject by metis

  lemma sscan_const[simp]: "sscan const xs a = xs"
    by (coinduction arbitrary: xs a) (auto)
  lemma sscan_snth[simp]: "sscan f xs a !! i = fold f (stake (Suc i) xs) a"
    by (induct i arbitrary: xs a) (auto)
  lemma sscan_scons_snth[simp]: "(a ## sscan f xs a) !! i = fold f (stake i xs) a"
    by (induct i arbitrary: xs a) (auto)
  lemma sscan_smap[simp]: "sscan f (smap g xs) a = sscan (f \<circ> g) xs a"
    by (coinduction arbitrary: xs a) (auto)
  lemma sscan_stake[simp]: "stake k (sscan f xs a) = scan f (stake k xs) a"
    by (induct k arbitrary: a xs) (auto)
  lemma sscan_sdrop[simp]: "sdrop k (sscan f xs a) = sscan f (sdrop k xs) (fold f (stake k xs) a)"
    by (induct k arbitrary: a xs) (auto)

  (* sdistinct *)

  coinductive sdistinct :: "'a stream \<Rightarrow> bool" where
    scons[intro!]: "x \<notin> sset xs \<Longrightarrow> sdistinct xs \<Longrightarrow> sdistinct (x ## xs)"

  lemma sdistinct_scons_elim[elim!]:
    assumes "sdistinct (x ## xs)"
    obtains "x \<notin> sset xs" "sdistinct xs"
    using assms by (auto elim: sdistinct.cases)

  lemma sdistinct_coinduct[case_names sdistinct, coinduct pred: sdistinct]:
    assumes "P xs"
    assumes "\<And> x xs. P (x ## xs) \<Longrightarrow> x \<notin> sset xs \<and> P xs"
    shows "sdistinct xs"
    using stream.collapse sdistinct.coinduct assms by metis

  lemma sdistinct_shift[intro!]:
    assumes "distinct xs" "sdistinct ys" "set xs \<inter> sset ys = {}"
    shows "sdistinct (xs @- ys)"
    using assms by (induct xs) (auto)
  lemma sdistinct_shift_elim[elim!]:
    assumes "sdistinct (xs @- ys)"
    obtains "distinct xs" "sdistinct ys" "set xs \<inter> sset ys = {}"
    using assms by (induct xs) (auto)

  lemma sdistinct_infinite_sset:
    assumes "sdistinct w"
    shows "infinite (sset w)"
    using assms by (coinduction arbitrary: w) (force elim: sdistinct.cases)

  lemma not_sdistinct_decomp:
    assumes "\<not> sdistinct w"
    obtains u v a w'
    where "w = u @- a ## v @- a ## w'"
  proof (rule ccontr)
    assume 1: "\<not> thesis"
    assume 2: "w = u @- a ## v @- a ## w' \<Longrightarrow> thesis" for u a v w'
    have 3: "\<forall> u v a w'. w \<noteq> u @- a ## v @- a ## w'" using 1 2 by auto
    have 4: "sdistinct w" using 3 by (coinduct) (metis id_stake_snth_sdrop imageE shift.simps sset_range)
    show False using assms 4 by auto
  qed

  (* sorted streams *)

  coinductive (in order) sascending :: "'a stream \<Rightarrow> bool" where
    "a \<le> b \<Longrightarrow> sascending (b ## w) \<Longrightarrow> sascending (a ## b ## w)"

  coinductive (in order) sdescending :: "'a stream \<Rightarrow> bool" where
    "a \<ge> b \<Longrightarrow> sdescending (b ## w) \<Longrightarrow> sdescending (a ## b ## w)"

  lemma sdescending_coinduct[case_names sdescending, coinduct pred: sdescending]:
    assumes "P w"
    assumes "\<And> a b w. P (a ## b ## w) \<Longrightarrow> a \<ge> b \<and> P (b ## w)"
    shows "sdescending w"
    using stream.collapse sdescending.coinduct assms by (metis (no_types))

  lemma sdescending_sdrop:
    assumes "sdescending w"
    shows "sdescending (sdrop k w)"
    using assms by (induct k) (auto, metis sdescending.cases sdrop_stl stream.sel(2))

  lemma sdescending_snth_antimono:
    assumes "sdescending w"
    shows "antimono (snth w)"
  unfolding antimono_iff_le_Suc
  proof
    fix k
    have "sdescending (sdrop k w)" using sdescending_sdrop assms by this
    then obtain a b v where 2: "sdrop k w = a ## b ## v" "a \<ge> b" by rule
    then show "w !! k \<ge> w !! Suc k" by (metis sdrop_simps stream.sel)
  qed

  lemma sdescending_stuck:
    fixes w :: "'a :: wellorder stream"
    assumes "sdescending w"
    obtains k
    where "sdrop k w = sconst (w !! k)"
  using assms
  proof (induct "w !! 0" arbitrary: w thesis rule: less_induct)
    case less
    show ?case
    proof (cases "w = sconst (w !! 0)")
      case True
      show ?thesis using less(2)[of 0] True by simp
    next
      case False
      obtain k where 1: "w !! k \<noteq> w !! 0"
        using False by (metis empty_iff eqI_snth insert_iff snth_sset sset_sconst)
      have 2: "antimono (snth w)" using sdescending_snth_antimono less(3) by this
      have 3: "w !! k \<le> w !! 0" using 1 2 by (blast dest: antimonoD)
      have 4: "sdrop k w !! 0 < w !! 0" using 1 3 by auto
      have 5: "sdescending (sdrop k w)" using sdescending_sdrop less(3) by this
      obtain l where 5: "sdrop l (sdrop k w) = sconst (sdrop k w !! l)"
        using less(1)[OF 4 _ 5] by this
      show ?thesis using less(2) 5 by simp
    qed
  qed

end


section \<open>HOL Setup\<close>
theory Sepref_HOL_Bindings
imports Sepref_Tool
begin

subsection \<open>Assertion Annotation\<close>
text \<open>Annotate an assertion to a term. The term must then be refined with this assertion.\<close>
(* TODO: Version for monadic expressions.*)
definition ASSN_ANNOT :: "('a \<Rightarrow> 'ai \<Rightarrow> assn) \<Rightarrow> 'a \<Rightarrow> 'a" where [simp]: "ASSN_ANNOT A x \<equiv> x"
context fixes A :: "'a \<Rightarrow> 'ai \<Rightarrow> assn" begin
  sepref_register "PR_CONST (ASSN_ANNOT A)"

lemma annotate_assn: "x \<equiv> ASSN_ANNOT A x" by simp

subsection \<open>Shortcuts\<close>
abbreviation "nat_assn \<equiv> (id_assn::nat \<Rightarrow> _)"
abbreviation "int_assn \<equiv> (id_assn::int \<Rightarrow> _)"
abbreviation "bool_assn \<equiv> (id_assn::bool \<Rightarrow> _)"

subsection \<open>Identity Relations\<close>
definition "IS_ID R \<equiv> R=Id"
definition "IS_BELOW_ID R \<equiv> R\<subseteq>Id"

lemma [safe_constraint_rules]:
  "IS_ID Id"
  "IS_ID R1 \<Longrightarrow> IS_ID R2 \<Longrightarrow> IS_ID (R1 \<rightarrow> R2)"
  "IS_ID R \<Longrightarrow> IS_ID (\<langle>R\<rangle>option_rel)"
  "IS_ID R \<Longrightarrow> IS_ID (\<langle>R\<rangle>list_rel)"
  "IS_ID R1 \<Longrightarrow> IS_ID R2 \<Longrightarrow> IS_ID (R1 \<times>\<^sub>r R2)"
  "IS_ID R1 \<Longrightarrow> IS_ID R2 \<Longrightarrow> IS_ID (\<langle>R1,R2\<rangle>sum_rel)"
  by (auto simp: IS_ID_def)

lemma [safe_constraint_rules]:
  "IS_BELOW_ID Id"
  "IS_BELOW_ID R \<Longrightarrow> IS_BELOW_ID (\<langle>R\<rangle>option_rel)"
  "IS_BELOW_ID R1 \<Longrightarrow> IS_BELOW_ID R2 \<Longrightarrow> IS_BELOW_ID (R1 \<times>\<^sub>r R2)"
  "IS_BELOW_ID R1 \<Longrightarrow> IS_BELOW_ID R2 \<Longrightarrow> IS_BELOW_ID (\<langle>R1,R2\<rangle>sum_rel)"
  by (auto simp: IS_ID_def IS_BELOW_ID_def option_rel_def sum_rel_def list_rel_def)

lemma IS_BELOW_ID_fun_rel_aux: "R1\<supseteq>Id \<Longrightarrow> IS_BELOW_ID R2 \<Longrightarrow> IS_BELOW_ID (R1 \<rightarrow> R2)"
  by (auto simp: IS_BELOW_ID_def dest: fun_relD)

corollary IS_BELOW_ID_fun_rel[safe_constraint_rules]:
  "IS_ID R1 \<Longrightarrow> IS_BELOW_ID R2 \<Longrightarrow> IS_BELOW_ID (R1 \<rightarrow> R2)"
  using IS_BELOW_ID_fun_rel_aux[of Id R2]
  by (auto simp: IS_ID_def)

lemma IS_BELOW_ID_list_rel[safe_constraint_rules]:
  "IS_BELOW_ID R \<Longrightarrow> IS_BELOW_ID (\<langle>R\<rangle>list_rel)"
  unfolding IS_BELOW_ID_def
proof safe
  fix l l'
  assume A: "R\<subseteq>Id"
  assume "(l,l')\<in>\<langle>R\<rangle>list_rel"
  thus "l=l'"
    apply induction
    using A by auto
qed

lemma IS_ID_imp_BELOW_ID[constraint_rules]:
  "IS_ID R \<Longrightarrow> IS_BELOW_ID R"
  by (auto simp: IS_ID_def IS_BELOW_ID_def )

subsection \<open>Inverse Relation\<close>

lemma inv_fun_rel_eq[simp]: "(A\<rightarrow>B)\<inverse> = A\<inverse>\<rightarrow>B\<inverse>"
  by (auto dest: fun_relD)

lemma inv_option_rel_eq[simp]: "(\<langle>K\<rangle>option_rel)\<inverse> = \<langle>K\<inverse>\<rangle>option_rel"
  by (auto simp: option_rel_def)

lemma inv_prod_rel_eq[simp]: "(P \<times>\<^sub>r Q)\<inverse> = P\<inverse> \<times>\<^sub>r Q\<inverse>"
  by (auto)

lemma inv_sum_rel_eq[simp]: "(\<langle>P,Q\<rangle>sum_rel)\<inverse> = \<langle>P\<inverse>,Q\<inverse>\<rangle>sum_rel"
  by (auto simp: sum_rel_def)

lemma inv_list_rel_eq[simp]: "(\<langle>R\<rangle>list_rel)\<inverse> = \<langle>R\<inverse>\<rangle>list_rel"
  unfolding list_rel_def
  apply safe
  apply (subst list.rel_flip[symmetric])
  apply (simp add: conversep_iff[abs_def])
  apply (subst list.rel_flip[symmetric])
  apply (simp add: conversep_iff[abs_def])
  done

lemmas [constraint_simps] =
  Relation.converse_Id
  inv_fun_rel_eq
  inv_option_rel_eq
  inv_prod_rel_eq
  inv_sum_rel_eq
  inv_list_rel_eq

subsection \<open>Single Valued and Total Relations\<close>

(* TODO: Link to other such theories: Transfer, Autoref *)
definition "IS_LEFT_UNIQUE R \<equiv> single_valued (R\<inverse>)"
definition "IS_LEFT_TOTAL R \<equiv> Domain R = UNIV"
definition "IS_RIGHT_TOTAL R \<equiv> Range R = UNIV"
abbreviation (input) "IS_RIGHT_UNIQUE \<equiv> single_valued"

lemmas IS_RIGHT_UNIQUED = single_valuedD
lemma IS_LEFT_UNIQUED: "\<lbrakk>IS_LEFT_UNIQUE r; (y, x) \<in> r; (z, x) \<in> r\<rbrakk> \<Longrightarrow> y = z"
  by (auto simp: IS_LEFT_UNIQUE_def dest: single_valuedD)

lemma prop2p:
  "IS_LEFT_UNIQUE R = left_unique (rel2p R)"
  "IS_RIGHT_UNIQUE R = right_unique (rel2p R)"
  "right_unique (rel2p (R\<inverse>)) = left_unique (rel2p R)"
  "IS_LEFT_TOTAL R = left_total (rel2p R)"
  "IS_RIGHT_TOTAL R = right_total (rel2p R)"
  by (auto
    simp: IS_LEFT_UNIQUE_def left_unique_def single_valued_def
    simp: right_unique_def
    simp: IS_LEFT_TOTAL_def left_total_def
    simp: IS_RIGHT_TOTAL_def right_total_def
    simp: rel2p_def
    )

lemma p2prop:
  "left_unique P = IS_LEFT_UNIQUE (p2rel P)"
  "right_unique P = IS_RIGHT_UNIQUE (p2rel P)"
  "left_total P = IS_LEFT_TOTAL (p2rel P)"
  "right_total P = IS_RIGHT_TOTAL (p2rel P)"
  "bi_unique P \<longleftrightarrow> left_unique P \<and> right_unique P"
  by (auto
    simp: IS_LEFT_UNIQUE_def left_unique_def single_valued_def
    simp: right_unique_def bi_unique_alt_def
    simp: IS_LEFT_TOTAL_def left_total_def
    simp: IS_RIGHT_TOTAL_def right_total_def
    simp: p2rel_def
    )

lemmas [safe_constraint_rules] =
  single_valued_Id
  prod_rel_sv
  list_rel_sv
  option_rel_sv
  sum_rel_sv

lemma [safe_constraint_rules]:
  "IS_LEFT_UNIQUE Id"
  "IS_LEFT_UNIQUE R1 \<Longrightarrow> IS_LEFT_UNIQUE R2 \<Longrightarrow> IS_LEFT_UNIQUE (R1\<times>\<^sub>rR2)"
  "IS_LEFT_UNIQUE R1 \<Longrightarrow> IS_LEFT_UNIQUE R2 \<Longrightarrow> IS_LEFT_UNIQUE (\<langle>R1,R2\<rangle>sum_rel)"
  "IS_LEFT_UNIQUE R \<Longrightarrow> IS_LEFT_UNIQUE (\<langle>R\<rangle>option_rel)"
  "IS_LEFT_UNIQUE R \<Longrightarrow> IS_LEFT_UNIQUE (\<langle>R\<rangle>list_rel)"
  by (auto simp: IS_LEFT_UNIQUE_def prod_rel_sv sum_rel_sv option_rel_sv list_rel_sv)

lemma IS_LEFT_TOTAL_alt: "IS_LEFT_TOTAL R \<longleftrightarrow> (\<forall>x. \<exists>y. (x,y)\<in>R)"
  by (auto simp: IS_LEFT_TOTAL_def)

lemma IS_RIGHT_TOTAL_alt: "IS_RIGHT_TOTAL R \<longleftrightarrow> (\<forall>x. \<exists>y. (y,x)\<in>R)"
  by (auto simp: IS_RIGHT_TOTAL_def)

lemma [safe_constraint_rules]:
  "IS_LEFT_TOTAL Id"
  "IS_LEFT_TOTAL R1 \<Longrightarrow> IS_LEFT_TOTAL R2 \<Longrightarrow> IS_LEFT_TOTAL (R1\<times>\<^sub>rR2)"
  "IS_LEFT_TOTAL R1 \<Longrightarrow> IS_LEFT_TOTAL R2 \<Longrightarrow> IS_LEFT_TOTAL (\<langle>R1,R2\<rangle>sum_rel)"
  "IS_LEFT_TOTAL R \<Longrightarrow> IS_LEFT_TOTAL (\<langle>R\<rangle>option_rel)"
  apply (auto simp: IS_LEFT_TOTAL_alt sum_rel_def option_rel_def list_rel_def)
  apply (rename_tac x; case_tac x; auto)
  apply (rename_tac x; case_tac x; auto)
  done

lemma [safe_constraint_rules]: "IS_LEFT_TOTAL R \<Longrightarrow> IS_LEFT_TOTAL (\<langle>R\<rangle>list_rel)"
  unfolding IS_LEFT_TOTAL_alt
proof safe
  assume A: "\<forall>x.\<exists>y. (x,y)\<in>R"
  fix l
  show "\<exists>l'. (l,l')\<in>\<langle>R\<rangle>list_rel"
    apply (induction l)
    using A
    by (auto simp: list_rel_split_right_iff)
qed

lemma [safe_constraint_rules]:
  "IS_RIGHT_TOTAL Id"
  "IS_RIGHT_TOTAL R1 \<Longrightarrow> IS_RIGHT_TOTAL R2 \<Longrightarrow> IS_RIGHT_TOTAL (R1\<times>\<^sub>rR2)"
  "IS_RIGHT_TOTAL R1 \<Longrightarrow> IS_RIGHT_TOTAL R2 \<Longrightarrow> IS_RIGHT_TOTAL (\<langle>R1,R2\<rangle>sum_rel)"
  "IS_RIGHT_TOTAL R \<Longrightarrow> IS_RIGHT_TOTAL (\<langle>R\<rangle>option_rel)"
  apply (auto simp: IS_RIGHT_TOTAL_alt sum_rel_def option_rel_def) []
  apply (auto simp: IS_RIGHT_TOTAL_alt sum_rel_def option_rel_def) []
  apply (auto simp: IS_RIGHT_TOTAL_alt sum_rel_def option_rel_def) []
  apply (rename_tac x; case_tac x; auto)
  apply (clarsimp simp: IS_RIGHT_TOTAL_alt option_rel_def)
  apply (rename_tac x; case_tac x; auto)
  done

lemma [safe_constraint_rules]: "IS_RIGHT_TOTAL R \<Longrightarrow> IS_RIGHT_TOTAL (\<langle>R\<rangle>list_rel)"
  unfolding IS_RIGHT_TOTAL_alt
proof safe
  assume A: "\<forall>x.\<exists>y. (y,x)\<in>R"
  fix l
  show "\<exists>l'. (l',l)\<in>\<langle>R\<rangle>list_rel"
    apply (induction l)
    using A
    by (auto simp: list_rel_split_left_iff)
qed

lemma [constraint_simps]:
  "IS_LEFT_TOTAL (R\<inverse>) \<longleftrightarrow> IS_RIGHT_TOTAL R "
  "IS_RIGHT_TOTAL (R\<inverse>) \<longleftrightarrow> IS_LEFT_TOTAL R  "
  "IS_LEFT_UNIQUE (R\<inverse>) \<longleftrightarrow> IS_RIGHT_UNIQUE R"
  "IS_RIGHT_UNIQUE (R\<inverse>) \<longleftrightarrow> IS_LEFT_UNIQUE R "
  by (auto simp: IS_RIGHT_TOTAL_alt IS_LEFT_TOTAL_alt IS_LEFT_UNIQUE_def)

lemma [safe_constraint_rules]:
  "IS_RIGHT_UNIQUE A \<Longrightarrow> IS_RIGHT_TOTAL B \<Longrightarrow> IS_RIGHT_TOTAL (A\<rightarrow>B)"
  "IS_RIGHT_TOTAL A \<Longrightarrow> IS_RIGHT_UNIQUE B \<Longrightarrow> IS_RIGHT_UNIQUE (A\<rightarrow>B)"
  "IS_LEFT_UNIQUE A \<Longrightarrow> IS_LEFT_TOTAL B \<Longrightarrow> IS_LEFT_TOTAL (A\<rightarrow>B)"
  "IS_LEFT_TOTAL A \<Longrightarrow> IS_LEFT_UNIQUE B \<Longrightarrow> IS_LEFT_UNIQUE (A\<rightarrow>B)"
  apply (simp_all add: prop2p rel2p)
  (*apply transfer_step TODO: Isabelle 2016 *)
  apply (blast intro!: transfer_raw)+
  done

lemma [constraint_rules]:
  "IS_BELOW_ID R \<Longrightarrow> IS_RIGHT_UNIQUE R"
  "IS_BELOW_ID R \<Longrightarrow> IS_LEFT_UNIQUE R"
  "IS_ID R \<Longrightarrow> IS_RIGHT_TOTAL R"
  "IS_ID R \<Longrightarrow> IS_LEFT_TOTAL R"
  by (auto simp: IS_BELOW_ID_def IS_ID_def IS_LEFT_UNIQUE_def IS_RIGHT_TOTAL_def IS_LEFT_TOTAL_def
    intro: single_valuedI)

thm constraint_rules

subsubsection \<open>Additional Parametricity Lemmas\<close>
(* TODO: Move. Problem: Depend on IS_LEFT_UNIQUE, which has to be moved to!*)

lemma param_distinct[param]: "\<lbrakk>IS_LEFT_UNIQUE A; IS_RIGHT_UNIQUE A\<rbrakk> \<Longrightarrow> (distinct, distinct) \<in> \<langle>A\<rangle>list_rel \<rightarrow> bool_rel"
  apply (fold rel2p_def)
  apply (simp add: rel2p)
  apply (rule distinct_transfer)
  apply (simp add: p2prop)
  done

lemma param_Image[param]:
  assumes "IS_LEFT_UNIQUE A" "IS_RIGHT_UNIQUE A"
  shows "((``), (``)) \<in> \<langle>A\<times>\<^sub>rB\<rangle>set_rel \<rightarrow> \<langle>A\<rangle>set_rel \<rightarrow> \<langle>B\<rangle>set_rel"
  apply (clarsimp simp: set_rel_def; intro conjI)
  apply (fastforce dest: IS_RIGHT_UNIQUED[OF assms(2)])
  apply (fastforce dest: IS_LEFT_UNIQUED[OF assms(1)])
  done

lemma pres_eq_iff_svb: "((=),(=))\<in>K\<rightarrow>K\<rightarrow>bool_rel \<longleftrightarrow> (single_valued K \<and> single_valued (K\<inverse>))"
  apply (safe intro!: single_valuedI)
  apply (metis (full_types) IdD fun_relD1)
  apply (metis (full_types) IdD fun_relD1)
  by (auto dest: single_valuedD)

definition "IS_PRES_EQ R \<equiv> ((=), (=))\<in>R\<rightarrow>R\<rightarrow>bool_rel"
lemma [constraint_rules]: "\<lbrakk>single_valued R; single_valued (R\<inverse>)\<rbrakk> \<Longrightarrow> IS_PRES_EQ R"
  by (simp add: pres_eq_iff_svb IS_PRES_EQ_def)

subsection \<open>Bounded Assertions\<close>
definition "b_rel R P \<equiv> R \<inter> UNIV\<times>Collect P"
definition "b_assn A P \<equiv> \<lambda>x y. A x y * \<up>(P x)"

lemma b_assn_pure_conv[constraint_simps]: "b_assn (pure R) P = pure (b_rel R P)"
  by (auto intro!: ext simp: b_rel_def b_assn_def pure_def)
lemmas [sepref_import_rewrite, sepref_frame_normrel_eqs, fcomp_norm_unfold]
  = b_assn_pure_conv[symmetric]

lemma b_rel_nesting[simp]:
  "b_rel (b_rel R P1) P2 = b_rel R (\<lambda>x. P1 x \<and> P2 x)"
  by (auto simp: b_rel_def)
lemma b_rel_triv[simp]:
  "b_rel R (\<lambda>_. True) = R"
  by (auto simp: b_rel_def)
lemma b_assn_nesting[simp]:
  "b_assn (b_assn A P1) P2 = b_assn A (\<lambda>x. P1 x \<and> P2 x)"
  by (auto simp: b_assn_def pure_def intro!: ext)
lemma b_assn_triv[simp]:
  "b_assn A (\<lambda>_. True) = A"
  by (auto simp: b_assn_def pure_def intro!: ext)

lemmas [simp,constraint_simps,sepref_import_rewrite, sepref_frame_normrel_eqs, fcomp_norm_unfold]
  = b_rel_nesting b_assn_nesting

lemma b_rel_simp[simp]: "(x,y)\<in>b_rel R P \<longleftrightarrow> (x,y)\<in>R \<and> P y"
  by (auto simp: b_rel_def)

lemma b_assn_simp[simp]: "b_assn A P x y = A x y * \<up>(P x)"
  by (auto simp: b_assn_def)

lemma b_rel_Range[simp]: "Range (b_rel R P) = Range R \<inter> Collect P" by auto
lemma b_assn_rdom[simp]: "rdomp (b_assn R P) x \<longleftrightarrow> rdomp R x \<and> P x"
  by (auto simp: rdomp_def)

lemma b_rel_below_id[constraint_rules]:
  "IS_BELOW_ID R \<Longrightarrow> IS_BELOW_ID (b_rel R P)"
  by (auto simp: IS_BELOW_ID_def)

lemma b_rel_left_unique[constraint_rules]:
  "IS_LEFT_UNIQUE R \<Longrightarrow> IS_LEFT_UNIQUE (b_rel R P)"
  by (auto simp: IS_LEFT_UNIQUE_def single_valued_def)

lemma b_rel_right_unique[constraint_rules]:
  "IS_RIGHT_UNIQUE R \<Longrightarrow> IS_RIGHT_UNIQUE (b_rel R P)"
  by (auto simp: single_valued_def)

\<comment> \<open>Registered as safe rule, although may loose information in the
    odd case that purity depends condition.\<close>
lemma b_assn_is_pure[safe_constraint_rules]:
  "is_pure A \<Longrightarrow> is_pure (b_assn A P)"
  by (auto simp: is_pure_conv b_assn_pure_conv)

\<comment> \<open>Most general form\<close>
lemma b_assn_subtyping_match[sepref_frame_match_rules]:
  assumes "hn_ctxt (b_assn A P) x y \<Longrightarrow>\<^sub>t hn_ctxt A' x y"
  assumes "\<lbrakk>vassn_tag (hn_ctxt A x y); vassn_tag (hn_ctxt A' x y); P x\<rbrakk> \<Longrightarrow> P' x"
  shows "hn_ctxt (b_assn A P) x y \<Longrightarrow>\<^sub>t hn_ctxt (b_assn A' P') x y"
  using assms
  unfolding hn_ctxt_def b_assn_def entailst_def entails_def
  by (fastforce simp: vassn_tag_def mod_star_conv)

\<comment> \<open>Simplified forms:\<close>
lemma b_assn_subtyping_match_eqA[sepref_frame_match_rules]:
  assumes "\<lbrakk>vassn_tag (hn_ctxt A x y); P x\<rbrakk> \<Longrightarrow> P' x"
  shows "hn_ctxt (b_assn A P) x y \<Longrightarrow>\<^sub>t hn_ctxt (b_assn A P') x y"
  apply (rule b_assn_subtyping_match)
  subgoal
    unfolding hn_ctxt_def b_assn_def entailst_def entails_def
    by (fastforce simp: vassn_tag_def mod_star_conv)
  subgoal
    using assms .
  done

lemma b_assn_subtyping_match_tR[sepref_frame_match_rules]:
  assumes "\<lbrakk>P x\<rbrakk> \<Longrightarrow> hn_ctxt A x y \<Longrightarrow>\<^sub>t hn_ctxt A' x y"
  shows "hn_ctxt (b_assn A P) x y \<Longrightarrow>\<^sub>t hn_ctxt A' x y"
  using assms
  unfolding hn_ctxt_def b_assn_def entailst_def entails_def
  by (fastforce simp: vassn_tag_def mod_star_conv)

lemma b_assn_subtyping_match_tL[sepref_frame_match_rules]:
  assumes "hn_ctxt A x y \<Longrightarrow>\<^sub>t hn_ctxt A' x y"
  assumes "\<lbrakk>vassn_tag (hn_ctxt A x y)\<rbrakk> \<Longrightarrow> P' x"
  shows "hn_ctxt A x y \<Longrightarrow>\<^sub>t hn_ctxt (b_assn A' P') x y"
  using assms
  unfolding hn_ctxt_def b_assn_def entailst_def entails_def
  by (fastforce simp: vassn_tag_def mod_star_conv)

lemma b_assn_subtyping_match_eqA_tR[sepref_frame_match_rules]:
  "hn_ctxt (b_assn A P) x y \<Longrightarrow>\<^sub>t hn_ctxt A x y"
  unfolding hn_ctxt_def b_assn_def
  by (sep_auto intro!: enttI)

lemma b_assn_subtyping_match_eqA_tL[sepref_frame_match_rules]:
  assumes "\<lbrakk>vassn_tag (hn_ctxt A x y)\<rbrakk> \<Longrightarrow> P' x"
  shows "hn_ctxt A x y \<Longrightarrow>\<^sub>t hn_ctxt (b_assn A P') x y"
  using assms
  unfolding hn_ctxt_def b_assn_def entailst_def entails_def
  by (fastforce simp: vassn_tag_def mod_star_conv)

\<comment> \<open>General form\<close>
lemma b_rel_subtyping_merge[sepref_frame_merge_rules]:
  assumes "hn_ctxt A x y \<or>\<^sub>A hn_ctxt A' x y \<Longrightarrow>\<^sub>t hn_ctxt Am x y"
  shows "hn_ctxt (b_assn A P) x y \<or>\<^sub>A hn_ctxt (b_assn A' P') x y \<Longrightarrow>\<^sub>t hn_ctxt (b_assn Am (\<lambda>x. P x \<or> P' x)) x y"
  using assms
  unfolding hn_ctxt_def b_assn_def entailst_def entails_def
  by (fastforce simp: vassn_tag_def)

\<comment> \<open>Simplified forms\<close>
lemma b_rel_subtyping_merge_eqA[sepref_frame_merge_rules]:
  shows "hn_ctxt (b_assn A P) x y \<or>\<^sub>A hn_ctxt (b_assn A P') x y \<Longrightarrow>\<^sub>t hn_ctxt (b_assn A (\<lambda>x. P x \<or> P' x)) x y"
  apply (rule b_rel_subtyping_merge)
  by simp

lemma b_rel_subtyping_merge_tL[sepref_frame_merge_rules]:
  assumes "hn_ctxt A x y \<or>\<^sub>A hn_ctxt A' x y \<Longrightarrow>\<^sub>t hn_ctxt Am x y"
  shows "hn_ctxt A x y \<or>\<^sub>A hn_ctxt (b_assn A' P') x y \<Longrightarrow>\<^sub>t hn_ctxt Am x y"
  using b_rel_subtyping_merge[of A x y A' Am "\<lambda>_. True" P', simplified] assms .

lemma b_rel_subtyping_merge_tR[sepref_frame_merge_rules]:
  assumes "hn_ctxt A x y \<or>\<^sub>A hn_ctxt A' x y \<Longrightarrow>\<^sub>t hn_ctxt Am x y"
  shows "hn_ctxt (b_assn A P) x y \<or>\<^sub>A hn_ctxt A' x y \<Longrightarrow>\<^sub>t hn_ctxt Am x y"
  using b_rel_subtyping_merge[of A x y A' Am P "\<lambda>_. True", simplified] assms .

lemma b_rel_subtyping_merge_eqA_tL[sepref_frame_merge_rules]:
  shows "hn_ctxt A x y \<or>\<^sub>A hn_ctxt (b_assn A P') x y \<Longrightarrow>\<^sub>t hn_ctxt A x y"
  using b_rel_subtyping_merge_eqA[of A "\<lambda>_. True" x y P', simplified] .

lemma b_rel_subtyping_merge_eqA_tR[sepref_frame_merge_rules]:
  shows "hn_ctxt (b_assn A P) x y \<or>\<^sub>A hn_ctxt A x y \<Longrightarrow>\<^sub>t hn_ctxt A x y"
  using b_rel_subtyping_merge_eqA[of A P x y "\<lambda>_. True", simplified] .

(* TODO: Combinatorial explosion :( *)
lemma b_assn_invalid_merge1: "hn_invalid (b_assn A P) x y \<or>\<^sub>A hn_invalid (b_assn A P') x y
  \<Longrightarrow>\<^sub>t hn_invalid (b_assn A (\<lambda>x. P x \<or> P' x)) x y"
  by (sep_auto simp: hn_ctxt_def invalid_assn_def entailst_def)

lemma b_assn_invalid_merge2: "hn_invalid (b_assn A P) x y \<or>\<^sub>A hn_invalid A x y
  \<Longrightarrow>\<^sub>t hn_invalid A x y"
  by (sep_auto simp: hn_ctxt_def invalid_assn_def entailst_def)
lemma b_assn_invalid_merge3: "hn_invalid A x y \<or>\<^sub>A hn_invalid (b_assn A P) x y
  \<Longrightarrow>\<^sub>t hn_invalid A x y"
  by (sep_auto simp: hn_ctxt_def invalid_assn_def entailst_def)

lemma b_assn_invalid_merge4: "hn_invalid (b_assn A P) x y \<or>\<^sub>A hn_ctxt (b_assn A P') x y
  \<Longrightarrow>\<^sub>t hn_invalid (b_assn A (\<lambda>x. P x \<or> P' x)) x y"
  by (sep_auto simp: hn_ctxt_def invalid_assn_def entailst_def)
lemma b_assn_invalid_merge5: "hn_ctxt (b_assn A P') x y \<or>\<^sub>A hn_invalid (b_assn A P) x y
  \<Longrightarrow>\<^sub>t hn_invalid (b_assn A (\<lambda>x. P x \<or> P' x)) x y"
  by (sep_auto simp: hn_ctxt_def invalid_assn_def entailst_def)

lemma b_assn_invalid_merge6: "hn_invalid (b_assn A P) x y \<or>\<^sub>A hn_ctxt A x y
  \<Longrightarrow>\<^sub>t hn_invalid A x y"
  by (sep_auto simp: hn_ctxt_def invalid_assn_def entailst_def)
lemma b_assn_invalid_merge7: "hn_ctxt A x y \<or>\<^sub>A hn_invalid (b_assn A P) x y
  \<Longrightarrow>\<^sub>t hn_invalid A x y"
  by (sep_auto simp: hn_ctxt_def invalid_assn_def entailst_def)

lemma b_assn_invalid_merge8: "hn_ctxt (b_assn A P) x y \<or>\<^sub>A hn_invalid A x y
  \<Longrightarrow>\<^sub>t hn_invalid A x y"
  by (sep_auto simp: hn_ctxt_def invalid_assn_def entailst_def)
lemma b_assn_invalid_merge9: "hn_invalid A x y \<or>\<^sub>A hn_ctxt (b_assn A P) x y
  \<Longrightarrow>\<^sub>t hn_invalid A x y"
  by (sep_auto simp: hn_ctxt_def invalid_assn_def entailst_def)

lemmas b_assn_invalid_merge[sepref_frame_merge_rules] =
  b_assn_invalid_merge1
  b_assn_invalid_merge2
  b_assn_invalid_merge3
  b_assn_invalid_merge4
  b_assn_invalid_merge5
  b_assn_invalid_merge6
  b_assn_invalid_merge7
  b_assn_invalid_merge8
  b_assn_invalid_merge9

(*
lemma list_rel_b_id: "\<forall>x\<in>set l. B x \<Longrightarrow> (l,l)\<in>\<langle>b_rel B\<rangle>list_rel"
  by (induction l) auto
*)

abbreviation nbn_rel :: "nat \<Rightarrow> (nat \<times> nat) set"
  \<comment> \<open>Natural numbers with upper bound.\<close>
  where "nbn_rel n \<equiv> b_rel nat_rel (\<lambda>x::nat. x<n)"

abbreviation nbn_assn :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> assn"
  \<comment> \<open>Natural numbers with upper bound.\<close>
  where "nbn_assn n \<equiv> b_assn nat_assn (\<lambda>x::nat. x<n)"

(*
subsection \<open>Bounded Identity Relations\<close>
definition "b_rel B \<equiv> {(x,x) | x. B x}"

lemma b_rel_simp[simp]: "(x,y)\<in>b_rel B \<longleftrightarrow> x=y \<and> B y"
  by (auto simp: b_rel_def)

lemma b_rel_Range[simp]: "Range (b_rel B) = Collect B" by auto

lemma b_rel_below_id[safe_constraint_rules]: "IS_BELOW_ID (b_rel B)"
  by (auto simp: IS_BELOW_ID_def)

lemma list_rel_b_id: "\<forall>x\<in>set l. B x \<Longrightarrow> (l,l)\<in>\<langle>b_rel B\<rangle>list_rel"
  by (induction l) auto

lemma b_rel_subtyping_match[sepref_frame_match_rules]:
  "P x \<Longrightarrow> hn_val Id x y \<Longrightarrow>\<^sub>t hn_val (b_rel P) x y"
  "\<lbrakk>P1 x \<Longrightarrow> P2 x\<rbrakk> \<Longrightarrow> hn_val (b_rel P1) x y \<Longrightarrow>\<^sub>t hn_val (b_rel P2) x y"
  "hn_val (b_rel P) x y \<Longrightarrow>\<^sub>t hn_val Id x y"
  by (auto simp: hn_ctxt_def pure_def intro: enttI)

lemma b_rel_subtyping_merge[sepref_frame_merge_rules]:
  "hn_val Id x y \<or>\<^sub>A hn_val (b_rel P) x y \<Longrightarrow>\<^sub>t hn_val Id x y"
  "hn_val (b_rel P) x y \<or>\<^sub>A hn_val Id x y \<Longrightarrow>\<^sub>t hn_val Id x y"
  "hn_val (b_rel P1) x y \<or>\<^sub>A hn_val (b_rel P2) x y \<Longrightarrow>\<^sub>t hn_val (b_rel (\<lambda>x. P1 x \<or> P2 x)) x y"
  by (auto simp: hn_ctxt_def pure_def intro: enttI)

abbreviation nbn_rel :: "nat \<Rightarrow> (nat \<times> nat) set"
  -- \<open>Natural numbers with upper bound.\<close>
  where "nbn_rel n \<equiv> b_rel (\<lambda>x::nat. x<n)"

*)

subsection \<open>Tool Setup\<close>
lemmas [sepref_relprops] =
  sepref_relpropI[of IS_LEFT_UNIQUE]
  sepref_relpropI[of IS_RIGHT_UNIQUE]
  sepref_relpropI[of IS_LEFT_TOTAL]
  sepref_relpropI[of IS_RIGHT_TOTAL]
  sepref_relpropI[of is_pure]
  sepref_relpropI[of "IS_PURE \<Phi>" for \<Phi>]
  sepref_relpropI[of IS_ID]
  sepref_relpropI[of IS_BELOW_ID]

lemma [sepref_relprops_simps]:
  "CONSTRAINT (IS_PURE IS_ID) A \<Longrightarrow> CONSTRAINT (IS_PURE IS_BELOW_ID) A"
  "CONSTRAINT (IS_PURE IS_ID) A \<Longrightarrow> CONSTRAINT (IS_PURE IS_LEFT_TOTAL) A"
  "CONSTRAINT (IS_PURE IS_ID) A \<Longrightarrow> CONSTRAINT (IS_PURE IS_RIGHT_TOTAL) A"
  "CONSTRAINT (IS_PURE IS_BELOW_ID) A \<Longrightarrow> CONSTRAINT (IS_PURE IS_LEFT_UNIQUE) A"
  "CONSTRAINT (IS_PURE IS_BELOW_ID) A \<Longrightarrow> CONSTRAINT (IS_PURE IS_RIGHT_UNIQUE) A"
  by (auto
    simp: IS_ID_def IS_BELOW_ID_def IS_PURE_def IS_LEFT_UNIQUE_def
    simp: IS_LEFT_TOTAL_def IS_RIGHT_TOTAL_def
    simp: single_valued_below_Id)

declare True_implies_equals[sepref_relprops_simps]

lemma [sepref_relprops_transform]: "single_valued (R\<inverse>) = IS_LEFT_UNIQUE R"
  by (auto simp: IS_LEFT_UNIQUE_def)

subsection \<open>HOL Combinators\<close>
lemma hn_if[sepref_comb_rules]:
  assumes P: "\<Gamma> \<Longrightarrow>\<^sub>t \<Gamma>1 * hn_val bool_rel a a'"
  assumes RT: "a \<Longrightarrow> hn_refine (\<Gamma>1 * hn_val bool_rel a a') b' \<Gamma>2b R b"
  assumes RE: "\<not>a \<Longrightarrow> hn_refine (\<Gamma>1 * hn_val bool_rel a a') c' \<Gamma>2c R c"
  assumes IMP: "TERM If \<Longrightarrow> \<Gamma>2b \<or>\<^sub>A \<Gamma>2c \<Longrightarrow>\<^sub>t \<Gamma>'"
  shows "hn_refine \<Gamma> (if a' then b' else c') \<Gamma>' R (If$a$b$c)"
  using P RT RE IMP[OF TERMI]
  unfolding APP_def PROTECT2_def
  by (rule hnr_If)

lemmas [sepref_opt_simps] = if_True if_False

lemma hn_let[sepref_comb_rules]:
  assumes P: "\<Gamma> \<Longrightarrow>\<^sub>t \<Gamma>1 * hn_ctxt R v v'"
  assumes R: "\<And>x x'. x=v \<Longrightarrow> hn_refine (\<Gamma>1 * hn_ctxt R x x') (f' x')
    (\<Gamma>' x x') R2 (f x)"
  assumes F: "\<And>x x'. \<Gamma>' x x' \<Longrightarrow>\<^sub>t \<Gamma>2 * hn_ctxt R' x x'"
  shows
    "hn_refine \<Gamma> (Let v' f') (\<Gamma>2 * hn_ctxt R' v v') R2 (Let$v$(\<lambda>\<^sub>2x. f x))"
  apply (rule hn_refine_cons[OF P _ F entt_refl])
  apply (simp)
  apply (rule R)
  by simp

subsection \<open>Basic HOL types\<close>

lemma hnr_default[sepref_import_param]: "(default,default)\<in>Id" by simp

lemma unit_hnr[sepref_import_param]: "((),())\<in>unit_rel" by auto

lemmas [sepref_import_param] =
  param_bool
  param_nat1
  param_int

lemmas [id_rules] =
  itypeI[Pure.of 0 "TYPE (nat)"]
  itypeI[Pure.of 0 "TYPE (int)"]
  itypeI[Pure.of 1 "TYPE (nat)"]
  itypeI[Pure.of 1 "TYPE (int)"]
  itypeI[Pure.of numeral "TYPE (num \<Rightarrow> nat)"]
  itypeI[Pure.of numeral "TYPE (num \<Rightarrow> int)"]
  itype_self[of num.One]
  itype_self[of num.Bit0]
  itype_self[of num.Bit1]

lemma param_min_nat[param,sepref_import_param]: "(min,min)\<in>nat_rel \<rightarrow> nat_rel \<rightarrow> nat_rel" by auto
lemma param_max_nat[param,sepref_import_param]: "(max,max)\<in>nat_rel \<rightarrow> nat_rel \<rightarrow> nat_rel" by auto

lemma param_min_int[param,sepref_import_param]: "(min,min)\<in>int_rel \<rightarrow> int_rel \<rightarrow> int_rel" by auto
lemma param_max_int[param,sepref_import_param]: "(max,max)\<in>int_rel \<rightarrow> int_rel \<rightarrow> int_rel" by auto

lemma uminus_hnr[sepref_import_param]: "(uminus,uminus)\<in>int_rel \<rightarrow> int_rel" by auto

lemma nat_param[param,sepref_import_param]: "(nat,nat) \<in> int_rel \<rightarrow> nat_rel" by auto
lemma int_param[param,sepref_import_param]: "(int,int) \<in> nat_rel \<rightarrow> int_rel" by auto

subsection "Product"

lemmas [sepref_import_rewrite, sepref_frame_normrel_eqs, fcomp_norm_unfold] = prod_assn_pure_conv[symmetric]

lemma prod_assn_precise[constraint_rules]:
  "precise P1 \<Longrightarrow> precise P2 \<Longrightarrow> precise (prod_assn P1 P2)"
  apply rule
  apply (clarsimp simp: prod_assn_def star_assoc)
  apply safe
  apply (erule (1) prec_frame) apply frame_inference+
  apply (erule (1) prec_frame) apply frame_inference+
  done

lemma
  "precise P1 \<Longrightarrow> precise P2 \<Longrightarrow> precise (prod_assn P1 P2)" \<comment> \<open>Original proof\<close>
  apply rule
  apply (clarsimp simp: prod_assn_def)
proof (rule conjI)
  fix F F' h as a b a' b' ap bp
  assume P1: "precise P1" and P2: "precise P2"
  assume F: "(h, as) \<Turnstile> P1 a ap * P2 b bp * F \<and>\<^sub>A P1 a' ap * P2 b' bp * F'"

  from F have "(h, as) \<Turnstile> P1 a ap * (P2 b bp * F) \<and>\<^sub>A P1 a' ap * (P2 b' bp * F')"
    by (simp only: mult.assoc)
  with preciseD[OF P1] show "a=a'" .
  from F have "(h, as) \<Turnstile> P2 b bp * (P1 a ap * F) \<and>\<^sub>A P2 b' bp * (P1 a' ap * F')"
    by (simp only: mult.assoc[where 'a=assn] mult.commute[where 'a=assn] mult.left_commute[where 'a=assn])
  with preciseD[OF P2] show "b=b'" .
qed

(* TODO Add corresponding rules for other types and add to datatype snippet *)
lemma intf_of_prod_assn[intf_of_assn]:
  assumes "intf_of_assn A TYPE('a)" "intf_of_assn B TYPE('b)"
  shows "intf_of_assn (prod_assn A B) TYPE('a * 'b)"
by simp

lemma pure_prod[constraint_rules]:
  assumes P1: "is_pure P1" and P2: "is_pure P2"
  shows "is_pure (prod_assn P1 P2)"
proof -
  from P1 obtain P1' where P1': "\<And>x x'. P1 x x' = \<up>(P1' x x')"
    using is_pureE by blast
  from P2 obtain P2' where P2': "\<And>x x'. P2 x x' = \<up>(P2' x x')"
    using is_pureE by blast

  show ?thesis proof
    fix x x'
    show "prod_assn P1 P2 x x' =
         \<up> (case (x, x') of ((a1, a2), c1, c2) \<Rightarrow> P1' a1 c1 \<and> P2' a2 c2)"
      unfolding prod_assn_def
      apply (simp add: P1' P2' split: prod.split)
      done
  qed
qed

lemma prod_frame_match[sepref_frame_match_rules]:
  assumes "hn_ctxt A (fst x) (fst y) \<Longrightarrow>\<^sub>t hn_ctxt A' (fst x) (fst y)"
  assumes "hn_ctxt B (snd x) (snd y) \<Longrightarrow>\<^sub>t hn_ctxt B' (snd x) (snd y)"
  shows "hn_ctxt (prod_assn A B) x y \<Longrightarrow>\<^sub>t hn_ctxt (prod_assn A' B') x y"
  apply (cases x; cases y; simp)
  apply (simp add: hn_ctxt_def)
  apply (rule entt_star_mono)
  using assms apply (auto simp: hn_ctxt_def)
  done

lemma prod_frame_merge[sepref_frame_merge_rules]:
  assumes "hn_ctxt A (fst x) (fst y) \<or>\<^sub>A hn_ctxt A' (fst x) (fst y) \<Longrightarrow>\<^sub>t hn_ctxt Am (fst x) (fst y)"
  assumes "hn_ctxt B (snd x) (snd y) \<or>\<^sub>A hn_ctxt B' (snd x) (snd y) \<Longrightarrow>\<^sub>t hn_ctxt Bm (snd x) (snd y)"
  shows "hn_ctxt (prod_assn A B) x y \<or>\<^sub>A hn_ctxt (prod_assn A' B') x y \<Longrightarrow>\<^sub>t hn_ctxt (prod_assn Am Bm) x y"
  by (blast intro: entt_disjE prod_frame_match
    entt_disjD1[OF assms(1)] entt_disjD2[OF assms(1)]
    entt_disjD1[OF assms(2)] entt_disjD2[OF assms(2)])

lemma entt_invalid_prod: "hn_invalid (prod_assn A B) p p' \<Longrightarrow>\<^sub>t hn_ctxt (prod_assn (invalid_assn A) (invalid_assn B)) p p'"
    apply (simp add: hn_ctxt_def invalid_assn_def[abs_def])
    apply (rule enttI)
    apply clarsimp
    apply (cases p; cases p'; auto simp: mod_star_conv pure_def)
    done

lemmas invalid_prod_merge[sepref_frame_merge_rules] = gen_merge_cons[OF entt_invalid_prod]

lemma prod_assn_ctxt: "prod_assn A1 A2 x y = z \<Longrightarrow> hn_ctxt (prod_assn A1 A2) x y = z"
  by (simp add: hn_ctxt_def)

lemma hn_case_prod'[sepref_prep_comb_rule,sepref_comb_rules]:
  assumes FR: "\<Gamma>\<Longrightarrow>\<^sub>thn_ctxt (prod_assn P1 P2) p' p * \<Gamma>1"
  assumes Pair: "\<And>a1 a2 a1' a2'. \<lbrakk>p'=(a1',a2')\<rbrakk>
    \<Longrightarrow> hn_refine (hn_ctxt P1 a1' a1 * hn_ctxt P2 a2' a2 * \<Gamma>1 * hn_invalid (prod_assn P1 P2) p' p) (f a1 a2)
          (hn_ctxt P1' a1' a1 * hn_ctxt P2' a2' a2 * hn_ctxt XX1 p' p * \<Gamma>1') R (f' a1' a2')"
  shows "hn_refine \<Gamma> (case_prod f p) (hn_ctxt (prod_assn P1' P2') p' p * \<Gamma>1')
    R (case_prod$(\<lambda>\<^sub>2a b. f' a b)$p')" (is "?G \<Gamma>")
    apply1 (rule hn_refine_cons_pre[OF FR])
    apply1 extract_hnr_invalids
    apply1 (cases p; cases p'; simp add: prod_assn_pair_conv[THEN prod_assn_ctxt])
    apply (rule hn_refine_cons[OF _ Pair _ entt_refl])
    applyS (simp add: hn_ctxt_def)
    applyS simp
    applyS (simp add: hn_ctxt_def entt_fr_refl entt_fr_drop)
    done

lemma hn_case_prod_old:
  assumes P: "\<Gamma>\<Longrightarrow>\<^sub>t\<Gamma>1 * hn_ctxt (prod_assn P1 P2) p' p"
  assumes R: "\<And>a1 a2 a1' a2'. \<lbrakk>p'=(a1',a2')\<rbrakk>
    \<Longrightarrow> hn_refine (\<Gamma>1 * hn_ctxt P1 a1' a1 * hn_ctxt P2 a2' a2 * hn_invalid (prod_assn P1 P2) p' p) (f a1 a2)
          (\<Gamma>h a1 a1' a2 a2') R (f' a1' a2')"
  assumes M: "\<And>a1 a1' a2 a2'. \<Gamma>h a1 a1' a2 a2'
    \<Longrightarrow>\<^sub>t \<Gamma>' * hn_ctxt P1' a1' a1 * hn_ctxt P2' a2' a2 * hn_ctxt Pxx p' p"
  shows "hn_refine \<Gamma> (case_prod f p) (\<Gamma>' * hn_ctxt (prod_assn P1' P2') p' p)
    R (case_prod$(\<lambda>\<^sub>2a b. f' a b)$p')"
  apply1 (cases p; cases p'; simp)
  apply1 (rule hn_refine_cons_pre[OF P])
  apply (rule hn_refine_preI)
  apply (simp add: hn_ctxt_def assn_aci)
  apply (rule hn_refine_cons[OF _ R])
  apply1 (rule enttI)
  applyS (sep_auto simp add: hn_ctxt_def invalid_assn_def mod_star_conv)

  applyS simp
  apply1 (rule entt_trans[OF M])
  applyS (sep_auto intro!: enttI simp: hn_ctxt_def)

  applyS simp
  done

lemma hn_Pair[sepref_fr_rules]: "hn_refine
  (hn_ctxt P1 x1 x1' * hn_ctxt P2 x2 x2')
  (return (x1',x2'))
  (hn_invalid P1 x1 x1' * hn_invalid P2 x2 x2')
  (prod_assn P1 P2)
  (RETURN$(Pair$x1$x2))"
  unfolding hn_refine_def
  apply (sep_auto simp: hn_ctxt_def prod_assn_def)
  apply (rule ent_frame_fwd[OF invalidate_clone'[of P1]], frame_inference)
  apply (rule ent_frame_fwd[OF invalidate_clone'[of P2]], frame_inference)
  apply sep_auto
  done

lemma fst_hnr[sepref_fr_rules]: "(return o fst,RETURN o fst) \<in> (prod_assn A B)\<^sup>d \<rightarrow>\<^sub>a A"
  by sepref_to_hoare sep_auto
lemma snd_hnr[sepref_fr_rules]: "(return o snd,RETURN o snd) \<in> (prod_assn A B)\<^sup>d \<rightarrow>\<^sub>a B"
  by sepref_to_hoare sep_auto

lemmas [constraint_simps] = prod_assn_pure_conv
lemmas [sepref_import_param] = param_prod_swap

lemma rdomp_prodD[dest!]: "rdomp (prod_assn A B) (a,b) \<Longrightarrow> rdomp A a \<and> rdomp B b"
  unfolding rdomp_def prod_assn_def
  by (sep_auto simp: mod_star_conv)

subsection "Option"
fun option_assn :: "('a \<Rightarrow> 'c \<Rightarrow> assn) \<Rightarrow> 'a option \<Rightarrow> 'c option \<Rightarrow> assn" where
  "option_assn P None None = emp"
| "option_assn P (Some a) (Some c) = P a c"
| "option_assn _ _ _ = false"

lemma option_assn_simps[simp]:
  "option_assn P None v' = \<up>(v'=None)"
  "option_assn P v None = \<up>(v=None)"
  apply (cases v', simp_all)
  apply (cases v, simp_all)
  done

lemma option_assn_alt_def: "option_assn R a b =
  (case (a,b) of (Some x, Some y) \<Rightarrow> R x y
  | (None,None) \<Rightarrow> emp
  | _ \<Rightarrow> false)"
  by (auto split: option.split)

lemma option_assn_pure_conv[constraint_simps]: "option_assn (pure R) = pure (\<langle>R\<rangle>option_rel)"
  apply (intro ext)
  apply (rename_tac a c)
  apply (case_tac "(pure R,a,c)" rule: option_assn.cases)
  by (auto simp: pure_def)

lemmas [sepref_import_rewrite, sepref_frame_normrel_eqs, fcomp_norm_unfold] = option_assn_pure_conv[symmetric]

lemma hr_comp_option_conv[simp, fcomp_norm_unfold]: "
  hr_comp (option_assn R) (\<langle>R'\<rangle>option_rel)
  = option_assn (hr_comp R R')"
  unfolding hr_comp_def[abs_def]
  apply (intro ext ent_iffI)
  apply solve_entails
  apply (case_tac "(R,b,c)" rule: option_assn.cases)
  apply clarsimp_all

  apply (sep_auto simp: option_assn_alt_def split: option.splits)
  apply (clarsimp simp: option_assn_alt_def split: option.splits; safe)
  apply (sep_auto split: option.splits)
  apply (intro ent_ex_preI)
  apply (rule ent_ex_postI)
  apply (sep_auto split: option.splits)
  done

lemma option_assn_precise[safe_constraint_rules]:
  assumes "precise P"
  shows "precise (option_assn P)"
proof
  fix a a' p h F F'
  assume A: "h \<Turnstile> option_assn P a p * F \<and>\<^sub>A option_assn P a' p * F'"
  thus "a=a'" proof (cases "(P,a,p)" rule: option_assn.cases)
    case (2 _ av pv) hence [simp]: "a=Some av" "p=Some pv" by simp_all

    from A obtain av' where [simp]: "a'=Some av'" by (cases a', simp_all)

    from A have "h \<Turnstile> P av pv * F \<and>\<^sub>A P av' pv * F'" by simp
    with \<open>precise P\<close> have "av=av'" by (rule preciseD)
    thus ?thesis by simp
  qed simp_all
qed

lemma pure_option[safe_constraint_rules]:
  assumes P: "is_pure P"
  shows "is_pure (option_assn P)"
proof -
  from P obtain P' where P': "\<And>x x'. P x x' = \<up>(P' x x')"
    using is_pureE by blast

  show ?thesis proof
    fix x x'
    show "option_assn P x x' =
         \<up> (case (x, x') of
             (None,None) \<Rightarrow> True | (Some v, Some v') \<Rightarrow> P' v v' | _ \<Rightarrow> False
           )"
      apply (simp add: P' split: prod.split option.split)
      done
  qed
qed

lemma hn_ctxt_option: "option_assn A x y = z \<Longrightarrow> hn_ctxt (option_assn A) x y = z"
  by (simp add: hn_ctxt_def)

lemma hn_case_option[sepref_prep_comb_rule, sepref_comb_rules]:
  fixes p p' P
  defines [simp]: "INVE \<equiv> hn_invalid (option_assn P) p p'"
  assumes FR: "\<Gamma> \<Longrightarrow>\<^sub>t hn_ctxt (option_assn P) p p' * F"
  assumes Rn: "p=None \<Longrightarrow> hn_refine (hn_ctxt (option_assn P) p p' * F) f1' (hn_ctxt XX1 p p' * \<Gamma>1') R f1"
  assumes Rs: "\<And>x x'. \<lbrakk> p=Some x; p'=Some x' \<rbrakk> \<Longrightarrow>
    hn_refine (hn_ctxt P x x' * INVE * F) (f2' x') (hn_ctxt P' x x' * hn_ctxt XX2 p p' * \<Gamma>2') R (f2 x)"
  assumes MERGE1: "\<Gamma>1' \<or>\<^sub>A \<Gamma>2' \<Longrightarrow>\<^sub>t \<Gamma>'"
  shows "hn_refine \<Gamma> (case_option f1' f2' p') (hn_ctxt (option_assn P') p p' * \<Gamma>') R (case_option$f1$(\<lambda>\<^sub>2x. f2 x)$p)"
    apply (rule hn_refine_cons_pre[OF FR])
    apply1 extract_hnr_invalids
    apply (cases p; cases p'; simp add: option_assn.simps[THEN hn_ctxt_option])
    subgoal
      apply (rule hn_refine_cons[OF _ Rn _ entt_refl]; assumption?)
      applyS (simp add: hn_ctxt_def)

      apply (subst mult.commute, rule entt_fr_drop)
      apply (rule entt_trans[OF _ MERGE1])
      apply (simp add: ent_disjI1' ent_disjI2')
    done

    subgoal
      apply (rule hn_refine_cons[OF _ Rs _ entt_refl]; assumption?)
      applyS (simp add: hn_ctxt_def)
      apply (rule entt_star_mono)
      apply1 (rule entt_fr_drop)
      applyS (simp add: hn_ctxt_def)
      apply1 (rule entt_trans[OF _ MERGE1])
      applyS (simp add: hn_ctxt_def)
    done
    done

lemma hn_None[sepref_fr_rules]:
  "hn_refine emp (return None) emp (option_assn P) (RETURN$None)"
  by rule sep_auto

lemma hn_Some[sepref_fr_rules]: "hn_refine
  (hn_ctxt P v v')
  (return (Some v'))
  (hn_invalid P v v')
  (option_assn P)
  (RETURN$(Some$v))"
  by rule (sep_auto simp: hn_ctxt_def invalidate_clone')

definition "imp_option_eq eq a b \<equiv> case (a,b) of
  (None,None) \<Rightarrow> return True
| (Some a, Some b) \<Rightarrow> eq a b
| _ \<Rightarrow> return False"

(* TODO: This is some kind of generic algorithm! Use GEN_ALGO here, and
  let GEN_ALGO re-use the registered operator rules *)
lemma option_assn_eq[sepref_comb_rules]:
  fixes a b :: "'a option"
  assumes F1: "\<Gamma> \<Longrightarrow>\<^sub>t hn_ctxt (option_assn P) a a' * hn_ctxt (option_assn P) b b' * \<Gamma>1"
  assumes EQ: "\<And>va va' vb vb'. hn_refine
    (hn_ctxt P va va' * hn_ctxt P vb vb' * \<Gamma>1)
    (eq' va' vb')
    (\<Gamma>' va va' vb vb')
    bool_assn
    (RETURN$((=) $va$vb))"
  assumes F2:
    "\<And>va va' vb vb'.
      \<Gamma>' va va' vb vb' \<Longrightarrow>\<^sub>t hn_ctxt P va va' * hn_ctxt P vb vb' * \<Gamma>1"
  shows "hn_refine
    \<Gamma>
    (imp_option_eq eq' a' b')
    (hn_ctxt (option_assn P) a a' * hn_ctxt (option_assn P) b b' * \<Gamma>1)
    bool_assn
    (RETURN$((=) $a$b))"
  apply (rule hn_refine_cons_pre[OF F1])
  unfolding imp_option_eq_def
  apply rule
  apply (simp split: option.split add: hn_ctxt_def, intro impI conjI)

  apply (sep_auto split: option.split simp: hn_ctxt_def pure_def)
  apply (cases a, (sep_auto split: option.split simp: hn_ctxt_def pure_def)+)[]
  apply (cases a, (sep_auto split: option.split simp: hn_ctxt_def pure_def)+)[]
  apply (cases b, (sep_auto split: option.split simp: hn_ctxt_def pure_def)+)[]
  apply (rule cons_post_rule)
  apply (rule hn_refineD[OF EQ[unfolded hn_ctxt_def]])
  apply simp
  apply (rule ent_frame_fwd[OF F2[THEN enttD,unfolded hn_ctxt_def]])
  apply (fr_rot 2)
  apply (fr_rot_rhs 1)
  apply (rule fr_refl)
  apply (rule ent_refl)
  apply (sep_auto simp: pure_def)
  done

lemma [pat_rules]:
  "(=) $a$None \<equiv> is_None$a"
  "(=) $None$a \<equiv> is_None$a"
  apply (rule eq_reflection, simp split: option.split)+
  done

lemma hn_is_None[sepref_fr_rules]: "hn_refine
  (hn_ctxt (option_assn P) a a')
  (return (is_None a'))
  (hn_ctxt (option_assn P) a a')
  bool_assn
  (RETURN$(is_None$a))"
  apply rule
  apply (sep_auto split: option.split simp: hn_ctxt_def pure_def)
  done

lemma (in -) sepref_the_complete[sepref_fr_rules]:
  assumes "x\<noteq>None"
  shows "hn_refine
    (hn_ctxt (option_assn R) x xi)
    (return (the xi))
    (hn_invalid (option_assn R) x xi)
    (R)
    (RETURN$(the$x))"
    using assms
    apply (cases x)
    apply simp
    apply (cases xi)
    apply (simp add: hn_ctxt_def)
    apply rule
    apply (sep_auto simp: hn_ctxt_def invalidate_clone' vassn_tagI invalid_assn_const)
    done

(* As the sepref_the_complete rule does not work for us
  --- the assertion ensuring the side-condition gets decoupled from its variable by a copy-operation ---
  we use the following rule that only works for the identity relation *)
lemma (in -) sepref_the_id:
  assumes "CONSTRAINT (IS_PURE IS_ID) R"
  shows "hn_refine
    (hn_ctxt (option_assn R) x xi)
    (return (the xi))
    (hn_ctxt (option_assn R) x xi)
    (R)
    (RETURN$(the$x))"
    using assms
    apply (clarsimp simp: IS_PURE_def IS_ID_def hn_ctxt_def is_pure_conv)
    apply (cases x)
    apply simp
    apply (cases xi)
    apply (simp add: hn_ctxt_def invalid_assn_def)
    apply rule apply (sep_auto simp: pure_def)
    apply rule apply (sep_auto)
    apply (simp add: option_assn_pure_conv)
    apply rule apply (sep_auto simp: pure_def invalid_assn_def)
    done

subsection "Lists"

fun list_assn :: "('a \<Rightarrow> 'c \<Rightarrow> assn) \<Rightarrow> 'a list \<Rightarrow> 'c list \<Rightarrow> assn" where
  "list_assn P [] [] = emp"
| "list_assn P (a#as) (c#cs) = P a c * list_assn P as cs"
| "list_assn _ _ _ = false"

lemma list_assn_aux_simps[simp]:
  "list_assn P [] l' = (\<up>(l'=[]))"
  "list_assn P l [] = (\<up>(l=[]))"
  unfolding hn_ctxt_def
  apply (cases l')
  apply simp
  apply simp
  apply (cases l)
  apply simp
  apply simp
  done

lemma list_assn_aux_append[simp]:
  "length l1=length l1' \<Longrightarrow>
    list_assn P (l1@l2) (l1'@l2')
    = list_assn P l1 l1' * list_assn P l2 l2'"
  apply (induct rule: list_induct2)
  apply simp
  apply (simp add: star_assoc)
  done

lemma list_assn_aux_ineq_len: "length l \<noteq> length li \<Longrightarrow> list_assn A l li = false"
proof (induction l arbitrary: li)
  case (Cons x l li) thus ?case by (cases li; auto)
qed simp

lemma list_assn_aux_append2[simp]:
  assumes "length l2=length l2'"
  shows "list_assn P (l1@l2) (l1'@l2')
    = list_assn P l1 l1' * list_assn P l2 l2'"
  apply (cases "length l1 = length l1'")
  apply (erule list_assn_aux_append)
  apply (simp add: list_assn_aux_ineq_len assms)
  done

lemma list_assn_pure_conv[constraint_simps]: "list_assn (pure R) = pure (\<langle>R\<rangle>list_rel)"
proof (intro ext)
  fix l li
  show "list_assn (pure R) l li = pure (\<langle>R\<rangle>list_rel) l li"
    apply (induction "pure R" l li rule: list_assn.induct)
    by (auto simp: pure_def)
qed

lemmas [sepref_import_rewrite, sepref_frame_normrel_eqs, fcomp_norm_unfold] = list_assn_pure_conv[symmetric]

lemma list_assn_simps[simp]:
  "hn_ctxt (list_assn P) [] l' = (\<up>(l'=[]))"
  "hn_ctxt (list_assn P) l [] = (\<up>(l=[]))"
  "hn_ctxt (list_assn P) [] [] = emp"
  "hn_ctxt (list_assn P) (a#as) (c#cs) = hn_ctxt P a c * hn_ctxt (list_assn P) as cs"
  "hn_ctxt (list_assn P) (a#as) [] = false"
  "hn_ctxt (list_assn P) [] (c#cs) = false"
  unfolding hn_ctxt_def
  apply (cases l')
  apply simp
  apply simp
  apply (cases l)
  apply simp
  apply simp
  apply simp_all
  done

lemma list_assn_precise[constraint_rules]: "precise P \<Longrightarrow> precise (list_assn P)"
proof
  fix l1 l2 l h F1 F2
  assume P: "precise P"
  assume "h\<Turnstile>list_assn P l1 l * F1 \<and>\<^sub>A list_assn P l2 l * F2"
  thus "l1=l2"
  proof (induct l arbitrary: l1 l2 F1 F2)
    case Nil thus ?case by simp
  next
    case (Cons a ls)
    from Cons obtain a1 ls1 where [simp]: "l1=a1#ls1"
      by (cases l1, simp)
    from Cons obtain a2 ls2 where [simp]: "l2=a2#ls2"
      by (cases l2, simp)

    from Cons.prems have M:
      "h \<Turnstile> P a1 a * list_assn P ls1 ls * F1
        \<and>\<^sub>A P a2 a * list_assn P ls2 ls * F2" by simp
    have "a1=a2"
      apply (rule preciseD[OF P, where a=a1 and a'=a2 and p=a
        and F= "list_assn P ls1 ls * F1"
        and F'="list_assn P ls2 ls * F2"
        ])
      using M
      by (simp add: star_assoc)

    moreover have "ls1=ls2"
      apply (rule Cons.hyps[where ?F1.0="P a1 a * F1" and ?F2.0="P a2 a * F2"])
      using M
      by (simp only: star_aci)
    ultimately show ?case by simp
  qed
qed
lemma list_assn_pure[constraint_rules]:
  assumes P: "is_pure P"
  shows "is_pure (list_assn P)"
proof -
  from P obtain P' where P_eq: "\<And>x x'. P x x' = \<up>(P' x x')"
    by (rule is_pureE) blast

  {
    fix l l'
    have "list_assn P l l' = \<up>(list_all2 P' l l')"
      by (induct P\<equiv>P l l' rule: list_assn.induct)
         (simp_all add: P_eq)
  } thus ?thesis by rule
qed

lemma list_assn_mono:
  "\<lbrakk>\<And>x x'. P x x'\<Longrightarrow>\<^sub>AP' x x'\<rbrakk> \<Longrightarrow> list_assn P l l' \<Longrightarrow>\<^sub>A list_assn P' l l'"
  unfolding hn_ctxt_def
  apply (induct P l l' rule: list_assn.induct)
  by (auto intro: ent_star_mono)

lemma list_assn_monot:
  "\<lbrakk>\<And>x x'. P x x'\<Longrightarrow>\<^sub>tP' x x'\<rbrakk> \<Longrightarrow> list_assn P l l' \<Longrightarrow>\<^sub>t list_assn P' l l'"
  unfolding hn_ctxt_def
  apply (induct P l l' rule: list_assn.induct)
  by (auto intro: entt_star_mono)

lemma list_match_cong[sepref_frame_match_rules]:
  "\<lbrakk>\<And>x x'. \<lbrakk>x\<in>set l; x'\<in>set l'\<rbrakk> \<Longrightarrow> hn_ctxt A x x' \<Longrightarrow>\<^sub>t hn_ctxt A' x x' \<rbrakk> \<Longrightarrow> hn_ctxt (list_assn A) l l' \<Longrightarrow>\<^sub>t hn_ctxt (list_assn A') l l'"
  unfolding hn_ctxt_def
  by (induct A l l' rule: list_assn.induct) (simp_all add: entt_star_mono)

lemma list_merge_cong[sepref_frame_merge_rules]:
  assumes "\<And>x x'. \<lbrakk>x\<in>set l; x'\<in>set l'\<rbrakk> \<Longrightarrow> hn_ctxt A x x' \<or>\<^sub>A hn_ctxt A' x x' \<Longrightarrow>\<^sub>t hn_ctxt Am x x'"
  shows "hn_ctxt (list_assn A) l l' \<or>\<^sub>A hn_ctxt (list_assn A') l l' \<Longrightarrow>\<^sub>t hn_ctxt (list_assn Am) l l'"
  apply (blast intro: entt_disjE list_match_cong entt_disjD1[OF assms] entt_disjD2[OF assms])
  done

lemma invalid_list_split:
  "invalid_assn (list_assn A) (x#xs) (y#ys) \<Longrightarrow>\<^sub>t invalid_assn A x y * invalid_assn (list_assn A) xs ys"
  by (fastforce simp: invalid_assn_def intro!: enttI simp: mod_star_conv)

lemma entt_invalid_list: "hn_invalid (list_assn A) l l' \<Longrightarrow>\<^sub>t hn_ctxt (list_assn (invalid_assn A)) l l'"
  apply (induct A l l' rule: list_assn.induct)
  applyS simp

  subgoal
    apply1 (simp add: hn_ctxt_def cong del: invalid_assn_cong)
    apply1 (rule entt_trans[OF invalid_list_split])
    apply (rule entt_star_mono)
      applyS simp

      apply (rule entt_trans)
        applyS assumption
        applyS simp
    done

  applyS (simp add: hn_ctxt_def invalid_assn_def)
  applyS (simp add: hn_ctxt_def invalid_assn_def)
  done

lemmas invalid_list_merge[sepref_frame_merge_rules] = gen_merge_cons[OF entt_invalid_list]

lemma list_assn_comp[fcomp_norm_unfold]: "hr_comp (list_assn A) (\<langle>B\<rangle>list_rel) = list_assn (hr_comp A B)"
proof (intro ext)
  { fix x l y m
    have "hr_comp (list_assn A) (\<langle>B\<rangle>list_rel) (x # l) (y # m) =
      hr_comp A B x y * hr_comp (list_assn A) (\<langle>B\<rangle>list_rel) l m"
      by (sep_auto
        simp: hr_comp_def list_rel_split_left_iff
        intro!: ent_ex_preI ent_iffI) (* TODO: ent_ex_preI should be applied by default, before ent_ex_postI!*)
  } note aux = this

  fix l li
  show "hr_comp (list_assn A) (\<langle>B\<rangle>list_rel) l li = list_assn (hr_comp A B) l li"
    apply (induction l arbitrary: li; case_tac li; intro ent_iffI)
    apply (sep_auto simp: hr_comp_def; fail)+
    by (simp_all add: aux)
qed

lemma hn_ctxt_eq: "A x y = z \<Longrightarrow> hn_ctxt A x y = z" by (simp add: hn_ctxt_def)

lemmas hn_ctxt_list = hn_ctxt_eq[of "list_assn A" for A]

lemma hn_case_list[sepref_prep_comb_rule, sepref_comb_rules]:
  fixes p p' P
  defines [simp]: "INVE \<equiv> hn_invalid (list_assn P) p p'"
  assumes FR: "\<Gamma> \<Longrightarrow>\<^sub>t hn_ctxt (list_assn P) p p' * F"
  assumes Rn: "p=[] \<Longrightarrow> hn_refine (hn_ctxt (list_assn P) p p' * F) f1' (hn_ctxt XX1 p p' * \<Gamma>1') R f1"
  assumes Rs: "\<And>x l x' l'. \<lbrakk> p=x#l; p'=x'#l' \<rbrakk> \<Longrightarrow>
    hn_refine (hn_ctxt P x x' * hn_ctxt (list_assn P) l l' * INVE * F) (f2' x' l') (hn_ctxt P1' x x' * hn_ctxt (list_assn P2') l l' * hn_ctxt XX2 p p' * \<Gamma>2') R (f2 x l)"
  assumes MERGE1[unfolded hn_ctxt_def]: "\<And>x x'. hn_ctxt P1' x x' \<or>\<^sub>A hn_ctxt P2' x x' \<Longrightarrow>\<^sub>t hn_ctxt P' x x'"
  assumes MERGE2: "\<Gamma>1' \<or>\<^sub>A \<Gamma>2' \<Longrightarrow>\<^sub>t \<Gamma>'"
  shows "hn_refine \<Gamma> (case_list f1' f2' p') (hn_ctxt (list_assn P') p p' * \<Gamma>') R (case_list$f1$(\<lambda>\<^sub>2x l. f2 x l)$p)"
    apply (rule hn_refine_cons_pre[OF FR])
    apply1 extract_hnr_invalids
    apply (cases p; cases p'; simp add: list_assn.simps[THEN hn_ctxt_list])
    subgoal
      apply (rule hn_refine_cons[OF _ Rn _ entt_refl]; assumption?)
      applyS (simp add: hn_ctxt_def)

      apply (subst mult.commute, rule entt_fr_drop)
      apply (rule entt_trans[OF _ MERGE2])
      apply (simp add: ent_disjI1' ent_disjI2')
    done

    subgoal
      apply (rule hn_refine_cons[OF _ Rs _ entt_refl]; assumption?)
      applyS (simp add: hn_ctxt_def)
      apply (rule entt_star_mono)
      apply1 (rule entt_fr_drop)
      apply (rule entt_star_mono)

      apply1 (simp add: hn_ctxt_def)
      apply1 (rule entt_trans[OF _ MERGE1])
      applyS (simp)

      apply1 (simp add: hn_ctxt_def)
      apply (rule list_assn_monot)
      apply1 (rule entt_trans[OF _ MERGE1])
      applyS (simp)

      apply1 (rule entt_trans[OF _ MERGE2])
      applyS (simp)
    done
    done

lemma hn_Nil[sepref_fr_rules]:
  "hn_refine emp (return []) emp (list_assn P) (RETURN$[])"
  unfolding hn_refine_def
  by sep_auto

lemma hn_Cons[sepref_fr_rules]: "hn_refine (hn_ctxt P x x' * hn_ctxt (list_assn P) xs xs')
  (return (x'#xs')) (hn_invalid P x x' * hn_invalid (list_assn P) xs xs') (list_assn P)
  (RETURN$((#) $x$xs))"
  unfolding hn_refine_def
  apply (sep_auto simp: hn_ctxt_def)
  apply (rule ent_frame_fwd[OF invalidate_clone'[of P]], frame_inference)
  apply (rule ent_frame_fwd[OF invalidate_clone'[of "list_assn P"]], frame_inference)
  apply solve_entails
  done

lemma list_assn_aux_len:
  "list_assn P l l' = list_assn P l l' * \<up>(length l = length l')"
  apply (induct P\<equiv>P l l' rule: list_assn.induct)
  apply simp_all
  subgoal for a as c cs
    by (erule_tac t="list_assn P as cs" in subst[OF sym]) simp
  done

lemma list_assn_aux_eqlen_simp:
  "vassn_tag (list_assn P l l') \<Longrightarrow> length l' = length l"
  "h \<Turnstile> (list_assn P l l') \<Longrightarrow> length l' = length l"
  apply (subst (asm) list_assn_aux_len; auto simp: vassn_tag_def)+
  done

lemma hn_append[sepref_fr_rules]: "hn_refine (hn_ctxt (list_assn P) l1 l1' * hn_ctxt (list_assn P) l2 l2')
  (return (l1'@l2')) (hn_invalid (list_assn P) l1 l1' * hn_invalid (list_assn P) l2 l2') (list_assn P)
  (RETURN$((@) $l1$l2))"
  apply rule
  apply (sep_auto simp: hn_ctxt_def)
  apply (subst list_assn_aux_len)
  apply (sep_auto)
  apply (rule ent_frame_fwd[OF invalidate_clone'[of "list_assn P"]], frame_inference)
  apply (rule ent_frame_fwd[OF invalidate_clone'[of "list_assn P"]], frame_inference)
  apply solve_entails
  done

lemma list_assn_aux_cons_conv1:
  "list_assn R (a#l) m = (\<exists>\<^sub>Ab m'. R a b * list_assn R l m' * \<up>(m=b#m'))"
  apply (cases m)
  apply sep_auto
  apply (sep_auto intro!: ent_iffI)
  done
lemma list_assn_aux_cons_conv2:
  "list_assn R l (b#m) = (\<exists>\<^sub>Aa l'. R a b * list_assn R l' m * \<up>(l=a#l'))"
  apply (cases l)
  apply sep_auto
  apply (sep_auto intro!: ent_iffI)
  done
lemmas list_assn_aux_cons_conv = list_assn_aux_cons_conv1 list_assn_aux_cons_conv2

lemma list_assn_aux_append_conv1:
  "list_assn R (l1@l2) m = (\<exists>\<^sub>Am1 m2. list_assn R l1 m1 * list_assn R l2 m2 * \<up>(m=m1@m2))"
  apply (induction l1 arbitrary: m)
  apply (sep_auto intro!: ent_iffI)
  apply (sep_auto intro!: ent_iffI simp: list_assn_aux_cons_conv)
  done
lemma list_assn_aux_append_conv2:
  "list_assn R l (m1@m2) = (\<exists>\<^sub>Al1 l2. list_assn R l1 m1 * list_assn R l2 m2 * \<up>(l=l1@l2))"
  apply (induction m1 arbitrary: l)
  apply (sep_auto intro!: ent_iffI)
  apply (sep_auto intro!: ent_iffI simp: list_assn_aux_cons_conv)
  done
lemmas list_assn_aux_append_conv = list_assn_aux_append_conv1 list_assn_aux_append_conv2

declare param_upt[sepref_import_param]

subsection \<open>Sum-Type\<close>

fun sum_assn :: "('ai \<Rightarrow> 'a \<Rightarrow> assn) \<Rightarrow> ('bi \<Rightarrow> 'b \<Rightarrow> assn) \<Rightarrow> ('ai+'bi) \<Rightarrow> ('a+'b) \<Rightarrow> assn" where
  "sum_assn A B (Inl ai) (Inl a) = A ai a"
| "sum_assn A B (Inr bi) (Inr b) = B bi b"
| "sum_assn A B _ _ = false"

notation sum_assn (infixr "+\<^sub>a" 67)

lemma sum_assn_pure[safe_constraint_rules]: "\<lbrakk>is_pure A; is_pure B\<rbrakk> \<Longrightarrow> is_pure (sum_assn A B)"
  apply (auto simp: is_pure_iff_pure_assn)
  apply (rename_tac x x')
  apply (case_tac x; case_tac x'; simp add: pure_def)
  done

lemma sum_assn_id[simp]: "sum_assn id_assn id_assn = id_assn"
  apply (intro ext)
  subgoal for x y by (cases x; cases y; simp add: pure_def)
  done

lemma sum_assn_pure_conv[simp]: "sum_assn (pure A) (pure B) = pure (\<langle>A,B\<rangle>sum_rel)"
  apply (intro ext)
  subgoal for a b by (cases a; cases b; auto simp: pure_def)
  done

lemma sum_match_cong[sepref_frame_match_rules]:
  "\<lbrakk>
    \<And>x y. \<lbrakk>e = Inl x; e'=Inl y\<rbrakk> \<Longrightarrow> hn_ctxt A x y \<Longrightarrow>\<^sub>t hn_ctxt A' x y;
    \<And>x y. \<lbrakk>e = Inr x; e'=Inr y\<rbrakk> \<Longrightarrow> hn_ctxt B x y \<Longrightarrow>\<^sub>t hn_ctxt B' x y
  \<rbrakk> \<Longrightarrow> hn_ctxt (sum_assn A B) e e' \<Longrightarrow>\<^sub>t hn_ctxt (sum_assn A' B') e e'"
  by (cases e; cases e'; simp add: hn_ctxt_def entt_star_mono)

lemma enum_merge_cong[sepref_frame_merge_rules]:
  assumes "\<And>x y. \<lbrakk>e=Inl x; e'=Inl y\<rbrakk> \<Longrightarrow> hn_ctxt A x y \<or>\<^sub>A hn_ctxt A' x y \<Longrightarrow>\<^sub>t hn_ctxt Am x y"
  assumes "\<And>x y. \<lbrakk>e=Inr x; e'=Inr y\<rbrakk> \<Longrightarrow> hn_ctxt B x y \<or>\<^sub>A hn_ctxt B' x y \<Longrightarrow>\<^sub>t hn_ctxt Bm x y"
  shows "hn_ctxt (sum_assn A B) e e' \<or>\<^sub>A hn_ctxt (sum_assn A' B') e e' \<Longrightarrow>\<^sub>t hn_ctxt (sum_assn Am Bm) e e'"
  apply (rule entt_disjE)
  apply (rule sum_match_cong)
  apply (rule entt_disjD1[OF assms(1)]; simp)
  apply (rule entt_disjD1[OF assms(2)]; simp)

  apply (rule sum_match_cong)
  apply (rule entt_disjD2[OF assms(1)]; simp)
  apply (rule entt_disjD2[OF assms(2)]; simp)
  done

lemma entt_invalid_sum: "hn_invalid (sum_assn A B) e e' \<Longrightarrow>\<^sub>t hn_ctxt (sum_assn (invalid_assn A) (invalid_assn B)) e e'"
  apply (simp add: hn_ctxt_def invalid_assn_def[abs_def])
  apply (rule enttI)
  apply clarsimp
  apply (cases e; cases e'; auto simp: mod_star_conv pure_def)
  done

lemmas invalid_sum_merge[sepref_frame_merge_rules] = gen_merge_cons[OF entt_invalid_sum]

sepref_register Inr Inl

lemma [sepref_fr_rules]: "(return o Inl,RETURN o Inl) \<in> A\<^sup>d \<rightarrow>\<^sub>a sum_assn A B"
  by sepref_to_hoare sep_auto
lemma [sepref_fr_rules]: "(return o Inr,RETURN o Inr) \<in> B\<^sup>d \<rightarrow>\<^sub>a sum_assn A B"
  by sepref_to_hoare sep_auto

sepref_register case_sum

text \<open>In the monadify phase, this eta-expands to make visible all required arguments\<close>
lemma [sepref_monadify_arity]: "case_sum \<equiv> \<lambda>\<^sub>2f1 f2 x. SP case_sum$(\<lambda>\<^sub>2x. f1$x)$(\<lambda>\<^sub>2x. f2$x)$x"
  by simp

text \<open>This determines an evaluation order for the first-order operands\<close>
lemma [sepref_monadify_comb]: "case_sum$f1$f2$x \<equiv> (\<bind>) $(EVAL$x)$(\<lambda>\<^sub>2x. SP case_sum$f1$f2$x)" by simp

text \<open>This enables translation of the case-distinction in a non-monadic context.\<close>
lemma [sepref_monadify_comb]: "EVAL$(case_sum$(\<lambda>\<^sub>2x. f1 x)$(\<lambda>\<^sub>2x. f2 x)$x)
  \<equiv> (\<bind>) $(EVAL$x)$(\<lambda>\<^sub>2x. SP case_sum$(\<lambda>\<^sub>2x. EVAL $ f1 x)$(\<lambda>\<^sub>2x. EVAL $ f2 x)$x)"
  apply (rule eq_reflection)
  by (simp split: sum.splits)

text \<open>Auxiliary lemma, to lift simp-rule over \<open>hn_ctxt\<close>\<close>
lemma sum_assn_ctxt: "sum_assn A B x y = z \<Longrightarrow> hn_ctxt (sum_assn A B) x y = z"
  by (simp add: hn_ctxt_def)

text \<open>The cases lemma first extracts the refinement for the datatype from the precondition.
  Next, it generate proof obligations to refine the functions for every case.
  Finally the postconditions of the refinement are merged.

  Note that we handle the
  destructed values separately, to allow reconstruction of the original datatype after the case-expression.

  Moreover, we provide (invalidated) versions of the original compound value to the cases,
  which allows access to pure compound values from inside the case.
  \<close>
lemma sum_cases_hnr:
  fixes A B e e'
  defines [simp]: "INVe \<equiv> hn_invalid (sum_assn A B) e e'"
  assumes FR: "\<Gamma> \<Longrightarrow>\<^sub>t hn_ctxt (sum_assn A B) e e' * F"
  assumes E1: "\<And>x1 x1a. \<lbrakk>e = Inl x1; e' = Inl x1a\<rbrakk> \<Longrightarrow> hn_refine (hn_ctxt A x1 x1a * INVe * F) (f1' x1a) (hn_ctxt A' x1 x1a * hn_ctxt XX1 e e' * \<Gamma>1') R (f1 x1)"
  assumes E2: "\<And>x2 x2a. \<lbrakk>e = Inr x2; e' = Inr x2a\<rbrakk> \<Longrightarrow> hn_refine (hn_ctxt B x2 x2a * INVe * F) (f2' x2a) (hn_ctxt B' x2 x2a * hn_ctxt XX2 e e' * \<Gamma>2') R (f2 x2)"
  assumes MERGE[unfolded hn_ctxt_def]: "\<Gamma>1' \<or>\<^sub>A \<Gamma>2' \<Longrightarrow>\<^sub>t \<Gamma>'"
  shows "hn_refine \<Gamma> (case_sum f1' f2' e') (hn_ctxt (sum_assn A' B') e e' * \<Gamma>') R (case_sum$(\<lambda>\<^sub>2x. f1 x)$(\<lambda>\<^sub>2x. f2 x)$e)"
  apply (rule hn_refine_cons_pre[OF FR])
  apply1 extract_hnr_invalids
  apply (cases e; cases e'; simp add: sum_assn.simps[THEN sum_assn_ctxt])
  subgoal
    apply (rule hn_refine_cons[OF _ E1 _ entt_refl]; assumption?)
    applyS (simp add: hn_ctxt_def) \<comment> \<open>Match precondition for case, get \<open>enum_assn\<close> from assumption generated by \<open>extract_hnr_invalids\<close>\<close>
    apply (rule entt_star_mono) \<comment> \<open>Split postcondition into pairs for compounds and frame, drop \<open>hn_ctxt XX\<close>\<close>
    apply1 (rule entt_fr_drop)
    applyS (simp add: hn_ctxt_def entt_disjI1' entt_disjI2')
    apply1 (rule entt_trans[OF _ MERGE])
    applyS (simp add: entt_disjI1' entt_disjI2')
  done
  subgoal
    apply (rule hn_refine_cons[OF _ E2 _ entt_refl]; assumption?)
    applyS (simp add: hn_ctxt_def)
    apply (rule entt_star_mono)
    apply1 (rule entt_fr_drop)
    applyS (simp add: hn_ctxt_def entt_disjI1' entt_disjI2')
    apply1 (rule entt_trans[OF _ MERGE])
    applyS (simp add: entt_disjI1' entt_disjI2')
  done
done

text \<open>After some more preprocessing (adding extra frame-rules for non-atomic postconditions,
  and splitting the merge-terms into binary merges), this rule can be registered\<close>
lemmas [sepref_comb_rules] = sum_cases_hnr[sepref_prep_comb_rule]

sepref_register isl projl projr
lemma isl_hnr[sepref_fr_rules]: "(return o isl,RETURN o isl) \<in> (sum_assn A B)\<^sup>k \<rightarrow>\<^sub>a bool_assn"
  apply sepref_to_hoare
  subgoal for a b by (cases a; cases b; sep_auto)
  done

lemma projl_hnr[sepref_fr_rules]: "(return o projl,RETURN o projl) \<in> [isl]\<^sub>a (sum_assn A B)\<^sup>d \<rightarrow> A"
  apply sepref_to_hoare
  subgoal for a b by (cases a; cases b; sep_auto)
  done

lemma projr_hnr[sepref_fr_rules]: "(return o projr,RETURN o projr) \<in> [Not o isl]\<^sub>a (sum_assn A B)\<^sup>d \<rightarrow> B"
  apply sepref_to_hoare
  subgoal for a b by (cases a; cases b; sep_auto)
  done

subsection \<open>String Literals\<close>

sepref_register "PR_CONST String.empty_literal"

lemma empty_literal_hnr [sepref_import_param]:
  "(String.empty_literal, PR_CONST String.empty_literal) \<in> Id"
  by simp

lemma empty_literal_pat [def_pat_rules]:
  "String.empty_literal \<equiv> UNPROTECT String.empty_literal"
  by simp

context
  fixes b0 b1 b2 b3 b4 b5 b6 :: bool
  and s :: String.literal
begin

sepref_register "PR_CONST (String.Literal b0 b1 b2 b3 b4 b5 b6 s)"

lemma Literal_hnr [sepref_import_param]:
  "(String.Literal b0 b1 b2 b3 b4 b5 b6 s,
    PR_CONST (String.Literal b0 b1 b2 b3 b4 b5 b6 s)) \<in> Id"
  by simp

end

lemma Literal_pat [def_pat_rules]:
  "String.Literal $ b0 $ b1 $ b2 $ b3 $ b4 $ b5 $ b6 $ s \<equiv>
    UNPROTECT (String.Literal $ b0 $ b1 $ b2 $ b3 $ b4 $ b5 $ b6 $ s)"
  by simp

end


theory InferredAnomaly
  imports Main Observation
begin

section \<open>Inferred Non-Cyclic Anomalies\<close>

text \<open>Using observations, we set out to infer anomalies which should (we hope) be present in
any compatible observation. We prefix these versions of the anomalies with 'i' for 'inferred'.\<close>

definition has_ig1a :: "observation \<Rightarrow> bool" where
"has_ig1a obs \<equiv> (\<exists>t1 t2 k v. t1\<in> all_otxns obs \<and>
                              t2 \<in> all_otxns obs \<and>
                              o_is_committed t1 = Some False \<and>
                              o_is_committed t2 = Some True \<and>
                              is_recoverable obs k v t1 \<and>
                              (ORead k (Some v)) \<in> (all_oops obs))"

theorem ig1a_sound "has_ig1a obs \<longrightarrow> (\<forall>i. i \<in> interpretations obs \<longrightarrow> has_g1a (history i))"

end


(*  Title:      RSAPSS/EMSAPSS.thy
    Author:     Christina Lindenberg, Kai Wirt, Technische Universität Darmstadt
    Copyright:  2005 - Technische Universität Darmstadt
*)

section "EMSA-PSS encoding and decoding operation"

theory EMSAPSS
imports SHA1 Wordarith
begin

text \<open>We define the encoding and decoding operations for the probabilistic
 signature scheme. Finally we show, that encoded messages always can be
 verified\<close>

definition show_rightmost_bits:: "bv \<Rightarrow> nat \<Rightarrow> bv" (* extract n rightmost bits of a bit string*)
  where "show_rightmost_bits bvec n = rev (take n (rev bvec))"

definition BC:: "bv" (* 0xbc *)
  where "BC = [One, Zero, One, One, One, One, Zero, Zero]"

definition salt:: "bv"
  where "salt = []"

definition sLen:: "nat" (* length of salt *)
  where "sLen = length salt"

definition generate_M':: "bv \<Rightarrow> bv \<Rightarrow> bv" (* generate_M' outputs "M'" a bit string of length "64 + length(sha1 _ ) + sLen" with 64 initial zero bits *)
  where "generate_M' mHash salt_new = bv_prepend 64 \<zero> [] @ mHash @ salt_new"

definition generate_PS:: "nat \<Rightarrow> nat \<Rightarrow> bv" (* generate_PS outputs "PS" a bit string consisting of "nat (roundup emBits 8) * 8 - sLen - length (sha1 _ ) - 16" zero bits *)
  where "generate_PS emBits hLen = bv_prepend ((roundup emBits 8)*8 - sLen - hLen - 16) \<zero> []"

definition generate_DB:: "bv \<Rightarrow> bv" (* generate_DB outputs the bit string DB="PS#(0x01)#salt" of length "nat (roundup emBits 8) * 8 - length (sha1 _ ) - 8" *)
  where "generate_DB PS = PS @ [Zero, Zero, Zero, Zero, Zero, Zero, Zero, One] @ salt"

definition maskedDB_zero:: "bv \<Rightarrow> nat \<Rightarrow> bv" (* sets "roundup emBits 8 * 8 - emBits" bits of maskedDB to zero *)
  where "maskedDB_zero maskedDB emBits = bv_prepend ((roundup emBits 8) * 8 - emBits)  \<zero> (drop ((roundup emBits 8)*8 - emBits) maskedDB)"

definition generate_H:: "bv \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bv" (* generate_H returns a bit string of length (sha1 _) *)
  where "generate_H EM emBits hLen = take hLen (drop ((roundup emBits 8)*8 - hLen - 8) EM)"

definition generate_maskedDB:: "bv \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bv " (* outputs a bit string of length "nat (roundup emBits 8) * 8 - length (sha1 _) - 8" *)
  where "generate_maskedDB EM emBits hLen = take ((roundup emBits 8)*8 - hLen - 8) EM"

definition generate_salt:: "bv \<Rightarrow> bv" (* outputs a bit string of length sLen *)
  where "generate_salt DB_zero = show_rightmost_bits DB_zero sLen"

primrec MGF2:: "bv \<Rightarrow> nat \<Rightarrow> bv" (* help function for MGF1 *)
where
  "MGF2 Z 0 = sha1 (Z@(nat_to_bv_length 0 32))"
| "MGF2 Z (Suc n) = (MGF2 Z n)@(sha1 (Z@(nat_to_bv_length (Suc n) 32)))"

definition MGF1:: "bv \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bv" (* help function for MGF *)
  where "MGF1 Z n l = take l (MGF2 Z n)"

definition MGF:: "bv \<Rightarrow> nat \<Rightarrow> bv" (* mask generation function *)
where
  "MGF Z l = (if l = 0 \<or> 2^32*(length (sha1 Z)) < l
              then []
              else MGF1 Z ( roundup l (length (sha1 Z))  - 1 ) l)"

definition emsapss_encode_help8:: "bv \<Rightarrow> bv \<Rightarrow> bv"
  where "emsapss_encode_help8 DBzero H = DBzero @ H @ BC"

definition emsapss_encode_help7:: "bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bv"
  where "emsapss_encode_help7 maskedDB H emBits =
    emsapss_encode_help8 (maskedDB_zero maskedDB emBits) H"

definition emsapss_encode_help6:: "bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bv"
  where "emsapss_encode_help6 DB dbMask H emBits =
    (if dbMask = []
     then []
     else emsapss_encode_help7 (bvxor DB dbMask) H emBits)"

definition emsapss_encode_help5:: "bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bv"
  where "emsapss_encode_help5 DB H emBits =
    emsapss_encode_help6 DB (MGF H (length DB)) H emBits"

definition emsapss_encode_help4:: "bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bv"
  where "emsapss_encode_help4 PS H emBits =
    emsapss_encode_help5 (generate_DB PS) H emBits"

definition emsapss_encode_help3:: "bv \<Rightarrow> nat \<Rightarrow> bv"
  where "emsapss_encode_help3 H emBits =
    emsapss_encode_help4 (generate_PS emBits (length H)) H emBits"

definition emsapss_encode_help2:: "bv \<Rightarrow> nat \<Rightarrow> bv"
  where "emsapss_encode_help2 M' emBits = emsapss_encode_help3 (sha1 M') emBits"

definition emsapss_encode_help1:: "bv \<Rightarrow> nat \<Rightarrow> bv"
  where "emsapss_encode_help1 mHash emBits =
    (if emBits  < length (mHash) + sLen + 16
     then []
     else emsapss_encode_help2 (generate_M' mHash salt) emBits)"

definition emsapss_encode:: "bv \<Rightarrow> nat \<Rightarrow> bv" (* outputs the encoded message of length emBits *)
  where "emsapss_encode M emBits =
    (if (2^64 \<le> length M \<or> 2^32 * 160 < emBits)
     then []
     else emsapss_encode_help1 (sha1 M) emBits)"

definition emsapss_decode_help11:: "bv \<Rightarrow> bv \<Rightarrow> bool"
  where "emsapss_decode_help11 H' H = (if H' \<noteq> H then False else True)"

definition emsapss_decode_help10:: "bv \<Rightarrow> bv \<Rightarrow> bool"
  where "emsapss_decode_help10 M' H = emsapss_decode_help11 (sha1 M') H"

definition emsapss_decode_help9:: "bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> bool"
  where "emsapss_decode_help9 mHash salt_new H =
    emsapss_decode_help10 (generate_M' mHash salt_new) H"

definition emsapss_decode_help8:: "bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> bool"
  where "emsapss_decode_help8 mHash DB_zero H =
    emsapss_decode_help9 mHash (generate_salt DB_zero) H"

definition emsapss_decode_help7:: "bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool"
  where "emsapss_decode_help7 mHash DB_zero H emBits =
   (if (take ( (roundup emBits 8)*8 - (length mHash) - sLen - 16) DB_zero \<noteq> bv_prepend ( (roundup emBits 8)*8 - (length mHash) - sLen - 16) \<zero> []) \<or> (take 8 ( drop ((roundup emBits 8)*8 - (length mHash) - sLen - 16 ) DB_zero ) \<noteq> [Zero, Zero, Zero, Zero, Zero, Zero, Zero, One])
    then False
    else emsapss_decode_help8 mHash DB_zero H)"

definition emsapss_decode_help6:: "bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool"
  where "emsapss_decode_help6 mHash DB H emBits =
    emsapss_decode_help7 mHash (maskedDB_zero DB emBits) H emBits"

definition emsapss_decode_help5:: "bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool"
  where "emsapss_decode_help5 mHash maskedDB dbMask H emBits =
    emsapss_decode_help6 mHash (bvxor maskedDB dbMask) H emBits"

definition emsapss_decode_help4:: "bv \<Rightarrow> bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool"
  where "emsapss_decode_help4 mHash maskedDB H emBits =
   (if take ((roundup emBits 8)*8 - emBits) maskedDB \<noteq> bv_prepend ((roundup emBits 8)*8 - emBits) \<zero> []
    then False
    else emsapss_decode_help5 mHash maskedDB (MGF H ((roundup emBits 8)*8 - (length mHash) - 8)) H emBits)"

definition emsapss_decode_help3:: "bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool"
  where "emsapss_decode_help3 mHash EM emBits =
    emsapss_decode_help4 mHash (generate_maskedDB EM emBits (length mHash)) (generate_H EM emBits (length mHash)) emBits"

definition emsapss_decode_help2:: "bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool"
  where "emsapss_decode_help2 mHash EM emBits =
   (if show_rightmost_bits EM 8 \<noteq> BC
    then False
    else emsapss_decode_help3 mHash EM emBits)"

definition emsapss_decode_help1:: "bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool"
  where "emsapss_decode_help1 mHash EM emBits =
    (if emBits < length (mHash) + sLen + 16
     then False
     else emsapss_decode_help2 mHash EM emBits)"

definition emsapss_decode:: "bv \<Rightarrow> bv \<Rightarrow> nat \<Rightarrow> bool" (* outputs "true" if EM is encoding of M *)
  where "emsapss_decode M EM emBits =
    (if (2^64 \<le> length M \<or> 2^32*160<emBits)
     then False
     else emsapss_decode_help1 (sha1 M) EM emBits)"

lemma roundup_positiv: "0 < emBits \<Longrightarrow> 0 < roundup emBits 160"
  by (auto simp add: roundup)

lemma roundup_ge_emBits:" 0 < emBits \<Longrightarrow> 0 < x \<Longrightarrow> emBits \<le> (roundup emBits x) * x"
  apply (simp add: roundup mult.commute)
  apply (safe)
  apply (simp)
  apply (simp add: add.commute [of x "x*(emBits div x)" ])
  apply (insert mult_div_mod_eq [of x emBits])
  apply (subgoal_tac "emBits mod x < x")
  apply (arith)
  apply (simp only: mod_less_divisor)
  done

lemma roundup_ge_0: "0 < emBits \<Longrightarrow> 0 < x \<Longrightarrow> 0 \<le> roundup emBits x * x - emBits"
  by (simp add: roundup)

lemma roundup_le_7: "0 < emBits \<Longrightarrow> roundup emBits 8 * 8 - emBits \<le>  7"
  by (auto simp add: roundup) arith

lemma roundup_nat_ge_8_help:
  "length (sha1 M) + sLen + 16 \<le> emBits \<Longrightarrow> 8 \<le> roundup emBits 8 * 8 - (length (sha1 M) + 8)"
  apply (insert roundup_ge_emBits [of emBits 8])
  apply (simp add: roundup sha1len sLen_def)
  done

lemma roundup_nat_ge_8:
  "length (sha1 M) + sLen + 16 \<le> emBits \<Longrightarrow> 8 \<le> roundup emBits 8 * 8 - (length (sha1 M) + 8)"
  apply (insert roundup_nat_ge_8_help [of M emBits])
  apply arith
  done

lemma roundup_le_ub:
  "\<lbrakk> 176 + sLen \<le> emBits; emBits \<le> 2^32 * 160\<rbrakk> \<Longrightarrow> (roundup emBits 8) * 8 - 168 \<le> 2^32 * 160"
  apply (simp add: roundup)
  apply (safe)
  apply (simp)
  apply (arith)+
  done

lemma modify_roundup_ge1: "\<lbrakk>8 \<le> roundup emBits 8 * 8 - 168\<rbrakk> \<Longrightarrow> 176 \<le>  roundup emBits 8 * 8"
  by arith

lemma modify_roundup_ge2: "\<lbrakk> 176 \<le> roundup emBits 8 * 8\<rbrakk> \<Longrightarrow> 21 < roundup emBits 8"
  by simp

lemma roundup_help1: "\<lbrakk> 0 < roundup l 160\<rbrakk> \<Longrightarrow> (roundup l 160 - 1) + 1 = (roundup l 160)"
  by arith

lemma roundup_help1_new: "\<lbrakk> 0 < l\<rbrakk> \<Longrightarrow> (roundup l 160 - 1) + 1 = (roundup l 160)"
  apply (drule roundup_positiv [of l])
  apply arith
  done

lemma roundup_help2: "\<lbrakk>176 + sLen \<le> emBits\<rbrakk> \<Longrightarrow> roundup emBits 8 * 8 - emBits <=  roundup emBits 8 * 8 - 160 - sLen - 16"
  by (simp add: sLen_def)

lemma bv_prepend_equal: "bv_prepend (Suc n) b l = b#bv_prepend n b l"
  by (simp add: bv_prepend)

lemma length_bv_prepend: "length (bv_prepend n b l) = n+length l"
  by (induct n) (simp_all add: bv_prepend)

lemma length_bv_prepend_drop: "a <= length xs \<longrightarrow> length (bv_prepend a b (drop a xs)) = length xs"
  by (simp add:length_bv_prepend)

lemma take_bv_prepend: "take n (bv_prepend n b x) = bv_prepend n b []"
  by (induct n) (simp add: bv_prepend)+

lemma take_bv_prepend2: "take n (bv_prepend n b xs@ys@zs) = bv_prepend n b []"
  by (induct n) (simp add: bv_prepend)+

lemma bv_prepend_append: "bv_prepend a b x = bv_prepend a b [] @ x"
  by (induct a) (simp add: bv_prepend, simp add: bv_prepend_equal)

lemma bv_prepend_append2:
  "x < y \<Longrightarrow> bv_prepend y b xs = (bv_prepend x b [])@(bv_prepend (y-x) b [])@xs"
  by (simp add: bv_prepend replicate_add [symmetric])

lemma drop_bv_prepend_help2: "\<lbrakk>x < y\<rbrakk> \<Longrightarrow> drop x (bv_prepend y b []) = bv_prepend (y-x) b []"
  apply (insert bv_prepend_append2 [of "x" "y" b "[]"])
  by (simp add: length_bv_prepend)

lemma drop_bv_prepend_help3: "\<lbrakk>x = y\<rbrakk> \<Longrightarrow> drop x (bv_prepend y b []) = bv_prepend (y-x) b []"
  apply (insert length_bv_prepend [of y b "[]"])
  by (simp add: bv_prepend)

lemma bv_prepend_add: "bv_prepend x b [] @ bv_prepend y b [] = bv_prepend (x + y) b []"
  by (induct x) (simp add: bv_prepend)+

lemma bv_prepend_drop: "x \<le> y \<longrightarrow> bv_prepend x b (drop x (bv_prepend y b [])) = bv_prepend y b []"
  apply (simp add: drop_bv_prepend_help4 [of x y b])
  by (simp add: bv_prepend_append [of "x" b "(bv_prepend (y - x) b [])"] bv_prepend_add)

lemma bv_prepend_split: "bv_prepend x b (left @ right) = bv_prepend x b left @ right"
  by (induct x) (simp add: bv_prepend)+

lemma length_generate_DB: "length (generate_DB PS) = length PS + 8 + sLen"
  by (simp add: generate_DB_def sLen_def)

lemma length_generate_PS: "length (generate_PS emBits 160) = (roundup emBits 8)*8 - sLen - 160 - 16"
  by (simp add: generate_PS_def length_bv_prepend)

lemma length_bvxor: "length a = length b \<Longrightarrow> length (bvxor a b) = length a"
  by (simp add: bvxor)

lemma length_MGF2: "length (MGF2 Z m) = Suc m * length (sha1 (Z @ nat_to_bv_length m 32))"
  by (induct m) (simp+, simp add: sha1len)

lemma length_MGF1: "l \<le> (Suc n) * 160 \<Longrightarrow> length (MGF1 Z n l) = l"
  by (simp add: MGF1_def length_MGF2 sha1len)

lemma length_MGF: "0 < l \<Longrightarrow> l \<le>  2^32 * length (sha1 x) \<Longrightarrow> length (MGF x l) = l"
  apply (simp add: MGF_def sha1len)
  apply (insert roundup_help1_new [of l])
  apply (rule length_MGF1)
  apply (simp)
  apply (insert roundup_ge_emBits [of l 160])
  apply (arith)
  done

lemma solve_length_generate_DB:
  "\<lbrakk> 0 < emBits; length (sha1 M) + sLen + 16 \<le> emBits\<rbrakk>
  \<Longrightarrow> length (generate_DB (generate_PS emBits (length (sha1 x)) )) = (roundup emBits 8) * 8 - 168"
  apply (insert roundup_ge_emBits [of emBits 8])
  apply (simp add: length_generate_DB length_generate_PS sha1len)
  done

lemma length_maskedDB_zero:
  "\<lbrakk> roundup emBits 8 * 8 - emBits \<le> length maskedDB\<rbrakk>
  \<Longrightarrow> length (maskedDB_zero maskedDB emBits) = length maskedDB"
  by (simp add: maskedDB_zero_def length_bv_prepend)

lemma take_equal_bv_prepend:
  "\<lbrakk> 176 + sLen \<le> emBits; roundup emBits 8 * 8 - emBits \<le> 7\<rbrakk>
  \<Longrightarrow> take (roundup emBits 8 * 8 - length (sha1 M) - sLen - 16) (maskedDB_zero (generate_DB (generate_PS emBits 160)) emBits) =
    bv_prepend (roundup emBits 8 * 8 - length (sha1 M) - sLen - 16) \<zero> []"
  apply (insert roundup_help2 [of emBits] length_generate_PS [of emBits])
  apply (simp add: sha1len maskedDB_zero_def generate_DB_def generate_PS_def
    bv_prepend_split bv_prepend_drop)
  done

lemma lastbits_BC: "BC = show_rightmost_bits (xs @ ys @ BC) 8"
  by (simp add: show_rightmost_bits_def BC_def)

lemma equal_zero:
  "176 + sLen \<le> emBits \<Longrightarrow> roundup emBits 8 * 8 - emBits \<le> roundup emBits 8 * 8 - (176 + sLen)
  \<Longrightarrow> 0 = roundup emBits 8 * 8 - emBits - (roundup emBits 8 * 8 - (176 + sLen))"
  by arith

lemma get_salt: "\<lbrakk> 176 + sLen \<le> emBits; roundup emBits 8 * 8 - emBits \<le> 7\<rbrakk> \<Longrightarrow> (generate_salt (maskedDB_zero (generate_DB (generate_PS emBits 160)) emBits)) = salt"
  apply (insert roundup_help2 [of emBits] length_generate_PS [of emBits] equal_zero [of emBits])
  apply (simp add: generate_DB_def generate_PS_def maskedDB_zero_def)
  apply (simp add: bv_prepend_split bv_prepend_drop generate_salt_def
    show_rightmost_bits_def sLen_def)
  done

lemma generate_maskedDB_elim: "\<lbrakk>roundup emBits 8 * 8 - emBits \<le> length x; ( roundup emBits 8) * 8 - (length (sha1 M)) - 8 = length (maskedDB_zero x emBits)\<rbrakk> \<Longrightarrow> generate_maskedDB (maskedDB_zero x emBits @ y @ z) emBits (length(sha1 M)) = maskedDB_zero x emBits"
  apply (simp add: maskedDB_zero_def)
  apply (insert length_bv_prepend_drop [of "(roundup emBits 8 * 8 - emBits)" "x"])
  apply (simp add: generate_maskedDB_def)
  done

lemma generate_H_elim: "\<lbrakk> roundup emBits 8 * 8 - emBits \<le> length x; length (maskedDB_zero x emBits) =  (roundup emBits 8) * 8 - 168; length y = 160\<rbrakk> \<Longrightarrow> generate_H (maskedDB_zero x emBits @ y @ z) emBits 160 = y"
  apply (simp add: maskedDB_zero_def)
  apply (insert length_bv_prepend_drop [of "roundup emBits 8 * 8 - emBits" "x"])
  apply (simp add: generate_H_def)
  done

lemma length_bv_prepend_drop_special: "[|roundup emBits 8 * 8 - emBits <= roundup emBits 8 * 8 - (176 + sLen); length (generate_PS emBits 160) = roundup emBits 8 * 8 - (176 + sLen)|] ==> length ( bv_prepend (roundup emBits 8 * 8 - emBits) \<zero> (drop (roundup emBits 8 * 8 - emBits) (generate_PS emBits 160))) = length (generate_PS emBits 160)"
  by (simp add: length_bv_prepend_drop)

lemma x01_elim: "\<lbrakk>176 + sLen \<le> emBits; roundup emBits 8 * 8 - emBits \<le> 7\<rbrakk> \<Longrightarrow> take 8 (drop (roundup emBits 8 * 8 - (length (sha1 M) + sLen + 16))(maskedDB_zero (generate_DB (generate_PS emBits 160)) emBits)) = [\<zero>, \<zero>, \<zero>, \<zero>, \<zero>, \<zero>, \<zero>, \<one>]"
  apply (insert roundup_help2 [of emBits] length_generate_PS [of emBits] equal_zero [of emBits])
  apply (simp add: sha1len maskedDB_zero_def generate_DB_def generate_PS_def
    bv_prepend_split bv_prepend_drop)
  done

lemma bvxorxor_elim_help:
  assumes "x <= length a" and "length a = length b"
  shows "bv_prepend x \<zero> (drop x (bvxor (bv_prepend x \<zero> (drop x (bvxor a b))) b)) =
    bv_prepend x \<zero> (drop x a)"
proof -
  have "drop x (bvxor (bv_prepend x \<zero> (drop x (bvxor a b))) b) = drop x a"
    apply (unfold bvxor bv_prepend)
    apply (cut_tac assms)
    apply (insert length_replicate [of x \<zero> ])
    apply (insert length_drop [of x a])
    apply (insert length_drop [of x b])
    apply (insert length_bvxor [of "drop x a" "drop x b"])
    apply (subgoal_tac "length (replicate x \<zero> @ drop x (bv_mapzip (\<oplus>\<^sub>b) a b)) = length b")
    apply (subgoal_tac "b = (take x b)@(drop x b)")
    apply (insert drop_bv_mapzip [of x "(replicate x \<zero> @ drop x (bv_mapzip (\<oplus>\<^sub>b) a b))" b "(\<oplus>\<^sub>b)"])
    apply (simp)
    apply (insert drop_bv_mapzip [of x a b "(\<oplus>\<^sub>b)"])
    apply (simp)
    apply (fold bvxor)
    apply (simp_all)
    done
  with assms show ?thesis by simp
qed

lemma bvxorxor_elim: "\<lbrakk> roundup emBits 8 * 8 - emBits \<le> length a; length a = length b\<rbrakk> \<Longrightarrow> (maskedDB_zero (bvxor (maskedDB_zero (bvxor a b) emBits)b) emBits) = bv_prepend (roundup emBits 8 * 8 - emBits) \<zero> (drop (roundup emBits 8 * 8 - emBits) a)"
  by (simp add: maskedDB_zero_def bvxorxor_elim_help)

lemma verify: "\<lbrakk>(emsapss_encode M emBits) \<noteq> []; EM=(emsapss_encode M emBits)\<rbrakk> \<Longrightarrow> emsapss_decode M EM emBits = True"
  apply (simp add: emsapss_decode_def emsapss_encode_def)
  apply (safe, simp+)
  apply (simp add: emsapss_decode_help1_def emsapss_encode_help1_def)
  apply (safe, simp+)
  apply (simp add: emsapss_decode_help2_def emsapss_encode_help2_def)
  apply (safe)
  apply (simp add: emsapss_encode_help3_def emsapss_encode_help4_def
    emsapss_encode_help5_def emsapss_encode_help6_def)
  apply (safe)
  apply (simp add: emsapss_encode_help7_def emsapss_encode_help8_def lastbits_BC [symmetric])+
  apply (simp add: emsapss_decode_help3_def emsapss_encode_help3_def
    emsapss_decode_help4_def emsapss_encode_help4_def)
  apply (safe)
  apply (insert roundup_le_7 [of emBits] roundup_ge_0 [of emBits 8] roundup_nat_ge_8 [of M emBits])
  apply (simp add: generate_maskedDB_def emsapss_encode_help5_def emsapss_encode_help6_def)
  apply (safe)
  apply (simp)
  apply (simp add: emsapss_encode_help7_def)
  apply (simp only: emsapss_encode_help8_def)
  apply (simp only: maskedDB_zero_def)
  apply (simp only: take_bv_prepend2 min.absorb1)
  apply (simp)
  apply (simp add: emsapss_encode_help5_def emsapss_encode_help6_def)
  apply (safe)
  apply (simp)+
  apply (insert solve_length_generate_DB [of emBits M "generate_M' (sha1 M) salt"] roundup_le_ub [of emBits])
  apply (insert length_MGF [of "(roundup emBits 8) * 8 - 168" "(sha1 (generate_M' (sha1 M) salt))"])
  apply (insert modify_roundup_ge1 [of emBits] modify_roundup_ge2 [of emBits])
  apply (simp add: sha1len emsapss_encode_help7_def emsapss_encode_help8_def)
  apply (insert length_bvxor [of "(generate_DB (generate_PS emBits 160))" "(MGF (sha1 (generate_M' (sha1 M) salt)) ((roundup emBits 8) * 8 - 168))"])
  apply (insert generate_maskedDB_elim [of emBits "(bvxor (generate_DB (generate_PS emBits 160))(MGF (sha1 (generate_M' (sha1 M) salt)) ((roundup emBits 8) * 8 - 168)))" M "sha1 (generate_M' (sha1 M) salt)" BC])
  apply (insert length_maskedDB_zero [of emBits "(bvxor (generate_DB (generate_PS emBits 160))(MGF (sha1 (generate_M' (sha1 M) salt)) ((roundup emBits 8) * 8 - 168)))"])
  apply (insert generate_H_elim [of emBits "(bvxor (generate_DB (generate_PS emBits 160))(MGF (sha1 (generate_M' (sha1 M) salt)) (roundup emBits 8 * 8 - 168)))" "sha1 (generate_M' (sha1 M) salt)" BC])
  apply (simp add: sha1len emsapss_decode_help5_def)
  apply (simp only: emsapss_decode_help6_def emsapss_decode_help7_def)
  apply (insert bvxorxor_elim [of emBits "(generate_DB (generate_PS emBits 160))" "(MGF (sha1 (generate_M' (sha1 M) salt)) ((roundup emBits 8) * 8 - 168))"])
  apply (fold maskedDB_zero_def)
  apply (insert take_equal_bv_prepend [of emBits M] x01_elim [of emBits M] get_salt [of emBits])
  apply (simp add: emsapss_decode_help8_def emsapss_decode_help9_def emsapss_decode_help10_def emsapss_decode_help11_def)
  done

end