diff --git a/thys/Applicative_Lifting/Applicative.thy b/thys/Applicative_Lifting/Applicative.thy
--- a/thys/Applicative_Lifting/Applicative.thy
+++ b/thys/Applicative_Lifting/Applicative.thy
@@ -1,135 +1,146 @@
 (* Author: Joshua Schneider, ETH Zurich *)
 
 section \<open>Lifting with applicative functors\<close>
 
 theory Applicative
 imports Main
 keywords "applicative" :: thy_goal and "print_applicative" :: diag
 begin
 
 subsection \<open>Equality restricted to a set\<close>
 
 definition eq_on :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
 where [simp]: "eq_on A = (\<lambda>x y. x \<in> A \<and> x = y)"
 
 lemma rel_fun_eq_onI: "(\<And>x. x \<in> A \<Longrightarrow> R (f x) (g x)) \<Longrightarrow> rel_fun (eq_on A) R f g"
 by auto
 
+lemma rel_fun_map_fun2: "rel_fun (eq_on (range h)) A f g \<Longrightarrow> rel_fun (BNF_Def.Grp UNIV h)\<inverse>\<inverse> A f (map_fun h id g)"
+  by(auto simp add: rel_fun_def Grp_def eq_onp_def)
+
+lemma rel_fun_refl_eq_onp:
+  "(\<And>z. z \<in> f ` X \<Longrightarrow> A z z) \<Longrightarrow> rel_fun (eq_on X) A f f"
+  by(auto simp add: rel_fun_def eq_onp_def)
+
+lemma eq_onE: "\<lbrakk> eq_on X a b; \<lbrakk> b \<in> X; a = b \<rbrakk> \<Longrightarrow> thesis \<rbrakk> \<Longrightarrow> thesis" by auto
+
+lemma Domainp_eq_on [simp]: "Domainp (eq_on X) = (\<lambda>x. x \<in> X)"
+  by auto
 
 subsection \<open>Proof automation\<close>
 
 lemma arg1_cong: "x = y \<Longrightarrow> f x z = f y z"
 by (rule arg_cong)
 
 lemma UNIV_E: "x \<in> UNIV \<Longrightarrow> P \<Longrightarrow> P" .
 
 context begin
 
 private named_theorems combinator_unfold
 private named_theorems combinator_repr
 
 private definition "B g f x \<equiv> g (f x)"
 private definition "C f x y \<equiv> f y x"
 private definition "I x \<equiv> x"
 private definition "K x y \<equiv> x"
 private definition "S f g x \<equiv> (f x) (g x)"
 private definition "T x f \<equiv> f x"
 private definition "W f x \<equiv> f x x"
 
 lemmas [abs_def, combinator_unfold] = B_def C_def I_def K_def S_def T_def W_def
 lemmas [combinator_repr] = combinator_unfold
 
 private definition "cpair \<equiv> Pair"
 private definition "cuncurry \<equiv> case_prod"
 
 private lemma uncurry_pair: "cuncurry f (cpair x y) = f x y"
 unfolding cpair_def cuncurry_def by simp
 
 ML_file "applicative.ML"
 
 local_setup \<open>Applicative.setup_combinators
  [("B", @{thm B_def}),
   ("C", @{thm C_def}),
   ("I", @{thm I_def}),
   ("K", @{thm K_def}),
   ("S", @{thm S_def}),
   ("T", @{thm T_def}),
   ("W", @{thm W_def})]\<close>
 
 private attribute_setup combinator_eq =
   \<open>Scan.lift (Scan.option (Args.$$$ "weak" |--
     Scan.optional (Args.colon |-- Scan.repeat1 Args.name) []) >>
     Applicative.combinator_rule_attrib)\<close>
 
 lemma [combinator_eq]: "B \<equiv> S (K S) K" unfolding combinator_unfold .
 lemma [combinator_eq]: "C \<equiv> S (S (K (S (K S) K)) S) (K K)" unfolding combinator_unfold .
 lemma [combinator_eq]: "I \<equiv> W K" unfolding combinator_unfold .
 lemma [combinator_eq]: "I \<equiv> C K ()" unfolding combinator_unfold .
 lemma [combinator_eq]: "S \<equiv> B (B W) (B B C)" unfolding combinator_unfold .
 lemma [combinator_eq]: "T \<equiv> C I" unfolding combinator_unfold .
 lemma [combinator_eq]: "W \<equiv> S S (S K)" unfolding combinator_unfold .
 
 lemma [combinator_eq weak: C]:
   "C \<equiv> C (B B (B B (B W (C (B C (B (B B) (C B (cuncurry (K I))))) (cuncurry K))))) cpair"
 unfolding combinator_unfold uncurry_pair .
 
 end (* context *)
 
 
 method_setup applicative_unfold =
   \<open>Applicative.parse_opt_afun >> (fn opt_af => fn ctxt =>
     SIMPLE_METHOD' (Applicative.unfold_wrapper_tac ctxt opt_af))\<close>
   "unfold into an applicative expression"
 
 method_setup applicative_fold =
   \<open>Applicative.parse_opt_afun >> (fn opt_af => fn ctxt =>
     SIMPLE_METHOD' (Applicative.fold_wrapper_tac ctxt opt_af))\<close>
   "fold an applicative expression"
 
 method_setup applicative_nf =
   \<open>Applicative.parse_opt_afun >> (fn opt_af => fn ctxt =>
     SIMPLE_METHOD' (Applicative.normalize_wrapper_tac ctxt opt_af))\<close>
   "prove an equation that has been lifted to an applicative functor, using normal forms"
 
 method_setup applicative_lifting =
   \<open>Applicative.parse_opt_afun >> (fn opt_af => fn ctxt =>
     SIMPLE_METHOD' (Applicative.lifting_wrapper_tac ctxt opt_af))\<close>
   "prove an equation that has been lifted to an applicative functor"
 
 ML \<open>Outer_Syntax.local_theory_to_proof @{command_keyword "applicative"}
   "register applicative functors"
   (Parse.binding --
     Scan.optional (@{keyword "("} |-- Parse.list Parse.short_ident --| @{keyword ")"}) [] --
     (@{keyword "for"} |-- Parse.reserved "pure" |-- @{keyword ":"} |-- Parse.term) --
     (Parse.reserved "ap" |-- @{keyword ":"} |-- Parse.term) --
     Scan.option (Parse.reserved "rel" |-- @{keyword ":"} |-- Parse.term) --
     Scan.option (Parse.reserved "set" |-- @{keyword ":"} |-- Parse.term) >>
     Applicative.applicative_cmd)\<close>
 
 ML \<open>Outer_Syntax.command @{command_keyword "print_applicative"}
   "print registered applicative functors"
   (Scan.succeed (Toplevel.keep (Applicative.print_afuns o Toplevel.context_of)))\<close>
 
 attribute_setup applicative_unfold =
   \<open>Scan.lift (Scan.option Parse.name >> Applicative.add_unfold_attrib)\<close>
   "register rules for unfolding into applicative expressions"
 
 attribute_setup applicative_lifted =
   \<open>Scan.lift (Parse.name >> Applicative.forward_lift_attrib)\<close>
   "lift an equation to an applicative functor"
 
 
 subsection \<open>Overloaded applicative operators\<close>
 
 consts
   pure :: "'a \<Rightarrow> 'b"
   ap :: "'a \<Rightarrow> 'b \<Rightarrow> 'c"
 
 bundle applicative_syntax
 begin
   notation ap (infixl "\<diamondop>" 70)
 end
 
 hide_const (open) ap
 
 end
diff --git a/thys/Constructive_Cryptography/More_CryptHOL.thy b/thys/Constructive_Cryptography/More_CryptHOL.thy
deleted file mode 100644
--- a/thys/Constructive_Cryptography/More_CryptHOL.thy
+++ /dev/null
@@ -1,2451 +0,0 @@
-(* Author: Andreas Lochbihler, ETH Zurich *)
-
-theory More_CryptHOL imports
-  CryptHOL.CryptHOL
-begin
-
-(* Misc *)
-
-lemma is_empty_image [simp]: "Set.is_empty (f ` A) = Set.is_empty A"
-  by(auto simp add: Set.is_empty_def)
-
-lemma inj_on_map_sum [simp]:
-  "\<lbrakk> inj_on f A; inj_on g B \<rbrakk> \<Longrightarrow> inj_on (map_sum f g) (A <+> B)"
-proof(rule inj_onI, goal_cases)
-  case (1 x y)
-  then show ?case by(cases x; cases y; auto simp add: inj_on_def)
-qed
-
-lemma inv_into_map_sum:
-  "inv_into (A <+> B) (map_sum f g) x = map_sum (inv_into A f) (inv_into B g) x"
-  if "x \<in> f ` A <+> g ` B" "inj_on f A" "inj_on g B"
-  using that by(cases rule: PlusE[consumes 1])(auto simp add: inv_into_f_eq f_inv_into_f)
-
-lemma Pair_fst_Unity: "(fst x, ()) = x"
-  by(cases x) simp
-
-fun rsuml :: "('a + 'b) + 'c \<Rightarrow> 'a + ('b + 'c)" where
-  "rsuml (Inl (Inl a)) = Inl a"
-| "rsuml (Inl (Inr b)) = Inr (Inl b)"
-| "rsuml (Inr c) = Inr (Inr c)"
-
-fun lsumr :: "'a + ('b + 'c) \<Rightarrow> ('a + 'b) + 'c" where
-  "lsumr (Inl a) = Inl (Inl a)"
-| "lsumr (Inr (Inl b)) = Inl (Inr b)"
-| "lsumr (Inr (Inr c)) = Inr c"
-
-lemma rsuml_lsumr [simp]: "rsuml (lsumr x) = x"
-  by(cases x rule: lsumr.cases) simp_all
-
-lemma lsumr_rsuml [simp]: "lsumr (rsuml x) = x"
-  by(cases x rule: rsuml.cases) simp_all
-
-definition rprodl :: "('a \<times> 'b) \<times> 'c \<Rightarrow> 'a \<times> ('b \<times> 'c)" where "rprodl = (\<lambda>((a, b), c). (a, (b, c)))"
-
-lemma rprodl_simps [simp]: "rprodl ((a, b), c) = (a, (b, c))"
-  by(simp add: rprodl_def)
-
-lemma rprodl_parametric [transfer_rule]: includes lifting_syntax shows
-  "(rel_prod (rel_prod A B) C ===> rel_prod A (rel_prod B C)) rprodl rprodl"
-  unfolding rprodl_def by transfer_prover
-
-definition lprodr :: "'a \<times> ('b \<times> 'c) \<Rightarrow> ('a \<times> 'b) \<times> 'c" where "lprodr = (\<lambda>(a, b, c). ((a, b), c))"
-
-lemma lprodr_simps [simp]: "lprodr (a, b, c) = ((a, b), c)"
-  by(simp add: lprodr_def)
-
-lemma lprodr_parametric [transfer_rule]: includes lifting_syntax shows
-  "(rel_prod A (rel_prod B C) ===> rel_prod (rel_prod A B) C) lprodr lprodr"
-  unfolding lprodr_def by transfer_prover
-
-lemma lprodr_inverse [simp]: "rprodl (lprodr x) = x"
-  by(cases x) auto
-
-lemma rprodl_inverse [simp]: "lprodr (rprodl x) = x"
-  by(cases x) auto
-
-
-lemma rel_fun_comp:
-  "\<And>f g h. rel_fun A B (f \<circ> g) h = rel_fun A (\<lambda>x. B (f x)) g h"
-  "\<And>f g h. rel_fun A B f (g \<circ> h) = rel_fun A (\<lambda>x y. B x (g y)) f h"
-  by(auto simp add: rel_fun_def)
-
-lemma rel_fun_map_fun1: "rel_fun (BNF_Def.Grp UNIV h)\<inverse>\<inverse> A f g \<Longrightarrow> rel_fun (=) A (map_fun h id f) g"
-  by(auto simp add: rel_fun_def Grp_def)
-
-lemma rel_fun_map_fun2: "rel_fun (eq_on (range h)) A f g \<Longrightarrow> rel_fun (BNF_Def.Grp UNIV h)\<inverse>\<inverse> A f (map_fun h id g)"
-  by(auto simp add: rel_fun_def Grp_def eq_onp_def)
-
-lemma map_fun2_id: "map_fun f g x = g \<circ> map_fun f id x"
-  by(simp add: map_fun_def o_assoc)
-
-lemma rel_fun_refl_eq_onp:
-  "(\<And>z. z \<in> f ` X \<Longrightarrow> A z z) \<Longrightarrow> rel_fun (eq_on X) A f f"
-  by(auto simp add: rel_fun_def eq_onp_def)
-
-lemma map_fun_id2_in: "map_fun g h f = map_fun g id (h \<circ> f)"
-  by(simp add: map_fun_def)
-
-lemma Domainp_rel_fun_le: "Domainp (rel_fun A B) \<le> pred_fun (Domainp A) (Domainp B)"
-  by(auto dest: rel_funD)
-
-lemma eq_onE: "\<lbrakk> eq_on X a b; \<lbrakk> b \<in> X; a = b \<rbrakk> \<Longrightarrow> thesis \<rbrakk> \<Longrightarrow> thesis" by auto
-
-lemma Domainp_eq_on [simp]: "Domainp (eq_on X) = (\<lambda>x. x \<in> X)"
-  by auto
-
-declare eq_on_def [simp del]
-
-lemma pred_prod_mono' [mono]:
-  "pred_prod A B xy \<longrightarrow> pred_prod A' B' xy"
-  if "\<And>x. A x \<longrightarrow> A' x" "\<And>y. B y \<longrightarrow> B' y"
-  using that by(cases xy) auto
-
-fun rel_witness_prod :: "('a \<times> 'b) \<times> ('c \<times> 'd) \<Rightarrow> (('a \<times> 'c) \<times> ('b \<times> 'd))" where
-  "rel_witness_prod ((a, b), (c, d)) = ((a, c), (b, d))"
-
-consts relcompp_witness :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'c \<Rightarrow> 'b"
-specification (relcompp_witness)
-  relcompp_witness1: "(A OO B) (fst xy) (snd xy) \<Longrightarrow> A (fst xy) (relcompp_witness A B xy)"
-  relcompp_witness2: "(A OO B) (fst xy) (snd xy) \<Longrightarrow> B (relcompp_witness A B xy) (snd xy)"
-  apply(fold all_conj_distrib)
-  apply(rule choice allI)+
-  by(auto intro: choice allI)
-
-lemmas relcompp_witness[of _ _ "(x, y)" for x y, simplified] = relcompp_witness1 relcompp_witness2
-
-hide_fact (open) relcompp_witness1 relcompp_witness2
-
-lemma relcompp_witness_eq [simp]: "relcompp_witness (=) (=) (x, x) = x"
-  using relcompp_witness(1)[of "(=)" "(=)" x x] by(simp add: eq_OO)
-
-fun rel_witness_option :: "'a option \<times> 'b option \<Rightarrow> ('a \<times> 'b) option" where
-  "rel_witness_option (Some x, Some y) = Some (x, y)"
-| "rel_witness_option (None, None) = None"
-| "rel_witness_option _ = None" \<comment> \<open>Just to make the definition complete\<close>
-
-lemma rel_witness_option:
-  shows set_rel_witness_option: "\<lbrakk> rel_option A x y; (a, b) \<in> set_option (rel_witness_option (x, y)) \<rbrakk> \<Longrightarrow> A a b"
-    and map1_rel_witness_option: "rel_option A x y \<Longrightarrow> map_option fst (rel_witness_option (x, y)) = x"
-    and map2_rel_witness_option: "rel_option A x y \<Longrightarrow> map_option snd (rel_witness_option (x, y)) = y"
-  by(cases "(x, y)" rule: rel_witness_option.cases; simp; fail)+
-
-lemma rel_witness_option1:
-  assumes "rel_option A x y"
-  shows "rel_option (\<lambda>a (a', b). a = a' \<and> A a' b) x (rel_witness_option (x, y))"
-  using map1_rel_witness_option[OF assms, symmetric]
-  unfolding option.rel_eq[symmetric] option.rel_map
-  by(rule option.rel_mono_strong)(auto intro: set_rel_witness_option[OF assms])
-
-lemma rel_witness_option2:
-  assumes "rel_option A x y"
-  shows "rel_option (\<lambda>(a, b') b. b = b' \<and> A a b') (rel_witness_option (x, y)) y"
-  using map2_rel_witness_option[OF assms]
-  unfolding option.rel_eq[symmetric] option.rel_map
-  by(rule option.rel_mono_strong)(auto intro: set_rel_witness_option[OF assms])
-
-
-definition rel_witness_fun :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'd) \<times> ('c \<Rightarrow> 'e) \<Rightarrow> ('b \<Rightarrow> 'd \<times> 'e)" where
-  "rel_witness_fun A A' = (\<lambda>(f, g) b. (f (THE a. A a b), g (THE c. A' b c)))"
-
-lemma
-  assumes fg: "rel_fun (A OO A') B f g"
-    and A: "left_unique A" "right_total A"
-    and A': "right_unique A'" "left_total A'"
-  shows rel_witness_fun1: "rel_fun A (\<lambda>x (x', y). x = x' \<and> B x' y) f (rel_witness_fun A A' (f, g))"
-    and rel_witness_fun2: "rel_fun A' (\<lambda>(x, y') y. y = y' \<and> B x y') (rel_witness_fun A A' (f, g)) g"
-proof (goal_cases)
-  case 1
-  have "A x y \<Longrightarrow> f x = f (THE a. A a y) \<and> B (f (THE a. A a y)) (g (The (A' y)))" for x y 
-    by(rule left_totalE[OF A'(2)]; erule meta_allE[of _ y]; erule exE; frule (1) fg[THEN rel_funD, OF relcomppI])
-      (auto intro!: arg_cong[where f=f] arg_cong[where f=g] rel_funI the_equality the_equality[symmetric] dest: left_uniqueD[OF A(1)] right_uniqueD[OF A'(1)] elim!: arg_cong2[where f=B, THEN iffD2, rotated -1])
-
-  with 1 show ?case by(clarsimp simp add: rel_fun_def rel_witness_fun_def)
-next
-  case 2
-  have "A' x y \<Longrightarrow> g y = g (The (A' x)) \<and> B (f (THE a. A a x)) (g (The (A' x)))" for x y
-    by(rule right_totalE[OF A(2), of x]; frule (1) fg[THEN rel_funD, OF relcomppI])
-      (auto intro!: arg_cong[where f=f] arg_cong[where f=g] rel_funI the_equality the_equality[symmetric] dest: left_uniqueD[OF A(1)] right_uniqueD[OF A'(1)] elim!: arg_cong2[where f=B, THEN iffD2, rotated -1])
-
-  with 2 show ?case by(clarsimp simp add: rel_fun_def rel_witness_fun_def)    
-qed
-
-lemma rel_witness_fun_eq [simp]: "rel_witness_fun (=) (=) (f, g) = (\<lambda>x. (f x, g x))"
-  by(simp add: rel_witness_fun_def)
-
-
-consts rel_witness_pmf :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a pmf \<times> 'b pmf \<Rightarrow> ('a \<times> 'b) pmf"
-specification (rel_witness_pmf)
-  set_rel_witness_pmf': "rel_pmf A (fst xy) (snd xy) \<Longrightarrow> set_pmf (rel_witness_pmf A xy) \<subseteq> {(a, b). A a b}"
-  map1_rel_witness_pmf': "rel_pmf A (fst xy) (snd xy) \<Longrightarrow> map_pmf fst (rel_witness_pmf A xy) = fst xy"
-  map2_rel_witness_pmf': "rel_pmf A (fst xy) (snd xy) \<Longrightarrow> map_pmf snd (rel_witness_pmf A xy) = snd xy"
-  apply(fold all_conj_distrib imp_conjR)
-  apply(rule choice allI)+
-  apply(unfold pmf.in_rel)
-  by blast
-
-lemmas set_rel_witness_pmf = set_rel_witness_pmf'[of _ "(x, y)" for x y, simplified]
-lemmas map1_rel_witness_pmf = map1_rel_witness_pmf'[of _ "(x, y)" for x y, simplified]
-lemmas map2_rel_witness_pmf = map2_rel_witness_pmf'[of _ "(x, y)" for x y, simplified]
-lemmas rel_witness_pmf = set_rel_witness_pmf map1_rel_witness_pmf map2_rel_witness_pmf
-
-lemma rel_witness_pmf1:
-  assumes "rel_pmf A p q" 
-  shows "rel_pmf (\<lambda>a (a', b). a = a' \<and> A a' b) p (rel_witness_pmf A (p, q))"
-  using map1_rel_witness_pmf[OF assms, symmetric]
-  unfolding pmf.rel_eq[symmetric] pmf.rel_map
-  by(rule pmf.rel_mono_strong)(auto dest: set_rel_witness_pmf[OF assms, THEN subsetD])
-
-lemma rel_witness_pmf2:
-  assumes "rel_pmf A p q" 
-  shows "rel_pmf (\<lambda>(a, b') b. b = b' \<and> A a b') (rel_witness_pmf A (p, q)) q"
-  using map2_rel_witness_pmf[OF assms]
-  unfolding pmf.rel_eq[symmetric] pmf.rel_map
-  by(rule pmf.rel_mono_strong)(auto dest: set_rel_witness_pmf[OF assms, THEN subsetD])
-
-definition rel_witness_spmf :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a spmf \<times> 'b spmf \<Rightarrow> ('a \<times> 'b) spmf" where
-  "rel_witness_spmf A = map_pmf rel_witness_option \<circ> rel_witness_pmf (rel_option A)"
-
-lemma assumes "rel_spmf A p q"
-  shows rel_witness_spmf1: "rel_spmf (\<lambda>a (a', b). a = a' \<and> A a' b) p (rel_witness_spmf A (p, q))"
-    and rel_witness_spmf2: "rel_spmf (\<lambda>(a, b') b. b = b' \<and> A a b') (rel_witness_spmf A (p, q)) q"
-  by(auto simp add: pmf.rel_map rel_witness_spmf_def intro: pmf.rel_mono_strong[OF rel_witness_pmf1[OF assms]] rel_witness_option1 pmf.rel_mono_strong[OF rel_witness_pmf2[OF assms]] rel_witness_option2)
-
-
-primrec (transfer) enforce_option :: "('a \<Rightarrow> bool) \<Rightarrow> 'a option \<Rightarrow> 'a option" where
-  "enforce_option P (Some x) = (if P x then Some x else None)"
-| "enforce_option P None = None"
-
-lemma set_enforce_option [simp]: "set_option (enforce_option P x) = {a \<in> set_option x. P a}"
-  by(cases x) auto
-
-lemma enforce_map_option: "enforce_option P (map_option f x) = map_option f (enforce_option (P \<circ> f) x)"
-  by(cases x) auto
-
-lemma enforce_bind_option [simp]:
-  "enforce_option P (Option.bind x f) = Option.bind x (enforce_option P \<circ> f)"
-  by(cases x) auto
-
-lemma enforce_option_alt_def:
-  "enforce_option P x = Option.bind x (\<lambda>a. Option.bind (assert_option (P a)) (\<lambda>_ :: unit. Some a))"
-  by(cases x) simp_all
-
-lemma enforce_option_eq_None_iff [simp]:
-  "enforce_option P x = None \<longleftrightarrow> (\<forall>a. x = Some a \<longrightarrow> \<not> P a)"
-  by(cases x) auto
-
-lemma enforce_option_eq_Some_iff [simp]:
-  "enforce_option P x = Some y \<longleftrightarrow> x = Some y \<and> P y"
-  by(cases x) auto
-
-lemma Some_eq_enforce_option_iff [simp]:
-  "Some y = enforce_option P x \<longleftrightarrow> x = Some y \<and> P y"
-  by(cases x) auto
-
-lemma enforce_option_top [simp]: "enforce_option \<top> = id"
-  by(rule ext; rename_tac x; case_tac x; simp)
-
-lemma enforce_option_K_True [simp]: "enforce_option (\<lambda>_. True) x = x"
-  by(cases x) simp_all
-
-lemma enforce_option_bot [simp]: "enforce_option \<bottom> = (\<lambda>_. None)"
-  by(simp add: fun_eq_iff)
-
-lemma enforce_option_K_False [simp]: "enforce_option (\<lambda>_. False) x = None"
-  by simp
-
-lemma enforce_pred_id_option: "pred_option P x \<Longrightarrow> enforce_option P x = x"
-  by(cases x) auto
-
-lemma rel_fun_refl: "\<lbrakk> A \<le> (=); (=) \<le> B \<rbrakk> \<Longrightarrow> (=) \<le> rel_fun A B"
-  by(subst fun.rel_eq[symmetric])(rule fun_mono)
-
-lemma rel_fun_mono_strong:
-  "\<lbrakk> rel_fun A B f g; A' \<le> A; \<And>x y. \<lbrakk> x \<in> f ` {x. Domainp A' x}; y \<in> g ` {x. Rangep A' x}; B x y \<rbrakk> \<Longrightarrow> B' x y \<rbrakk> \<Longrightarrow> rel_fun A' B' f g"
-  by(auto simp add: rel_fun_def) fastforce
-
-lemma rel_fun_refl_strong: 
-  assumes "A \<le> (=)" "\<And>x. x \<in> f ` {x. Domainp A x} \<Longrightarrow> B x x"
-  shows "rel_fun A B f f"
-proof -
-  have "rel_fun (=) (=) f f" by(simp add: rel_fun_eq)
-  then show ?thesis using assms(1)
-    by(rule rel_fun_mono_strong) (auto intro: assms(2))
-qed
-
-lemma Grp_iff: "BNF_Def.Grp B g x y \<longleftrightarrow> y = g x \<and> x \<in> B" by(simp add: Grp_def)
-
-lemma Rangep_Grp: "Rangep (BNF_Def.Grp A f) = (\<lambda>x. x \<in> f ` A)"
-  by(auto simp add: fun_eq_iff Grp_iff)
-
-lemma Domainp_Grp: "Domainp (BNF_Def.Grp A f) = (\<lambda>x. x \<in> A)"
-  by(auto simp add: Grp_iff fun_eq_iff)
-
-lemma rel_fun_Grp:
-  "rel_fun (BNF_Def.Grp UNIV h)\<inverse>\<inverse> (BNF_Def.Grp A g) = BNF_Def.Grp {f. f ` range h \<subseteq> A} (map_fun h g)"
-  by(auto simp add: rel_fun_def fun_eq_iff Grp_iff)
-
-lemma wf_strict_prefix: "wfP strict_prefix"
-proof -
-  from wf have "wf (inv_image {(x, y). x < y} length)" by(rule wf_inv_image)
-  moreover have "{(x, y). strict_prefix x y} \<subseteq> inv_image {(x, y). x < y} length" by(auto intro: prefix_length_less)
-  ultimately show ?thesis unfolding wfP_def by(rule wf_subset)
-qed
-
-lemma strict_prefix_setD:
-  "strict_prefix xs ys \<Longrightarrow> set xs \<subseteq> set ys"
-  by(auto simp add: strict_prefix_def prefix_def)
-
-
-(* SPMF *)
-
-lemma weight_assert_spmf [simp]: "weight_spmf (assert_spmf b) = indicator {True} b"
-  by(simp split: split_indicator)
-
-definition enforce_spmf :: "('a \<Rightarrow> bool) \<Rightarrow> 'a spmf \<Rightarrow> 'a spmf" where
-  "enforce_spmf P = map_pmf (enforce_option P)"
-
-lemma enforce_spmf_parametric [transfer_rule]: includes lifting_syntax shows
-  "((A ===> (=)) ===> rel_spmf A ===> rel_spmf A) enforce_spmf enforce_spmf"
-  unfolding enforce_spmf_def by transfer_prover
-
-lemma enforce_return_spmf [simp]:
-  "enforce_spmf P (return_spmf x) = (if P x then return_spmf x else return_pmf None)"
-  by(simp add: enforce_spmf_def)
-
-lemma enforce_return_pmf_None [simp]:
-  "enforce_spmf P (return_pmf None) = return_pmf None"
-  by(simp add: enforce_spmf_def)
-
-lemma enforce_map_spmf:
-  "enforce_spmf P (map_spmf f p) = map_spmf f (enforce_spmf (P \<circ> f) p)"
-  by(simp add: enforce_spmf_def pmf.map_comp o_def enforce_map_option)
-
-lemma enforce_bind_spmf [simp]:
-  "enforce_spmf P (bind_spmf p f) = bind_spmf p (enforce_spmf P \<circ> f)"
-  by(auto simp add: enforce_spmf_def bind_spmf_def map_bind_pmf intro!: bind_pmf_cong split: option.split)
-
-lemma set_enforce_spmf [simp]: "set_spmf (enforce_spmf P p) = {a \<in> set_spmf p. P a}"
-  by(auto simp add: enforce_spmf_def in_set_spmf)
-
-lemma enforce_spmf_alt_def:
-  "enforce_spmf P p = bind_spmf p (\<lambda>a. bind_spmf (assert_spmf (P a)) (\<lambda>_ :: unit. return_spmf a))"
-  by(auto simp add: enforce_spmf_def assert_spmf_def map_pmf_def bind_spmf_def bind_return_pmf intro!: bind_pmf_cong split: option.split)
-
-lemma bind_enforce_spmf [simp]:
-  "bind_spmf (enforce_spmf P p) f = bind_spmf p (\<lambda>x. if P x then f x else return_pmf None)"
-  by(auto simp add: enforce_spmf_alt_def assert_spmf_def intro!: bind_spmf_cong)
-
-lemma weight_enforce_spmf:
-  "weight_spmf (enforce_spmf P p) = weight_spmf p - measure (measure_spmf p) {x. \<not> P x}" (is "?lhs = ?rhs")
-proof -
-  have "?lhs = LINT x|measure_spmf p. indicator {x. P x} x"
-    by(auto simp add: enforce_spmf_alt_def weight_bind_spmf o_def simp del: Bochner_Integration.integral_indicator intro!: Bochner_Integration.integral_cong split: split_indicator)
-  also have "\<dots> = ?rhs"
-    by(subst measure_spmf.finite_measure_Diff[symmetric])(auto simp add: space_measure_spmf intro!: arg_cong2[where f=measure])
-  finally show ?thesis .
-qed
-
-lemma lossless_enforce_spmf [simp]:
-  "lossless_spmf (enforce_spmf P p) \<longleftrightarrow> lossless_spmf p \<and> set_spmf p \<subseteq> {x. P x}"
-  by(auto simp add: enforce_spmf_alt_def)
-
-lemma enforce_spmf_top [simp]: "enforce_spmf \<top> = id"
-  by(simp add: enforce_spmf_def)
-
-lemma enforce_spmf_K_True [simp]: "enforce_spmf (\<lambda>_. True) p = p"
-  using enforce_spmf_top[THEN fun_cong, of p] by(simp add: top_fun_def)
-
-lemma enforce_spmf_bot [simp]: "enforce_spmf \<bottom> = (\<lambda>_. return_pmf None)"
-  by(simp add: enforce_spmf_def fun_eq_iff)
-
-lemma enforce_spmf_K_False [simp]: "enforce_spmf (\<lambda>_. False) p = return_pmf None"
-  using enforce_spmf_bot[THEN fun_cong, of p] by(simp add: bot_fun_def)
-
-lemma enforce_pred_id_spmf: "enforce_spmf P p = p" if "pred_spmf P p"
-proof -
-  have "enforce_spmf P p = map_pmf id p" using that
-    by(auto simp add: enforce_spmf_def enforce_pred_id_option simp del: map_pmf_id intro!: pmf.map_cong_pred[OF refl] elim!: pmf_pred_mono_strong)
-  then show ?thesis by simp
-qed
-
-lemma map_the_spmf_of_pmf [simp]: "map_pmf the (spmf_of_pmf p) = p"
-  by(simp add: spmf_of_pmf_def pmf.map_comp o_def)
-
-lemma bind_bind_conv_pair_spmf:
-  "bind_spmf p (\<lambda>x. bind_spmf q (f x)) = bind_spmf (pair_spmf p q) (\<lambda>(x, y). f x y)"
-  by(simp add: pair_spmf_alt_def)
-
-lemma cond_pmf_of_set:
-  assumes fin: "finite A" and nonempty: "A \<inter> B \<noteq> {}"
-  shows "cond_pmf (pmf_of_set A) B = pmf_of_set (A \<inter> B)" (is "?lhs = ?rhs")
-proof(rule pmf_eqI)
-  from nonempty have A: "A \<noteq> {}" by auto
-  show "pmf ?lhs x = pmf ?rhs x" for x
-    by(subst pmf_cond; clarsimp simp add: fin A nonempty measure_pmf_of_set split: split_indicator)
-qed
-
-lemma cond_spmf_spmf_of_set:
-  "cond_spmf (spmf_of_set A) B = spmf_of_set (A \<inter> B)" if "finite A"
-  by(rule spmf_eqI)(auto simp add: spmf_of_set measure_spmf_of_set that split: split_indicator)
-
-lemma pair_pmf_of_set:
-  assumes A: "finite A" "A \<noteq> {}"
-    and B: "finite B" "B \<noteq> {}"
-  shows "pair_pmf (pmf_of_set A) (pmf_of_set B) = pmf_of_set (A \<times> B)"
-  by(rule pmf_eqI)(clarsimp simp add: pmf_pair assms split: split_indicator)
-
-lemma pair_spmf_of_set:
-  "pair_spmf (spmf_of_set A) (spmf_of_set B) = spmf_of_set (A \<times> B)"
-  by(rule spmf_eqI)(clarsimp simp add: spmf_of_set card_cartesian_product split: split_indicator)
-
-(*lemma cond_bind_pmf:
-  assumes *: "\<And>x. x \<in> set_pmf p \<Longrightarrow> set_pmf (f x) \<inter> A \<noteq> {}"
-  shows "cond_pmf (bind_pmf p f) A = bind_pmf p (\<lambda>x. cond_pmf (f x) A)"
-  apply(rule pmf_eqI)
-  apply(subst pmf_cond)
-  subgoal using * set_pmf_not_empty[of p] by auto
-  apply clarsimp
-  oops*)
-
-lemma emeasure_cond_pmf:
-  fixes p A
-  defines "q \<equiv> cond_pmf p A"
-  assumes "set_pmf p \<inter> A \<noteq> {}"
-  shows "emeasure (measure_pmf q) B = emeasure (measure_pmf p) (A \<inter> B) / emeasure (measure_pmf p) A"
-proof -
-  note [transfer_rule] = cond_pmf.transfer[OF assms(2), folded q_def]
-  interpret pmf_as_measure .
-  show ?thesis by transfer simp
-qed
-
-lemma measure_cond_pmf:
-  "measure (measure_pmf (cond_pmf p A)) B = measure (measure_pmf p) (A \<inter> B) / measure (measure_pmf p) A"
-  if "set_pmf p \<inter> A \<noteq> {}"
-  using emeasure_cond_pmf[OF that, of B] that 
-  by(auto simp add: measure_pmf.emeasure_eq_measure measure_pmf_posI divide_ennreal)
-
-lemma emeasure_measure_pmf_zero_iff: "emeasure (measure_pmf p) s = 0 \<longleftrightarrow> set_pmf p \<inter> s = {}" (is "?lhs = ?rhs")
-proof -
-  have "?lhs \<longleftrightarrow> (AE x in measure_pmf p. x \<notin> s)"
-    by(subst AE_iff_measurable)(auto)
-  also have "\<dots> = ?rhs" by(auto simp add: AE_measure_pmf_iff)
-  finally show ?thesis .
-qed
-
-lemma emeasure_cond_spmf:
-  "emeasure (measure_spmf (cond_spmf p A)) B = emeasure (measure_spmf p) (A \<inter> B) / emeasure (measure_spmf p) A"
-  apply(clarsimp simp add: cond_spmf_def emeasure_measure_spmf_conv_measure_pmf emeasure_measure_pmf_zero_iff set_pmf_Int_Some split!: if_split)
-   apply blast
-  apply(subst (asm) emeasure_cond_pmf)
-  by(auto simp add: set_pmf_Int_Some image_Int)
-
-lemma measure_cond_spmf:
-  "measure (measure_spmf (cond_spmf p A)) B = measure (measure_spmf p) (A \<inter> B) / measure (measure_spmf p) A"
-  apply(clarsimp simp add: cond_spmf_def measure_measure_spmf_conv_measure_pmf measure_pmf_zero_iff set_pmf_Int_Some split!: if_split)
-  apply(subst (asm) measure_cond_pmf)
-  by(auto simp add: image_Int set_pmf_Int_Some)
-
-
-lemma lossless_cond_spmf [simp]: "lossless_spmf (cond_spmf p A) \<longleftrightarrow> set_spmf p \<inter> A \<noteq> {}"
-  by(clarsimp simp add: cond_spmf_def lossless_iff_set_pmf_None set_pmf_Int_Some)
-
-lemma measure_spmf_eq_density: "measure_spmf p = density (count_space UNIV) (spmf p)"
-  by(rule measure_eqI)(simp_all add: emeasure_density nn_integral_spmf[symmetric] nn_integral_count_space_indicator)
-
-lemma integral_measure_spmf:
-  fixes f :: "'a \<Rightarrow> 'b::{banach, second_countable_topology}"
-  assumes A: "finite A"
-  shows "(\<And>a. a \<in> set_spmf M \<Longrightarrow> f a \<noteq> 0 \<Longrightarrow> a \<in> A) \<Longrightarrow> (LINT x|measure_spmf M. f x) = (\<Sum>a\<in>A. spmf M a *\<^sub>R f a)"
-  unfolding measure_spmf_eq_density
-  apply (simp add: integral_density)
-  apply (subst lebesgue_integral_count_space_finite_support)
-  by (auto intro!: finite_subset[OF _ \<open>finite A\<close>] sum.mono_neutral_left simp: spmf_eq_0_set_spmf)
-
-
-lemma image_set_spmf_eq:
-  "f ` set_spmf p = g ` set_spmf q" if "ASSUMPTION (map_spmf f p = map_spmf g q)"
-  using that[unfolded ASSUMPTION_def, THEN arg_cong[where f=set_spmf]] by simp
-
-lemma map_spmf_const: "map_spmf (\<lambda>_. x) p = scale_spmf (weight_spmf p) (return_spmf x)"
-  by(simp add: map_spmf_conv_bind_spmf bind_spmf_const)
-
-lemma cond_return_pmf [simp]: "cond_pmf (return_pmf x) A = return_pmf x" if "x \<in> A"
-  using that by(intro pmf_eqI)(auto simp add: pmf_cond split: split_indicator)
-
-lemma cond_return_spmf [simp]: "cond_spmf (return_spmf x) A = (if x \<in> A then return_spmf x else return_pmf None)"
-  by(simp add: cond_spmf_def)
-
-lemma measure_range_Some_eq_weight:
-  "measure (measure_pmf p) (range Some) = weight_spmf p"
-  by (simp add: measure_measure_spmf_conv_measure_pmf space_measure_spmf)
-
-lemma restrict_spmf_eq_return_pmf_None [simp]:
-  "restrict_spmf p A = return_pmf None \<longleftrightarrow> set_spmf p \<inter> A = {}"
-  by(auto 4 3 simp add: restrict_spmf_def map_pmf_eq_return_pmf_iff bind_UNION in_set_spmf bind_eq_None_conv option.the_def dest: bspec split: if_split_asm option.split_asm)
-
-lemma integrable_scale_measure [simp]:
-  "\<lbrakk> integrable M f; r < \<top> \<rbrakk> \<Longrightarrow> integrable (scale_measure r M) f" 
-  for f :: "'a \<Rightarrow> 'b::{banach, second_countable_topology}"
-  by(auto simp add: integrable_iff_bounded nn_integral_scale_measure ennreal_mult_less_top)
-
-lemma integral_scale_measure:
-  assumes "integrable M f" "r < \<top>"
-  shows "integral\<^sup>L (scale_measure r M) f = enn2real r * integral\<^sup>L M f"
-  using assms
-  apply(subst (1 2) real_lebesgue_integral_def)
-    apply(simp_all add: nn_integral_scale_measure ennreal_enn2real_if)
-  by(auto simp add: ennreal_mult_less_top ennreal_less_top_iff ennreal_mult_eq_top_iff enn2real_mult right_diff_distrib elim!: integrableE)
-
-definition mk_lossless :: "'a spmf \<Rightarrow> 'a spmf" where
-  "mk_lossless p = scale_spmf (inverse (weight_spmf p)) p"
-
-lemma mk_lossless_idem [simp]: "mk_lossless (mk_lossless p) = mk_lossless p"
-  by(simp add: mk_lossless_def weight_scale_spmf min_def max_def inverse_eq_divide) 
-
-lemma mk_lossless_return [simp]: "mk_lossless (return_pmf x) = return_pmf x"
-  by(cases x)(simp_all add: mk_lossless_def)
-
-lemma mk_lossless_map [simp]: "mk_lossless (map_spmf f p) = map_spmf f (mk_lossless p)"
-  by(simp add: mk_lossless_def map_scale_spmf)
-
-lemma spmf_mk_lossless [simp]: "spmf (mk_lossless p) x = spmf p x / weight_spmf p"
-  by(simp add: mk_lossless_def spmf_scale_spmf inverse_eq_divide max_def)
-
-lemma set_spmf_mk_lossless [simp]: "set_spmf (mk_lossless p) = set_spmf p"
-  by(simp add: mk_lossless_def set_scale_spmf measure_spmf_zero_iff zero_less_measure_iff)
-
-lemma mk_lossless_lossless [simp]: "lossless_spmf p \<Longrightarrow> mk_lossless p = p"
-  by(simp add: mk_lossless_def lossless_weight_spmfD)
-
-lemma mk_lossless_eq_return_pmf_None [simp]: "mk_lossless p = return_pmf None \<longleftrightarrow> p = return_pmf None"
-proof -
-  have aux: "weight_spmf p = 0 \<Longrightarrow> spmf p i = 0" for i
-    by(rule antisym, rule order_trans[OF spmf_le_weight]) (auto intro!: order_trans[OF spmf_le_weight])
-
-  have[simp]: " spmf (scale_spmf (inverse (weight_spmf p)) p) = spmf (return_pmf None) \<Longrightarrow> spmf p i = 0" for i
-    by(drule fun_cong[where x=i]) (auto simp add: aux spmf_scale_spmf max_def)
-
-  show ?thesis by(auto simp add: mk_lossless_def intro: spmf_eqI)
-qed
-
-lemma return_pmf_None_eq_mk_lossless [simp]: "return_pmf None = mk_lossless p \<longleftrightarrow> p = return_pmf None"
-  by(metis mk_lossless_eq_return_pmf_None)
-
-lemma mk_lossless_spmf_of_set [simp]: "mk_lossless (spmf_of_set A) = spmf_of_set A"
-  by(simp add: spmf_of_set_def del: spmf_of_pmf_pmf_of_set)
-
-lemma weight_mk_lossless: "weight_spmf (mk_lossless p) = (if p = return_pmf None then 0 else 1)"
-  by(simp add: mk_lossless_def weight_scale_spmf min_def max_def inverse_eq_divide weight_spmf_eq_0)
-
-lemma mk_lossless_parametric [transfer_rule]: includes lifting_syntax shows
-  "(rel_spmf A ===> rel_spmf A) mk_lossless mk_lossless"
-  by(simp add: mk_lossless_def rel_fun_def rel_spmf_weightD rel_spmf_scaleI)
-
-lemma rel_spmf_mk_losslessI:
-  "rel_spmf A p q \<Longrightarrow> rel_spmf A (mk_lossless p) (mk_lossless q)"
-  by(rule mk_lossless_parametric[THEN rel_funD])
-
-lemma rel_spmf_restrict_spmfI:
-  "rel_spmf (\<lambda>x y. (x \<in> A \<and> y \<in> B \<and> R x y) \<or> x \<notin> A \<and> y \<notin> B) p q
-   \<Longrightarrow> rel_spmf R (restrict_spmf p A) (restrict_spmf q B)"
-  by(auto simp add: restrict_spmf_def pmf.rel_map elim!: option.rel_cases pmf.rel_mono_strong)
-
-lemma cond_spmf_alt: "cond_spmf p A = mk_lossless (restrict_spmf p A)"
-proof(cases "set_spmf p \<inter> A = {}")
-  case True
-  then show ?thesis by(simp add: cond_spmf_def measure_spmf_zero_iff)
-next
-  case False
-  show ?thesis
-    by(rule spmf_eqI)(simp add: False cond_spmf_def pmf_cond set_pmf_Int_Some image_iff measure_measure_spmf_conv_measure_pmf[symmetric] spmf_scale_spmf max_def inverse_eq_divide)
-qed
-
-lemma cond_spmf_bind:
-  "cond_spmf (bind_spmf p f) A = mk_lossless (p \<bind> (\<lambda>x. f x \<upharpoonleft> A))"
-  by(simp add: cond_spmf_alt restrict_bind_spmf scale_bind_spmf)
-
-lemma cond_spmf_UNIV [simp]: "cond_spmf p UNIV = mk_lossless p"
-  by(clarsimp simp add: cond_spmf_alt)
-
-lemma cond_pmf_singleton:
-  "cond_pmf p A = return_pmf x" if "set_pmf p \<inter> A = {x}"
-proof -
-  have[simp]: "set_pmf p \<inter> A = {x} \<Longrightarrow> x \<in> A \<Longrightarrow> measure_pmf.prob p A = pmf p x"
-    by(auto simp add: measure_pmf_single[symmetric] AE_measure_pmf_iff intro!: measure_pmf.finite_measure_eq_AE)
-
-  have "pmf (cond_pmf p A) i = pmf (return_pmf x) i" for i
-    using that by(auto simp add: pmf_cond measure_pmf_zero_iff pmf_eq_0_set_pmf split: split_indicator)
-
-  then show ?thesis by(rule pmf_eqI)
-qed
-
-
-definition cond_spmf_fst :: "('a \<times> 'b) spmf \<Rightarrow> 'a \<Rightarrow> 'b spmf" where
-  "cond_spmf_fst p a = map_spmf snd (cond_spmf p ({a} \<times> UNIV))"
-
-lemma cond_spmf_fst_return_spmf [simp]:
-  "cond_spmf_fst (return_spmf (x, y)) x = return_spmf y"
-  by(simp add: cond_spmf_fst_def)
-
-lemma cond_spmf_fst_map_Pair [simp]: "cond_spmf_fst (map_spmf (Pair x) p) x = mk_lossless p"
-  by(clarsimp simp add: cond_spmf_fst_def spmf.map_comp o_def)
-
-lemma cond_spmf_fst_map_Pair' [simp]: "cond_spmf_fst (map_spmf (\<lambda>y. (x, f y)) p) x = map_spmf f (mk_lossless p)"
-  by(subst spmf.map_comp[where f="Pair x", symmetric, unfolded o_def]) simp
-
-lemma cond_spmf_fst_eq_return_None [simp]: "cond_spmf_fst p x = return_pmf None \<longleftrightarrow> x \<notin> fst ` set_spmf p"
-  by(auto 4 4 simp add: cond_spmf_fst_def map_pmf_eq_return_pmf_iff in_set_spmf[symmetric] dest: bspec[where x="Some _"] intro: ccontr rev_image_eqI)
-
-lemma cond_spmf_fst_map_Pair1:
-  "cond_spmf_fst (map_spmf (\<lambda>x. (f x, g x)) p) (f x) = return_spmf (g (inv_into (set_spmf p) f (f x)))"
-  if "x \<in> set_spmf p" "inj_on f (set_spmf p)"
-proof -
-  let ?foo="\<lambda>y. map_option (\<lambda>x. (f x, g x)) -` Some ` ({f y} \<times> UNIV)"
-  have[simp]: "y \<in> set_spmf p \<Longrightarrow> f x = f y \<Longrightarrow> set_pmf p \<inter> (?foo y) \<noteq> {}" for y
-    by(auto simp add: vimage_def image_def in_set_spmf)
-
-  have[simp]: "y \<in> set_spmf p \<Longrightarrow> f x = f y \<Longrightarrow>  map_spmf snd (map_spmf (\<lambda>x. (f x, g x)) (cond_pmf p (?foo y))) = return_spmf (g x)" for y
-    using that by(subst cond_pmf_singleton[where x="Some x"]) (auto simp add: in_set_spmf elim: inj_onD)
-
-  show ?thesis
-    using that
-    by(auto simp add: cond_spmf_fst_def cond_spmf_def)
-      (erule notE, subst cond_map_pmf, simp_all)
-qed
-
-lemma lossless_cond_spmf_fst [simp]: "lossless_spmf (cond_spmf_fst p x) \<longleftrightarrow> x \<in> fst ` set_spmf p"
-  by(auto simp add: cond_spmf_fst_def intro: rev_image_eqI)
-
-lemma cond_spmf_fst_inverse:
-  "bind_spmf (map_spmf fst p) (\<lambda>x. map_spmf (Pair x) (cond_spmf_fst p x)) = p"
-  (is "?lhs = ?rhs")
-proof(rule spmf_eqI)
-  fix i :: "'a \<times> 'b"
-  have *: "({x} \<times> UNIV \<inter> (Pair x \<circ> snd) -` {i}) = (if x = fst i then {i} else {})" for x by(cases i)auto
-  have "spmf ?lhs i = LINT x|measure_spmf (map_spmf fst p). spmf (map_spmf (Pair x \<circ> snd) (cond_spmf p ({x} \<times> UNIV))) i"
-    by(auto simp add: spmf_bind spmf.map_comp[symmetric] cond_spmf_fst_def intro!: integral_cong_AE)
-  also have "\<dots> = LINT x|measure_spmf (map_spmf fst p). measure (measure_spmf (cond_spmf p ({x} \<times> UNIV))) ((Pair x \<circ> snd) -` {i})"
-    by(rule integral_cong_AE)(auto simp add: spmf_map)
-  also have "\<dots> = LINT x|measure_spmf (map_spmf fst p). measure (measure_spmf p) ({x} \<times> UNIV \<inter> (Pair x \<circ> snd) -` {i}) /
-       measure (measure_spmf p) ({x} \<times> UNIV)"
-    by(rule integral_cong_AE; clarsimp simp add: measure_cond_spmf)
-  also have "\<dots> = spmf (map_spmf fst p) (fst i) * spmf p i / measure (measure_spmf p) ({fst i} \<times> UNIV)"
-    by(simp add: * if_distrib[where f="measure (measure_spmf _)"] cong: if_cong)
-      (subst integral_measure_spmf[where A="{fst i}"]; auto split: if_split_asm simp add: spmf_conv_measure_spmf)
-  also have "\<dots> = spmf p i"
-    by(clarsimp simp add: spmf_map vimage_fst)(metis (no_types, lifting) Int_insert_left_if1 in_set_spmf_iff_spmf insertI1 insert_UNIV insert_absorb insert_not_empty measure_spmf_zero_iff mem_Sigma_iff prod.collapse)
-  finally show "spmf ?lhs i = spmf ?rhs i" .
-qed
-
-(* Generat *)
-
-fun rel_witness_generat :: "('a, 'c, 'e) generat \<times> ('b, 'd, 'f) generat \<Rightarrow> ('a \<times> 'b, 'c \<times> 'd, 'e \<times> 'f) generat" where
-  "rel_witness_generat (Pure x, Pure y) = Pure (x, y)"
-| "rel_witness_generat (IO out c, IO out' c') = IO (out, out') (c, c')"
-
-lemma rel_witness_generat: 
-  assumes "rel_generat A C R x y"
-  shows pures_rel_witness_generat: "generat_pures (rel_witness_generat (x, y)) \<subseteq> {(a, b). A a b}"
-    and outs_rel_witness_generat: "generat_outs (rel_witness_generat (x, y)) \<subseteq> {(c, d). C c d}"
-    and conts_rel_witness_generat: "generat_conts (rel_witness_generat (x, y)) \<subseteq> {(e, f). R e f}"
-    and map1_rel_witness_generat: "map_generat fst fst fst (rel_witness_generat (x, y)) = x"
-    and map2_rel_witness_generat: "map_generat snd snd snd (rel_witness_generat (x, y)) = y"
-  using assms by(cases; simp; fail)+
-
-lemmas set_rel_witness_generat = pures_rel_witness_generat outs_rel_witness_generat conts_rel_witness_generat
-
-lemma rel_witness_generat1:
-  assumes "rel_generat A C R x y"
-  shows "rel_generat (\<lambda>a (a', b). a = a' \<and> A a' b) (\<lambda>c (c', d). c = c' \<and> C c' d) (\<lambda>r (r', s). r = r' \<and> R r' s) x (rel_witness_generat (x, y))"
-  using map1_rel_witness_generat[OF assms, symmetric]
-  unfolding generat.rel_eq[symmetric] generat.rel_map
-  by(rule generat.rel_mono_strong)(auto dest: set_rel_witness_generat[OF assms, THEN subsetD])
-
-lemma rel_witness_generat2:
-  assumes "rel_generat A C R x y"
-  shows "rel_generat (\<lambda>(a, b') b. b = b' \<and> A a b') (\<lambda>(c, d') d. d = d' \<and> C c d') (\<lambda>(r, s') s. s = s' \<and> R r s') (rel_witness_generat (x, y)) y"
-  using map2_rel_witness_generat[OF assms]
-  unfolding generat.rel_eq[symmetric] generat.rel_map
-  by(rule generat.rel_mono_strong)(auto dest: set_rel_witness_generat[OF assms, THEN subsetD])
-
-
-(* Generative_Probabilistic_Value *)
-
-lemma rel_gpv''_map_gpv1:
-  "rel_gpv'' A C R (map_gpv f g gpv) gpv' = rel_gpv'' (\<lambda>a. A (f a)) (\<lambda>c. C (g c)) R gpv gpv'" (is "?lhs = ?rhs")
-proof
-  show ?rhs if ?lhs using that
-    apply(coinduction arbitrary: gpv gpv')
-    apply(drule rel_gpv''D)
-    apply(simp add: gpv.map_sel spmf_rel_map)
-    apply(erule rel_spmf_mono)
-    by(auto simp add: generat.rel_map rel_fun_comp elim!: generat.rel_mono_strong rel_fun_mono)
-  show ?lhs if ?rhs using that
-    apply(coinduction arbitrary: gpv gpv')
-    apply(drule rel_gpv''D)
-    apply(simp add: gpv.map_sel spmf_rel_map)
-    apply(erule rel_spmf_mono)
-    by(auto simp add: generat.rel_map rel_fun_comp elim!: generat.rel_mono_strong rel_fun_mono)
-qed
-
-lemma rel_gpv''_map_gpv2:
-  "rel_gpv'' A C R gpv (map_gpv f g gpv') = rel_gpv'' (\<lambda>a b. A a (f b)) (\<lambda>c d. C c (g d)) R gpv gpv'"
-  using rel_gpv''_map_gpv1[of "conversep A" "conversep C" "conversep R" f g gpv' gpv]
-  apply(rewrite in "\<hole> = _" conversep_iff[symmetric])
-  apply(rewrite in "_ = \<hole>" conversep_iff[symmetric])
-  apply(simp only: rel_gpv''_conversep)
-  apply(simp only: rel_gpv''_conversep[symmetric])
-  apply(simp only: conversep_iff[abs_def])
-  done
-
-lemmas rel_gpv''_map_gpv = rel_gpv''_map_gpv1[abs_def] rel_gpv''_map_gpv2
-
-lemma rel_gpv''_map_gpv' [simp]:
-  shows "\<And>f g h gpv. NO_MATCH id f \<or> NO_MATCH id g 
-    \<Longrightarrow> rel_gpv'' A C R (map_gpv' f g h gpv) = rel_gpv'' (\<lambda>a. A (f a)) (\<lambda>c. C (g c)) R (map_gpv' id id h gpv)"
-    and "\<And>f g h gpv gpv'. NO_MATCH id f \<or> NO_MATCH id g 
-    \<Longrightarrow> rel_gpv'' A C R gpv (map_gpv' f g h gpv') = rel_gpv'' (\<lambda>a b. A a (f b)) (\<lambda>c d. C c (g d)) R gpv (map_gpv' id id h gpv')"
-proof (goal_cases)
-  case (1 f g h gpv)
-  then show ?case using map_gpv'_comp[of f g id id id h gpv, symmetric] by(simp add: rel_gpv''_map_gpv[unfolded map_gpv_conv_map_gpv'])
-next
-  case (2 f g h gpv gpv')
-  then show ?case using map_gpv'_comp[of f g id id id h gpv', symmetric] by(simp add: rel_gpv''_map_gpv[unfolded map_gpv_conv_map_gpv'])
-qed
-
-lemmas rel_gpv_map_gpv' = rel_gpv''_map_gpv'[where R="(=)", folded rel_gpv_conv_rel_gpv'']
-
-definition rel_witness_gpv :: "('a \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'e \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'g \<Rightarrow> bool) \<Rightarrow> ('g \<Rightarrow> 'f \<Rightarrow> bool) \<Rightarrow> ('a, 'b, 'c) gpv \<times> ('d, 'e, 'f) gpv \<Rightarrow> ('a \<times> 'd, 'b \<times> 'e, 'g) gpv" where
-  "rel_witness_gpv A C R R' = corec_gpv (
-     map_spmf (map_generat id id (\<lambda>(rpv, rpv'). (Inr \<circ> rel_witness_fun R R' (rpv, rpv'))) \<circ> rel_witness_generat) \<circ>
-     rel_witness_spmf (rel_generat A C (rel_fun (R OO R') (rel_gpv'' A C (R OO R')))) \<circ> map_prod the_gpv the_gpv)"
-
-lemma rel_witness_gpv_sel [simp]:
-  "the_gpv (rel_witness_gpv A C R R' (gpv, gpv')) = 
-    map_spmf (map_generat id id (\<lambda>(rpv, rpv'). (rel_witness_gpv A C R R' \<circ> rel_witness_fun R R' (rpv, rpv'))) \<circ> rel_witness_generat)
-     (rel_witness_spmf (rel_generat A C (rel_fun (R OO R') (rel_gpv'' A C (R OO R')))) (the_gpv gpv, the_gpv gpv'))"
-  unfolding rel_witness_gpv_def
-  by(auto simp add: spmf.map_comp generat.map_comp o_def intro!: map_spmf_cong generat.map_cong)
-
-lemma assumes "rel_gpv'' A C (R OO R') gpv gpv'"
-  and R: "left_unique R" "right_total R"
-  and R': "right_unique R'" "left_total R'"
-shows rel_witness_gpv1: "rel_gpv'' (\<lambda>a (a', b). a = a' \<and> A a' b) (\<lambda>c (c', d). c = c' \<and> C c' d) R gpv (rel_witness_gpv A C R R' (gpv, gpv'))" (is "?thesis1")
-  and rel_witness_gpv2: "rel_gpv'' (\<lambda>(a, b') b. b = b' \<and> A a b') (\<lambda>(c, d') d. d = d' \<and> C c d') R' (rel_witness_gpv A C R R' (gpv, gpv')) gpv'" (is "?thesis2")
-proof -
-  show ?thesis1 using assms(1)
-  proof(coinduction arbitrary: gpv gpv')
-    case rel_gpv''
-    from this[THEN rel_gpv''D] show ?case
-      by(auto simp add: spmf_rel_map generat.rel_map rel_fun_comp elim!: rel_fun_mono[OF rel_witness_fun1[OF _ R R']]
-          rel_spmf_mono[OF rel_witness_spmf1] generat.rel_mono[THEN predicate2D, rotated -1, OF rel_witness_generat1])
-  qed
-  show ?thesis2 using assms(1)
-  proof(coinduction arbitrary: gpv gpv')
-    case rel_gpv''
-    from this[THEN rel_gpv''D] show ?case
-      by(simp add: spmf_rel_map) 
-        (erule rel_spmf_mono[OF rel_witness_spmf2]
-          , auto simp add: generat.rel_map rel_fun_comp elim!: rel_fun_mono[OF rel_witness_fun2[OF _ R R']]
-          generat.rel_mono[THEN predicate2D, rotated -1, OF rel_witness_generat2])
-  qed
-qed
-
-lemma rel_gpv''_neg_distr:
-  assumes R: "left_unique R" "right_total R"
-    and R': "right_unique R'" "left_total R'"
-  shows "rel_gpv'' (A OO A') (C OO C') (R OO R') \<le> rel_gpv'' A C R OO rel_gpv'' A' C' R'"
-proof(rule predicate2I relcomppI)+
-  fix gpv gpv''
-  assume *: "rel_gpv'' (A OO A') (C OO C') (R OO R') gpv gpv''"
-  let ?gpv' = "map_gpv (relcompp_witness A A') (relcompp_witness C C') (rel_witness_gpv (A OO A') (C OO C') R R' (gpv, gpv''))"
-  show "rel_gpv'' A C R gpv ?gpv'" using rel_witness_gpv1[OF * R R'] unfolding rel_gpv''_map_gpv
-    by(rule rel_gpv''_mono[THEN predicate2D, rotated -1]; clarify del: relcomppE elim!: relcompp_witness)
-  show "rel_gpv'' A' C' R' ?gpv' gpv''" using rel_witness_gpv2[OF * R R'] unfolding rel_gpv''_map_gpv
-    by(rule rel_gpv''_mono[THEN predicate2D, rotated -1]; clarify del: relcomppE elim!: relcompp_witness)
-qed
-
-lemma rel_gpv''_mono' [mono]:
-  assumes "\<And>x y. A x y \<longrightarrow> A' x y"
-    and "\<And>x y. C x y \<longrightarrow> C' x y"
-    and "\<And>x y. R' x y \<longrightarrow> R x y"
-  shows "rel_gpv'' A C R gpv gpv' \<longrightarrow> rel_gpv'' A' C' R' gpv gpv'"
-  using rel_gpv''_mono[of A A' C C' R' R] assms by(blast)
-
-context includes \<I>.lifting begin
-
-lift_definition \<I>_uniform :: "'out set \<Rightarrow> 'in set \<Rightarrow> ('out, 'in) \<I>" is "\<lambda>A B x. if x \<in> A then B else {}" .
-
-lemma outs_\<I>_uniform [simp]: "outs_\<I> (\<I>_uniform A B) = (if B = {} then {} else A)"
-  by transfer simp
-
-lemma responses_\<I>_uniform [simp]: "responses_\<I> (\<I>_uniform A B) x = (if x \<in> A then B else {})"
-  by transfer simp
-
-lemma \<I>_uniform_UNIV [simp]: "\<I>_uniform UNIV UNIV = \<I>_full" (* TODO: make \<I>_full an abbreviation *)
-  by transfer simp
-
-lifting_update \<I>.lifting
-lifting_forget \<I>.lifting
-
-end 
-
-lemma \<I>_eqI: "\<lbrakk> outs_\<I> \<I> = outs_\<I> \<I>'; \<And>x. x \<in> outs_\<I> \<I>' \<Longrightarrow> responses_\<I> \<I> x = responses_\<I> \<I>' x \<rbrakk> \<Longrightarrow> \<I> = \<I>'"
-  including \<I>.lifting by transfer auto
-
-instantiation \<I> :: (type, type) order begin
-
-definition less_eq_\<I> :: "('a, 'b) \<I> \<Rightarrow> ('a, 'b) \<I> \<Rightarrow> bool"
-  where le_\<I>_def: "less_eq_\<I> \<I> \<I>' \<longleftrightarrow> outs_\<I> \<I> \<subseteq> outs_\<I> \<I>' \<and> (\<forall>x\<in>outs_\<I> \<I>. responses_\<I> \<I>' x \<subseteq> responses_\<I> \<I> x)"
-
-definition less_\<I> :: "('a, 'b) \<I> \<Rightarrow> ('a, 'b) \<I> \<Rightarrow> bool"
-  where "less_\<I> = mk_less (\<le>)"
-
-instance
-proof
-  show "\<I> < \<I>' \<longleftrightarrow> \<I> \<le> \<I>' \<and> \<not> \<I>' \<le> \<I>" for \<I> \<I>' :: "('a, 'b) \<I>" by(simp add: less_\<I>_def mk_less_def)
-  show "\<I> \<le> \<I>" for \<I> :: "('a, 'b) \<I>" by(simp add: le_\<I>_def)
-  show "\<I> \<le> \<I>''" if "\<I> \<le> \<I>'" "\<I>' \<le> \<I>''" for \<I> \<I>' \<I>'' :: "('a, 'b) \<I>" using that
-    by(fastforce simp add: le_\<I>_def)
-  show "\<I> = \<I>'" if "\<I> \<le> \<I>'" "\<I>' \<le> \<I>" for \<I> \<I>' :: "('a, 'b) \<I>" using that
-    by(auto simp add: le_\<I>_def intro!: \<I>_eqI)
-qed
-end
-
-instantiation \<I> :: (type, type) order_bot begin
-definition bot_\<I> :: "('a, 'b) \<I>" where "bot_\<I> = \<I>_uniform {} UNIV"
-instance by standard(auto simp add: bot_\<I>_def le_\<I>_def)
-end
-
-lemma outs_\<I>_bot [simp]: "outs_\<I> bot = {}"
-  by(simp add: bot_\<I>_def)
-
-lemma respones_\<I>_bot [simp]: "responses_\<I> bot x = {}"
-  by(simp add: bot_\<I>_def)
-
-lemma outs_\<I>_mono: "\<I> \<le> \<I>' \<Longrightarrow> outs_\<I> \<I> \<subseteq> outs_\<I> \<I>'"
-  by(simp add: le_\<I>_def)
-
-lemma responses_\<I>_mono: "\<lbrakk> \<I> \<le> \<I>'; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> responses_\<I> \<I>' x \<subseteq> responses_\<I> \<I> x"
-  by(simp add: le_\<I>_def)
-
-lemma \<I>_uniform_empty [simp]: "\<I>_uniform {} A = bot" 
-  unfolding bot_\<I>_def including \<I>.lifting by transfer simp
-
-lemma WT_gpv_\<I>_mono: "\<lbrakk> \<I> \<turnstile>g gpv \<surd>; \<I> \<le> \<I>' \<rbrakk> \<Longrightarrow> \<I>' \<turnstile>g gpv \<surd>"
-  by(erule WT_gpv_mono; rule outs_\<I>_mono responses_\<I>_mono)
-
-lemma results_gpv_mono:
-  assumes le: "\<I>' \<le> \<I>" and WT: "\<I>' \<turnstile>g gpv \<surd>"
-  shows "results_gpv \<I> gpv \<subseteq> results_gpv \<I>' gpv"
-proof(rule subsetI, goal_cases)
-  case (1 x)
-  show ?case using 1 WT by(induction)(auto 4 3 intro: results_gpv.intros responses_\<I>_mono[OF le, THEN subsetD] intro: WT_gpvD)
-qed
-
-lemma \<I>_uniform_mono:
-  "\<I>_uniform A B \<le> \<I>_uniform C D" if "A \<subseteq> C" "D \<subseteq> B" "D = {} \<longrightarrow> B = {}"
-  unfolding le_\<I>_def using that by auto
-
-context begin
-qualified inductive outsp_gpv :: "('out, 'in) \<I> \<Rightarrow> 'out \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> bool"
-  for \<I> x where
-    IO: "IO x c \<in> set_spmf (the_gpv gpv) \<Longrightarrow> outsp_gpv \<I> x gpv"
-  | Cont: "\<lbrakk> IO out rpv \<in> set_spmf (the_gpv gpv); input \<in> responses_\<I> \<I> out; outsp_gpv \<I> x (rpv input) \<rbrakk>
-  \<Longrightarrow> outsp_gpv \<I> x gpv"
-
-definition outs_gpv :: "('out, 'in) \<I> \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> 'out set"
-  where "outs_gpv \<I> gpv \<equiv> {x. outsp_gpv \<I> x gpv}"
-
-lemma outsp_gpv_outs_gpv_eq [pred_set_conv]: "outsp_gpv \<I> x = (\<lambda>gpv. x \<in> outs_gpv \<I> gpv)"
-  by(simp add: outs_gpv_def)
-
-context begin
-local_setup \<open>Local_Theory.map_background_naming (Name_Space.mandatory_path "outs_gpv")\<close>
-
-lemmas intros [intro?] = outsp_gpv.intros[to_set]
-  and IO = IO[to_set]
-  and Cont = Cont[to_set]
-  and induct [consumes 1, case_names IO Cont, induct set: outs_gpv] = outsp_gpv.induct[to_set]
-  and cases [consumes 1, case_names IO Cont, cases set: outs_gpv] = outsp_gpv.cases[to_set]
-  and simps = outsp_gpv.simps[to_set]
-end
-
-inductive_simps outs_gpv_GPV [to_set, simp]: "outsp_gpv \<I> x (GPV gpv)"
-
-end
-
-lemma outs_gpv_Done [iff]: "outs_gpv \<I> (Done x) = {}"
-  by(auto simp add: Done.ctr)
-
-lemma outs_gpv_Fail [iff]: "outs_gpv \<I> Fail = {}"
-  by(auto simp add: Fail_def)
-
-lemma outs_gpv_Pause [simp]:
-  "outs_gpv \<I> (Pause out c) = insert out (\<Union>input\<in>responses_\<I> \<I> out. outs_gpv \<I> (c input))"
-  by(auto simp add: Pause.ctr)
-
-lemma outs_gpv_lift_spmf [iff]: "outs_gpv \<I> (lift_spmf p) = {}"
-  by(auto simp add: lift_spmf.ctr)
-
-lemma outs_gpv_assert_gpv [simp]: "outs_gpv \<I> (assert_gpv b) = {}"
-  by(cases b)auto
-
-lemma outs_gpv_bind_gpv [simp]:
-  "outs_gpv \<I> (gpv \<bind> f) = outs_gpv \<I> gpv \<union> (\<Union>x\<in>results_gpv \<I> gpv. outs_gpv \<I> (f x))"
-  (is "?lhs = ?rhs")
-proof(intro Set.set_eqI iffI)
-  fix x
-  assume "x \<in> ?lhs"
-  then show "x \<in> ?rhs"
-  proof(induction gpv'\<equiv>"gpv \<bind> f" arbitrary: gpv)
-    case IO thus ?case
-    proof(clarsimp split: if_split_asm elim!: is_PureE not_is_PureE, goal_cases)
-      case (1 generat)
-      then show ?case by(cases generat)(auto intro: results_gpv.Pure outs_gpv.intros)
-    qed
-  next
-    case (Cont out rpv input)
-    thus ?case
-    proof(clarsimp split: if_split_asm, goal_cases)
-      case (1 generat)
-      then show ?case by(cases generat)(auto 4 3 split: if_split_asm intro: results_gpv.intros outs_gpv.intros)
-    qed
-  qed
-next
-  fix x
-  assume "x \<in> ?rhs"
-  then consider (out) "x \<in> outs_gpv \<I> gpv" | (result) y where "y \<in> results_gpv \<I> gpv" "x \<in> outs_gpv \<I> (f y)" by auto
-  then show "x \<in> ?lhs"
-  proof cases
-    case out then show ?thesis
-      by(induction) (auto 4 4 intro: outs_gpv.IO  outs_gpv.Cont rev_bexI) 
-  next
-    case result then show ?thesis
-      by induction ((erule outs_gpv.cases | rule outs_gpv.Cont), 
-          auto 4 4 intro: outs_gpv.intros rev_bexI elim: outs_gpv.cases)+
-  qed
-qed
-
-lemma outs_gpv_\<I>_full: "outs_gpv \<I>_full = outs'_gpv"
-proof(intro ext Set.set_eqI iffI)
-  show "x \<in> outs'_gpv gpv" if "x \<in> outs_gpv \<I>_full gpv" for x gpv
-    using that by induction(auto intro: outs'_gpvI)
-  show "x \<in> outs_gpv \<I>_full gpv" if "x \<in> outs'_gpv gpv" for x gpv
-    using that by induction(auto intro: outs_gpv.intros elim!: generat.set_cases)
-qed
-
-lemma outs'_bind_gpv [simp]:
-  "outs'_gpv (bind_gpv gpv f) = outs'_gpv gpv \<union> (\<Union>x\<in>results'_gpv gpv. outs'_gpv (f x))"
-  unfolding outs_gpv_\<I>_full[symmetric] results_gpv_\<I>_full[symmetric] by simp
-
-lemma outs_gpv_map_gpv_id [simp]: "outs_gpv \<I> (map_gpv f id gpv) = outs_gpv \<I> gpv"
-  by(auto simp add: map_gpv_conv_bind id_def)
-
-lemma outs_gpv_map_gpv_id' [simp]: "outs_gpv \<I> (map_gpv f (\<lambda>x. x) gpv) = outs_gpv \<I> gpv"
-  by(auto simp add: map_gpv_conv_bind id_def)
-
-lemma outs'_gpv_bind_option [simp]:
-  "outs'_gpv (monad.bind_option Fail x f) = (\<Union>y\<in>set_option x. outs'_gpv (f y))"
-  by(cases x) simp_all
-
-lemma WT_gpv_outs_gpv:
-  assumes "\<I> \<turnstile>g gpv \<surd>"
-  shows "outs_gpv \<I> gpv \<subseteq> outs_\<I> \<I>"
-proof
-  show "x \<in> outs_\<I> \<I>" if "x \<in> outs_gpv \<I> gpv" for x using that assms
-    by(induction)(blast intro: WT_gpv_OutD WT_gpv_ContD)+
-qed
-
-context includes \<I>.lifting begin
-
-lift_definition map_\<I> :: "('out' \<Rightarrow> 'out) \<Rightarrow> ('in \<Rightarrow> 'in') \<Rightarrow> ('out, 'in) \<I> \<Rightarrow> ('out', 'in') \<I>"
-  is "\<lambda>f g resp x. g ` resp (f x)" .
-
-lemma outs_\<I>_map_\<I> [simp]:
-  "outs_\<I> (map_\<I> f g \<I>) = f -` outs_\<I> \<I>"
-  by transfer simp
-
-lemma responses_\<I>_map_\<I> [simp]:
-  "responses_\<I> (map_\<I> f g \<I>) x = g ` responses_\<I> \<I> (f x)"
-  by transfer simp
-
-lemma map_\<I>_\<I>_uniform [simp]:
-  "map_\<I> f g (\<I>_uniform A B) = \<I>_uniform (f -` A) (g ` B)"
-  by transfer(auto simp add: fun_eq_iff)
-
-lemma map_\<I>_id [simp]: "map_\<I> id id \<I> = \<I>"
-  by transfer simp
-
-lemma map_\<I>_id0: "map_\<I> id id = id"
-  by(simp add: fun_eq_iff)
-
-lemma map_\<I>_comp [simp]: "map_\<I> f g (map_\<I> f' g' \<I>) = map_\<I> (f' \<circ> f) (g \<circ> g') \<I>"
-  by transfer auto
-
-lemma map_\<I>_cong: "map_\<I> f g \<I> = map_\<I> f' g' \<I>'"
-  if "\<I> = \<I>'" and f: "f = f'" and "\<And>x y. \<lbrakk> x \<in> outs_\<I> \<I>'; y \<in> responses_\<I> \<I>' x \<rbrakk> \<Longrightarrow> g y = g' y"
-  unfolding that(1,2) using that(3-)
-  by transfer(auto simp add: fun_eq_iff intro!: image_cong)
-
-lifting_update \<I>.lifting
-lifting_forget \<I>.lifting
-end
-
-functor map_\<I> by(simp_all add: fun_eq_iff)
-
-lemma WT_gpv_map_gpv': "\<I> \<turnstile>g map_gpv' f g h gpv \<surd>" if "map_\<I> g h \<I> \<turnstile>g gpv \<surd>"
-  using that by(coinduction arbitrary: gpv)(auto 4 4 dest: WT_gpvD)
-
-lemma WT_gpv_map_gpv: "\<I> \<turnstile>g map_gpv f g gpv \<surd>" if "map_\<I> g id \<I> \<turnstile>g gpv \<surd>"
-  unfolding map_gpv_conv_map_gpv' using that by(rule WT_gpv_map_gpv')
-
-lemma results_gpv_map_gpv' [simp]:
-  "results_gpv \<I> (map_gpv' f g h gpv) = f ` (results_gpv (map_\<I> g h \<I>) gpv)"
-proof(intro Set.set_eqI iffI; (elim imageE; hypsubst)?)
-  show "x \<in> f ` results_gpv (map_\<I> g h \<I>) gpv" if "x \<in> results_gpv \<I> (map_gpv' f g h gpv)" for x using that
-    by(induction gpv'\<equiv>"map_gpv' f g h gpv" arbitrary: gpv)(fastforce intro: results_gpv.intros rev_image_eqI)+
-  show "f x \<in> results_gpv \<I> (map_gpv' f g h gpv)" if "x \<in> results_gpv (map_\<I> g h \<I>) gpv" for x using that
-    by(induction)(fastforce intro: results_gpv.intros)+
-qed
-
-lemma map_\<I>_plus_\<I> [simp]: 
-  "map_\<I> (map_sum f1 f2) (map_sum g1 g2) (\<I>1 \<oplus>\<^sub>\<I> \<I>2) = map_\<I> f1 g1 \<I>1 \<oplus>\<^sub>\<I> map_\<I> f2 g2 \<I>2"
-proof(rule \<I>_eqI[OF Set.set_eqI], goal_cases)
-  case (1 x)
-  then show ?case by(cases x) auto
-qed (auto simp add: image_image)
-
-lemma le_plus_\<I>_iff [simp]:
-  "\<I>1 \<oplus>\<^sub>\<I> \<I>2 \<le> \<I>1' \<oplus>\<^sub>\<I> \<I>2' \<longleftrightarrow> \<I>1 \<le> \<I>1' \<and> \<I>2 \<le> \<I>2'"
-  by(auto 4 4 simp add: le_\<I>_def dest: bspec[where x="Inl _"] bspec[where x="Inr _"])
-
-
-
-inductive pred_gpv' :: "('a \<Rightarrow> bool) \<Rightarrow> ('out \<Rightarrow> bool) \<Rightarrow> 'in set \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> bool" for P Q X gpv where
-  "pred_gpv' P Q X gpv" 
-if "\<And>x. x \<in> results_gpv (\<I>_uniform UNIV X) gpv \<Longrightarrow> P x" "\<And>out. out \<in> outs_gpv (\<I>_uniform UNIV X) gpv \<Longrightarrow> Q out"
-
-lemma pred_gpv_conv_pred_gpv': "pred_gpv P Q = pred_gpv' P Q UNIV"
-  by(auto simp add: fun_eq_iff pred_gpv_def pred_gpv'.simps results_gpv_\<I>_full outs_gpv_\<I>_full)
-
-lemma rel_gpv''_Grp: includes lifting_syntax shows
-  "rel_gpv'' (BNF_Def.Grp A f) (BNF_Def.Grp B g) (BNF_Def.Grp UNIV h)\<inverse>\<inverse> = 
-   BNF_Def.Grp {x. results_gpv (\<I>_uniform UNIV (range h)) x \<subseteq> A \<and> outs_gpv (\<I>_uniform UNIV (range h)) x \<subseteq> B} (map_gpv' f g h)"
-  (is "?lhs = ?rhs")
-proof(intro ext GrpI iffI CollectI conjI subsetI)
-  let ?\<I> = "\<I>_uniform UNIV (range h)"
-  fix gpv gpv'
-  assume *: "?lhs gpv gpv'"
-  then show "map_gpv' f g h gpv = gpv'"
-    by(coinduction arbitrary: gpv gpv')
-      (drule rel_gpv''D
-        , auto 4 5 simp add: spmf_rel_map generat.rel_map elim!: rel_spmf_mono generat.rel_mono_strong GrpE intro!: GrpI dest: rel_funD)
-  show "x \<in> A" if "x \<in> results_gpv ?\<I> gpv" for x using that *
-  proof(induction arbitrary: gpv')
-    case (Pure gpv)
-    have "pred_spmf (Domainp (rel_generat (BNF_Def.Grp A f) (BNF_Def.Grp B g) ((BNF_Def.Grp UNIV h)\<inverse>\<inverse> ===> rel_gpv'' (BNF_Def.Grp A f) (BNF_Def.Grp B g) (BNF_Def.Grp UNIV h)\<inverse>\<inverse>))) (the_gpv gpv)"
-      using Pure.prems[THEN rel_gpv''D] unfolding spmf_Domainp_rel[symmetric] by(rule DomainPI)
-    with Pure.hyps show ?case by(simp add: generat.Domainp_rel pred_spmf_def pred_generat_def Domainp_Grp)
-  next
-    case (IO out c gpv input)
-    have "pred_spmf (Domainp (rel_generat (BNF_Def.Grp A f) (BNF_Def.Grp B g) ((BNF_Def.Grp UNIV h)\<inverse>\<inverse> ===> rel_gpv'' (BNF_Def.Grp A f) (BNF_Def.Grp B g) (BNF_Def.Grp UNIV h)\<inverse>\<inverse>))) (the_gpv gpv)"
-      using IO.prems[THEN rel_gpv''D] unfolding spmf_Domainp_rel[symmetric] by(rule DomainPI)
-    with IO.hyps show ?case 
-      by(auto simp add: generat.Domainp_rel pred_spmf_def pred_generat_def Grp_iff dest: rel_funD intro: IO.IH dest!: bspec)
-  qed
-  show "x \<in> B" if "x \<in> outs_gpv ?\<I> gpv" for x using that *
-  proof(induction arbitrary: gpv')
-    case (IO c gpv)
-    have "pred_spmf (Domainp (rel_generat (BNF_Def.Grp A f) (BNF_Def.Grp B g) ((BNF_Def.Grp UNIV h)\<inverse>\<inverse> ===> rel_gpv'' (BNF_Def.Grp A f) (BNF_Def.Grp B g) (BNF_Def.Grp UNIV h)\<inverse>\<inverse>))) (the_gpv gpv)"
-      using IO.prems[THEN rel_gpv''D] unfolding spmf_Domainp_rel[symmetric] by(rule DomainPI)
-    with IO.hyps show ?case by(simp add: generat.Domainp_rel pred_spmf_def pred_generat_def Domainp_Grp)
-  next
-    case (Cont out rpv gpv input)
-    have "pred_spmf (Domainp (rel_generat (BNF_Def.Grp A f) (BNF_Def.Grp B g) ((BNF_Def.Grp UNIV h)\<inverse>\<inverse> ===> rel_gpv'' (BNF_Def.Grp A f) (BNF_Def.Grp B g) (BNF_Def.Grp UNIV h)\<inverse>\<inverse>))) (the_gpv gpv)"
-      using Cont.prems[THEN rel_gpv''D] unfolding spmf_Domainp_rel[symmetric] by(rule DomainPI)
-    with Cont.hyps show ?case 
-      by(auto simp add: generat.Domainp_rel pred_spmf_def pred_generat_def Grp_iff dest: rel_funD intro: Cont.IH dest!: bspec)
-  qed
-next
-  fix gpv gpv'
-  assume "?rhs gpv gpv'"
-  then have gpv': "gpv' = map_gpv' f g h gpv"
-    and *: "results_gpv (\<I>_uniform UNIV (range h)) gpv \<subseteq> A" "outs_gpv (\<I>_uniform UNIV (range h)) gpv \<subseteq> B" by(auto simp add: Grp_iff)
-  show "?lhs gpv gpv'" using * unfolding gpv'
-    by(coinduction arbitrary: gpv)
-      (fastforce simp add: spmf_rel_map generat.rel_map Grp_iff intro!: rel_spmf_reflI generat.rel_refl_strong rel_funI elim!: generat.set_cases intro: results_gpv.intros outs_gpv.intros)
-qed
-
-lemma rel_gpv''_map_gpv'1:
-  "rel_gpv'' A C (BNF_Def.Grp UNIV h)\<inverse>\<inverse> gpv gpv' \<Longrightarrow> rel_gpv'' A C (=) (map_gpv' id id h gpv) gpv'"
-  apply(coinduction arbitrary: gpv gpv')
-  apply(drule rel_gpv''D)
-  apply(simp add: spmf_rel_map)
-  apply(erule rel_spmf_mono)
-  apply(simp add: generat.rel_map)
-  apply(erule generat.rel_mono_strong; simp?)
-  apply(subst map_fun2_id)
-  by(auto simp add: rel_fun_comp intro!: rel_fun_map_fun1 elim: rel_fun_mono)
-
-lemma rel_gpv''_map_gpv'2:
-  "rel_gpv'' A C (eq_on (range h)) gpv gpv' \<Longrightarrow> rel_gpv'' A C (BNF_Def.Grp UNIV h)\<inverse>\<inverse> gpv (map_gpv' id id h gpv')"
-  apply(coinduction arbitrary: gpv gpv')
-  apply(drule rel_gpv''D)
-  apply(simp add: spmf_rel_map)
-  apply(erule rel_spmf_mono_strong)
-  apply(simp add: generat.rel_map)
-  apply(erule generat.rel_mono_strong; simp?)
-  apply(subst map_fun_id2_in)
-  apply(rule rel_fun_map_fun2)
-  by (auto simp add: rel_fun_comp  elim: rel_fun_mono)
-
-context
-  fixes A :: "'a \<Rightarrow> 'd \<Rightarrow> bool"
-    and C :: "'c \<Rightarrow> 'g \<Rightarrow> bool"
-    and R :: "'b \<Rightarrow> 'e \<Rightarrow> bool"
-begin
-
-private lemma f11:" Pure x \<in> set_spmf (the_gpv gpv) \<Longrightarrow>
-   Domainp (rel_generat A C (rel_fun R (rel_gpv'' A C R))) (Pure x) \<Longrightarrow> Domainp A x"
-  by (auto simp add: pred_generat_def elim:bspec dest: generat.Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI])
-
-private lemma f21: "IO out c \<in> set_spmf (the_gpv gpv) \<Longrightarrow> 
-  rel_generat A C (rel_fun R (rel_gpv'' A C R)) (IO out c) ba \<Longrightarrow> Domainp C out"
-  by (auto simp add: pred_generat_def elim:bspec dest: generat.Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI])
-
-private lemma f12:
-  assumes "IO out c \<in> set_spmf (the_gpv gpv)"
-    and "input \<in> responses_\<I> (\<I>_uniform UNIV {x. Domainp R x}) out"
-    and "x \<in> results_gpv (\<I>_uniform UNIV {x. Domainp R x}) (c input)"
-    and "Domainp (rel_gpv'' A C R) gpv"
-  shows "Domainp (rel_gpv'' A C R) (c input)"
-proof -
-  obtain b1 where o1:"rel_gpv'' A C R gpv b1" using assms(4) by clarsimp
-  obtain b2 where o2:"rel_generat A C (rel_fun R (rel_gpv'' A C R)) (IO out c) b2"
-    using assms(1) o1[THEN rel_gpv''D, THEN spmf_Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI]]
-    unfolding pred_spmf_def by - (drule (1) bspec, auto)
-
-  have "Ball (generat_conts (IO out c)) (Domainp (rel_fun R (rel_gpv'' A C R)))"
-    using o2[THEN generat.Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI]]
-    unfolding pred_generat_def by simp
-
-  with assms(2) show ?thesis 
-    apply -
-    apply(drule bspec)
-     apply simp
-    apply clarify
-    apply(drule Domainp_rel_fun_le[THEN predicate1D, OF Domainp_iff[THEN iffD2], OF exI])
-    by simp  
-qed
-
-private lemma f22:
-  assumes "IO out' rpv \<in> set_spmf (the_gpv gpv)"
-    and "input \<in> responses_\<I> (\<I>_uniform UNIV {x. Domainp R x}) out'"
-    and "out \<in> outs_gpv (\<I>_uniform UNIV {x. Domainp R x}) (rpv input)"
-    and "Domainp (rel_gpv'' A C R) gpv"
-  shows "Domainp (rel_gpv'' A C R) (rpv input)"
-proof -
-  obtain b1 where o1:"rel_gpv'' A C R gpv b1" using assms(4) by auto
-  obtain b2 where o2:"rel_generat A C (rel_fun R (rel_gpv'' A C R)) (IO out' rpv) b2"
-    using assms(1) o1[THEN rel_gpv''D, THEN spmf_Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI]]
-    unfolding pred_spmf_def by - (drule (1) bspec, auto)
-
-  have "Ball (generat_conts (IO out' rpv)) (Domainp (rel_fun R (rel_gpv'' A C R)))"
-    using o2[THEN generat.Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI]]
-    unfolding pred_generat_def by simp
-
-  with assms(2) show ?thesis 
-    apply -
-    apply(drule bspec)
-     apply simp
-    apply clarify
-    apply(drule Domainp_rel_fun_le[THEN predicate1D, OF Domainp_iff[THEN iffD2], OF exI])
-    by simp 
-qed
-
-lemma Domainp_rel_gpv''_le:
-  "Domainp (rel_gpv'' A C R) \<le> pred_gpv' (Domainp A) (Domainp C) {x. Domainp R x}"
-proof(rule predicate1I pred_gpv'.intros)+
-
-  show "Domainp A x" if "x \<in> results_gpv (\<I>_uniform UNIV {x. Domainp R x}) gpv" "Domainp (rel_gpv'' A C R) gpv" for x gpv using that
-  proof(induction)
-    case (Pure gpv)
-    then show ?case 
-      by (clarify) (drule rel_gpv''D
-          , auto simp add: f11 pred_spmf_def dest: spmf_Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI])
-  qed (simp add: f12) 
-  show "Domainp C out" if "out \<in> outs_gpv (\<I>_uniform UNIV {x. Domainp R x}) gpv" "Domainp (rel_gpv'' A C R) gpv" for out gpv using that
-  proof( induction)
-    case (IO c gpv)
-    then show ?case
-      by (clarify) (drule rel_gpv''D
-          , auto simp add: f21 pred_spmf_def dest!: bspec spmf_Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI])
-  qed (simp add: f22)
-qed
-
-end
-
-
-lemma map_gpv'_id12: "map_gpv' f g h gpv = map_gpv' id id h (map_gpv f g gpv)"
-  unfolding map_gpv_conv_map_gpv' map_gpv'_comp by simp
-
-lemma rel_gpv''_refl: "\<lbrakk> (=) \<le> A; (=) \<le> C; R \<le> (=) \<rbrakk> \<Longrightarrow> (=) \<le> rel_gpv'' A C R"
-  by(subst rel_gpv''_eq[symmetric])(rule rel_gpv''_mono)
-
-
-context
-  fixes A A' :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
-    and C C' :: "'c \<Rightarrow> 'd \<Rightarrow> bool"
-    and R R' :: "'e \<Rightarrow> 'f \<Rightarrow> bool"
-   
-begin
-
-private abbreviation foo where 
-  "foo \<equiv> (\<lambda> fx fy gpvx gpvy g1 g2. 
-            \<forall>x y. x \<in> fx (\<I>_uniform UNIV (Collect (Domainp R'))) gpvx \<longrightarrow>
-                  y \<in> fy (\<I>_uniform UNIV (Collect (Rangep R'))) gpvy \<longrightarrow> g1 x y \<longrightarrow> g2 x y)"
-
-private lemma f1: "foo results_gpv results_gpv gpv gpv' A A' \<Longrightarrow>
-       x \<in> set_spmf (the_gpv gpv) \<Longrightarrow> y \<in> set_spmf (the_gpv gpv') \<Longrightarrow>
-       a \<in> generat_conts x \<Longrightarrow> b \<in> generat_conts y \<Longrightarrow>  R' a' \<alpha> \<Longrightarrow> R' \<beta> b' \<Longrightarrow> 
-    foo results_gpv results_gpv (a a') (b b') A A'"
-  by (fastforce elim: generat.set_cases intro: results_gpv.IO)
-
-private lemma f2: "foo outs_gpv outs_gpv gpv gpv' C C' \<Longrightarrow>
-       x \<in> set_spmf (the_gpv gpv) \<Longrightarrow> y \<in> set_spmf (the_gpv gpv') \<Longrightarrow>
-       a \<in> generat_conts x \<Longrightarrow> b \<in> generat_conts y \<Longrightarrow> R' a' \<alpha> \<Longrightarrow> R' \<beta> b' \<Longrightarrow> 
-    foo outs_gpv outs_gpv (a a') (b b') C C'"
-  by (fastforce elim: generat.set_cases intro: outs_gpv.Cont)
-
-lemma rel_gpv''_mono_strong:
-  "\<lbrakk> rel_gpv'' A C R gpv gpv'; 
-     \<And>x y. \<lbrakk> x \<in> results_gpv (\<I>_uniform UNIV {x. Domainp R' x}) gpv; y \<in> results_gpv (\<I>_uniform UNIV {x. Rangep R' x}) gpv'; A x y \<rbrakk> \<Longrightarrow> A' x y;
-     \<And>x y. \<lbrakk> x \<in> outs_gpv (\<I>_uniform UNIV {x. Domainp R' x}) gpv; y \<in> outs_gpv (\<I>_uniform UNIV {x. Rangep R' x}) gpv'; C x y \<rbrakk> \<Longrightarrow> C' x y;
-     R' \<le> R \<rbrakk>
-  \<Longrightarrow> rel_gpv'' A' C' R' gpv gpv'"
-  apply(coinduction arbitrary: gpv gpv')
-  apply(drule rel_gpv''D)
-  apply(erule rel_spmf_mono_strong)
-  apply(erule generat.rel_mono_strong)
-    apply(erule generat.set_cases)+
-    apply(erule allE, rotate_tac -1)
-    apply(erule allE)
-    apply(erule impE)
-     apply(rule results_gpv.Pure)
-     apply simp
-    apply(erule impE)
-     apply(rule results_gpv.Pure)
-     apply simp
-    apply simp
-   apply(erule generat.set_cases)+
-   apply(rotate_tac 1)
-   apply(erule allE, rotate_tac -1)
-   apply(erule allE)
-   apply(erule impE)
-    apply(rule outs_gpv.IO)
-    apply simp
-   apply(erule impE)
-    apply(rule outs_gpv.IO)
-    apply simp
-   apply simp
-  apply(erule (1) rel_fun_mono_strong)
-  by (fastforce simp add: f1[simplified] f2[simplified])
-
-end
-
-lemma rel_gpv''_refl_strong:
-  assumes "\<And>x. x \<in> results_gpv (\<I>_uniform UNIV {x. Domainp R x}) gpv \<Longrightarrow> A x x"
-    and "\<And>x. x \<in> outs_gpv (\<I>_uniform UNIV {x. Domainp R x}) gpv \<Longrightarrow> C x x"
-    and "R \<le> (=)"
-  shows "rel_gpv'' A C R gpv gpv"
-proof -
-  have "rel_gpv'' (=) (=) (=) gpv gpv" unfolding rel_gpv''_eq by simp
-  then show ?thesis using _ _ assms(3) by(rule rel_gpv''_mono_strong)(auto intro: assms(1-2))
-qed
-
-lemma rel_gpv''_refl_eq_on:
-  "\<lbrakk> \<And>x. x \<in> results_gpv (\<I>_uniform UNIV X) gpv \<Longrightarrow> A x x; \<And>out. out \<in> outs_gpv (\<I>_uniform UNIV X) gpv \<Longrightarrow> B out out \<rbrakk>
-  \<Longrightarrow> rel_gpv'' A B (eq_on X) gpv gpv"
-  by(rule rel_gpv''_refl_strong) (auto elim: eq_onE)
-
-lemma pred_gpv'_mono' [mono]:
-  "pred_gpv' A C R gpv \<longrightarrow> pred_gpv' A' C' R gpv"
-  if "\<And>x. A x \<longrightarrow> A' x" "\<And>x. C x \<longrightarrow> C' x"
-  using that unfolding pred_gpv'.simps
-  by auto
-
-
-
-primcorec enforce_\<I>_gpv :: "('out, 'in) \<I> \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> ('a, 'out, 'in) gpv" where
-  "enforce_\<I>_gpv \<I> gpv = GPV 
-    (map_spmf (map_generat id id ((\<circ>) (enforce_\<I>_gpv \<I>))) 
-     (map_spmf (\<lambda>generat. case generat of Pure x \<Rightarrow> Pure x | IO out rpv \<Rightarrow> IO out (\<lambda>input. if input \<in> responses_\<I> \<I> out then rpv input else Fail))
-        (enforce_spmf (pred_generat \<top> (\<lambda>x. x \<in> outs_\<I> \<I>) \<top>) (the_gpv gpv))))"
-
-lemma enforce_\<I>_gpv_Done [simp]: "enforce_\<I>_gpv \<I> (Done x) = Done x"
-  by(rule gpv.expand) simp
-
-lemma enforce_\<I>_gpv_Fail [simp]: "enforce_\<I>_gpv \<I> Fail = Fail"
-  by(rule gpv.expand) simp
-
-lemma enforce_\<I>_gpv_Pause [simp]:
-  "enforce_\<I>_gpv \<I> (Pause out rpv) =
-   (if out \<in> outs_\<I> \<I> then Pause out (\<lambda>input. if input \<in> responses_\<I> \<I> out then enforce_\<I>_gpv \<I> (rpv input) else Fail) else Fail)"
-  by(rule gpv.expand)(simp add: fun_eq_iff)
-
-lemma enforce_\<I>_gpv_lift_spmf [simp]: "enforce_\<I>_gpv \<I> (lift_spmf p) = lift_spmf p"
-  by(rule gpv.expand)(simp add: enforce_map_spmf spmf.map_comp o_def)
-
-lemma enforce_\<I>_gpv_bind_gpv [simp]:
-  "enforce_\<I>_gpv \<I> (bind_gpv gpv f) = bind_gpv (enforce_\<I>_gpv \<I> gpv) (enforce_\<I>_gpv \<I> \<circ> f)"
-  by(coinduction arbitrary: gpv rule: gpv.coinduct_strong)
-    (auto 4 3 simp add: bind_gpv.sel spmf_rel_map bind_map_spmf o_def pred_generat_def elim!: generat.set_cases intro!: generat.rel_refl_strong rel_spmf_bind_reflI rel_spmf_reflI rel_funI split!: if_splits generat.split_asm)
-
-lemma enforce_\<I>_gpv_parametric':
-  includes lifting_syntax 
-  notes [transfer_rule] = corec_gpv_parametric' the_gpv_parametric' Fail_parametric'
-  assumes [transfer_rule]: "bi_unique C" "bi_unique R"
-  shows "(rel_\<I> C R ===> rel_gpv'' A C R ===> rel_gpv'' A C R) enforce_\<I>_gpv enforce_\<I>_gpv"
-  unfolding enforce_\<I>_gpv_def top_fun_def by(transfer_prover)
-
-lemma enforce_\<I>_gpv_parametric [transfer_rule]: includes lifting_syntax shows
-  "bi_unique C \<Longrightarrow> (rel_\<I> C (=) ===> rel_gpv A C ===> rel_gpv A C) enforce_\<I>_gpv enforce_\<I>_gpv"
-  unfolding rel_gpv_conv_rel_gpv'' by(rule enforce_\<I>_gpv_parametric'[OF _ bi_unique_eq])
-
-lemma WT_enforce_\<I>_gpv [simp]: "\<I> \<turnstile>g enforce_\<I>_gpv \<I> gpv \<surd>"
-  by(coinduction arbitrary: gpv)(auto split: generat.split_asm)
-
-lemma WT_gpv_parametric': includes lifting_syntax shows
-  "bi_unique C \<Longrightarrow> (rel_\<I> C R ===> rel_gpv'' A C R ===> (=)) WT_gpv WT_gpv"
-proof(rule rel_funI iffI)+
-  note [transfer_rule] = the_gpv_parametric'
-  show *: "\<I> \<turnstile>g gpv \<surd>" if [transfer_rule]: "rel_\<I> C R \<I> \<I>'" "bi_unique C" 
-    and *: "\<I>' \<turnstile>g gpv' \<surd>" "rel_gpv'' A C R gpv gpv'" for \<I> \<I>' gpv gpv' A C R
-    using *
-  proof(coinduction arbitrary: gpv gpv')
-    case (WT_gpv out c gpv gpv')
-    note [transfer_rule] = WT_gpv(2)
-    have "rel_set (rel_generat A C (R ===> rel_gpv'' A C R)) (set_spmf (the_gpv gpv)) (set_spmf (the_gpv gpv'))" 
-      by transfer_prover
-    from rel_setD1[OF this WT_gpv(3)] obtain out' c'
-      where [transfer_rule]: "C out out'" "(R ===> rel_gpv'' A C R) c c'"
-        and out': "IO out' c' \<in> set_spmf (the_gpv gpv')"
-      by(auto elim: generat.rel_cases)
-    have "out \<in> outs_\<I> \<I> \<longleftrightarrow> out' \<in> outs_\<I> \<I>'" by transfer_prover
-    with WT_gpvD(1)[OF WT_gpv(1) out'] have ?out by simp
-    moreover have ?cont
-    proof(standard; goal_cases cont)
-      case (cont input)
-      have "rel_set R (responses_\<I> \<I> out) (responses_\<I> \<I>' out')" by transfer_prover
-      from rel_setD1[OF this cont] obtain input' where [transfer_rule]: "R input input'"
-        and input': "input' \<in> responses_\<I> \<I>' out'" by blast
-      have "rel_gpv'' A C R (c input) (c' input')" by transfer_prover
-      with WT_gpvD(2)[OF WT_gpv(1) out' input'] show ?case by auto
-    qed
-    ultimately show ?case ..
-  qed
-
-  show "\<I>' \<turnstile>g gpv' \<surd>" if "rel_\<I> C R \<I> \<I>'" "bi_unique C" "\<I> \<turnstile>g gpv \<surd>" "rel_gpv'' A C R gpv gpv'" 
-    for \<I> \<I>' gpv gpv'
-    using *[of "conversep C" "conversep R" \<I>' \<I> gpv "conversep A" gpv'] that
-    by(simp add: rel_gpv''_conversep)
-qed
-
-lemma WT_gpv_map_gpv_id [simp]: "\<I> \<turnstile>g map_gpv f id gpv \<surd> \<longleftrightarrow> \<I> \<turnstile>g gpv \<surd>"
-  using WT_gpv_parametric'[of "BNF_Def.Grp UNIV id" "(=)" "BNF_Def.Grp UNIV f", folded rel_gpv_conv_rel_gpv'']
-  unfolding gpv.rel_Grp unfolding eq_alt[symmetric] relator_eq
-  by(auto simp add: rel_fun_def Grp_def bi_unique_eq)
-
-locale raw_converter_invariant =
-  fixes \<I> :: "('call, 'ret) \<I>"
-    and \<I>' :: "('call', 'ret') \<I>"
-    and callee :: "'s \<Rightarrow> 'call \<Rightarrow> ('ret \<times> 's, 'call', 'ret') gpv"
-    and I :: "'s \<Rightarrow> bool"
-  assumes results_callee: "\<And>s x. \<lbrakk> x \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> results_gpv \<I>' (callee s x) \<subseteq> responses_\<I> \<I> x \<times> {s. I s}"
-    and WT_callee: "\<And>x s. \<lbrakk> x \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> \<I>' \<turnstile>g callee s x \<surd>"
-begin
-
-context begin
-private lemma aux:
-  "set_spmf (inline1 callee gpv s) \<subseteq> {Inr (out, callee', rpv') | out callee' rpv'.
-    \<exists>call\<in>outs_\<I> \<I>. \<exists>s. I s \<and> (\<forall>x \<in> responses_\<I> \<I>' out. callee' x \<in> sub_gpvs \<I>' (callee s call))} \<union>
-     {Inl (x, s') | x s'. x \<in> results_gpv \<I> gpv \<and> I s'}"
-  (is "?concl (inline1 callee) gpv s" is "_ \<subseteq> ?rhs1 \<union> ?rhs2 gpv")
-  if "\<I> \<turnstile>g gpv \<surd>" "I s"
-  using that
-proof(induction arbitrary: gpv s rule: inline1_fixp_induct)
-  case adm show ?case by simp
-  case bottom show ?case by simp
-  case (step inline1')
-  { fix out c
-    assume IO: "IO out c \<in> set_spmf (the_gpv gpv)" 
-    from step.prems(1) IO have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpvD)
-    { fix x s'
-      assume Pure: "Pure (x, s') \<in> set_spmf (the_gpv (callee s out))"
-      then have "(x, s') \<in> results_gpv \<I>' (callee s out)" by(rule results_gpv.Pure)
-      with out step.prems(2) have "x \<in> responses_\<I> \<I> out" "I s'" by(auto dest: results_callee)
-      from step.prems(1) IO this(1) have "\<I> \<turnstile>g c x \<surd>" by(rule WT_gpvD)
-      hence "?concl inline1' (c x) s'" using \<open>I s'\<close> by(rule step.IH)
-      also have "\<dots> \<subseteq> ?rhs1 \<union> ?rhs2 gpv" using \<open>x \<in> _\<close> IO by(auto intro: results_gpv.intros)
-      also note calculation
-    } moreover {
-      fix out' c'
-      assume "IO out' c' \<in> set_spmf (the_gpv (callee s out))"
-      hence "\<forall>x\<in>responses_\<I> \<I>' out'. c' x \<in> sub_gpvs \<I>' (callee s out)"
-        by(auto intro: sub_gpvs.base)
-      then have "\<exists>call\<in>outs_\<I> \<I>. \<exists>s. I s \<and> (\<forall>x\<in>responses_\<I> \<I>' out'. c' x \<in> sub_gpvs \<I>' (callee s call))"
-        using out step.prems(2) by blast
-    } moreover note calculation }
-    then show ?case using step.prems
-      by(auto 4 3 del: subsetI simp add: bind_UNION intro!: UN_least split: generat.split intro: results_gpv.intros)
-  qed
-
-lemma inline1_in_sub_gpvs_callee:
-  assumes "Inr (out, callee', rpv') \<in> set_spmf (inline1 callee gpv s)"
-    and WT: "\<I> \<turnstile>g gpv \<surd>"
-    and s: "I s"
-  shows "\<exists>call\<in>outs_\<I> \<I>. \<exists>s. I s \<and> (\<forall>x \<in> responses_\<I> \<I>' out. callee' x \<in> sub_gpvs \<I>' (callee s call))"
-  using aux[OF WT s] assms(1) by fastforce
-
-lemma inline1_Inl_results_gpv:
-  assumes "Inl (x, s') \<in> set_spmf (inline1 callee gpv s)"
-    and WT: "\<I> \<turnstile>g gpv \<surd>"
-    and s: "I s"
-  shows "x \<in> results_gpv \<I> gpv \<and> I s'"
-  using aux[OF WT s] assms(1) by fastforce
-end
-
-lemma inline1_in_sub_gpvs:
-  assumes "Inr (out, callee', rpv') \<in> set_spmf (inline1 callee gpv s)"
-    and "(x, s') \<in> results_gpv \<I>' (callee' input)"
-    and "input \<in> responses_\<I> \<I>' out"
-    and "\<I> \<turnstile>g gpv \<surd>"
-    and "I s"
-  shows "rpv' x \<in> sub_gpvs \<I> gpv \<and> I s'"
-proof -
-  from \<open>\<I> \<turnstile>g gpv \<surd>\<close> \<open>I s\<close>
-  have "set_spmf (inline1 callee gpv s) \<subseteq> {Inr (out, callee', rpv') | out callee' rpv'.
-    \<forall>input \<in> responses_\<I> \<I>' out. \<forall>(x, s')\<in>results_gpv \<I>' (callee' input). I s' \<and> rpv' x \<in> sub_gpvs \<I> gpv}
-    \<union> {Inl (x, s') | x s'. I s'}" (is "?concl (inline1 callee) gpv s" is "_ \<subseteq> ?rhs gpv s")
-  proof(induction arbitrary: gpv s rule: inline1_fixp_induct)
-    case adm show ?case by(intro cont_intro ccpo_class.admissible_leI)
-    case bottom show ?case by simp
-    case (step inline1')
-    { fix out c
-      assume IO: "IO out c \<in> set_spmf (the_gpv gpv)" 
-      from step.prems(1) IO have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpvD)
-      { fix x s'
-        assume Pure: "Pure (x, s') \<in> set_spmf (the_gpv (callee s out))"
-        then have "(x, s') \<in> results_gpv \<I>' (callee s out)" by(rule results_gpv.Pure)
-        with out step.prems(2) have "x \<in> responses_\<I> \<I> out" "I s'" by(auto dest: results_callee)
-        from step.prems(1) IO this(1) have "\<I> \<turnstile>g c x \<surd>" by(rule WT_gpvD)
-        hence "?concl inline1' (c x) s'" using \<open>I s'\<close> by(rule step.IH)
-        also have "\<dots> \<subseteq> ?rhs gpv s'" using IO Pure \<open>I s\<close>
-          by(fastforce intro: sub_gpvs.cont dest: WT_gpv_OutD[OF step.prems(1)] results_callee[THEN subsetD, OF _ _ results_gpv.Pure])
-        finally have "set_spmf (inline1' (c x) s') \<subseteq> \<dots>" .
-      } moreover {
-        fix out' c' input x s'
-        assume "IO out' c' \<in> set_spmf (the_gpv (callee s out))"
-          and "input \<in> responses_\<I> \<I>' out'" and "(x, s') \<in> results_gpv \<I>' (c' input)"
-        then have "c x \<in> sub_gpvs \<I> gpv" "I s'" using IO \<open>I s\<close>
-          by(auto intro!: sub_gpvs.base dest: WT_gpv_OutD[OF step.prems(1)] results_callee[THEN subsetD, OF _ _ results_gpv.IO])
-      } moreover note calculation }
-      then show ?case using step.prems(2)
-        by(auto simp add: bind_UNION intro!: UN_least split: generat.split del: subsetI)
-    qed
-    with assms show ?thesis by fastforce
-  qed
-
-lemma WT_gpv_inline1:
-  assumes "Inr (out, rpv, rpv') \<in> set_spmf (inline1 callee gpv s)"
-    and "\<I> \<turnstile>g gpv \<surd>"
-    and "I s"
-  shows "out \<in> outs_\<I> \<I>'" (is "?thesis1")
-    and "input \<in> responses_\<I> \<I>' out \<Longrightarrow> \<I>' \<turnstile>g rpv input \<surd>" (is "PROP ?thesis2")
-    and "\<lbrakk> input \<in> responses_\<I> \<I>' out; (x, s') \<in> results_gpv \<I>' (rpv input) \<rbrakk> \<Longrightarrow> \<I> \<turnstile>g rpv' x \<surd> \<and> I s'" (is "PROP ?thesis3")
-proof -
-  from \<open>\<I> \<turnstile>g gpv \<surd>\<close> \<open>I s\<close>
-  have "set_spmf (inline1 callee gpv s) \<subseteq> {Inr (out, rpv, rpv') | out rpv rpv'. out \<in> outs_\<I> \<I>'} \<union> {Inl (x, s')| x s'. I s'}"
-  proof(induction arbitrary: gpv s rule: inline1_fixp_induct)
-    { case adm show ?case by(intro cont_intro ccpo_class.admissible_leI) }
-    { case bottom show ?case by simp }
-    case (step inline1')
-    { fix out c
-      assume IO: "IO out c \<in> set_spmf (the_gpv gpv)" 
-      from step.prems(1) IO have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpvD)
-      { fix x s'
-        assume Pure: "Pure (x, s') \<in> set_spmf (the_gpv (callee s out))"
-        then have *: "(x, s') \<in> results_gpv \<I>' (callee s out)" by(rule results_gpv.Pure)
-        with out step.prems(2) have "x \<in> responses_\<I> \<I> out" "I s'" by(auto dest: results_callee)
-        from step.prems(1) IO this(1) have "\<I> \<turnstile>g c x \<surd>" by(rule WT_gpvD)
-        note this \<open>I s'\<close>
-      } moreover {
-        fix out' c'
-        from out step.prems(2) have "\<I>' \<turnstile>g callee s out \<surd>" by(rule WT_callee)
-        moreover assume "IO out' c' \<in> set_spmf (the_gpv (callee s out))"
-        ultimately have "out' \<in> outs_\<I> \<I>'" by(rule WT_gpvD) 
-      } moreover note calculation }
-      then show ?case using step.prems(2)
-        by(auto del: subsetI simp add: bind_UNION intro!: UN_least split: generat.split intro!: step.IH[THEN order_trans])
-    qed
-    then show ?thesis1 using assms by auto
-
-    assume "input \<in> responses_\<I> \<I>' out"
-    with inline1_in_sub_gpvs_callee[OF \<open>Inr _ \<in> _\<close> \<open>\<I> \<turnstile>g gpv \<surd>\<close> \<open>I s\<close>]
-    obtain out' s where "out' \<in> outs_\<I> \<I>" 
-      and *: "rpv input \<in> sub_gpvs \<I>' (callee s out')" and "I s" by blast
-    from \<open>out' \<in> _\<close> \<open>I s\<close> have "\<I>' \<turnstile>g callee s out' \<surd>" by(rule WT_callee)
-    then show "\<I>' \<turnstile>g rpv input \<surd>" using * by(rule WT_sub_gpvsD)
-
-    assume "(x, s') \<in> results_gpv \<I>' (rpv input)"
-    with \<open>Inr _ \<in> _\<close> have "rpv' x \<in> sub_gpvs \<I> gpv \<and> I s'"
-      using \<open>input \<in> _\<close> \<open>\<I> \<turnstile>g gpv \<surd>\<close> assms(3) \<open>I s\<close> by-(rule inline1_in_sub_gpvs)
-    with \<open>\<I> \<turnstile>g gpv \<surd>\<close> show "\<I> \<turnstile>g rpv' x \<surd> \<and> I s'" by(blast intro: WT_sub_gpvsD)
-  qed
-
-lemma WT_gpv_inline_invar:
-  assumes "\<I> \<turnstile>g gpv \<surd>"
-    and "I s"
-  shows "\<I>' \<turnstile>g inline callee gpv s \<surd>"
-  using assms
-proof(coinduction arbitrary: gpv s rule: WT_gpv_coinduct_bind)
-  case (WT_gpv out c gpv)
-  from \<open>IO out c \<in> _\<close> obtain callee' rpv'
-    where Inr: "Inr (out, callee', rpv') \<in> set_spmf (inline1 callee gpv s)"
-      and c: "c = (\<lambda>input. callee' input \<bind> (\<lambda>(x, s). inline callee (rpv' x) s))"
-    by(clarsimp simp add: inline_sel split: sum.split_asm)
-  from Inr \<open>\<I> \<turnstile>g gpv \<surd>\<close> \<open>I s\<close> have ?out by(rule WT_gpv_inline1)
-  moreover have "?cont TYPE('ret \<times> 's)" (is "\<forall>input\<in>_. _ \<or> _ \<or> ?case' input")
-  proof(rule ballI disjI2)+
-    fix input
-    assume "input \<in> responses_\<I> \<I>' out"
-    with Inr \<open>\<I> \<turnstile>g gpv \<surd> \<close> \<open>I s\<close> have "\<I>' \<turnstile>g callee' input \<surd>"
-      and "\<And>x s'. (x, s') \<in> results_gpv \<I>' (callee' input) \<Longrightarrow> \<I> \<turnstile>g rpv' x \<surd> \<and> I s'"
-      by(blast dest: WT_gpv_inline1)+
-    then show "?case' input" by(subst c)(auto 4 5)
-  qed
-  ultimately show "?case TYPE('ret \<times> 's)" ..
-qed
-
-end
-
-lemma WT_gpv_inline:
-  assumes "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> results_gpv \<I>' (callee s x) \<subseteq> responses_\<I> \<I> x \<times> UNIV"
-    and "\<And>x s. x \<in> outs_\<I> \<I> \<Longrightarrow> \<I>' \<turnstile>g callee s x \<surd>"
-    and "\<I> \<turnstile>g gpv \<surd>"
-  shows "\<I>' \<turnstile>g inline callee gpv s \<surd>"
-proof -
-  interpret raw_converter_invariant \<I> \<I>' callee "\<lambda>_. True" 
-    using assms by(unfold_locales)auto
-  show ?thesis by(rule WT_gpv_inline_invar)(use assms in auto)
-qed
-
-lemma results_gpv_sub_gvps: "gpv' \<in> sub_gpvs \<I> gpv \<Longrightarrow> results_gpv \<I> gpv' \<subseteq> results_gpv \<I> gpv"
-  by(induction rule: sub_gpvs.induct)(auto intro: results_gpv.IO)
-
-lemma in_results_gpv_sub_gvps: "\<lbrakk> x \<in> results_gpv \<I> gpv'; gpv' \<in> sub_gpvs \<I> gpv \<rbrakk> \<Longrightarrow> x \<in> results_gpv \<I> gpv"
-  using results_gpv_sub_gvps[of gpv' \<I> gpv] by blast
-
-context raw_converter_invariant begin
-lemma results_gpv_inline_aux:
-  assumes "(x, s') \<in> results_gpv \<I>' (inline_aux callee y)"
-  shows "\<lbrakk> y = Inl (gpv, s); \<I> \<turnstile>g gpv \<surd>; I s \<rbrakk> \<Longrightarrow> x \<in> results_gpv \<I> gpv \<and> I s'"
-    and "\<lbrakk> y = Inr (rpv, callee'); \<forall>(z, s') \<in> results_gpv \<I>' callee'. \<I> \<turnstile>g rpv z \<surd> \<and> I s' \<rbrakk>
-    \<Longrightarrow> \<exists>(z, s'') \<in> results_gpv \<I>' callee'. x \<in> results_gpv \<I> (rpv z) \<and> I s'' \<and> I s'"
-  using assms
-proof(induction gvp'\<equiv>"inline_aux callee y" arbitrary: y gpv s rpv callee')
-  case Pure case 1
-  with Pure show ?case
-    by(auto simp add: inline_aux.sel split: sum.split_asm dest: inline1_Inl_results_gpv)
-next
-  case Pure case 2
-  with Pure show ?case
-    by(clarsimp simp add: inline_aux.sel split: sum.split_asm)
-      (fastforce split: generat.split_asm dest: inline1_Inl_results_gpv intro: results_gpv.Pure)+
-next
-  case (IO out c input) case 1
-  with IO(1) obtain rpv rpv' where inline1: "Inr (out, rpv, rpv') \<in> set_spmf (inline1 callee gpv s)"
-    and c: "c = (\<lambda>input. inline_aux callee (Inr (rpv', rpv input)))"
-    by(auto simp add: inline_aux.sel split: sum.split_asm)
-  from inline1[THEN inline1_in_sub_gpvs, OF _ \<open>input \<in> responses_\<I> \<I>' out\<close> _ \<open>I s\<close>] \<open>\<I> \<turnstile>g gpv \<surd>\<close>
-  have "\<forall>(z, s')\<in>results_gpv \<I>' (rpv input). \<I> \<turnstile>g rpv' z \<surd> \<and> I s'"
-    by(auto intro: WT_sub_gpvsD)
-  from IO(5)[unfolded c, OF refl refl this] obtain input' s'' 
-    where input': "(input', s'') \<in> results_gpv \<I>' (rpv input)" 
-      and x: "x \<in> results_gpv \<I> (rpv' input')" and s'': "I s''" "I s'"
-    by auto
-  from inline1[THEN inline1_in_sub_gpvs, OF input' \<open>input \<in> responses_\<I> \<I>' out\<close> \<open>\<I> \<turnstile>g gpv \<surd>\<close> \<open>I s\<close>] s'' x
-  show ?case by(auto intro: in_results_gpv_sub_gvps)
-next
-  case (IO out c input) case 2
-  from IO(1) "2"(1) consider (Pure) input' s'' rpv' rpv''
-    where "Pure (input', s'') \<in> set_spmf (the_gpv callee')" "Inr (out, rpv', rpv'') \<in> set_spmf (inline1 callee (rpv input') s'')"
-      "c = (\<lambda>input. inline_aux callee (Inr (rpv'', rpv' input)))"
-    | (Cont) rpv' where "IO out rpv' \<in> set_spmf (the_gpv callee')" "c = (\<lambda>input. inline_aux callee (Inr (rpv, rpv' input)))"
-    by(auto simp add: inline_aux.sel split: sum.split_asm; rename_tac generat; case_tac generat; clarsimp)
-  then show ?case
-  proof cases
-    case Pure
-    have res: "(input', s'') \<in> results_gpv \<I>' callee'" using Pure(1) by(rule results_gpv.Pure)
-    with 2 have WT: "\<I> \<turnstile>g rpv input' \<surd>" "I s''" by auto
-    have "\<forall>(z, s')\<in>results_gpv \<I>' (rpv' input). \<I> \<turnstile>g rpv'' z \<surd> \<and> I s'"
-      using inline1_in_sub_gpvs[OF Pure(2) _ \<open>input \<in> _\<close> WT] WT by(auto intro: WT_sub_gpvsD)
-    from IO(5)[unfolded Pure(3), OF refl refl this] obtain z s'''
-      where z: "(z, s''') \<in> results_gpv \<I>' (rpv' input)"
-        and x: "x \<in> results_gpv \<I> (rpv'' z)" and s': "I s'''" "I s'" by auto
-    have "x \<in> results_gpv \<I> (rpv input')" using x inline1_in_sub_gpvs[OF Pure(2) z \<open>input \<in> _\<close> WT]
-      by(auto intro: in_results_gpv_sub_gvps)
-    then show ?thesis using res WT s' by auto
-  next
-    case Cont
-    have "\<forall>(z, s')\<in>results_gpv \<I>' (rpv' input). \<I> \<turnstile>g rpv z \<surd> \<and> I s'" 
-      using Cont 2 \<open>input \<in> responses_\<I> \<I>' out\<close> by(auto intro: results_gpv.IO)
-    from IO(5)[unfolded Cont, OF refl refl this] obtain z s'' 
-      where "(z, s'') \<in> results_gpv \<I>' (rpv' input)" "x \<in> results_gpv \<I> (rpv z)" "I s''" "I s'" by auto
-    then show ?thesis using Cont(1) \<open>input \<in> _\<close> by(auto intro: results_gpv.IO)
-  qed
-qed
-
-lemma results_gpv_inline: 
-  "\<lbrakk>(x, s') \<in> results_gpv \<I>' (inline callee gpv s); \<I> \<turnstile>g gpv \<surd>; I s\<rbrakk> \<Longrightarrow> x \<in> results_gpv \<I> gpv \<and> I s'"
-  unfolding inline_def by(rule results_gpv_inline_aux(1)[OF _ refl])
-
-end
-
-
-lemma inline_map_gpv:
-  "inline callee (map_gpv f g gpv) s = map_gpv (apfst f) id (inline (\<lambda>s x. callee s (g x)) gpv s)"
-  unfolding apfst_def
-  by(rule inline_parametric
-      [where S="BNF_Def.Grp UNIV id" and C="BNF_Def.Grp UNIV g" and C'="BNF_Def.Grp UNIV id" and A="BNF_Def.Grp UNIV f",
-        THEN rel_funD, THEN rel_funD, THEN rel_funD,
-        unfolded gpv.rel_Grp prod.rel_Grp, simplified, folded eq_alt, unfolded Grp_def, simplified])
-    (auto simp add: rel_fun_def relator_eq)
-
-
-
-(* Computational_Model *)
-
-lemma \<I>_full_le_plus_\<I>: "\<I>_full \<le> plus_\<I> \<I>1 \<I>2" if "\<I>_full \<le> \<I>1" "\<I>_full \<le> \<I>2"
-  using that by(auto simp add: le_\<I>_def top_unique)
-
-lemma plus_\<I>_mono: "plus_\<I> \<I>1 \<I>2 \<le> plus_\<I> \<I>1' \<I>2'" if "\<I>1 \<le> \<I>1'" "\<I>2 \<le> \<I>2'" 
-  using that by(fastforce simp add: le_\<I>_def)
-
-primcorec (transfer) left_gpv :: "('a, 'out, 'in) gpv \<Rightarrow> ('a, 'out + 'out', 'in + 'in') gpv" where
-  "the_gpv (left_gpv gpv) = 
-   map_spmf (map_generat id Inl (\<lambda>rpv input. case input of Inl input' \<Rightarrow> left_gpv (rpv input') | _ \<Rightarrow> Fail)) (the_gpv gpv)"
-
-abbreviation left_rpv :: "('a, 'out, 'in) rpv \<Rightarrow> ('a, 'out + 'out', 'in + 'in') rpv" where
-  "left_rpv rpv \<equiv> \<lambda>input. case input of Inl input' \<Rightarrow> left_gpv (rpv input') | _ \<Rightarrow> Fail"
-
-primcorec (transfer) right_gpv :: "('a, 'out, 'in) gpv \<Rightarrow> ('a, 'out' + 'out, 'in' + 'in) gpv" where
-  "the_gpv (right_gpv gpv) =
-   map_spmf (map_generat id Inr (\<lambda>rpv input. case input of Inr input' \<Rightarrow> right_gpv (rpv input') | _ \<Rightarrow> Fail)) (the_gpv gpv)"
-
-abbreviation right_rpv :: "('a, 'out, 'in) rpv \<Rightarrow> ('a, 'out' + 'out, 'in' + 'in) rpv" where
-  "right_rpv rpv \<equiv> \<lambda>input. case input of Inr input' \<Rightarrow> right_gpv (rpv input') | _ \<Rightarrow> Fail"
-
-context 
-  includes lifting_syntax
-  notes [transfer_rule] = corec_gpv_parametric' Fail_parametric' the_gpv_parametric'
-begin
-
-lemmas left_gpv_parametric = left_gpv.transfer
-
-lemma left_gpv_parametric':
-  "(rel_gpv'' A C R ===> rel_gpv'' A (rel_sum C C') (rel_sum R R')) left_gpv left_gpv"
-  unfolding left_gpv_def by transfer_prover
-
-lemmas right_gpv_parametric = right_gpv.transfer
-
-lemma right_gpv_parametric':
-  "(rel_gpv'' A C' R' ===> rel_gpv'' A (rel_sum C C') (rel_sum R R')) right_gpv right_gpv"
-  unfolding right_gpv_def by transfer_prover
-
-end
-
-lemma left_gpv_Done [simp]: "left_gpv (Done x) = Done x"
-  by(rule gpv.expand) simp
-
-lemma right_gpv_Done [simp]: "right_gpv (Done x) = Done x"
-  by(rule gpv.expand) simp
-
-lemma left_gpv_Pause [simp]:
-  "left_gpv (Pause x rpv) = Pause (Inl x) (\<lambda>input. case input of Inl input' \<Rightarrow> left_gpv (rpv input') | _ \<Rightarrow> Fail)"
-  by(rule gpv.expand) simp
-
-lemma right_gpv_Pause [simp]:
-  "right_gpv (Pause x rpv) = Pause (Inr x) (\<lambda>input. case input of Inr input' \<Rightarrow> right_gpv (rpv input') | _ \<Rightarrow> Fail)"
-  by(rule gpv.expand) simp
-
-lemma left_gpv_map: "left_gpv (map_gpv f g gpv) = map_gpv f (map_sum g h) (left_gpv gpv)"
-  using left_gpv.transfer[of "BNF_Def.Grp UNIV f" "BNF_Def.Grp UNIV g" "BNF_Def.Grp UNIV h"]
-  unfolding sum.rel_Grp gpv.rel_Grp
-  by(auto simp add: rel_fun_def Grp_def)
-
-lemma right_gpv_map: "right_gpv (map_gpv f g gpv) = map_gpv f (map_sum h g) (right_gpv gpv)"
-  using right_gpv.transfer[of "BNF_Def.Grp UNIV f" "BNF_Def.Grp UNIV g" "BNF_Def.Grp UNIV h"]
-  unfolding sum.rel_Grp gpv.rel_Grp
-  by(auto simp add: rel_fun_def Grp_def)
-
-lemma results'_gpv_left_gpv [simp]: 
-  "results'_gpv (left_gpv gpv :: ('a, 'out + 'out', 'in + 'in') gpv) = results'_gpv gpv" (is "?lhs = ?rhs")
-proof(rule Set.set_eqI iffI)+
-  show "x \<in> ?rhs" if "x \<in> ?lhs" for x using that
-    by(induction gpv'\<equiv>"left_gpv gpv :: ('a, 'out + 'out', 'in + 'in') gpv" arbitrary: gpv)
-      (fastforce simp add: elim!: generat.set_cases intro: results'_gpvI split: sum.splits)+
-  show "x \<in> ?lhs" if "x \<in> ?rhs" for x using that
-    by(induction)
-      (auto 4 3 elim!: generat.set_cases intro: results'_gpv_Pure rev_image_eqI results'_gpv_Cont[where input="Inl _"])
-qed
-
-lemma results'_gpv_right_gpv [simp]: 
-  "results'_gpv (right_gpv gpv :: ('a, 'out' + 'out, 'in' + 'in) gpv) = results'_gpv gpv" (is "?lhs = ?rhs")
-proof(rule Set.set_eqI iffI)+
-  show "x \<in> ?rhs" if "x \<in> ?lhs" for x using that
-    by(induction gpv'\<equiv>"right_gpv gpv :: ('a, 'out' + 'out, 'in' + 'in) gpv" arbitrary: gpv)
-      (fastforce simp add: elim!: generat.set_cases intro: results'_gpvI split: sum.splits)+
-  show "x \<in> ?lhs" if "x \<in> ?rhs" for x using that
-    by(induction)
-      (auto 4 3 elim!: generat.set_cases intro: results'_gpv_Pure rev_image_eqI results'_gpv_Cont[where input="Inr _"])
-qed
-
-lemma left_gpv_Inl_transfer: "rel_gpv'' (=) (\<lambda>l r. l = Inl r) (\<lambda>l r. l = Inl r) (left_gpv gpv) gpv"
-  by(coinduction arbitrary: gpv)
-    (auto simp add: spmf_rel_map generat.rel_map del: rel_funI intro!: rel_spmf_reflI generat.rel_refl_strong rel_funI)
-
-lemma right_gpv_Inr_transfer: "rel_gpv'' (=) (\<lambda>l r. l = Inr r) (\<lambda>l r. l = Inr r) (right_gpv gpv) gpv"
-  by(coinduction arbitrary: gpv)
-    (auto simp add: spmf_rel_map generat.rel_map del: rel_funI intro!: rel_spmf_reflI generat.rel_refl_strong rel_funI)
-
-lemma exec_gpv_plus_oracle_left: "exec_gpv (plus_oracle oracle1 oracle2) (left_gpv gpv) s = exec_gpv oracle1 gpv s"
-  unfolding spmf_rel_eq[symmetric] prod.rel_eq[symmetric]
-  by(rule exec_gpv_parametric'[where A="(=)" and S="(=)" and CALL="\<lambda>l r. l = Inl r" and R="\<lambda>l r. l = Inl r", THEN rel_funD, THEN rel_funD, THEN rel_funD])
-    (auto intro!: rel_funI simp add: spmf_rel_map apfst_def map_prod_def rel_prod_conv intro: rel_spmf_reflI left_gpv_Inl_transfer)
-
-lemma exec_gpv_plus_oracle_right: "exec_gpv (plus_oracle oracle1 oracle2) (right_gpv gpv) s = exec_gpv oracle2 gpv s"
-  unfolding spmf_rel_eq[symmetric] prod.rel_eq[symmetric]
-  by(rule exec_gpv_parametric'[where A="(=)" and S="(=)" and CALL="\<lambda>l r. l = Inr r" and R="\<lambda>l r. l = Inr r", THEN rel_funD, THEN rel_funD, THEN rel_funD])
-    (auto intro!: rel_funI simp add: spmf_rel_map apfst_def map_prod_def rel_prod_conv intro: rel_spmf_reflI right_gpv_Inr_transfer)
-
-lemma left_gpv_bind_gpv: "left_gpv (bind_gpv gpv f) = bind_gpv (left_gpv gpv) (left_gpv \<circ> f)"
-  by(coinduction arbitrary:gpv f rule: gpv.coinduct_strong)
-    (auto 4 4 simp add: bind_map_spmf spmf_rel_map intro!: rel_spmf_reflI rel_spmf_bindI[of "(=)"] generat.rel_refl rel_funI split: sum.splits)
-
-lemma inline1_left_gpv:
-  "inline1 (\<lambda>s q. left_gpv (callee s q)) gpv s = 
-   map_spmf (map_sum id (map_prod Inl (map_prod left_rpv id))) (inline1 callee gpv s)"
-proof(induction arbitrary: gpv s rule: parallel_fixp_induct_2_2[OF partial_function_definitions_spmf partial_function_definitions_spmf inline1.mono inline1.mono inline1_def inline1_def, unfolded lub_spmf_empty, case_names adm bottom step])
-  case adm show ?case by simp
-  case bottom show ?case by simp
-  case (step inline1' inline1'')
-  then show ?case
-    by(auto simp add: map_spmf_bind_spmf o_def bind_map_spmf intro!: ext bind_spmf_cong split: generat.split)
-qed
-
-lemma left_gpv_inline: "left_gpv (inline callee gpv s) = inline (\<lambda>s q. left_gpv (callee s q)) gpv s"
-  by(coinduction arbitrary: callee gpv s rule: gpv_coinduct_bind)
-    (fastforce simp add: inline_sel spmf_rel_map inline1_left_gpv left_gpv_bind_gpv o_def split_def intro!: rel_spmf_reflI split: sum.split intro!: rel_funI gpv.rel_refl_strong)
-
-lemma right_gpv_bind_gpv: "right_gpv (bind_gpv gpv f) = bind_gpv (right_gpv gpv) (right_gpv \<circ> f)"
-  by(coinduction arbitrary:gpv f rule: gpv.coinduct_strong)
-    (auto 4 4 simp add: bind_map_spmf spmf_rel_map intro!: rel_spmf_reflI rel_spmf_bindI[of "(=)"] generat.rel_refl rel_funI split: sum.splits)
-
-lemma inline1_right_gpv:
-  "inline1 (\<lambda>s q. right_gpv (callee s q)) gpv s = 
-   map_spmf (map_sum id (map_prod Inr (map_prod right_rpv id))) (inline1 callee gpv s)"
-proof(induction arbitrary: gpv s rule: parallel_fixp_induct_2_2[OF partial_function_definitions_spmf partial_function_definitions_spmf inline1.mono inline1.mono inline1_def inline1_def, unfolded lub_spmf_empty, case_names adm bottom step])
-  case adm show ?case by simp
-  case bottom show ?case by simp
-  case (step inline1' inline1'')
-  then show ?case
-    by(auto simp add: map_spmf_bind_spmf o_def bind_map_spmf intro!: ext bind_spmf_cong split: generat.split)
-qed
-
-lemma right_gpv_inline: "right_gpv (inline callee gpv s) = inline (\<lambda>s q. right_gpv (callee s q)) gpv s"
-  by(coinduction arbitrary: callee gpv s rule: gpv_coinduct_bind)
-    (fastforce simp add: inline_sel spmf_rel_map inline1_right_gpv right_gpv_bind_gpv o_def split_def intro!: rel_spmf_reflI split: sum.split intro!: rel_funI gpv.rel_refl_strong)
-
-lemma WT_gpv_left_gpv: "\<I>1 \<turnstile>g gpv \<surd> \<Longrightarrow> \<I>1 \<oplus>\<^sub>\<I> \<I>2 \<turnstile>g left_gpv gpv \<surd>"
-  by(coinduction arbitrary: gpv)(auto 4 4 dest: WT_gpvD)
-
-lemma WT_gpv_right_gpv: "\<I>2 \<turnstile>g gpv \<surd> \<Longrightarrow> \<I>1 \<oplus>\<^sub>\<I> \<I>2 \<turnstile>g right_gpv gpv \<surd>"
-  by(coinduction arbitrary: gpv)(auto 4 4 dest: WT_gpvD)
-
-lemma results_gpv_left_gpv [simp]: "results_gpv (\<I>1 \<oplus>\<^sub>\<I> \<I>2) (left_gpv gpv) = results_gpv \<I>1 gpv"
-  (is "?lhs = ?rhs")
-proof(rule Set.set_eqI iffI)+
-  show "x \<in> ?rhs" if "x \<in> ?lhs" for x using that
-    by(induction gpv'\<equiv>"left_gpv gpv :: ('a, 'b + 'c, 'd + 'e) gpv" arbitrary: gpv rule: results_gpv.induct)
-      (fastforce intro: results_gpv.intros)+
-  show "x \<in> ?lhs" if "x \<in> ?rhs" for x using that
-    by(induction)(fastforce intro: results_gpv.intros)+
-qed
-
-lemma results_gpv_right_gpv [simp]: "results_gpv (\<I>1 \<oplus>\<^sub>\<I> \<I>2) (right_gpv gpv) = results_gpv \<I>2 gpv"
-  (is "?lhs = ?rhs")
-proof(rule Set.set_eqI iffI)+
-  show "x \<in> ?rhs" if "x \<in> ?lhs" for x using that
-    by(induction gpv'\<equiv>"right_gpv gpv :: ('a, 'b + 'c, 'd + 'e) gpv" arbitrary: gpv rule: results_gpv.induct)
-      (fastforce intro: results_gpv.intros)+
-  show "x \<in> ?lhs" if "x \<in> ?rhs" for x using that
-    by(induction)(fastforce intro: results_gpv.intros)+
-qed
-
-lemma left_gpv_Fail [simp]: "left_gpv Fail = Fail"
-  by(rule gpv.expand) auto
-
-lemma right_gpv_Fail [simp]: "right_gpv Fail = Fail"
-  by(rule gpv.expand) auto
-
-lemma rsuml_lsumr_left_gpv_left_gpv:"map_gpv' id rsuml lsumr (left_gpv (left_gpv gpv)) = left_gpv gpv"
-  by(coinduction arbitrary: gpv)
-    (auto 4 3 simp add: spmf_rel_map generat.rel_map intro!: rel_spmf_reflI rel_generat_reflI rel_funI split!: sum.split elim!: lsumr.elims intro: exI[where x=Fail])
-
-lemma rsuml_lsumr_left_gpv_right_gpv: "map_gpv' id rsuml lsumr (left_gpv (right_gpv gpv)) = right_gpv (left_gpv gpv)"
-  by(coinduction arbitrary: gpv)
-    (auto 4 3 simp add: spmf_rel_map generat.rel_map intro!: rel_spmf_reflI rel_generat_reflI rel_funI split!: sum.split elim!: lsumr.elims intro: exI[where x=Fail])
-
-lemma rsuml_lsumr_right_gpv: "map_gpv' id rsuml lsumr (right_gpv gpv) = right_gpv (right_gpv gpv)"
-  by(coinduction arbitrary: gpv)
-    (auto 4 3 simp add: spmf_rel_map generat.rel_map intro!: rel_spmf_reflI rel_generat_reflI rel_funI split!: sum.split elim!: lsumr.elims intro: exI[where x=Fail])
-
-lemma map_gpv'_map_gpv_swap:
-  "map_gpv' f g h (map_gpv f' id gpv) = map_gpv (f \<circ> f') id (map_gpv' id g h gpv)"
-  by(simp add: map_gpv_conv_map_gpv' map_gpv'_comp)
-
-lemma lsumr_rsuml_left_gpv: "map_gpv' id lsumr rsuml (left_gpv gpv) = left_gpv (left_gpv gpv)"
-  by(coinduction arbitrary: gpv)
-    (auto 4 3 simp add: spmf_rel_map generat.rel_map intro!: rel_spmf_reflI rel_generat_reflI rel_funI split!: sum.split intro: exI[where x=Fail])
-
-lemma lsumr_rsuml_right_gpv_left_gpv:
-  "map_gpv' id lsumr rsuml (right_gpv (left_gpv gpv)) = left_gpv (right_gpv gpv)"
-  by(coinduction arbitrary: gpv)
-    (auto 4 3 simp add: spmf_rel_map generat.rel_map intro!: rel_spmf_reflI rel_generat_reflI rel_funI split!: sum.split intro: exI[where x=Fail])
-
-lemma lsumr_rsuml_right_gpv_right_gpv:
-  "map_gpv' id lsumr rsuml (right_gpv (right_gpv gpv)) = right_gpv gpv"
-  by(coinduction arbitrary: gpv)
-    (auto 4 3 simp add: spmf_rel_map generat.rel_map intro!: rel_spmf_reflI rel_generat_reflI rel_funI split!: sum.split elim!: rsuml.elims intro: exI[where x=Fail])
-
-
-lemma in_set_spmf_extend_state_oracle [simp]:
-  "x \<in> set_spmf (extend_state_oracle oracle s y) \<longleftrightarrow>
-   fst (snd x) = fst s \<and> (fst x, snd (snd x)) \<in> set_spmf (oracle (snd s) y)"
-  by(auto 4 4 simp add: extend_state_oracle_def split_beta intro: rev_image_eqI prod.expand)
-
-lemma extend_state_oracle_plus_oracle: 
-  "extend_state_oracle (plus_oracle oracle1 oracle2) = plus_oracle (extend_state_oracle oracle1) (extend_state_oracle oracle2)"
-proof ((rule ext)+; goal_cases)
-  case (1 s q)
-  then show ?case by (cases s; cases q) (simp_all add: apfst_def spmf.map_comp o_def split_def)
-qed
-
-definition stateless_callee :: "('a \<Rightarrow> ('b, 'out, 'in) gpv) \<Rightarrow> ('s \<Rightarrow> 'a \<Rightarrow> ('b \<times> 's, 'out, 'in) gpv)" where
-  "stateless_callee callee s = map_gpv (\<lambda>b. (b, s)) id \<circ> callee"
-
-lemma stateless_callee_parametric': 
-  includes lifting_syntax notes [transfer_rule] = map_gpv_parametric' shows
-    "((A ===> rel_gpv'' B C R) ===> S ===> A ===> (rel_gpv'' (rel_prod B S) C R))
-   stateless_callee stateless_callee"
-  unfolding stateless_callee_def by transfer_prover
-
-lemma id_oralce_alt_def: "id_oracle = stateless_callee (\<lambda>x. Pause x Done)"
-  by(simp add: id_oracle_def fun_eq_iff stateless_callee_def)
-
-context
-  fixes left :: "'s1 \<Rightarrow> 'x1 \<Rightarrow> ('y1 \<times> 's1, 'call1, 'ret1) gpv"
-    and right :: "'s2 \<Rightarrow> 'x2 \<Rightarrow> ('y2 \<times> 's2, 'call2, 'ret2) gpv"
-begin
-
-fun parallel_intercept :: "'s1 \<times> 's2 \<Rightarrow> 'x1 + 'x2 \<Rightarrow> (('y1 + 'y2) \<times> ('s1 \<times> 's2), 'call1 + 'call2, 'ret1 + 'ret2) gpv"
-  where
-    "parallel_intercept (s1, s2) (Inl a) = left_gpv (map_gpv (map_prod Inl (\<lambda>s1'. (s1', s2))) id (left s1 a))"
-  | "parallel_intercept (s1, s2) (Inr b) = right_gpv (map_gpv (map_prod Inr (Pair s1)) id (right s2 b))"
-
-end
-
-(* GPV_Expectation *)
-
-lemma expectation_gpv_\<I>_mono:
-  defines "expectation_gpv' \<equiv> expectation_gpv"
-  assumes le: "\<I> \<le> \<I>'"
-    and WT: "\<I> \<turnstile>g gpv \<surd>"
-  shows "expectation_gpv fail \<I> f gpv \<le> expectation_gpv' fail \<I>' f gpv"
-  using WT
-proof(induction arbitrary: gpv rule: expectation_gpv_fixp_induct)
-  case adm show ?case by simp
-  case bottom show ?case by simp
-  case step [unfolded expectation_gpv'_def]: (step expectation_gpv')
-  show ?case unfolding expectation_gpv'_def
-    by(subst expectation_gpv.simps)
-      (clarsimp intro!: add_mono nn_integral_mono_AE INF_mono split: generat.split
-        , auto intro!: bexI step add_mono nn_integral_mono_AE INF_mono split: generat.split dest: WT_gpvD[OF step.prems] intro!: step dest: responses_\<I>_mono[OF le])
-qed
-
-lemma pgen_lossless_gpv_mono:
-  assumes *: "pgen_lossless_gpv fail \<I> gpv"
-    and le: "\<I> \<le> \<I>'"
-    and WT: "\<I> \<turnstile>g gpv \<surd>"
-    and fail: "fail \<le> 1"
-  shows "pgen_lossless_gpv fail \<I>' gpv"
-  unfolding pgen_lossless_gpv_def
-proof(rule antisym)
-  from WT le have "\<I>' \<turnstile>g gpv \<surd>" by(rule WT_gpv_\<I>_mono)
-  from expectation_gpv_const_le[OF this, of fail 1] fail
-  show "expectation_gpv fail \<I>' (\<lambda>_. 1) gpv \<le> 1" by(simp add: max_def split: if_split_asm)
-  from expectation_gpv_\<I>_mono[OF le WT, of fail "\<lambda>_. 1"] *
-  show "expectation_gpv fail \<I>' (\<lambda>_. 1) gpv \<ge> 1" by(simp add: pgen_lossless_gpv_def)
-qed
-
-lemma plossless_gpv_mono:
-  "\<lbrakk> plossless_gpv \<I> gpv; \<I> \<le> \<I>'; \<I> \<turnstile>g gpv \<surd> \<rbrakk> \<Longrightarrow> plossless_gpv \<I>' gpv"
-  by(erule pgen_lossless_gpv_mono; simp)
-
-lemma pfinite_gpv_mono:
-  "\<lbrakk> pfinite_gpv \<I> gpv; \<I> \<le> \<I>'; \<I> \<turnstile>g gpv \<surd> \<rbrakk> \<Longrightarrow> pfinite_gpv \<I>' gpv"
-  by(erule pgen_lossless_gpv_mono; simp)
-
-lemma pgen_lossless_gpv_parametric': includes lifting_syntax shows
-  "((=) ===> rel_\<I> C R ===> rel_gpv'' A C R ===> (=)) pgen_lossless_gpv pgen_lossless_gpv"
-  unfolding pgen_lossless_gpv_def supply expectation_gpv_parametric'[transfer_rule] by transfer_prover
-
-lemma pgen_lossless_gpv_parametric: includes lifting_syntax shows
-  "((=) ===> rel_\<I> C (=) ===> rel_gpv A C ===> (=)) pgen_lossless_gpv pgen_lossless_gpv"
-  using pgen_lossless_gpv_parametric'[of C "(=)" A] by(simp add: rel_gpv_conv_rel_gpv'')
-
-lemma pgen_lossless_gpv_map_gpv_id [simp]:
-  "pgen_lossless_gpv fail \<I> (map_gpv f id gpv) = pgen_lossless_gpv fail \<I> gpv"
-  using pgen_lossless_gpv_parametric[of "BNF_Def.Grp UNIV id" "BNF_Def.Grp UNIV f"]
-  unfolding gpv.rel_Grp
-  by(auto simp add: eq_alt[symmetric] rel_\<I>_eq rel_fun_def Grp_iff)
-
-context raw_converter_invariant begin
-
-lemma expectation_gpv_le_inline:
-  defines "expectation_gpv2 \<equiv> expectation_gpv 0 \<I>'"
-  assumes callee: "\<And>s x. \<lbrakk> x \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> plossless_gpv \<I>' (callee s x)"
-    and WT_gpv: "\<I> \<turnstile>g gpv \<surd>"
-    and I: "I s"
-  shows "expectation_gpv 0 \<I> f gpv \<le> expectation_gpv2 (\<lambda>(x, s). f x) (inline callee gpv s)"
-  using WT_gpv I
-proof(induction arbitrary: gpv s rule: expectation_gpv_fixp_induct)
-  case adm show ?case by simp
-  case bottom show ?case by simp
-  case (step expectation_gpv')
-  { fix out c
-    assume IO: "IO out c \<in> set_spmf (the_gpv gpv)"
-    with step.prems (1) have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpv_OutD)
-    have "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) = \<integral>\<^sup>+ generat. (INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<partial>measure_spmf (the_gpv (callee s out))"
-      using WT_callee[OF out, of s] callee[OF out, of s] \<open>I s\<close>
-      by(clarsimp simp add: measure_spmf.emeasure_eq_measure plossless_iff_colossless_pfinite colossless_gpv_lossless_spmfD lossless_weight_spmfD)
-    also have "\<dots> \<le> \<integral>\<^sup>+ generat. (case generat of Pure (x, s') \<Rightarrow>
-            \<integral>\<^sup>+ xx. (case xx of Inl (x, _) \<Rightarrow> f x 
-               | Inr (out', callee', rpv) \<Rightarrow> INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r, s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (rpv r) s')) (callee' r'))
-            \<partial>measure_spmf (inline1 callee (c x) s')
-         | IO out' rpv \<Rightarrow> INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r', s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (c r') s')) (rpv r'))
-       \<partial>measure_spmf (the_gpv (callee s out))"
-    proof(rule nn_integral_mono_AE; simp split!: generat.split)
-      fix x s'
-      assume Pure: "Pure (x, s') \<in> set_spmf (the_gpv (callee s out))"
-      hence "(x, s') \<in> results_gpv \<I>' (callee s out)" by(rule results_gpv.Pure)
-      with results_callee[OF out, of s] \<open>I s\<close> have x: "x \<in> responses_\<I> \<I> out" and "I s'" by blast+
-      from x have "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> expectation_gpv' (c x)" by(rule INF_lower)
-      also have "\<dots> \<le> expectation_gpv2 (\<lambda>(x, s). f x) (inline callee (c x) s')"
-        by(rule step.IH)(rule WT_gpv_ContD[OF step.prems(1) IO x] step.prems \<open>I s'\<close>|assumption)+
-      also have "\<dots> = \<integral>\<^sup>+ xx. (case xx of Inl (x, _) \<Rightarrow> f x 
-               | Inr (out', callee', rpv) \<Rightarrow> INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r, s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (rpv r) s')) (callee' r'))
-            \<partial>measure_spmf (inline1 callee (c x) s')"
-        unfolding expectation_gpv2_def
-        by(subst expectation_gpv.simps)(auto simp add: inline_sel split_def o_def intro!: nn_integral_cong split: generat.split sum.split)
-      finally show "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> \<dots>" .
-    next
-      fix out' rpv
-      assume IO': "IO out' rpv \<in> set_spmf (the_gpv (callee s out))"
-      have "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> (INF (r, s')\<in>(\<Union>r'\<in>responses_\<I> \<I>' out'. results_gpv \<I>' (rpv r')). expectation_gpv' (c r))"
-        using IO' results_callee[OF out, of s] \<open>I s\<close> by(intro INF_mono)(auto intro: results_gpv.IO)
-      also have "\<dots> = (INF r'\<in>responses_\<I> \<I>' out'. INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv' (c r))"
-        by(simp add: INF_UNION)
-      also have "\<dots> \<le> (INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r', s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (c r') s')) (rpv r'))"
-      proof(rule INF_mono, rule bexI)
-        fix r'
-        assume r': "r' \<in> responses_\<I> \<I>' out'"
-        have "(INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv' (c r)) \<le> (INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv2 (\<lambda>(x, s). f x) (inline callee (c r) s'))"
-          using IO IO' step.prems out results_callee[OF out, of s] r'
-          by(auto intro!: INF_mono rev_bexI step.IH dest: WT_gpv_ContD intro: results_gpv.IO)
-        also have "\<dots> \<le>  expectation_gpv 0 \<I>' (\<lambda>(r', s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (c r') s')) (rpv r')"
-          unfolding expectation_gpv2_def using plossless_gpv_ContD[OF callee, OF out \<open>I s\<close> IO' r'] WT_callee[OF out \<open>I s\<close>] IO' r'
-          by(intro plossless_INF_le_expectation_gpv)(auto intro: WT_gpv_ContD)
-        finally show "(INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv' (c r)) \<le> \<dots>" .
-      qed
-      finally show "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> \<dots>" .
-    qed
-    also note calculation }
-  then show ?case unfolding expectation_gpv2_def
-    apply(rewrite expectation_gpv.simps)
-    apply(rewrite inline_sel)
-    apply(simp add: o_def pmf_map_spmf_None)
-    apply(rewrite sum.case_distrib[where h="case_generat _ _"])
-    apply(simp cong del: sum.case_cong_weak)
-    apply(simp add: split_beta o_def cong del: sum.case_cong_weak)
-    apply(rewrite inline1.simps)
-    apply(rewrite measure_spmf_bind)
-    apply(rewrite nn_integral_bind[where B="measure_spmf _"])
-      apply simp
-     apply(simp add: space_subprob_algebra)
-    apply(rule nn_integral_mono_AE)
-    apply(clarsimp split!: generat.split)
-     apply(simp add: measure_spmf_return_spmf nn_integral_return)
-    apply(rewrite measure_spmf_bind)
-    apply(simp add: nn_integral_bind[where B="measure_spmf _"] space_subprob_algebra)
-    apply(subst generat.case_distrib[where h="measure_spmf"])
-    apply(subst generat.case_distrib[where h="\<lambda>x. nn_integral x _"])
-    apply(simp add: measure_spmf_return_spmf nn_integral_return split_def)
-    done
-qed
-
-lemma plossless_inline:
-  assumes lossless: "plossless_gpv \<I> gpv"
-    and WT: "\<I> \<turnstile>g gpv \<surd>"
-    and callee: "\<And>s x. \<lbrakk> I s; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> plossless_gpv \<I>' (callee s x)"
-    and I: "I s"
-  shows "plossless_gpv \<I>' (inline callee gpv s)"
-  unfolding pgen_lossless_gpv_def
-proof(rule antisym)
-  have WT': "\<I>' \<turnstile>g inline callee gpv s \<surd>" using WT I by(rule WT_gpv_inline_invar)
-  from expectation_gpv_const_le[OF WT', of 0 1]
-  show "expectation_gpv 0 \<I>' (\<lambda>_. 1) (inline callee gpv s) \<le> 1" by(simp add: max_def)
-
-  have "1 = expectation_gpv 0 \<I> (\<lambda>_. 1) gpv" using lossless by(simp add: pgen_lossless_gpv_def)
-  also have "\<dots> \<le> expectation_gpv 0 \<I>' (\<lambda>_. 1) (inline callee gpv s)"
-    by(rule expectation_gpv_le_inline[unfolded split_def]; rule callee I WT)
-  finally show "1 \<le> \<dots>" .
-qed
-
-end
-
-lemma expectation_left_gpv [simp]:
-  "expectation_gpv fail (\<I> \<oplus>\<^sub>\<I> \<I>') f (left_gpv gpv) = expectation_gpv fail \<I> f gpv"
-proof(induction arbitrary: gpv rule: parallel_fixp_induct_1_1[OF complete_lattice_partial_function_definitions complete_lattice_partial_function_definitions expectation_gpv.mono expectation_gpv.mono expectation_gpv_def expectation_gpv_def, case_names adm bottom step])
-  case adm show ?case by simp
-  case bottom show ?case by simp
-  case (step expectation_gpv' expectation_gpv'')
-  show ?case
-    by (auto simp add: pmf_map_spmf_None o_def case_map_generat image_comp
-      split: generat.split intro!: nn_integral_cong_AE INF_cong step.IH)
-qed
-
-lemma expectation_right_gpv [simp]:
-  "expectation_gpv fail (\<I> \<oplus>\<^sub>\<I> \<I>') f (right_gpv gpv) = expectation_gpv fail \<I>' f gpv"
-proof(induction arbitrary: gpv rule: parallel_fixp_induct_1_1[OF complete_lattice_partial_function_definitions complete_lattice_partial_function_definitions expectation_gpv.mono expectation_gpv.mono expectation_gpv_def expectation_gpv_def, case_names adm bottom step])
-  case adm show ?case by simp
-  case bottom show ?case by simp
-  case (step expectation_gpv' expectation_gpv'')
-  show ?case
-    by (auto simp add: pmf_map_spmf_None o_def case_map_generat image_comp
-      split: generat.split intro!: nn_integral_cong_AE INF_cong step.IH)
-qed
-
-lemma pgen_lossless_left_gpv [simp]: "pgen_lossless_gpv fail (\<I> \<oplus>\<^sub>\<I> \<I>') (left_gpv gpv) = pgen_lossless_gpv fail \<I> gpv"
-  by(simp add: pgen_lossless_gpv_def)
-
-lemma pgen_lossless_right_gpv [simp]: "pgen_lossless_gpv fail (\<I> \<oplus>\<^sub>\<I> \<I>') (right_gpv gpv) = pgen_lossless_gpv fail \<I>' gpv"
-  by(simp add: pgen_lossless_gpv_def)
-
-lemma (in raw_converter_invariant) expectation_gpv_le_inline_invariant:
-  defines "expectation_gpv2 \<equiv> expectation_gpv 0 \<I>'"
-  assumes callee: "\<And>s x. \<lbrakk> x \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> plossless_gpv \<I>' (callee s x)"
-    and WT_gpv: "\<I> \<turnstile>g gpv \<surd>"
-    and I: "I s"
-  shows "expectation_gpv 0 \<I> f gpv \<le> expectation_gpv2 (\<lambda>(x, s). f x) (inline callee gpv s)"
-  using WT_gpv I
-proof(induction arbitrary: gpv s rule: expectation_gpv_fixp_induct)
-  case adm show ?case by simp
-  case bottom show ?case by simp
-  case (step expectation_gpv')
-  { fix out c
-    assume IO: "IO out c \<in> set_spmf (the_gpv gpv)"
-    with step.prems(1) have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpv_OutD)
-    have "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) = \<integral>\<^sup>+ generat. (INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<partial>measure_spmf (the_gpv (callee s out))"
-      using WT_callee[OF out, of s] callee[OF out, of s] step.prems(2)
-      by(clarsimp simp add: measure_spmf.emeasure_eq_measure plossless_iff_colossless_pfinite colossless_gpv_lossless_spmfD lossless_weight_spmfD)
-    also have "\<dots> \<le> \<integral>\<^sup>+ generat. (case generat of Pure (x, s') \<Rightarrow>
-            \<integral>\<^sup>+ xx. (case xx of Inl (x, _) \<Rightarrow> f x 
-               | Inr (out', callee', rpv) \<Rightarrow> INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r, s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (rpv r) s')) (callee' r'))
-            \<partial>measure_spmf (inline1 callee (c x) s')
-         | IO out' rpv \<Rightarrow> INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r', s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (c r') s')) (rpv r'))
-       \<partial>measure_spmf (the_gpv (callee s out))"
-    proof(rule nn_integral_mono_AE; simp split!: generat.split)
-      fix x s'
-      assume Pure: "Pure (x, s') \<in> set_spmf (the_gpv (callee s out))"
-      hence "(x, s') \<in> results_gpv \<I>' (callee s out)" by(rule results_gpv.Pure)
-      with results_callee[OF out step.prems(2)] have x: "x \<in> responses_\<I> \<I> out" and s': "I s'" by blast+
-      from this(1) have "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> expectation_gpv' (c x)" by(rule INF_lower)
-      also have "\<dots> \<le> expectation_gpv2 (\<lambda>(x, s). f x) (inline callee (c x) s')"
-        by(rule step.IH)(rule WT_gpv_ContD[OF step.prems(1) IO x] step.prems s'|assumption)+
-      also have "\<dots> = \<integral>\<^sup>+ xx. (case xx of Inl (x, _) \<Rightarrow> f x 
-               | Inr (out', callee', rpv) \<Rightarrow> INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r, s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (rpv r) s')) (callee' r'))
-            \<partial>measure_spmf (inline1 callee (c x) s')"
-        unfolding expectation_gpv2_def
-        by(subst expectation_gpv.simps)(auto simp add: inline_sel split_def o_def intro!: nn_integral_cong split: generat.split sum.split)
-      finally show "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> \<dots>" .
-    next
-      fix out' rpv
-      assume IO': "IO out' rpv \<in> set_spmf (the_gpv (callee s out))"
-      have "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> (INF (r, s')\<in>(\<Union>r'\<in>responses_\<I> \<I>' out'. results_gpv \<I>' (rpv r')). expectation_gpv' (c r))"
-        using IO' results_callee[OF out step.prems(2)] by(intro INF_mono)(auto intro: results_gpv.IO)
-      also have "\<dots> = (INF r'\<in>responses_\<I> \<I>' out'. INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv' (c r))"
-        by(simp add: INF_UNION)
-      also have "\<dots> \<le> (INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r', s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (c r') s')) (rpv r'))"
-      proof(rule INF_mono, rule bexI)
-        fix r'
-        assume r': "r' \<in> responses_\<I> \<I>' out'"
-        have "(INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv' (c r)) \<le> (INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv2 (\<lambda>(x, s). f x) (inline callee (c r) s'))"
-          using IO IO' step.prems out results_callee[OF out, of s] r'
-          by(auto intro!: INF_mono rev_bexI step.IH dest: WT_gpv_ContD intro: results_gpv.IO)
-        also have "\<dots> \<le>  expectation_gpv 0 \<I>' (\<lambda>(r', s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (c r') s')) (rpv r')"
-          unfolding expectation_gpv2_def using plossless_gpv_ContD[OF callee, OF out step.prems(2) IO' r'] WT_callee[OF out step.prems(2)] IO' r'
-          by(intro plossless_INF_le_expectation_gpv)(auto intro: WT_gpv_ContD)
-        finally show "(INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv' (c r)) \<le> \<dots>" .
-      qed
-      finally show "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> \<dots>" .
-    qed
-    also note calculation }
-  then show ?case unfolding expectation_gpv2_def
-    apply(rewrite expectation_gpv.simps)
-    apply(rewrite inline_sel)
-    apply(simp add: o_def pmf_map_spmf_None)
-    apply(rewrite sum.case_distrib[where h="case_generat _ _"])
-    apply(simp cong del: sum.case_cong_weak)
-    apply(simp add: split_beta o_def cong del: sum.case_cong_weak)
-    apply(rewrite inline1.simps)
-    apply(rewrite measure_spmf_bind)
-    apply(rewrite nn_integral_bind[where B="measure_spmf _"])
-      apply simp
-     apply(simp add: space_subprob_algebra)
-    apply(rule nn_integral_mono_AE)
-    apply(clarsimp split!: generat.split)
-     apply(simp add: measure_spmf_return_spmf nn_integral_return)
-    apply(rewrite measure_spmf_bind)
-    apply(simp add: nn_integral_bind[where B="measure_spmf _"] space_subprob_algebra)
-    apply(subst generat.case_distrib[where h="measure_spmf"])
-    apply(subst generat.case_distrib[where h="\<lambda>x. nn_integral x _"])
-    apply(simp add: measure_spmf_return_spmf nn_integral_return split_def)
-    done
-qed
-
-lemma (in raw_converter_invariant) plossless_inline_invariant:
-  assumes lossless: "plossless_gpv \<I> gpv"
-    and WT: "\<I> \<turnstile>g gpv \<surd>"
-    and callee: "\<And>s x. \<lbrakk> x \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> plossless_gpv \<I>' (callee s x)"
-    and I: "I s"
-  shows "plossless_gpv \<I>' (inline callee gpv s)"
-  unfolding pgen_lossless_gpv_def
-proof(rule antisym)
-  have WT': "\<I>' \<turnstile>g inline callee gpv s \<surd>" using WT I by(rule WT_gpv_inline_invar)
-  from expectation_gpv_const_le[OF WT', of 0 1]
-  show "expectation_gpv 0 \<I>' (\<lambda>_. 1) (inline callee gpv s) \<le> 1" by(simp add: max_def)
-
-  have "1 = expectation_gpv 0 \<I> (\<lambda>_. 1) gpv" using lossless by(simp add: pgen_lossless_gpv_def)
-  also have "\<dots> \<le> expectation_gpv 0 \<I>' (\<lambda>_. 1) (inline callee gpv s)"
-    by(rule expectation_gpv_le_inline[unfolded split_def]; rule callee WT WT_callee I)
-  finally show "1 \<le> \<dots>" .
-qed
-
-context callee_invariant_on begin
-
-lemma raw_converter_invariant: "raw_converter_invariant \<I> \<I>' (\<lambda>s x. lift_spmf (callee s x)) I"
-  by(unfold_locales)(auto dest: callee_invariant WT_callee WT_calleeD)
-
-lemma (in callee_invariant_on) plossless_exec_gpv:
-  assumes lossless: "plossless_gpv \<I> gpv"
-    and WT: "\<I> \<turnstile>g gpv \<surd>"
-    and callee: "\<And>s x. \<lbrakk> x \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> lossless_spmf (callee s x)"
-    and I: "I s"
-  shows "lossless_spmf (exec_gpv callee gpv s)"
-proof -
-  interpret raw_converter_invariant \<I> \<I>' "\<lambda>s x. lift_spmf (callee s x)" I for \<I>'
-    by(rule raw_converter_invariant)
-  have "plossless_gpv \<I>_full (inline (\<lambda>s x. lift_spmf (callee s x)) gpv s)"
-    using lossless WT by(rule plossless_inline)(simp_all add: callee I)
-  from this[THEN plossless_gpv_lossless_spmfD] show ?thesis
-    unfolding exec_gpv_conv_inline1 by(simp add: inline_sel)
-qed
-
-end
-
-definition extend_state_oracle2 :: "('call, 'ret, 's) callee \<Rightarrow> ('call, 'ret, 's \<times> 's') callee" ("_\<dagger>" [1000] 1000)
-  where "extend_state_oracle2 callee = (\<lambda>(s, s') x. map_spmf (\<lambda>(y, s). (y, (s, s'))) (callee s x))"
-
-lemma extend_state_oracle2_simps [simp]:
-  "extend_state_oracle2 callee (s, s') x = map_spmf (\<lambda>(y, s). (y, (s, s'))) (callee s x)"
-  by(simp add: extend_state_oracle2_def)
-
-lemma extend_state_oracle2_parametric [transfer_rule]: includes lifting_syntax shows
-  "((S ===> C ===> rel_spmf (rel_prod R S)) ===> rel_prod S S' ===> C ===> rel_spmf (rel_prod R (rel_prod S S')))
-  extend_state_oracle2 extend_state_oracle2"
-  unfolding extend_state_oracle2_def[abs_def] by transfer_prover
-
-lemma callee_invariant_extend_state_oracle2_const [simp]:
-  "callee_invariant oracle\<dagger> (\<lambda>(s, s'). I s')"
-  by unfold_locales auto
-
-lemma callee_invariant_extend_state_oracle2_const':
-  "callee_invariant oracle\<dagger> (\<lambda>s. I (snd s))"
-  by unfold_locales auto
-
-lemma extend_state_oracle2_plus_oracle: 
-  "extend_state_oracle2 (plus_oracle oracle1 oracle2) = plus_oracle (extend_state_oracle2 oracle1) (extend_state_oracle2 oracle2)"
-proof((rule ext)+; goal_cases)
-  case (1 s q)
-  then show ?case by (cases s; cases q) (simp_all add: apfst_def spmf.map_comp o_def split_def)
-qed
-
-lemma parallel_oracle_conv_plus_oracle:
-  "parallel_oracle oracle1 oracle2 = plus_oracle (oracle1\<dagger>) (\<dagger>oracle2)"
-proof((rule ext)+; goal_cases)
-  case (1 s q)
-  then show ?case by (cases s; cases q) (auto simp add: spmf.map_comp apfst_def o_def split_def map_prod_def)
-qed
-
-lemma map_sum_parallel_oracle: includes lifting_syntax shows
-  "(id ---> map_sum f g ---> map_spmf (map_prod (map_sum h k) id)) (parallel_oracle oracle1 oracle2)
-  = parallel_oracle ((id ---> f ---> map_spmf (map_prod h id)) oracle1) ((id ---> g ---> map_spmf (map_prod k id)) oracle2)"
-proof((rule ext)+; goal_cases)
-  case (1 s q)
-  then show ?case by (cases s; cases q) (simp_all add: spmf.map_comp o_def apfst_def prod.map_comp)
-qed
-
-lemma map_sum_plus_oracle: includes lifting_syntax shows
-  "(id ---> map_sum f g ---> map_spmf (map_prod (map_sum h k) id)) (plus_oracle oracle1 oracle2)
-  = plus_oracle ((id ---> f ---> map_spmf (map_prod h id)) oracle1) ((id ---> g ---> map_spmf (map_prod k id)) oracle2)"
-proof((rule ext)+; goal_cases)
-  case (1 s q)
-  then show ?case by (cases q) (simp_all add: spmf.map_comp o_def apfst_def prod.map_comp)
-qed
-
-lemma map_rsuml_plus_oracle: includes lifting_syntax shows
-  "(id ---> rsuml ---> (map_spmf (map_prod lsumr id))) (oracle1 \<oplus>\<^sub>O (oracle2 \<oplus>\<^sub>O oracle3)) =
-   ((oracle1 \<oplus>\<^sub>O oracle2) \<oplus>\<^sub>O oracle3)"
-proof((rule ext)+; goal_cases)
-  case (1 s q)
-  then show ?case 
-  proof(cases q)
-    case (Inl ql)
-    then show ?thesis by(cases ql)(simp_all add: spmf.map_comp o_def apfst_def prod.map_comp)
-  qed (simp add: spmf.map_comp o_def apfst_def prod.map_comp id_def)
-qed
-
-lemma map_lsumr_plus_oracle: includes lifting_syntax shows
-  "(id ---> lsumr ---> (map_spmf (map_prod rsuml id))) ((oracle1 \<oplus>\<^sub>O oracle2) \<oplus>\<^sub>O oracle3) =
-   (oracle1 \<oplus>\<^sub>O (oracle2 \<oplus>\<^sub>O oracle3))"
-proof((rule ext)+; goal_cases)
-  case (1 s q)
-  then show ?case 
-  proof(cases q)
-    case (Inr qr)
-    then show ?thesis by(cases qr)(simp_all add: spmf.map_comp o_def apfst_def prod.map_comp)
-  qed (simp add: spmf.map_comp o_def apfst_def prod.map_comp id_def)
-qed
-
-context includes lifting_syntax begin
-
-definition lift_state_oracle
-  :: "(('s \<Rightarrow> 'a \<Rightarrow> (('b \<times> 't) \<times> 's) spmf) \<Rightarrow> ('s' \<Rightarrow> 'a \<Rightarrow> (('b \<times> 't) \<times> 's') spmf)) 
-  \<Rightarrow> ('t \<times> 's \<Rightarrow> 'a \<Rightarrow> ('b \<times> 't \<times> 's) spmf) \<Rightarrow> ('t \<times> 's' \<Rightarrow> 'a \<Rightarrow> ('b \<times> 't \<times> 's') spmf)" where
-  "lift_state_oracle F oracle = 
-   (\<lambda>(t, s') a. map_spmf rprodl (F ((Pair t ---> id ---> map_spmf lprodr) oracle) s' a))"
-
-lemma lift_state_oracle_simps [simp]:
-  "lift_state_oracle F oracle (t, s') a = map_spmf rprodl (F ((Pair t ---> id ---> map_spmf lprodr) oracle) s' a)"
-  by(simp add: lift_state_oracle_def)
-
-lemma lift_state_oracle_parametric [transfer_rule]: includes lifting_syntax shows
-  "(((S ===> A ===> rel_spmf (rel_prod (rel_prod B T) S)) ===> S' ===> A ===> rel_spmf (rel_prod (rel_prod B T) S'))
-  ===> (rel_prod T S ===> A ===> rel_spmf (rel_prod B (rel_prod T S)))
-  ===> rel_prod T S' ===> A ===> rel_spmf (rel_prod B (rel_prod T S')))
-  lift_state_oracle lift_state_oracle"
-  unfolding lift_state_oracle_def map_fun_def o_def by transfer_prover
-
-lemma lift_state_oracle_extend_state_oracle:
-  includes lifting_syntax
-  assumes "\<And>B. Transfer.Rel (((=) ===> (=) ===> rel_spmf (rel_prod B (=))) ===> (=) ===> (=) ===> rel_spmf (rel_prod B (=))) G F"
-    (* TODO: implement simproc to discharge parametricity assumptions like this one *)
-  shows "lift_state_oracle F (extend_state_oracle oracle) = extend_state_oracle (G oracle)"
-  unfolding lift_state_oracle_def extend_state_oracle_def
-  apply(clarsimp simp add: fun_eq_iff map_fun_def o_def spmf.map_comp split_def rprodl_def)
-  subgoal for t s a
-    apply(rule sym)
-    apply(fold spmf_rel_eq)
-    apply(simp add: spmf_rel_map)
-    apply(rule rel_spmf_mono)
-     apply(rule assms[unfolded Rel_def, where B="\<lambda>x (y, z). x = y \<and> z = t", THEN rel_funD, THEN rel_funD, THEN rel_funD])
-       apply(auto simp add: rel_fun_def spmf_rel_map intro!: rel_spmf_reflI)
-    done
-  done
-
-lemma lift_state_oracle_compose: 
-  "lift_state_oracle F (lift_state_oracle G oracle) = lift_state_oracle (F \<circ> G) oracle"
-  by(simp add: lift_state_oracle_def map_fun_def o_def split_def spmf.map_comp)
-
-lemma lift_state_oracle_id [simp]: "lift_state_oracle id = id"
-  by(simp add: fun_eq_iff spmf.map_comp o_def)
-
-lemma rprodl_extend_state_oracle: includes lifting_syntax shows
-  "(rprodl ---> id ---> map_spmf (map_prod id lprodr)) (extend_state_oracle (extend_state_oracle oracle)) = 
-  extend_state_oracle oracle"
-  by(simp add: fun_eq_iff spmf.map_comp o_def split_def)
-
-end
-
-lemma interaction_bound_map_gpv':
-  assumes "surj h"
-  shows "interaction_bound consider (map_gpv' f g h gpv) = interaction_bound (consider \<circ> g) gpv"
-proof(induction arbitrary: gpv rule: parallel_fixp_induct_1_1[OF lattice_partial_function_definition lattice_partial_function_definition interaction_bound.mono interaction_bound.mono interaction_bound_def interaction_bound_def, case_names adm bottom step])
-  case (step interaction_bound' interaction_bound'' gpv)
-  have *: "IO out c \<in> set_spmf (the_gpv gpv) \<Longrightarrow>  x \<in> UNIV \<Longrightarrow> interaction_bound'' (c x) \<le> (\<Squnion>x. interaction_bound'' (c (h x)))" for out c x
-    using assms[THEN surjD, of x] by (clarsimp intro!: SUP_upper)
-
-  show ?case 
-    by (auto simp add: * step.IH image_comp split: generat.split
-      intro!: SUP_cong [OF refl] antisym SUP_upper SUP_least)
-qed simp_all
-
-lemma interaction_any_bounded_by_map_gpv':
-  assumes "interaction_any_bounded_by gpv n"
-    and "surj h"
-  shows "interaction_any_bounded_by (map_gpv' f g h gpv) n"
-  using assms by(simp add: interaction_bounded_by.simps interaction_bound_map_gpv' o_def)
-
-lemma results'_gpv_map_gpv':
-  assumes "surj h"
-  shows "results'_gpv (map_gpv' f g h gpv) = f ` results'_gpv gpv" (is "?lhs = ?rhs")
-proof -
-  have *:"IO z c \<in> set_spmf (the_gpv gpv) \<Longrightarrow> x \<in> results'_gpv (c input) \<Longrightarrow>
-     f x \<in> results'_gpv (map_gpv' f g h (c input)) \<Longrightarrow> f x \<in> results'_gpv (map_gpv' f g h gpv)" for x z gpv c input
-    using surjD[OF assms, of input] by(fastforce intro: results'_gpvI elim!: generat.set_cases intro: rev_image_eqI simp add: map_fun_def o_def)
-
-  show ?thesis 
-  proof(intro Set.set_eqI iffI; (elim imageE; hypsubst)?)
-    show "x \<in> ?rhs" if "x \<in> ?lhs" for x using that
-      by(induction gpv'\<equiv>"map_gpv' f g h gpv" arbitrary: gpv)(fastforce elim!: generat.set_cases intro: results'_gpvI)+
-    show "f x \<in> ?lhs" if "x \<in> results'_gpv gpv" for x using that
-      by induction (fastforce intro: results'_gpvI elim!: generat.set_cases intro: rev_image_eqI simp add: map_fun_def o_def
-          , clarsimp simp add: *  elim!: generat.set_cases)
-  qed
-qed
-
-context fixes B :: "'b \<Rightarrow> 'c set" and x :: 'a begin
-
-primcorec mk_lossless_gpv :: "('a, 'b, 'c) gpv \<Rightarrow> ('a, 'b, 'c) gpv" where
-  "the_gpv (mk_lossless_gpv gpv) =
-   map_spmf (\<lambda>generat. case generat of Pure x \<Rightarrow> Pure x 
-      | IO out c \<Rightarrow> IO out (\<lambda>input. if input \<in> B out then mk_lossless_gpv (c input) else Done x))
-    (the_gpv gpv)"
-
-end
-
-lemma WT_gpv_outs_gpvI:
-  assumes "outs_gpv \<I> gpv \<subseteq> outs_\<I> \<I>"
-  shows "\<I> \<turnstile>g gpv \<surd>"
-  using assms by(coinduction arbitrary: gpv)(auto intro: outs_gpv.intros)
-
-lemma WT_gpv_iff_outs_gpv:
-  "\<I> \<turnstile>g gpv \<surd> \<longleftrightarrow> outs_gpv \<I> gpv \<subseteq> outs_\<I> \<I>"
-  by(blast intro: WT_gpv_outs_gpvI dest: WT_gpv_outs_gpv)
-
-lemma WT_gpv_mk_lossless_gpv:
-  assumes "\<I> \<turnstile>g gpv \<surd>"
-    and outs: "outs_\<I> \<I>' = outs_\<I> \<I>"
-  shows "\<I>' \<turnstile>g mk_lossless_gpv (responses_\<I> \<I>) x gpv \<surd>"
-  using assms(1)
-  by(coinduction arbitrary: gpv)(auto 4 3 split: generat.split_asm simp add: outs dest: WT_gpvD)
-
-lemma expectation_gpv_mk_lossless_gpv:
-  fixes \<I> y
-  defines "rhs \<equiv> expectation_gpv 0 \<I> (\<lambda>_. y)"
-  assumes WT: "\<I>' \<turnstile>g gpv \<surd>"
-    and outs: "outs_\<I> \<I> = outs_\<I> \<I>'"
-  shows "expectation_gpv 0 \<I>' (\<lambda>_. y) gpv \<le> rhs (mk_lossless_gpv (responses_\<I> \<I>') x gpv)"
-  using WT
-proof(induction arbitrary: gpv rule: expectation_gpv_fixp_induct)
-  case adm show ?case by simp
-  case bottom show ?case by simp
-  case step [unfolded rhs_def]: (step expectation_gpv')
-  show ?case using step.prems outs unfolding rhs_def
-    apply(subst expectation_gpv.simps)
-    apply(clarsimp intro!: nn_integral_mono_AE INF_mono split!: generat.split if_split)
-    subgoal
-      by(frule (1) WT_gpv_OutD)(auto simp add: in_outs_\<I>_iff_responses_\<I> intro!: bexI step.IH[unfolded rhs_def] dest: WT_gpv_ContD)
-    apply(frule (1) WT_gpv_OutD; clarsimp simp add: in_outs_\<I>_iff_responses_\<I> ex_in_conv[symmetric])
-    subgoal for out c input input'
-      using step.hyps[of "c input'"] expectation_gpv_const_le[of \<I>' "c input'" 0 y]
-      by- (drule (2) WT_gpv_ContD, fastforce intro: rev_bexI simp add: max_def)
-    done
-qed
-
-lemma plossless_gpv_mk_lossless_gpv:
-  assumes "plossless_gpv \<I> gpv"
-    and "\<I> \<turnstile>g gpv \<surd>"
-    and "outs_\<I> \<I> = outs_\<I> \<I>'"
-  shows "plossless_gpv \<I>' (mk_lossless_gpv (responses_\<I> \<I>) x gpv)"
-  using assms expectation_gpv_mk_lossless_gpv[OF assms(2), of \<I>' 1 x]
-  unfolding pgen_lossless_gpv_def
-  by -(rule antisym[OF expectation_gpv_const_le[THEN order_trans]]; simp add: WT_gpv_mk_lossless_gpv)
-
-lemma (in callee_invariant_on) exec_gpv_mk_lossless_gpv:
-  assumes "\<I> \<turnstile>g gpv \<surd>"
-    and "I s"
-  shows "exec_gpv callee (mk_lossless_gpv (responses_\<I> \<I>) x gpv) s = exec_gpv callee gpv s"
-  using assms
-proof(induction arbitrary: gpv s rule: exec_gpv_fixp_induct)
-  case adm show ?case by simp
-  case bottom show ?case by simp
-  case (step exec_gpv')
-  show ?case using step.prems WT_gpv_OutD[OF step.prems(1)]
-    by(clarsimp simp add: bind_map_spmf intro!: bind_spmf_cong[OF refl] split!: generat.split if_split)
-      (force intro!: step.IH dest: WT_callee[THEN WT_calleeD] WT_gpv_OutD callee_invariant WT_gpv_ContD)+
-qed
-
-lemma in_results_gpv_restrict_gpvD:
-  assumes "x \<in> results_gpv \<I> (restrict_gpv \<I>' gpv)"
-  shows "x \<in> results_gpv \<I> gpv"
-  using assms
-  apply(induction gpv'\<equiv>"restrict_gpv \<I>' gpv" arbitrary: gpv)
-   apply(clarsimp split: option.split_asm simp add: in_set_spmf[symmetric])
-  subgoal for \<dots> y by(cases y)(auto intro: results_gpv.intros split: if_split_asm)
-  apply(clarsimp split: option.split_asm simp add: in_set_spmf[symmetric])
-  subgoal for \<dots> y by(cases y)(auto intro: results_gpv.intros split: if_split_asm)
-  done
-
-lemma results_gpv_restrict_gpv:
-  "results_gpv \<I> (restrict_gpv \<I>' gpv) \<subseteq> results_gpv \<I> gpv"
-  by(blast intro: in_results_gpv_restrict_gpvD)
-
-lemma in_results'_gpv_restrict_gpvD:
-  "x \<in> results'_gpv (restrict_gpv \<I>' gpv) \<Longrightarrow> x \<in> results'_gpv gpv"
-  by(rule in_results_gpv_restrict_gpvD[where \<I> = "\<I>_full", unfolded results_gpv_\<I>_full])
-
-lemma expectation_gpv_map_gpv' [simp]:
-  "expectation_gpv fail \<I> f (map_gpv' g h k gpv) =
-   expectation_gpv fail (map_\<I> h k \<I>) (f \<circ> g) gpv"
-proof(induction arbitrary: gpv rule: parallel_fixp_induct_1_1[OF complete_lattice_partial_function_definitions complete_lattice_partial_function_definitions expectation_gpv.mono expectation_gpv.mono expectation_gpv_def expectation_gpv_def, case_names adm bottom step])
-  case adm show ?case by simp
-  case bottom show ?case by simp
-  case (step exp1 exp2)
-  have "pmf (the_gpv (map_gpv' g h k gpv)) None = pmf (the_gpv gpv) None"
-    by(simp add: pmf_map_spmf_None)
-  then show ?case 
-    by simp
-      (auto simp add: nn_integral_measure_spmf step.IH image_comp
-        split: generat.split intro!: nn_integral_cong)
-qed
-
-lemma plossless_gpv_map_gpv' [simp]:
-  "pgen_lossless_gpv b \<I> (map_gpv' f g h gpv) \<longleftrightarrow> pgen_lossless_gpv b (map_\<I> g h \<I>) gpv"
-  unfolding pgen_lossless_gpv_def by(simp add: o_def)
-
-end
\ No newline at end of file
diff --git a/thys/Constructive_Cryptography/Resource.thy b/thys/Constructive_Cryptography/Resource.thy
--- a/thys/Constructive_Cryptography/Resource.thy
+++ b/thys/Constructive_Cryptography/Resource.thy
@@ -1,474 +1,474 @@
 theory Resource imports
-  More_CryptHOL
+  CryptHOL.CryptHOL
 begin
 
 section \<open>Resources\<close>
 
 subsection \<open>Type definition\<close>
 
 codatatype ('a, 'b) resource
   = Resource (run_resource: "'a \<Rightarrow> ('b \<times> ('a, 'b) resource) spmf")
   for map: map_resource'
     rel: rel_resource'
 
 lemma case_resource_conv_run_resource: "case_resource f res = f (run_resource res)"
   by(fact resource.case_eq_if)
 
 subsection \<open>Functor\<close>
 
 context 
   fixes a :: "'a \<Rightarrow> 'a'"
     and b :: "'b \<Rightarrow> 'b'"
 begin
 
 primcorec map_resource :: "('a', 'b) resource \<Rightarrow> ('a, 'b') resource" where
   "run_resource (map_resource res) = map_spmf (map_prod b map_resource) \<circ> (run_resource res) \<circ> a"
 
 lemma map_resource_sel [simp]:
   "run_resource (map_resource res) a' = map_spmf (map_prod b map_resource) (run_resource res (a a'))"
   by simp
 
 declare map_resource.sel [simp del]
 
 lemma map_resource_ctr [simp, code]:
   "map_resource (Resource f) = Resource (map_spmf (map_prod b map_resource) \<circ> f \<circ> a)"
   by(rule resource.expand; simp add: fun_eq_iff)
 
 end
 
 lemma map_resource_id1: "map_resource id f res = map_resource' f res"
   by(coinduction arbitrary: res)(auto simp add: rel_fun_def spmf_rel_map resource.map_sel intro!: rel_spmf_reflI)
 
 lemma map_resource_id [simp]: "map_resource id id res = res"
   by(simp add: map_resource_id1 resource.map_id)
 
 lemma map_resource_compose [simp]:
   "map_resource a b (map_resource a' b' res) = map_resource (a' \<circ> a) (b \<circ> b') res"
   by(coinduction arbitrary: res)(auto 4 3 intro!: rel_funI rel_spmf_reflI simp add: spmf_rel_map)
 
 functor resource: map_resource by(simp_all add: o_def fun_eq_iff)
 
 subsection \<open>Relator\<close>
 
 coinductive rel_resource :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a, 'c) resource \<Rightarrow> ('b, 'd) resource \<Rightarrow> bool"
   for A B where
     rel_resourceI:
     "rel_fun A (rel_spmf (rel_prod B (rel_resource A B))) (run_resource res1) (run_resource res2) 
   \<Longrightarrow> rel_resource A B res1 res2"
 
 lemma rel_resource_coinduct [consumes 1, case_names rel_resource, coinduct pred: rel_resource]:
   assumes "X res1 res2"
     and "\<And>res1 res2. X res1 res2 \<Longrightarrow>
          rel_fun A (rel_spmf (rel_prod B (\<lambda>res1 res2. X res1 res2 \<or> rel_resource A B res1 res2)))
             (run_resource res1) (run_resource res2)"
   shows "rel_resource A B res1 res2"
   using assms(1) by(rule rel_resource.coinduct)(simp add: assms(2))
 
 lemma rel_resource_simps [simp, code]:
   "rel_resource A B (Resource f) (Resource g) \<longleftrightarrow> rel_fun A (rel_spmf (rel_prod B (rel_resource A B))) f g" 
   by(subst rel_resource.simps) simp
 
 lemma rel_resourceD:
   "rel_resource A B res1 res2 \<Longrightarrow> rel_fun A (rel_spmf (rel_prod B (rel_resource A B))) (run_resource res1) (run_resource res2)"
   by(blast elim: rel_resource.cases)
 
 lemma rel_resource_eq1: "rel_resource (=) = rel_resource'"
 proof(intro ext iffI)
   show "rel_resource' B res1 res2" if "rel_resource (=) B res1 res2" for B res1 res2 using that
     by(coinduction arbitrary: res1 res2)(auto elim: rel_resource.cases)
   show "rel_resource (=) B res1 res2" if "rel_resource' B res1 res2" for B res1 res2 using that
     by(coinduction arbitrary: res1 res2)(auto 4 4 elim: resource.rel_cases intro: spmf_rel_mono_strong simp add: rel_fun_def)
 qed
 
 lemma rel_resource_eq: (* [relator_eq] *) "rel_resource (=) (=) = (=)"
   by(simp add: rel_resource_eq1 resource.rel_eq)
 
 lemma rel_resource_mono:
   assumes "A' \<le> A" "B \<le> B'"
   shows "rel_resource A B \<le> rel_resource A' B'"
 proof
   show "rel_resource A' B' res1 res2" if "rel_resource A B res1 res2" for res1 res2 using that
     by(coinduct)(auto dest: rel_resourceD elim!: rel_spmf_mono prod.rel_mono_strong rel_fun_mono intro: assms[THEN predicate2D])
 qed
 
 lemma rel_resource_conversep: "rel_resource A\<inverse>\<inverse> B\<inverse>\<inverse> = (rel_resource A B)\<inverse>\<inverse>"
 proof(intro ext iffI; simp)
   show "rel_resource A B res1 res2" if "rel_resource A\<inverse>\<inverse> B\<inverse>\<inverse> res2 res1"
     for A :: "'a1 \<Rightarrow> 'a2 \<Rightarrow> bool" and B :: "'c1 \<Rightarrow> 'c2 \<Rightarrow> bool" and res1 res2
     using that by(coinduct)
       (drule rel_resourceD, rewrite in \<hole> conversep_iff[symmetric] 
         , subst rel_fun_conversep[symmetric], subst spmf_rel_conversep[symmetric], erule rel_fun_mono
         , auto simp add: prod.rel_conversep[symmetric] rel_fun_def conversep_iff[abs_def]  elim:rel_spmf_mono prod.rel_mono_strong)
 
   from this[of "A\<inverse>\<inverse>" "B\<inverse>\<inverse>"]
   show "rel_resource A\<inverse>\<inverse> B\<inverse>\<inverse> res2 res1" if "rel_resource A B res1 res2" for res1 res2 using that by simp
 qed
 
 lemma rel_resource_map_resource'1:
   "rel_resource A B (map_resource' f res1) res2 = rel_resource A (\<lambda>x. B (f x)) res1 res2"
   (is "?lhs = ?rhs")
 proof
   show ?rhs if ?lhs using that
     by(coinduction arbitrary: res1 res2)
       (drule rel_resourceD, auto simp add: map_resource.sel map_resource_id1[symmetric] rel_fun_comp spmf_rel_map prod.rel_map[abs_def]
         elim!: rel_fun_mono rel_spmf_mono prod.rel_mono[THEN predicate2D, rotated -1])
 
   show ?lhs if ?rhs using that
     by(coinduction arbitrary: res1 res2)
       (drule rel_resourceD, auto simp add: map_resource.sel map_resource_id1[symmetric] rel_fun_comp spmf_rel_map prod.rel_map[abs_def]
         elim!: rel_fun_mono rel_spmf_mono prod.rel_mono[THEN predicate2D, rotated -1])
 qed
 
 lemma rel_resource_map_resource'2:
   "rel_resource A B res1 (map_resource' f res2) = rel_resource A (\<lambda>x y. B x (f y)) res1 res2"
   using rel_resource_map_resource'1[of "conversep A" "conversep B" f res2 res1]
   by(rewrite in "\<hole> = _" conversep_iff[symmetric]
       , rewrite in "_ = \<hole>" conversep_iff[symmetric])
     (simp only: rel_resource_conversep[symmetric]
       , simp only: conversep_iff[abs_def])
 
 lemmas resource_rel_map' = rel_resource_map_resource'1[abs_def] rel_resource_map_resource'2
 
 lemma rel_resource_pos_distr:
   "rel_resource A B OO rel_resource A' B' \<le> rel_resource (A OO A') (B OO B')"
 proof(rule predicate2I)
   show "rel_resource (A OO A') (B OO B') res1 res3"
     if "(rel_resource A B OO rel_resource A' B') res1 res3"
     for res1 res3 using that
     apply(coinduction arbitrary: res1 res3)
     apply(erule relcomppE)
     apply(drule rel_resourceD)+
     apply(rule rel_fun_mono)
       apply(rule pos_fun_distr[THEN predicate2D])
       apply(erule (1) relcomppI)
      apply simp
     apply(rule rel_spmf_mono)
      apply(erule rel_spmf_pos_distr[THEN predicate2D])
     apply(auto simp add: prod.rel_compp[symmetric] elim: prod.rel_mono[THEN predicate2D, rotated -1])
     done
 qed
 
 lemma left_unique_rel_resource:
   "\<lbrakk> left_total A; left_unique B \<rbrakk> \<Longrightarrow> left_unique (rel_resource A B)"
   unfolding left_unique_alt_def left_total_alt_def rel_resource_conversep[symmetric]
   apply(subst rel_resource_eq[symmetric])
   apply(rule order_trans[OF rel_resource_pos_distr])
   apply(erule (1) rel_resource_mono)
   done
 
 lemma right_unique_rel_resource:
   "\<lbrakk> right_total A; right_unique B \<rbrakk> \<Longrightarrow> right_unique (rel_resource A B)"
   unfolding right_unique_alt_def right_total_alt_def rel_resource_conversep[symmetric]
   apply(subst rel_resource_eq[symmetric])
   apply(rule order_trans[OF rel_resource_pos_distr])
   apply(erule (1) rel_resource_mono)
   done
 
 lemma bi_unique_rel_resource [transfer_rule]:
   "\<lbrakk> bi_total A; bi_unique B \<rbrakk> \<Longrightarrow> bi_unique (rel_resource A B)"
   unfolding bi_unique_alt_def bi_total_alt_def by(blast intro: left_unique_rel_resource right_unique_rel_resource)
 
 
 definition rel_witness_resource :: "('a \<Rightarrow> 'e \<Rightarrow> bool) \<Rightarrow> ('e \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a, 'b) resource \<times> ('c, 'd) resource \<Rightarrow> ('e, 'b \<times> 'd) resource" where
   "rel_witness_resource A A' B = corec_resource (\<lambda>(res1, res2).
    map_spmf (map_prod id Inr \<circ> rel_witness_prod) \<circ> 
    rel_witness_spmf (rel_prod B (rel_resource (A OO A') B)) \<circ> 
    rel_witness_fun A A' (run_resource res1, run_resource res2))"
 
 lemma rel_witness_resource_sel [simp]:
   "run_resource (rel_witness_resource A A' B (res1, res2)) =
    map_spmf (map_prod id (rel_witness_resource A A' B) \<circ> rel_witness_prod) \<circ> 
    rel_witness_spmf (rel_prod B (rel_resource (A OO A') B)) \<circ> 
    rel_witness_fun A A' (run_resource res1, run_resource res2)"
   by(auto simp add: rel_witness_resource_def o_def fun_eq_iff spmf.map_comp intro!: map_spmf_cong)
 
 lemma assumes "rel_resource (A OO A') B res res'"
   and A: "left_unique A" "right_total A"
   and A': "right_unique A'" "left_total A'"
 shows rel_witness_resource1: "rel_resource A (\<lambda>b (b', c). b = b' \<and> B b' c) res (rel_witness_resource A A' B (res, res'))" (is "?thesis1")
   and rel_witness_resource2: "rel_resource A' (\<lambda>(b, c') c. c = c' \<and> B b c') (rel_witness_resource A A' B (res, res')) res'" (is "?thesis2")
 proof -
   show ?thesis1 using assms(1)
   proof(coinduction arbitrary: res res')
     case rel_resource
     from this[THEN rel_resourceD] show ?case
       by(simp add: rel_fun_comp)
         (erule rel_fun_mono[OF rel_witness_fun1[OF _ A A']]
           , auto simp add: spmf_rel_map elim!: rel_spmf_mono[OF rel_witness_spmf1])
   qed
   show ?thesis2 using assms(1)
   proof(coinduction arbitrary: res res')
     case rel_resource
     from this[THEN rel_resourceD] show ?case
       by(simp add: rel_fun_comp)
         (erule rel_fun_mono[OF rel_witness_fun2[OF _ A A']]
           , auto simp add: spmf_rel_map elim!: rel_spmf_mono[OF rel_witness_spmf2])
   qed
 qed
 
 lemma rel_resource_neg_distr:
   assumes A: "left_unique A" "right_total A"
     and A': "right_unique A'" "left_total A'"
   shows "rel_resource (A OO A') (B OO B') \<le> rel_resource A B OO rel_resource A' B'"
 proof(rule predicate2I relcomppI)+
   fix res res''
   assume *: "rel_resource (A OO A') (B OO B') res res''"
   let ?res' = "map_resource' (relcompp_witness B B') (rel_witness_resource A A' (B OO B') (res, res''))"
   show "rel_resource A B res ?res'" using rel_witness_resource1[OF * A A'] unfolding resource_rel_map'
     by(rule rel_resource_mono[THEN predicate2D, rotated -1]; clarify del: relcomppE elim!: relcompp_witness)
   show "rel_resource A' B' ?res' res''" using rel_witness_resource2[OF * A A'] unfolding resource_rel_map'
     by(rule rel_resource_mono[THEN predicate2D, rotated -1]; clarify del: relcomppE elim!: relcompp_witness)
 qed
 
 lemma left_total_rel_resource:
   "\<lbrakk> left_unique A; right_total A; left_total B \<rbrakk> \<Longrightarrow> left_total (rel_resource A B)"
   unfolding left_unique_alt_def left_total_alt_def rel_resource_conversep[symmetric]
   apply(subst rel_resource_eq[symmetric])
   apply(rule order_trans[rotated])
    apply(rule rel_resource_neg_distr; simp add: left_unique_alt_def)
   apply(rule rel_resource_mono; assumption)
   done
 
 lemma right_total_rel_resource:
   "\<lbrakk> right_unique A; left_total A; right_total B \<rbrakk> \<Longrightarrow> right_total (rel_resource A B)"
   unfolding right_unique_alt_def right_total_alt_def rel_resource_conversep[symmetric]
   apply(subst rel_resource_eq[symmetric])
   apply(rule order_trans[rotated])
    apply(rule rel_resource_neg_distr; simp add: right_unique_alt_def)
   apply(rule rel_resource_mono; assumption)
   done
 
 lemma bi_total_rel_resource [transfer_rule]:
   "\<lbrakk> bi_total A; bi_unique A; bi_total B \<rbrakk> \<Longrightarrow> bi_total (rel_resource A B)"
   unfolding bi_total_alt_def bi_unique_alt_def
   by(blast intro: left_total_rel_resource right_total_rel_resource)
 
 context includes lifting_syntax begin
 
 lemma Resource_parametric [transfer_rule]:
   "((A ===> rel_spmf (rel_prod B (rel_resource A B))) ===> rel_resource A B) Resource Resource"
   by(rule rel_funI)(simp)
 
 lemma run_resource_parametric [transfer_rule]:
   "(rel_resource A B ===> A ===> rel_spmf (rel_prod B (rel_resource A B))) run_resource run_resource"
   by(rule rel_funI)(auto dest: rel_resourceD)
 
 lemma corec_resource_parametric [transfer_rule]:
   "((S ===> A ===> rel_spmf (rel_prod B (rel_sum (rel_resource A B) S))) ===> S ===> rel_resource A B)
    corec_resource corec_resource"
 proof((rule rel_funI)+, goal_cases)
   case (1 f g s1 s2)
   then show ?case using 1(2)
     by (coinduction arbitrary: s1 s2)
       (drule 1(1)[THEN rel_funD], auto 4 4 simp add: rel_fun_comp spmf_rel_map prod.rel_map[abs_def] split: sum.split elim!: rel_fun_mono rel_spmf_mono elim: prod.rel_mono[THEN predicate2D, rotated -1])
 qed
 
 lemma map_resource_parametric [transfer_rule]:
   "((A' ===> A) ===> (B ===> B') ===> rel_resource A B ===> rel_resource A' B') map_resource map_resource"
   unfolding map_resource_def by(transfer_prover)
 
 lemma map_resource'_parametric [transfer_rule]:
   "((B ===> B') ===> rel_resource (=) B ===> rel_resource (=) B') map_resource' map_resource'"
   unfolding map_resource_id1[symmetric] by transfer_prover
 
 lemma case_resource_parametric [transfer_rule]:
   "(((A ===> rel_spmf (rel_prod B (rel_resource A B))) ===> C) ===> rel_resource A B ===> C)
   case_resource case_resource"
   unfolding case_resource_conv_run_resource by transfer_prover
 
 end
 
 lemma rel_resource_Grp:
   "rel_resource (conversep (BNF_Def.Grp UNIV f)) (BNF_Def.Grp UNIV g) = BNF_Def.Grp UNIV (map_resource f g)"
 proof((rule ext iffI)+, goal_cases)
   case (1 res res')
   have *: "rel_resource (\<lambda>a b. b = f a)\<inverse>\<inverse> (\<lambda>a b. b = g a) res res' \<Longrightarrow> res' = map_resource f g res"
     by(rule sym, subst (3) map_resource_id[symmetric], subst rel_resource_eq[symmetric])
       (erule map_resource_parametric[THEN rel_funD, THEN rel_funD, THEN rel_funD, rotated -1]
         , auto simp add: rel_fun_def)
 
   from 1 show ?case unfolding Grp_def using * by (clarsimp simp add: * simp del: conversep_iff)
 next
   case (2 _ _)
   then show ?case 
     by(clarsimp simp add: Grp_iff, subst map_resource_id[symmetric])
       (rule map_resource_parametric[THEN rel_funD, THEN rel_funD, THEN rel_funD, rotated -1]
         , subst rel_resource_eq, auto simp add: Grp_iff rel_fun_def)
 qed
 
 subsection \<open>Losslessness\<close>
 
 coinductive lossless_resource :: "('a, 'b) \<I> \<Rightarrow> ('a, 'b) resource \<Rightarrow> bool"
   for \<I> where
     lossless_resourceI: "lossless_resource \<I> res" if
     "\<And>a. a \<in> outs_\<I> \<I> \<Longrightarrow> lossless_spmf (run_resource res a)"
     "\<And>a b res'. \<lbrakk> a \<in> outs_\<I> \<I>; (b, res') \<in> set_spmf (run_resource res a) \<rbrakk> \<Longrightarrow> lossless_resource \<I> res'"
 
 lemma lossless_resource_coinduct [consumes 1, case_names lossless_resource, case_conclusion lossless_resource lossless step, coinduct pred: lossless_resource]:
   assumes "X res"
     and "\<And>res a. \<lbrakk> X res; a \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> lossless_spmf (run_resource res a) \<and>
           (\<forall>(b, res') \<in> set_spmf (run_resource res a). X res' \<or> lossless_resource \<I> res')"
   shows "lossless_resource \<I> res"
   using assms(1) by(rule lossless_resource.coinduct)(auto dest: assms(2))
 
 lemma lossless_resourceD:
   "\<lbrakk> lossless_resource \<I> res; a \<in> outs_\<I> \<I> \<rbrakk>
   \<Longrightarrow> lossless_spmf (run_resource res a) \<and> (\<forall>(x, res')\<in>set_spmf (run_resource res a). lossless_resource \<I> res')"
   by(auto elim: lossless_resource.cases)
 
 lemma lossless_resource_mono:
   assumes "lossless_resource \<I>' res"
     and le: "outs_\<I> \<I> \<subseteq> outs_\<I> \<I>'"
   shows "lossless_resource \<I> res"
   using assms(1)
   by(coinduction arbitrary: res)(auto dest: lossless_resourceD intro: subsetD[OF le])
 
 lemma lossless_resource_mono': 
   "\<lbrakk> lossless_resource \<I>' res; \<I> \<le> \<I>' \<rbrakk> \<Longrightarrow> lossless_resource \<I> res"
   by(erule lossless_resource_mono)(simp add: le_\<I>_def)
 
 
 subsection \<open>Operations\<close>
 
 context fixes "oracle" :: "'s \<Rightarrow> 'a \<Rightarrow> ('b \<times> 's) spmf" begin
 
 primcorec resource_of_oracle :: "'s \<Rightarrow> ('a, 'b) resource" where
   "run_resource (resource_of_oracle s) = (\<lambda>a. map_spmf (map_prod id resource_of_oracle) (oracle s a))"
 
 end
 
 lemma resource_of_oracle_parametric [transfer_rule]: includes lifting_syntax shows
   "((S ===> A ===> rel_spmf (rel_prod B S)) ===> S ===> rel_resource A B) resource_of_oracle resource_of_oracle"
   unfolding resource_of_oracle_def by transfer_prover
 
 lemma map_resource_resource_of_oracle:
   "map_resource f g (resource_of_oracle oracle s) = resource_of_oracle (map_fun id (map_fun f (map_spmf (map_prod g id))) oracle) s"
   for s :: 's
   using resource_of_oracle_parametric[of "BNF_Def.Grp UNIV (id :: 's \<Rightarrow> _)" "conversep (BNF_Def.Grp UNIV f)" "BNF_Def.Grp UNIV g"]
   unfolding prod.rel_Grp option.rel_Grp pmf.rel_Grp rel_fun_Grp rel_resource_Grp
   by simp
     (subst (asm) (1 2) eq_alt[symmetric]
       , subst (asm) (1 2) conversep_eq[symmetric]
       , subst (asm) (1 2) eq_alt
       , unfold rel_fun_Grp, simp add: rel_fun_Grp rel_fun_def Grp_iff)
 
 lemma (in callee_invariant_on) lossless_resource_of_oracle:
   assumes *: "\<And>s x. \<lbrakk> x \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> lossless_spmf (callee s x)"
     and "I s" 
   shows "lossless_resource \<I> (resource_of_oracle callee s)"
   using \<open>I s\<close> by(coinduction arbitrary: s)(auto intro: * dest: callee_invariant)
 
 context includes lifting_syntax begin
 
 lemma resource_of_oracle_rprodl: includes lifting_syntax shows
   "resource_of_oracle ((rprodl ---> id ---> map_spmf (map_prod id lprodr)) oracle) ((s1, s2), s3) = 
     resource_of_oracle oracle (s1, s2, s3)"
   by(rule resource_of_oracle_parametric[of "BNF_Def.Grp UNIV rprodl" "(=)" "(=)", THEN rel_funD, THEN rel_funD, unfolded rel_resource_eq])
     (auto simp add: Grp_iff rel_fun_def spmf_rel_map intro!: rel_spmf_reflI)
 
 lemma resource_of_oracle_extend_state_oracle [simp]:
   "resource_of_oracle (extend_state_oracle oracle) (s', s) = resource_of_oracle oracle s"
   by(rule resource_of_oracle_parametric[of "conversep (BNF_Def.Grp UNIV (\<lambda>s. (s', s)))" "(=)" "(=)", THEN rel_funD, THEN rel_funD, unfolded rel_resource_eq])
     (auto simp add: Grp_iff rel_fun_def spmf_rel_map intro!: rel_spmf_reflI)
 
 end
 
 lemma exec_gpv_resource_of_oracle:
   "exec_gpv run_resource gpv (resource_of_oracle oracle s) = map_spmf (map_prod id (resource_of_oracle oracle)) (exec_gpv oracle gpv s)"
   by(subst spmf.map_id[symmetric], fold pmf.rel_eq)
     (rule pmf.map_transfer[THEN rel_funD, THEN rel_funD, rotated]
       , rule exec_gpv_parametric[where S="\<lambda>res s. res = resource_of_oracle oracle s" and CALL="(=)" and A="(=)", THEN rel_funD, THEN rel_funD, THEN rel_funD]
       , auto simp add: gpv.rel_eq rel_fun_def spmf_rel_map elim: option.rel_cases intro!: rel_spmf_reflI)
 
 primcorec parallel_resource :: "('a, 'b) resource \<Rightarrow> ('c, 'd) resource \<Rightarrow> ('a + 'c, 'b + 'd) resource" where
   "run_resource (parallel_resource res1 res2) = 
    (\<lambda>ac. case ac of Inl a \<Rightarrow> map_spmf (map_prod Inl (\<lambda>res1'. parallel_resource res1' res2)) (run_resource res1 a)
          | Inr c \<Rightarrow> map_spmf (map_prod Inr (\<lambda>res2'. parallel_resource res1 res2')) (run_resource res2 c))"
 
 lemma parallel_resource_parametric [transfer_rule]: includes lifting_syntax shows
   "(rel_resource A B ===> rel_resource C D ===> rel_resource (rel_sum A C) (rel_sum B D))
    parallel_resource parallel_resource"
   unfolding parallel_resource_def by transfer_prover
 
 text \<open>
   We cannot define the analogue of @{term plus_oracle} because we no longer have access to the state,
   so state sharing is not possible!  So we can only compose resources, but we cannot build one
   resource with several interfaces this way!
 \<close>
 
 lemma resource_of_parallel_oracle:
   "resource_of_oracle (parallel_oracle oracle1 oracle2) (s1, s2) =
    parallel_resource (resource_of_oracle oracle1 s1) (resource_of_oracle oracle2 s2)"
   by(coinduction arbitrary: s1 s2)
     (auto 4 3 simp add: rel_fun_def spmf_rel_map split: sum.split intro!: rel_spmf_reflI)
 
 lemma parallel_resource_assoc: \<comment> \<open>There's still an ugly map operation in there to rebalance the interface trees, but well...\<close>
   "parallel_resource (parallel_resource res1 res2) res3 = 
    map_resource rsuml lsumr (parallel_resource res1 (parallel_resource res2 res3))"
   by(coinduction arbitrary: res1 res2 res3)
     (auto 4 5 intro!: rel_funI rel_spmf_reflI simp add: spmf_rel_map split: sum.split)
 
 
 lemma lossless_parallel_resource:
   assumes "lossless_resource \<I> res1" "lossless_resource \<I>' res2"
   shows "lossless_resource (\<I> \<oplus>\<^sub>\<I> \<I>') (parallel_resource res1 res2)"
   using assms
   by(coinduction arbitrary: res1 res2)(clarsimp; erule PlusE; simp; frule (1) lossless_resourceD; auto 4 3)
 
 subsection \<open>Well-typing\<close>
 
 coinductive WT_resource :: "('a, 'b) \<I> \<Rightarrow> ('a, 'b) resource \<Rightarrow> bool" ("_ /\<turnstile>res _ \<surd>" [100, 0] 99)
   for \<I> where
     WT_resourceI: "\<I> \<turnstile>res res \<surd>"
   if "\<And>q r res'. \<lbrakk> q \<in> outs_\<I> \<I>; (r, res') \<in> set_spmf (run_resource res q) \<rbrakk> \<Longrightarrow> r \<in> responses_\<I> \<I> q \<and> \<I> \<turnstile>res res' \<surd>" 
 
 lemma WT_resource_coinduct [consumes 1, case_names WT_resource, case_conclusion WT_resource response WT_resource, coinduct pred: WT_resource]:
   assumes "X res"
     and "\<And>res q r res'. \<lbrakk> X res; q \<in> outs_\<I> \<I>; (r, res') \<in> set_spmf (run_resource res q) \<rbrakk>
        \<Longrightarrow> r \<in> responses_\<I> \<I> q \<and> (X res' \<or> \<I> \<turnstile>res res' \<surd>)"
   shows "\<I> \<turnstile>res res \<surd>"
   using assms(1) by(rule WT_resource.coinduct)(blast dest: assms(2))
 
 lemma WT_resourceD:
   assumes "\<I> \<turnstile>res res \<surd>" "q \<in> outs_\<I> \<I>" "(r, res') \<in> set_spmf (run_resource res q)"
   shows "r \<in> responses_\<I> \<I> q \<and> \<I> \<turnstile>res res' \<surd>"
   using assms by(auto elim: WT_resource.cases)
 
 lemma WT_resource_of_oracle [simp]:
   assumes "\<And>s. \<I> \<turnstile>c oracle s \<surd>"
   shows "\<I> \<turnstile>res resource_of_oracle oracle s \<surd>"
   by(coinduction arbitrary: s)(auto dest: WT_calleeD[OF assms])
 
 lemma WT_resource_bot [simp]: "bot \<turnstile>res res \<surd>"
   by(rule WT_resource.intros)auto
 
 lemma WT_resource_full: "\<I>_full \<turnstile>res res \<surd>"
   by(coinduction arbitrary: res)(auto)
 
 lemma (in callee_invariant_on) WT_resource_of_oracle:
   "I s \<Longrightarrow> \<I> \<turnstile>res resource_of_oracle callee s \<surd>"
   by(coinduction arbitrary: s)(auto dest: callee_invariant')
 
 named_theorems WT_intro "Interface typing introduction rules"
 
 lemmas [WT_intro] = WT_gpv_map_gpv' WT_gpv_map_gpv
 
 lemma WT_parallel_resource [WT_intro]:
   assumes "\<I>1 \<turnstile>res res1 \<surd>"
     and "\<I>2 \<turnstile>res res2 \<surd>"
   shows "\<I>1 \<oplus>\<^sub>\<I> \<I>2 \<turnstile>res parallel_resource res1 res2 \<surd>"
   using assms
   by(coinduction arbitrary: res1 res2)(auto 4 4 intro!: imageI dest: WT_resourceD)
 
 lemma callee_invariant_run_resource: "callee_invariant_on run_resource (\<lambda>res.  \<I> \<turnstile>res res \<surd>) \<I>"
   by(unfold_locales)(auto dest: WT_resourceD intro: WT_calleeI)
 
 lemma callee_invariant_run_lossless_resource:
   "callee_invariant_on run_resource (\<lambda>res. lossless_resource \<I> res \<and> \<I> \<turnstile>res res \<surd>) \<I>"
   by(unfold_locales)(auto dest: WT_resourceD lossless_resourceD intro: WT_calleeI)
 
 interpretation run_lossless_resource:
   callee_invariant_on run_resource "\<lambda>res. lossless_resource \<I> res \<and> \<I> \<turnstile>res res \<surd>" \<I> for \<I>
   by(rule callee_invariant_run_lossless_resource)
 
 end
diff --git a/thys/CryptHOL/Computational_Model.thy b/thys/CryptHOL/Computational_Model.thy
--- a/thys/CryptHOL/Computational_Model.thy
+++ b/thys/CryptHOL/Computational_Model.thy
@@ -1,440 +1,818 @@
 (* Title: Computational_Model.thy
   Author: Andreas Lochbihler, ETH Zurich *)
 
 section \<open>Oracle combinators\<close>
 
 theory Computational_Model imports 
   Generative_Probabilistic_Value
 begin
 
 type_synonym security = nat
 type_synonym advantage = "security \<Rightarrow> real"
 
 type_synonym ('\<sigma>, 'call, 'ret) oracle' = "'\<sigma> \<Rightarrow> 'call \<Rightarrow> ('ret \<times> '\<sigma>) spmf"
 type_synonym ('\<sigma>, 'call, 'ret) "oracle" = "security \<Rightarrow> ('\<sigma>, 'call, 'ret) oracle' \<times> '\<sigma>"
 
 print_translation \<comment> \<open>pretty printing for @{typ "('\<sigma>, 'call, 'ret) oracle"}\<close> \<open>
   let
     fun tr' [Const (@{type_syntax nat}, _), 
       Const (@{type_syntax prod}, _) $ 
         (Const (@{type_syntax fun}, _) $ s1 $ 
           (Const (@{type_syntax fun}, _) $ call $
             (Const (@{type_syntax pmf}, _) $
               (Const (@{type_syntax option}, _) $
                 (Const (@{type_syntax prod}, _) $ ret $ s2))))) $
         s3] =
       if s1 = s2 andalso s1 = s3 then Syntax.const @{type_syntax oracle} $ s1 $ call $ ret
       else raise Match;
   in [(@{type_syntax "fun"}, K tr')]
   end
 \<close>
 typ "('\<sigma>, 'call, 'ret) oracle"
 
 subsection \<open>Shared state\<close>
 
 context includes \<I>.lifting lifting_syntax begin
 
 lift_definition plus_\<I> :: "('out, 'ret) \<I> \<Rightarrow> ('out', 'ret') \<I> \<Rightarrow> ('out + 'out', 'ret + 'ret') \<I>" (infix "\<oplus>\<^sub>\<I>" 500)
 is "\<lambda>resp1 resp2. \<lambda>out. case out of Inl out' \<Rightarrow> Inl ` resp1 out' | Inr out' \<Rightarrow> Inr ` resp2 out'" .
 
 lemma plus_\<I>_sel [simp]:
   shows outs_plus_\<I>: "outs_\<I> (plus_\<I> \<I>l \<I>r) = outs_\<I> \<I>l <+> outs_\<I> \<I>r"
   and responses_plus_\<I>_Inl: "responses_\<I> (plus_\<I> \<I>l \<I>r) (Inl x) = Inl ` responses_\<I> \<I>l x"
   and responses_plus_\<I>_Inr: "responses_\<I> (plus_\<I> \<I>l \<I>r) (Inr y) = Inr ` responses_\<I> \<I>r y"
 by(transfer; auto split: sum.split_asm; fail)+
 
 lemma vimage_Inl_Plus [simp]: "Inl -` (A <+> B) = A" 
   and vimage_Inr_Plus [simp]: "Inr -` (A <+> B) = B"
 by auto
 
 lemma vimage_Inl_image_Inr: "Inl -` Inr ` A = {}"
   and vimage_Inr_image_Inl: "Inr -` Inl ` A = {}"
 by auto
 
 lemma plus_\<I>_parametric [transfer_rule]:
   "(rel_\<I> C R ===> rel_\<I> C' R' ===> rel_\<I> (rel_sum C C') (rel_sum R R')) plus_\<I> plus_\<I>"
 apply(rule rel_funI rel_\<I>I)+
 subgoal premises [transfer_rule] by(simp; rule conjI; transfer_prover)
 apply(erule rel_sum.cases; clarsimp simp add: inj_vimage_image_eq vimage_Inl_image_Inr empty_transfer vimage_Inr_image_Inl)
 subgoal premises [transfer_rule] by transfer_prover
 subgoal premises [transfer_rule] by transfer_prover
 done
 
 lifting_update \<I>.lifting
 lifting_forget \<I>.lifting
 
 lemma \<I>_trivial_plus_\<I> [simp]: "\<I>_trivial (\<I>\<^sub>1 \<oplus>\<^sub>\<I> \<I>\<^sub>2) \<longleftrightarrow> \<I>_trivial \<I>\<^sub>1 \<and> \<I>_trivial \<I>\<^sub>2"
 by(auto simp add: \<I>_trivial_def)
 
 end
 
+lemma map_\<I>_plus_\<I> [simp]: 
+  "map_\<I> (map_sum f1 f2) (map_sum g1 g2) (\<I>1 \<oplus>\<^sub>\<I> \<I>2) = map_\<I> f1 g1 \<I>1 \<oplus>\<^sub>\<I> map_\<I> f2 g2 \<I>2"
+proof(rule \<I>_eqI[OF Set.set_eqI], goal_cases)
+  case (1 x)
+  then show ?case by(cases x) auto
+qed (auto simp add: image_image)
+
+lemma le_plus_\<I>_iff [simp]:
+  "\<I>1 \<oplus>\<^sub>\<I> \<I>2 \<le> \<I>1' \<oplus>\<^sub>\<I> \<I>2' \<longleftrightarrow> \<I>1 \<le> \<I>1' \<and> \<I>2 \<le> \<I>2'"
+  by(auto 4 4 simp add: le_\<I>_def dest: bspec[where x="Inl _"] bspec[where x="Inr _"])
+
+lemma \<I>_full_le_plus_\<I>: "\<I>_full \<le> plus_\<I> \<I>1 \<I>2" if "\<I>_full \<le> \<I>1" "\<I>_full \<le> \<I>2"
+  using that by(auto simp add: le_\<I>_def top_unique)
+
+lemma plus_\<I>_mono: "plus_\<I> \<I>1 \<I>2 \<le> plus_\<I> \<I>1' \<I>2'" if "\<I>1 \<le> \<I>1'" "\<I>2 \<le> \<I>2'" 
+  using that by(fastforce simp add: le_\<I>_def)
+
 context
   fixes left :: "('s, 'a, 'b) oracle'"
   and right :: "('s,'c, 'd) oracle'"
   and s :: "'s"
 begin
 
 primrec plus_oracle :: "'a + 'c \<Rightarrow> (('b + 'd) \<times> 's) spmf"
 where
   "plus_oracle (Inl a) = map_spmf (apfst Inl) (left s a)"
 | "plus_oracle (Inr b) = map_spmf (apfst Inr) (right s b)"
 
 lemma lossless_plus_oracleI [intro, simp]:
   "\<lbrakk> \<And>a. x = Inl a \<Longrightarrow> lossless_spmf (left s a); 
      \<And>b. x = Inr b \<Longrightarrow> lossless_spmf (right s b) \<rbrakk>
   \<Longrightarrow> lossless_spmf (plus_oracle x)"
 by(cases x) simp_all
 
 lemma plus_oracle_split:
   "P (plus_oracle lr) \<longleftrightarrow>
   (\<forall>x. lr = Inl x \<longrightarrow> P (map_spmf (apfst Inl) (left s x))) \<and>
   (\<forall>y. lr = Inr y \<longrightarrow> P (map_spmf (apfst Inr) (right s y)))"
 by(cases lr) auto
 
 lemma plus_oracle_split_asm:
   "P (plus_oracle lr) \<longleftrightarrow>
   \<not> ((\<exists>x. lr = Inl x \<and> \<not> P (map_spmf (apfst Inl) (left s x))) \<or>
      (\<exists>y. lr = Inr y \<and> \<not> P (map_spmf (apfst Inr) (right s y))))"
 by(cases lr) auto
 
 end
 
 notation plus_oracle (infix "\<oplus>\<^sub>O" 500)
 
 context
   fixes left :: "('s, 'a, 'b) oracle'"
   and right :: "('s,'c, 'd) oracle'"
 begin
 
 lemma WT_plus_oracleI [intro!]:
   "\<lbrakk> \<I>l \<turnstile>c left s \<surd>; \<I>r \<turnstile>c right s \<surd> \<rbrakk> \<Longrightarrow> \<I>l \<oplus>\<^sub>\<I> \<I>r \<turnstile>c (left \<oplus>\<^sub>O right) s \<surd>"
 by(rule WT_calleeI)(auto elim!: WT_calleeD simp add: inj_image_mem_iff)
 
 lemma WT_plus_oracleD1:
   assumes "\<I>l \<oplus>\<^sub>\<I> \<I>r \<turnstile>c (left \<oplus>\<^sub>O right) s \<surd> " (is "?\<I> \<turnstile>c ?callee s \<surd>")
   shows "\<I>l \<turnstile>c left s \<surd>"
 proof(rule WT_calleeI)
   fix call ret s'
   assume "call \<in> outs_\<I> \<I>l" "(ret, s') \<in> set_spmf (left s call)"
   hence "(Inl ret, s') \<in> set_spmf (?callee s (Inl call))" "Inl call \<in> outs_\<I> (\<I>l \<oplus>\<^sub>\<I> \<I>r)"
     by(auto intro: rev_image_eqI)
   hence "Inl ret \<in> responses_\<I> ?\<I> (Inl call)" by(rule WT_calleeD[OF assms])
   then show "ret \<in> responses_\<I> \<I>l call" by(simp add: inj_image_mem_iff)
 qed
 
 lemma WT_plus_oracleD2:
   assumes "\<I>l \<oplus>\<^sub>\<I> \<I>r \<turnstile>c (left \<oplus>\<^sub>O right) s \<surd> " (is "?\<I> \<turnstile>c ?callee s \<surd>")
   shows "\<I>r \<turnstile>c right s \<surd>"
 proof(rule WT_calleeI)
   fix call ret s'
   assume "call \<in> outs_\<I> \<I>r" "(ret, s') \<in> set_spmf (right s call)"
   hence "(Inr ret, s') \<in> set_spmf (?callee s (Inr call))" "Inr call \<in> outs_\<I> (\<I>l \<oplus>\<^sub>\<I> \<I>r)"
     by(auto intro: rev_image_eqI)
   hence "Inr ret \<in> responses_\<I> ?\<I> (Inr call)" by(rule WT_calleeD[OF assms])
   then show "ret \<in> responses_\<I> \<I>r call" by(simp add: inj_image_mem_iff)
 qed
 
 lemma WT_plus_oracle_iff [simp]: "\<I>l \<oplus>\<^sub>\<I> \<I>r \<turnstile>c (left \<oplus>\<^sub>O right) s \<surd> \<longleftrightarrow> \<I>l \<turnstile>c left s \<surd> \<and> \<I>r \<turnstile>c right s \<surd>"
 by(blast dest: WT_plus_oracleD1 WT_plus_oracleD2)
 
 lemma callee_invariant_on_plus_oracle [simp]:
   "callee_invariant_on (left \<oplus>\<^sub>O right) I (\<I>l \<oplus>\<^sub>\<I> \<I>r) \<longleftrightarrow>
    callee_invariant_on left I \<I>l \<and> callee_invariant_on right I \<I>r"
    (is "?lhs \<longleftrightarrow> ?rhs")
 proof(intro iffI conjI)
   assume ?lhs
   then interpret plus: callee_invariant_on "left \<oplus>\<^sub>O right" I "\<I>l \<oplus>\<^sub>\<I> \<I>r" .
   show "callee_invariant_on left I \<I>l"
   proof
     fix s x y s'
     assume "(y, s') \<in> set_spmf (left s x)" and "I s" and "x \<in> outs_\<I> \<I>l"
     then have "(Inl y, s') \<in> set_spmf ((left \<oplus>\<^sub>O right) s (Inl x))"
       by(auto intro: rev_image_eqI)
     then show "I s'" using \<open>I s\<close> by(rule plus.callee_invariant)(simp add: \<open>x \<in> outs_\<I> \<I>l\<close>)
   next
     show "\<I>l \<turnstile>c left s \<surd>" if "I s" for s using plus.WT_callee[OF that] by simp
   qed
   show "callee_invariant_on right I \<I>r"
   proof
     fix s x y s'
     assume "(y, s') \<in> set_spmf (right s x)" and "I s" and "x \<in> outs_\<I> \<I>r"
     then have "(Inr y, s') \<in> set_spmf ((left \<oplus>\<^sub>O right) s (Inr x))"
       by(auto intro: rev_image_eqI)
     then show "I s'" using \<open>I s\<close> by(rule plus.callee_invariant)(simp add: \<open>x \<in> outs_\<I> \<I>r\<close>)
   next
     show "\<I>r \<turnstile>c right s \<surd>" if "I s" for s using plus.WT_callee[OF that] by simp
   qed
 next
   assume ?rhs
   interpret left: callee_invariant_on left I \<I>l using \<open>?rhs\<close> by simp
   interpret right: callee_invariant_on right I \<I>r using \<open>?rhs\<close> by simp
   show ?lhs
   proof
     fix s x y s'
     assume "(y, s') \<in> set_spmf ((left \<oplus>\<^sub>O right) s x)" and "I s" and "x \<in> outs_\<I> (\<I>l \<oplus>\<^sub>\<I> \<I>r)"
     then have "(projl y, s') \<in> set_spmf (left s (projl x)) \<and> projl x \<in> outs_\<I> \<I>l \<or>
       (projr y, s') \<in> set_spmf (right s (projr x)) \<and> projr x \<in> outs_\<I> \<I>r"
       by (cases x)  auto
     then show "I s'" using \<open>I s\<close> 
       by (auto dest: left.callee_invariant right.callee_invariant)
   next
     show "\<I>l \<oplus>\<^sub>\<I> \<I>r \<turnstile>c (left \<oplus>\<^sub>O right) s \<surd>" if "I s" for s 
       using left.WT_callee[OF that] right.WT_callee[OF that] by simp
   qed
 qed
 
 lemma callee_invariant_plus_oracle [simp]:
   "callee_invariant (left \<oplus>\<^sub>O right) I \<longleftrightarrow>
    callee_invariant left I \<and> callee_invariant right I"
   (is "?lhs \<longleftrightarrow>  ?rhs")
 proof -
   have "?lhs \<longleftrightarrow> callee_invariant_on (left \<oplus>\<^sub>O right) I (\<I>_full \<oplus>\<^sub>\<I> \<I>_full)"
     by(rule callee_invariant_on_cong)(auto split: plus_oracle_split_asm)
   also have "\<dots> \<longleftrightarrow> ?rhs" by(rule callee_invariant_on_plus_oracle)
   finally show ?thesis .
 qed
 
 lemma plus_oracle_parametric [transfer_rule]:
   includes lifting_syntax shows
   "((S ===> A ===> rel_spmf (rel_prod B S))
    ===> (S ===> C ===> rel_spmf (rel_prod D S))
    ===> S ===> rel_sum A C ===> rel_spmf (rel_prod (rel_sum B D) S))
    plus_oracle plus_oracle"
 unfolding plus_oracle_def[abs_def] by transfer_prover
 
 lemma rel_spmf_plus_oracle:
   "\<lbrakk> \<And>q1' q2'. \<lbrakk> q1 = Inl q1'; q2 = Inl q2' \<rbrakk> \<Longrightarrow> rel_spmf (rel_prod B S) (left1 s1 q1') (left2 s2 q2');
     \<And>q1' q2'. \<lbrakk> q1 = Inr q1'; q2 = Inr q2' \<rbrakk> \<Longrightarrow> rel_spmf (rel_prod D S) (right1 s1 q1') (right2 s2 q2');
     S s1 s2; rel_sum A C q1 q2 \<rbrakk>
   \<Longrightarrow> rel_spmf (rel_prod (rel_sum B D) S) ((left1 \<oplus>\<^sub>O right1) s1 q1) ((left2 \<oplus>\<^sub>O right2) s2 q2)"
 apply(erule rel_sum.cases; clarsimp)
  apply(erule meta_allE)+
  apply(erule meta_impE, rule refl)+
  subgoal premises [transfer_rule] by transfer_prover
 apply(erule meta_allE)+
 apply(erule meta_impE, rule refl)+
 subgoal premises [transfer_rule] by transfer_prover
 done
 
 end
 
 subsection \<open>Shared state with aborts\<close>
 
 context
   fixes left :: "('s, 'a, 'b option) oracle'"
   and right :: "('s,'c, 'd option) oracle'"
   and s :: "'s"
 begin
 
 primrec plus_oracle_stop :: "'a + 'c \<Rightarrow> (('b + 'd) option \<times> 's) spmf"
 where
   "plus_oracle_stop (Inl a) = map_spmf (apfst (map_option Inl)) (left s a)"
 | "plus_oracle_stop (Inr b) = map_spmf (apfst (map_option Inr)) (right s b)"
 
 lemma lossless_plus_oracle_stopI [intro, simp]:
   "\<lbrakk> \<And>a. x = Inl a \<Longrightarrow> lossless_spmf (left s a); 
      \<And>b. x = Inr b \<Longrightarrow> lossless_spmf (right s b) \<rbrakk>
   \<Longrightarrow> lossless_spmf (plus_oracle_stop x)"
 by(cases x) simp_all
 
 lemma plus_oracle_stop_split:
   "P (plus_oracle_stop lr) \<longleftrightarrow>
   (\<forall>x. lr = Inl x \<longrightarrow> P (map_spmf (apfst (map_option Inl)) (left s x))) \<and>
   (\<forall>y. lr = Inr y \<longrightarrow> P (map_spmf (apfst (map_option Inr)) (right s y)))"
 by(cases lr) auto
 
 lemma plus_oracle_stop_split_asm:
   "P (plus_oracle_stop lr) \<longleftrightarrow>
   \<not> ((\<exists>x. lr = Inl x \<and> \<not> P (map_spmf (apfst (map_option Inl)) (left s x))) \<or>
      (\<exists>y. lr = Inr y \<and> \<not> P (map_spmf (apfst (map_option Inr)) (right s y))))"
 by(cases lr) auto
 
 end
 
 notation plus_oracle_stop (infix "\<oplus>\<^sub>O\<^sup>S" 500)
 
 subsection \<open>Disjoint state\<close>
 
 context
   fixes left :: "('s1, 'a, 'b) oracle'"
   and right :: "('s2, 'c, 'd) oracle'"
 begin
 
 fun parallel_oracle :: "('s1 \<times> 's2, 'a + 'c, 'b + 'd) oracle'"
 where
   "parallel_oracle (s1, s2) (Inl a) = map_spmf (map_prod Inl (\<lambda>s1'. (s1', s2))) (left s1 a)"
 | "parallel_oracle (s1, s2) (Inr b) = map_spmf (map_prod Inr (Pair s1)) (right s2 b)"
 
 lemma parallel_oracle_def:
   "parallel_oracle = (\<lambda>(s1, s2). case_sum (\<lambda>a. map_spmf (map_prod Inl (\<lambda>s1'. (s1', s2))) (left s1 a)) (\<lambda>b. map_spmf (map_prod Inr (Pair s1)) (right s2 b)))"
 by(auto intro!: ext split: sum.split)
 
 lemma lossless_parallel_oracle [simp]:
   "lossless_spmf (parallel_oracle s12 xy) \<longleftrightarrow>
    (\<forall>x. xy = Inl x \<longrightarrow> lossless_spmf (left (fst s12) x)) \<and>
    (\<forall>y. xy = Inr y \<longrightarrow> lossless_spmf (right (snd s12) y))"
 by(cases s12; cases xy) simp_all
 
 lemma parallel_oracle_split:
   "P (parallel_oracle s1s2 lr) \<longleftrightarrow>
   (\<forall>s1 s2 x. s1s2 = (s1, s2) \<longrightarrow> lr = Inl x \<longrightarrow> P (map_spmf (map_prod Inl (\<lambda>s1'. (s1', s2))) (left s1 x))) \<and>
   (\<forall>s1 s2 y. s1s2 = (s1, s2) \<longrightarrow> lr = Inr y \<longrightarrow> P (map_spmf (map_prod Inr (Pair s1)) (right s2 y)))"
 by(cases s1s2; cases lr) auto
 
 lemma parallel_oracle_split_asm:
   "P (parallel_oracle s1s2 lr) \<longleftrightarrow>
   \<not> ((\<exists>s1 s2 x. s1s2 = (s1, s2) \<and> lr = Inl x \<and> \<not> P (map_spmf (map_prod Inl (\<lambda>s1'. (s1', s2))) (left s1 x))) \<or>
      (\<exists>s1 s2 y. s1s2 = (s1, s2) \<and> lr = Inr y \<and> \<not> P (map_spmf (map_prod Inr (Pair s1)) (right s2 y))))"
 by(cases s1s2; cases lr) auto
 
 lemma WT_parallel_oracle [intro!, simp]:
   "\<lbrakk> \<I>l \<turnstile>c left sl \<surd>; \<I>r \<turnstile>c right sr \<surd> \<rbrakk> \<Longrightarrow> plus_\<I> \<I>l \<I>r \<turnstile>c parallel_oracle (sl, sr) \<surd>"
 by(rule WT_calleeI)(auto elim!: WT_calleeD simp add: inj_image_mem_iff)
 
 lemma callee_invariant_parallel_oracleI [simp, intro]:
   assumes "callee_invariant_on left Il \<I>l" "callee_invariant_on right Ir \<I>r"
   shows "callee_invariant_on parallel_oracle (pred_prod Il Ir) (\<I>l \<oplus>\<^sub>\<I> \<I>r)"
 proof
   interpret left: callee_invariant_on left Il \<I>l by fact
   interpret right: callee_invariant_on right Ir \<I>r by fact
 
   show "pred_prod Il Ir s12'"
     if "(y, s12') \<in> set_spmf (parallel_oracle s12 x)" and "pred_prod Il Ir s12" and "x \<in> outs_\<I> (\<I>l \<oplus>\<^sub>\<I> \<I>r)"
     for s12 x y s12' using that
     by(cases s12; cases s12; cases x)(auto dest: left.callee_invariant right.callee_invariant)
 
   show "\<I>l \<oplus>\<^sub>\<I> \<I>r \<turnstile>c local.parallel_oracle s \<surd>" if "pred_prod Il Ir s" for s using that
     by(cases s)(simp add: left.WT_callee right.WT_callee)
 qed
 
 end
 
 lemma parallel_oracle_parametric:
   includes lifting_syntax shows
   "((S1 ===> CALL1 ===> rel_spmf (rel_prod (=) S1)) 
   ===> (S2 ===> CALL2 ===> rel_spmf (rel_prod (=) S2))
   ===> rel_prod S1 S2 ===> rel_sum CALL1 CALL2 ===> rel_spmf (rel_prod (=) (rel_prod S1 S2)))
   parallel_oracle parallel_oracle"
 unfolding parallel_oracle_def[abs_def] by (fold relator_eq)transfer_prover
 
 subsection \<open>Indexed oracles\<close>
 
 definition family_oracle :: "('i \<Rightarrow> ('s, 'a, 'b) oracle') \<Rightarrow> ('i \<Rightarrow> 's, 'i \<times> 'a, 'b) oracle'"
 where "family_oracle f s = (\<lambda>(i, x). map_spmf (\<lambda>(y, s'). (y, s(i := s'))) (f i (s i) x))"
 
 lemma family_oracle_apply [simp]:
   "family_oracle f s (i, x) = map_spmf (apsnd (fun_upd s i)) (f i (s i) x)"
 by(simp add: family_oracle_def apsnd_def map_prod_def)
 
 lemma lossless_family_oracle:
   "lossless_spmf (family_oracle f s ix) \<longleftrightarrow> lossless_spmf (f (fst ix) (s (fst ix)) (snd ix))"
 by(simp add: family_oracle_def split_beta)
 
 subsection \<open>State extension\<close>
 
 definition extend_state_oracle :: "('call, 'ret, 's) callee \<Rightarrow> ('call, 'ret, 's' \<times> 's) callee" ("\<dagger>_" [1000] 1000)
 where "extend_state_oracle callee = (\<lambda>(s', s) x. map_spmf (\<lambda>(y, s). (y, (s', s))) (callee s x))"
 
 lemma extend_state_oracle_simps [simp]:
   "extend_state_oracle callee (s', s) x = map_spmf (\<lambda>(y, s). (y, (s', s))) (callee s x)"
 by(simp add: extend_state_oracle_def)
 
 context includes lifting_syntax begin
 lemma extend_state_oracle_parametric [transfer_rule]:
   "((S ===> C ===> rel_spmf (rel_prod R S)) ===> rel_prod S' S ===> C ===> rel_spmf (rel_prod R (rel_prod S' S)))
   extend_state_oracle extend_state_oracle"
 unfolding extend_state_oracle_def[abs_def] by transfer_prover
 
 lemma extend_state_oracle_transfer:
   "((S ===> C ===> rel_spmf (rel_prod R S)) 
   ===> rel_prod2 S ===> C ===> rel_spmf (rel_prod R (rel_prod2 S)))
   (\<lambda>oracle. oracle) extend_state_oracle"
 unfolding extend_state_oracle_def[abs_def]
 apply(rule rel_funI)+
 apply clarsimp
 apply(drule (1) rel_funD)+
 apply(auto simp add: spmf_rel_map split_def dest: rel_funD intro: rel_spmf_mono)
 done
 end
 
 lemma callee_invariant_extend_state_oracle_const [simp]:
   "callee_invariant \<dagger>oracle (\<lambda>(s', s). I s')"
 by unfold_locales auto
 
 lemma callee_invariant_extend_state_oracle_const':
   "callee_invariant \<dagger>oracle (\<lambda>s. I (fst s))"
 by unfold_locales auto
 
 definition lift_stop_oracle :: "('call, 'ret, 's) callee \<Rightarrow> ('call, 'ret option, 's) callee"
 where "lift_stop_oracle oracle s x = map_spmf (apfst Some) (oracle s x)"
 
 lemma lift_stop_oracle_apply [simp]: "lift_stop_oracle  oracle s x = map_spmf (apfst Some) (oracle s x)"
   by(fact lift_stop_oracle_def)
   
 context includes lifting_syntax begin
 
 lemma lift_stop_oracle_transfer:
   "((S ===> C ===> rel_spmf (rel_prod R S)) ===> (S ===> C ===> rel_spmf (rel_prod (pcr_Some R) S)))
    (\<lambda>x. x) lift_stop_oracle"
 unfolding lift_stop_oracle_def
 apply(rule rel_funI)+
 apply(drule (1) rel_funD)+
 apply(simp add: spmf_rel_map apfst_def prod.rel_map)
 done
 
 end
 
+definition extend_state_oracle2 :: "('call, 'ret, 's) callee \<Rightarrow> ('call, 'ret, 's \<times> 's') callee" ("_\<dagger>" [1000] 1000)
+  where "extend_state_oracle2 callee = (\<lambda>(s, s') x. map_spmf (\<lambda>(y, s). (y, (s, s'))) (callee s x))"
+
+lemma extend_state_oracle2_simps [simp]:
+  "extend_state_oracle2 callee (s, s') x = map_spmf (\<lambda>(y, s). (y, (s, s'))) (callee s x)"
+  by(simp add: extend_state_oracle2_def)
+
+lemma extend_state_oracle2_parametric [transfer_rule]: includes lifting_syntax shows
+  "((S ===> C ===> rel_spmf (rel_prod R S)) ===> rel_prod S S' ===> C ===> rel_spmf (rel_prod R (rel_prod S S')))
+  extend_state_oracle2 extend_state_oracle2"
+  unfolding extend_state_oracle2_def[abs_def] by transfer_prover
+
+lemma callee_invariant_extend_state_oracle2_const [simp]:
+  "callee_invariant oracle\<dagger> (\<lambda>(s, s'). I s')"
+  by unfold_locales auto
+
+lemma callee_invariant_extend_state_oracle2_const':
+  "callee_invariant oracle\<dagger> (\<lambda>s. I (snd s))"
+  by unfold_locales auto
+
+lemma extend_state_oracle2_plus_oracle: 
+  "extend_state_oracle2 (plus_oracle oracle1 oracle2) = plus_oracle (extend_state_oracle2 oracle1) (extend_state_oracle2 oracle2)"
+proof((rule ext)+; goal_cases)
+  case (1 s q)
+  then show ?case by (cases s; cases q) (simp_all add: apfst_def spmf.map_comp o_def split_def)
+qed
+
+lemma parallel_oracle_conv_plus_oracle:
+  "parallel_oracle oracle1 oracle2 = plus_oracle (oracle1\<dagger>) (\<dagger>oracle2)"
+proof((rule ext)+; goal_cases)
+  case (1 s q)
+  then show ?case by (cases s; cases q) (auto simp add: spmf.map_comp apfst_def o_def split_def map_prod_def)
+qed
+
+lemma map_sum_parallel_oracle: includes lifting_syntax shows
+  "(id ---> map_sum f g ---> map_spmf (map_prod (map_sum h k) id)) (parallel_oracle oracle1 oracle2)
+  = parallel_oracle ((id ---> f ---> map_spmf (map_prod h id)) oracle1) ((id ---> g ---> map_spmf (map_prod k id)) oracle2)"
+proof((rule ext)+; goal_cases)
+  case (1 s q)
+  then show ?case by (cases s; cases q) (simp_all add: spmf.map_comp o_def apfst_def prod.map_comp)
+qed
+
+lemma map_sum_plus_oracle: includes lifting_syntax shows
+  "(id ---> map_sum f g ---> map_spmf (map_prod (map_sum h k) id)) (plus_oracle oracle1 oracle2)
+  = plus_oracle ((id ---> f ---> map_spmf (map_prod h id)) oracle1) ((id ---> g ---> map_spmf (map_prod k id)) oracle2)"
+proof((rule ext)+; goal_cases)
+  case (1 s q)
+  then show ?case by (cases q) (simp_all add: spmf.map_comp o_def apfst_def prod.map_comp)
+qed
+
+lemma map_rsuml_plus_oracle: includes lifting_syntax shows
+  "(id ---> rsuml ---> (map_spmf (map_prod lsumr id))) (oracle1 \<oplus>\<^sub>O (oracle2 \<oplus>\<^sub>O oracle3)) =
+   ((oracle1 \<oplus>\<^sub>O oracle2) \<oplus>\<^sub>O oracle3)"
+proof((rule ext)+; goal_cases)
+  case (1 s q)
+  then show ?case 
+  proof(cases q)
+    case (Inl ql)
+    then show ?thesis by(cases ql)(simp_all add: spmf.map_comp o_def apfst_def prod.map_comp)
+  qed (simp add: spmf.map_comp o_def apfst_def prod.map_comp id_def)
+qed
+
+lemma map_lsumr_plus_oracle: includes lifting_syntax shows
+  "(id ---> lsumr ---> (map_spmf (map_prod rsuml id))) ((oracle1 \<oplus>\<^sub>O oracle2) \<oplus>\<^sub>O oracle3) =
+   (oracle1 \<oplus>\<^sub>O (oracle2 \<oplus>\<^sub>O oracle3))"
+proof((rule ext)+; goal_cases)
+  case (1 s q)
+  then show ?case 
+  proof(cases q)
+    case (Inr qr)
+    then show ?thesis by(cases qr)(simp_all add: spmf.map_comp o_def apfst_def prod.map_comp)
+  qed (simp add: spmf.map_comp o_def apfst_def prod.map_comp id_def)
+qed
+
+context includes lifting_syntax begin
+
+definition lift_state_oracle
+  :: "(('s \<Rightarrow> 'a \<Rightarrow> (('b \<times> 't) \<times> 's) spmf) \<Rightarrow> ('s' \<Rightarrow> 'a \<Rightarrow> (('b \<times> 't) \<times> 's') spmf)) 
+  \<Rightarrow> ('t \<times> 's \<Rightarrow> 'a \<Rightarrow> ('b \<times> 't \<times> 's) spmf) \<Rightarrow> ('t \<times> 's' \<Rightarrow> 'a \<Rightarrow> ('b \<times> 't \<times> 's') spmf)" where
+  "lift_state_oracle F oracle = 
+   (\<lambda>(t, s') a. map_spmf rprodl (F ((Pair t ---> id ---> map_spmf lprodr) oracle) s' a))"
+
+lemma lift_state_oracle_simps [simp]:
+  "lift_state_oracle F oracle (t, s') a = map_spmf rprodl (F ((Pair t ---> id ---> map_spmf lprodr) oracle) s' a)"
+  by(simp add: lift_state_oracle_def)
+
+lemma lift_state_oracle_parametric [transfer_rule]: includes lifting_syntax shows
+  "(((S ===> A ===> rel_spmf (rel_prod (rel_prod B T) S)) ===> S' ===> A ===> rel_spmf (rel_prod (rel_prod B T) S'))
+  ===> (rel_prod T S ===> A ===> rel_spmf (rel_prod B (rel_prod T S)))
+  ===> rel_prod T S' ===> A ===> rel_spmf (rel_prod B (rel_prod T S')))
+  lift_state_oracle lift_state_oracle"
+  unfolding lift_state_oracle_def map_fun_def o_def by transfer_prover
+
+lemma lift_state_oracle_extend_state_oracle:
+  includes lifting_syntax
+  assumes "\<And>B. Transfer.Rel (((=) ===> (=) ===> rel_spmf (rel_prod B (=))) ===> (=) ===> (=) ===> rel_spmf (rel_prod B (=))) G F"
+    (* TODO: implement simproc to discharge parametricity assumptions like this one *)
+  shows "lift_state_oracle F (extend_state_oracle oracle) = extend_state_oracle (G oracle)"
+  unfolding lift_state_oracle_def extend_state_oracle_def
+  apply(clarsimp simp add: fun_eq_iff map_fun_def o_def spmf.map_comp split_def rprodl_def)
+  subgoal for t s a
+    apply(rule sym)
+    apply(fold spmf_rel_eq)
+    apply(simp add: spmf_rel_map)
+    apply(rule rel_spmf_mono)
+     apply(rule assms[unfolded Rel_def, where B="\<lambda>x (y, z). x = y \<and> z = t", THEN rel_funD, THEN rel_funD, THEN rel_funD])
+       apply(auto simp add: rel_fun_def spmf_rel_map intro!: rel_spmf_reflI)
+    done
+  done
+
+lemma lift_state_oracle_compose: 
+  "lift_state_oracle F (lift_state_oracle G oracle) = lift_state_oracle (F \<circ> G) oracle"
+  by(simp add: lift_state_oracle_def map_fun_def o_def split_def spmf.map_comp)
+
+lemma lift_state_oracle_id [simp]: "lift_state_oracle id = id"
+  by(simp add: fun_eq_iff spmf.map_comp o_def)
+
+lemma rprodl_extend_state_oracle: includes lifting_syntax shows
+  "(rprodl ---> id ---> map_spmf (map_prod id lprodr)) (extend_state_oracle (extend_state_oracle oracle)) = 
+  extend_state_oracle oracle"
+  by(simp add: fun_eq_iff spmf.map_comp o_def split_def)
+
+end
+
 section \<open>Combining GPVs\<close>
 
 subsection \<open>Shared state without interrupts\<close>
 
 context
   fixes left :: "'s \<Rightarrow> 'x1 \<Rightarrow> ('y1 \<times> 's, 'call, 'ret) gpv"
   and right :: "'s \<Rightarrow> 'x2 \<Rightarrow> ('y2 \<times> 's, 'call, 'ret) gpv"
 begin
 
 primrec plus_intercept :: "'s \<Rightarrow> 'x1 + 'x2 \<Rightarrow> (('y1 + 'y2) \<times> 's, 'call, 'ret) gpv"
 where
   "plus_intercept s (Inl x) = map_gpv (apfst Inl) id (left s x)"
 | "plus_intercept s (Inr x) = map_gpv (apfst Inr) id (right s x)"
 
 end
 
 lemma plus_intercept_parametric [transfer_rule]:
   includes lifting_syntax shows
   "((S ===> X1 ===> rel_gpv (rel_prod Y1 S) C)
   ===> (S ===> X2 ===> rel_gpv (rel_prod Y2 S) C)
   ===> S ===> rel_sum X1 X2 ===> rel_gpv (rel_prod (rel_sum Y1 Y2) S) C)
   plus_intercept plus_intercept"
 unfolding plus_intercept_def[abs_def] by transfer_prover
 
 lemma interaction_bounded_by_plus_intercept [interaction_bound]:
   fixes left right
   shows "\<lbrakk> \<And>x'. x = Inl x' \<Longrightarrow> interaction_bounded_by P (left s x') (n x');
     \<And>y. x = Inr y \<Longrightarrow> interaction_bounded_by P (right s y) (m y) \<rbrakk>
   \<Longrightarrow> interaction_bounded_by P (plus_intercept left right s x) (case x of Inl x \<Rightarrow> n x | Inr y \<Rightarrow> m y)"
 by(simp split!: sum.split add: interaction_bounded_by_map_gpv_id)
 
 subsection \<open>Shared state with interrupts\<close>
 
 context 
   fixes left :: "'s \<Rightarrow> 'x1 \<Rightarrow> ('y1 option \<times> 's, 'call, 'ret) gpv"
   and right :: "'s \<Rightarrow> 'x2 \<Rightarrow> ('y2 option \<times> 's, 'call, 'ret) gpv"
 begin
 
 primrec plus_intercept_stop :: "'s \<Rightarrow> 'x1 + 'x2 \<Rightarrow> (('y1 + 'y2) option \<times> 's, 'call, 'ret) gpv"
 where
   "plus_intercept_stop s (Inl x) = map_gpv (apfst (map_option Inl)) id (left s x)"
 | "plus_intercept_stop s (Inr x) = map_gpv (apfst (map_option Inr)) id (right s x)"
 
 end
 
 lemma plus_intercept_stop_parametric [transfer_rule]:
   includes lifting_syntax shows
   "((S ===> X1 ===> rel_gpv (rel_prod (rel_option Y1) S) C)
   ===> (S ===> X2 ===> rel_gpv (rel_prod (rel_option Y2) S) C)
   ===> S ===> rel_sum X1 X2 ===> rel_gpv (rel_prod (rel_option (rel_sum Y1 Y2)) S) C)
   plus_intercept_stop plus_intercept_stop"
 unfolding plus_intercept_stop_def by transfer_prover
 
+subsection \<open>One-sided shifts\<close>
+
+primcorec (transfer) left_gpv :: "('a, 'out, 'in) gpv \<Rightarrow> ('a, 'out + 'out', 'in + 'in') gpv" where
+  "the_gpv (left_gpv gpv) = 
+   map_spmf (map_generat id Inl (\<lambda>rpv input. case input of Inl input' \<Rightarrow> left_gpv (rpv input') | _ \<Rightarrow> Fail)) (the_gpv gpv)"
+
+abbreviation left_rpv :: "('a, 'out, 'in) rpv \<Rightarrow> ('a, 'out + 'out', 'in + 'in') rpv" where
+  "left_rpv rpv \<equiv> \<lambda>input. case input of Inl input' \<Rightarrow> left_gpv (rpv input') | _ \<Rightarrow> Fail"
+
+primcorec (transfer) right_gpv :: "('a, 'out, 'in) gpv \<Rightarrow> ('a, 'out' + 'out, 'in' + 'in) gpv" where
+  "the_gpv (right_gpv gpv) =
+   map_spmf (map_generat id Inr (\<lambda>rpv input. case input of Inr input' \<Rightarrow> right_gpv (rpv input') | _ \<Rightarrow> Fail)) (the_gpv gpv)"
+
+abbreviation right_rpv :: "('a, 'out, 'in) rpv \<Rightarrow> ('a, 'out' + 'out, 'in' + 'in) rpv" where
+  "right_rpv rpv \<equiv> \<lambda>input. case input of Inr input' \<Rightarrow> right_gpv (rpv input') | _ \<Rightarrow> Fail"
+
+context 
+  includes lifting_syntax
+  notes [transfer_rule] = corec_gpv_parametric' Fail_parametric' the_gpv_parametric'
+begin
+
+lemmas left_gpv_parametric = left_gpv.transfer
+
+lemma left_gpv_parametric':
+  "(rel_gpv'' A C R ===> rel_gpv'' A (rel_sum C C') (rel_sum R R')) left_gpv left_gpv"
+  unfolding left_gpv_def by transfer_prover
+
+lemmas right_gpv_parametric = right_gpv.transfer
+
+lemma right_gpv_parametric':
+  "(rel_gpv'' A C' R' ===> rel_gpv'' A (rel_sum C C') (rel_sum R R')) right_gpv right_gpv"
+  unfolding right_gpv_def by transfer_prover
+
 end
+
+lemma left_gpv_Done [simp]: "left_gpv (Done x) = Done x"
+  by(rule gpv.expand) simp
+
+lemma right_gpv_Done [simp]: "right_gpv (Done x) = Done x"
+  by(rule gpv.expand) simp
+
+lemma left_gpv_Pause [simp]:
+  "left_gpv (Pause x rpv) = Pause (Inl x) (\<lambda>input. case input of Inl input' \<Rightarrow> left_gpv (rpv input') | _ \<Rightarrow> Fail)"
+  by(rule gpv.expand) simp
+
+lemma right_gpv_Pause [simp]:
+  "right_gpv (Pause x rpv) = Pause (Inr x) (\<lambda>input. case input of Inr input' \<Rightarrow> right_gpv (rpv input') | _ \<Rightarrow> Fail)"
+  by(rule gpv.expand) simp
+
+lemma left_gpv_map: "left_gpv (map_gpv f g gpv) = map_gpv f (map_sum g h) (left_gpv gpv)"
+  using left_gpv.transfer[of "BNF_Def.Grp UNIV f" "BNF_Def.Grp UNIV g" "BNF_Def.Grp UNIV h"]
+  unfolding sum.rel_Grp gpv.rel_Grp
+  by(auto simp add: rel_fun_def Grp_def)
+
+lemma right_gpv_map: "right_gpv (map_gpv f g gpv) = map_gpv f (map_sum h g) (right_gpv gpv)"
+  using right_gpv.transfer[of "BNF_Def.Grp UNIV f" "BNF_Def.Grp UNIV g" "BNF_Def.Grp UNIV h"]
+  unfolding sum.rel_Grp gpv.rel_Grp
+  by(auto simp add: rel_fun_def Grp_def)
+
+lemma results'_gpv_left_gpv [simp]: 
+  "results'_gpv (left_gpv gpv :: ('a, 'out + 'out', 'in + 'in') gpv) = results'_gpv gpv" (is "?lhs = ?rhs")
+proof(rule Set.set_eqI iffI)+
+  show "x \<in> ?rhs" if "x \<in> ?lhs" for x using that
+    by(induction gpv'\<equiv>"left_gpv gpv :: ('a, 'out + 'out', 'in + 'in') gpv" arbitrary: gpv)
+      (fastforce simp add: elim!: generat.set_cases intro: results'_gpvI split: sum.splits)+
+  show "x \<in> ?lhs" if "x \<in> ?rhs" for x using that
+    by(induction)
+      (auto 4 3 elim!: generat.set_cases intro: results'_gpv_Pure rev_image_eqI results'_gpv_Cont[where input="Inl _"])
+qed
+
+lemma results'_gpv_right_gpv [simp]: 
+  "results'_gpv (right_gpv gpv :: ('a, 'out' + 'out, 'in' + 'in) gpv) = results'_gpv gpv" (is "?lhs = ?rhs")
+proof(rule Set.set_eqI iffI)+
+  show "x \<in> ?rhs" if "x \<in> ?lhs" for x using that
+    by(induction gpv'\<equiv>"right_gpv gpv :: ('a, 'out' + 'out, 'in' + 'in) gpv" arbitrary: gpv)
+      (fastforce simp add: elim!: generat.set_cases intro: results'_gpvI split: sum.splits)+
+  show "x \<in> ?lhs" if "x \<in> ?rhs" for x using that
+    by(induction)
+      (auto 4 3 elim!: generat.set_cases intro: results'_gpv_Pure rev_image_eqI results'_gpv_Cont[where input="Inr _"])
+qed
+
+lemma left_gpv_Inl_transfer: "rel_gpv'' (=) (\<lambda>l r. l = Inl r) (\<lambda>l r. l = Inl r) (left_gpv gpv) gpv"
+  by(coinduction arbitrary: gpv)
+    (auto simp add: spmf_rel_map generat.rel_map del: rel_funI intro!: rel_spmf_reflI generat.rel_refl_strong rel_funI)
+
+lemma right_gpv_Inr_transfer: "rel_gpv'' (=) (\<lambda>l r. l = Inr r) (\<lambda>l r. l = Inr r) (right_gpv gpv) gpv"
+  by(coinduction arbitrary: gpv)
+    (auto simp add: spmf_rel_map generat.rel_map del: rel_funI intro!: rel_spmf_reflI generat.rel_refl_strong rel_funI)
+
+lemma exec_gpv_plus_oracle_left: "exec_gpv (plus_oracle oracle1 oracle2) (left_gpv gpv) s = exec_gpv oracle1 gpv s"
+  unfolding spmf_rel_eq[symmetric] prod.rel_eq[symmetric]
+  by(rule exec_gpv_parametric'[where A="(=)" and S="(=)" and CALL="\<lambda>l r. l = Inl r" and R="\<lambda>l r. l = Inl r", THEN rel_funD, THEN rel_funD, THEN rel_funD])
+    (auto intro!: rel_funI simp add: spmf_rel_map apfst_def map_prod_def rel_prod_conv intro: rel_spmf_reflI left_gpv_Inl_transfer)
+
+lemma exec_gpv_plus_oracle_right: "exec_gpv (plus_oracle oracle1 oracle2) (right_gpv gpv) s = exec_gpv oracle2 gpv s"
+  unfolding spmf_rel_eq[symmetric] prod.rel_eq[symmetric]
+  by(rule exec_gpv_parametric'[where A="(=)" and S="(=)" and CALL="\<lambda>l r. l = Inr r" and R="\<lambda>l r. l = Inr r", THEN rel_funD, THEN rel_funD, THEN rel_funD])
+    (auto intro!: rel_funI simp add: spmf_rel_map apfst_def map_prod_def rel_prod_conv intro: rel_spmf_reflI right_gpv_Inr_transfer)
+
+lemma left_gpv_bind_gpv: "left_gpv (bind_gpv gpv f) = bind_gpv (left_gpv gpv) (left_gpv \<circ> f)"
+  by(coinduction arbitrary:gpv f rule: gpv.coinduct_strong)
+    (auto 4 4 simp add: bind_map_spmf spmf_rel_map intro!: rel_spmf_reflI rel_spmf_bindI[of "(=)"] generat.rel_refl rel_funI split: sum.splits)
+
+lemma inline1_left_gpv:
+  "inline1 (\<lambda>s q. left_gpv (callee s q)) gpv s = 
+   map_spmf (map_sum id (map_prod Inl (map_prod left_rpv id))) (inline1 callee gpv s)"
+proof(induction arbitrary: gpv s rule: parallel_fixp_induct_2_2[OF partial_function_definitions_spmf partial_function_definitions_spmf inline1.mono inline1.mono inline1_def inline1_def, unfolded lub_spmf_empty, case_names adm bottom step])
+  case adm show ?case by simp
+  case bottom show ?case by simp
+  case (step inline1' inline1'')
+  then show ?case
+    by(auto simp add: map_spmf_bind_spmf o_def bind_map_spmf intro!: ext bind_spmf_cong split: generat.split)
+qed
+
+lemma left_gpv_inline: "left_gpv (inline callee gpv s) = inline (\<lambda>s q. left_gpv (callee s q)) gpv s"
+  by(coinduction arbitrary: callee gpv s rule: gpv_coinduct_bind)
+    (fastforce simp add: inline_sel spmf_rel_map inline1_left_gpv left_gpv_bind_gpv o_def split_def intro!: rel_spmf_reflI split: sum.split intro!: rel_funI gpv.rel_refl_strong)
+
+lemma right_gpv_bind_gpv: "right_gpv (bind_gpv gpv f) = bind_gpv (right_gpv gpv) (right_gpv \<circ> f)"
+  by(coinduction arbitrary:gpv f rule: gpv.coinduct_strong)
+    (auto 4 4 simp add: bind_map_spmf spmf_rel_map intro!: rel_spmf_reflI rel_spmf_bindI[of "(=)"] generat.rel_refl rel_funI split: sum.splits)
+
+lemma inline1_right_gpv:
+  "inline1 (\<lambda>s q. right_gpv (callee s q)) gpv s = 
+   map_spmf (map_sum id (map_prod Inr (map_prod right_rpv id))) (inline1 callee gpv s)"
+proof(induction arbitrary: gpv s rule: parallel_fixp_induct_2_2[OF partial_function_definitions_spmf partial_function_definitions_spmf inline1.mono inline1.mono inline1_def inline1_def, unfolded lub_spmf_empty, case_names adm bottom step])
+  case adm show ?case by simp
+  case bottom show ?case by simp
+  case (step inline1' inline1'')
+  then show ?case
+    by(auto simp add: map_spmf_bind_spmf o_def bind_map_spmf intro!: ext bind_spmf_cong split: generat.split)
+qed
+
+lemma right_gpv_inline: "right_gpv (inline callee gpv s) = inline (\<lambda>s q. right_gpv (callee s q)) gpv s"
+  by(coinduction arbitrary: callee gpv s rule: gpv_coinduct_bind)
+    (fastforce simp add: inline_sel spmf_rel_map inline1_right_gpv right_gpv_bind_gpv o_def split_def intro!: rel_spmf_reflI split: sum.split intro!: rel_funI gpv.rel_refl_strong)
+
+lemma WT_gpv_left_gpv: "\<I>1 \<turnstile>g gpv \<surd> \<Longrightarrow> \<I>1 \<oplus>\<^sub>\<I> \<I>2 \<turnstile>g left_gpv gpv \<surd>"
+  by(coinduction arbitrary: gpv)(auto 4 4 dest: WT_gpvD)
+
+lemma WT_gpv_right_gpv: "\<I>2 \<turnstile>g gpv \<surd> \<Longrightarrow> \<I>1 \<oplus>\<^sub>\<I> \<I>2 \<turnstile>g right_gpv gpv \<surd>"
+  by(coinduction arbitrary: gpv)(auto 4 4 dest: WT_gpvD)
+
+lemma results_gpv_left_gpv [simp]: "results_gpv (\<I>1 \<oplus>\<^sub>\<I> \<I>2) (left_gpv gpv) = results_gpv \<I>1 gpv"
+  (is "?lhs = ?rhs")
+proof(rule Set.set_eqI iffI)+
+  show "x \<in> ?rhs" if "x \<in> ?lhs" for x using that
+    by(induction gpv'\<equiv>"left_gpv gpv :: ('a, 'b + 'c, 'd + 'e) gpv" arbitrary: gpv rule: results_gpv.induct)
+      (fastforce intro: results_gpv.intros)+
+  show "x \<in> ?lhs" if "x \<in> ?rhs" for x using that
+    by(induction)(fastforce intro: results_gpv.intros)+
+qed
+
+lemma results_gpv_right_gpv [simp]: "results_gpv (\<I>1 \<oplus>\<^sub>\<I> \<I>2) (right_gpv gpv) = results_gpv \<I>2 gpv"
+  (is "?lhs = ?rhs")
+proof(rule Set.set_eqI iffI)+
+  show "x \<in> ?rhs" if "x \<in> ?lhs" for x using that
+    by(induction gpv'\<equiv>"right_gpv gpv :: ('a, 'b + 'c, 'd + 'e) gpv" arbitrary: gpv rule: results_gpv.induct)
+      (fastforce intro: results_gpv.intros)+
+  show "x \<in> ?lhs" if "x \<in> ?rhs" for x using that
+    by(induction)(fastforce intro: results_gpv.intros)+
+qed
+
+lemma left_gpv_Fail [simp]: "left_gpv Fail = Fail"
+  by(rule gpv.expand) auto
+
+lemma right_gpv_Fail [simp]: "right_gpv Fail = Fail"
+  by(rule gpv.expand) auto
+
+lemma rsuml_lsumr_left_gpv_left_gpv:"map_gpv' id rsuml lsumr (left_gpv (left_gpv gpv)) = left_gpv gpv"
+  by(coinduction arbitrary: gpv)
+    (auto 4 3 simp add: spmf_rel_map generat.rel_map intro!: rel_spmf_reflI rel_generat_reflI rel_funI split!: sum.split elim!: lsumr.elims intro: exI[where x=Fail])
+
+lemma rsuml_lsumr_left_gpv_right_gpv: "map_gpv' id rsuml lsumr (left_gpv (right_gpv gpv)) = right_gpv (left_gpv gpv)"
+  by(coinduction arbitrary: gpv)
+    (auto 4 3 simp add: spmf_rel_map generat.rel_map intro!: rel_spmf_reflI rel_generat_reflI rel_funI split!: sum.split elim!: lsumr.elims intro: exI[where x=Fail])
+
+lemma rsuml_lsumr_right_gpv: "map_gpv' id rsuml lsumr (right_gpv gpv) = right_gpv (right_gpv gpv)"
+  by(coinduction arbitrary: gpv)
+    (auto 4 3 simp add: spmf_rel_map generat.rel_map intro!: rel_spmf_reflI rel_generat_reflI rel_funI split!: sum.split elim!: lsumr.elims intro: exI[where x=Fail])
+
+lemma map_gpv'_map_gpv_swap:
+  "map_gpv' f g h (map_gpv f' id gpv) = map_gpv (f \<circ> f') id (map_gpv' id g h gpv)"
+  by(simp add: map_gpv_conv_map_gpv' map_gpv'_comp)
+
+lemma lsumr_rsuml_left_gpv: "map_gpv' id lsumr rsuml (left_gpv gpv) = left_gpv (left_gpv gpv)"
+  by(coinduction arbitrary: gpv)
+    (auto 4 3 simp add: spmf_rel_map generat.rel_map intro!: rel_spmf_reflI rel_generat_reflI rel_funI split!: sum.split intro: exI[where x=Fail])
+
+lemma lsumr_rsuml_right_gpv_left_gpv:
+  "map_gpv' id lsumr rsuml (right_gpv (left_gpv gpv)) = left_gpv (right_gpv gpv)"
+  by(coinduction arbitrary: gpv)
+    (auto 4 3 simp add: spmf_rel_map generat.rel_map intro!: rel_spmf_reflI rel_generat_reflI rel_funI split!: sum.split intro: exI[where x=Fail])
+
+lemma lsumr_rsuml_right_gpv_right_gpv:
+  "map_gpv' id lsumr rsuml (right_gpv (right_gpv gpv)) = right_gpv gpv"
+  by(coinduction arbitrary: gpv)
+    (auto 4 3 simp add: spmf_rel_map generat.rel_map intro!: rel_spmf_reflI rel_generat_reflI rel_funI split!: sum.split elim!: rsuml.elims intro: exI[where x=Fail])
+
+
+lemma in_set_spmf_extend_state_oracle [simp]:
+  "x \<in> set_spmf (extend_state_oracle oracle s y) \<longleftrightarrow>
+   fst (snd x) = fst s \<and> (fst x, snd (snd x)) \<in> set_spmf (oracle (snd s) y)"
+  by(auto 4 4 simp add: extend_state_oracle_def split_beta intro: rev_image_eqI prod.expand)
+
+lemma extend_state_oracle_plus_oracle: 
+  "extend_state_oracle (plus_oracle oracle1 oracle2) = plus_oracle (extend_state_oracle oracle1) (extend_state_oracle oracle2)"
+proof ((rule ext)+; goal_cases)
+  case (1 s q)
+  then show ?case by (cases s; cases q) (simp_all add: apfst_def spmf.map_comp o_def split_def)
+qed
+
+
+definition stateless_callee :: "('a \<Rightarrow> ('b, 'out, 'in) gpv) \<Rightarrow> ('s \<Rightarrow> 'a \<Rightarrow> ('b \<times> 's, 'out, 'in) gpv)" where
+  "stateless_callee callee s = map_gpv (\<lambda>b. (b, s)) id \<circ> callee"
+
+lemma stateless_callee_parametric': 
+  includes lifting_syntax notes [transfer_rule] = map_gpv_parametric' shows
+    "((A ===> rel_gpv'' B C R) ===> S ===> A ===> (rel_gpv'' (rel_prod B S) C R))
+   stateless_callee stateless_callee"
+  unfolding stateless_callee_def by transfer_prover
+
+lemma id_oralce_alt_def: "id_oracle = stateless_callee (\<lambda>x. Pause x Done)"
+  by(simp add: id_oracle_def fun_eq_iff stateless_callee_def)
+
+context
+  fixes left :: "'s1 \<Rightarrow> 'x1 \<Rightarrow> ('y1 \<times> 's1, 'call1, 'ret1) gpv"
+    and right :: "'s2 \<Rightarrow> 'x2 \<Rightarrow> ('y2 \<times> 's2, 'call2, 'ret2) gpv"
+begin
+
+fun parallel_intercept :: "'s1 \<times> 's2 \<Rightarrow> 'x1 + 'x2 \<Rightarrow> (('y1 + 'y2) \<times> ('s1 \<times> 's2), 'call1 + 'call2, 'ret1 + 'ret2) gpv"
+  where
+    "parallel_intercept (s1, s2) (Inl a) = left_gpv (map_gpv (map_prod Inl (\<lambda>s1'. (s1', s2))) id (left s1 a))"
+  | "parallel_intercept (s1, s2) (Inr b) = right_gpv (map_gpv (map_prod Inr (Pair s1)) id (right s2 b))"
+
+end
+
+end
diff --git a/thys/CryptHOL/GPV_Expectation.thy b/thys/CryptHOL/GPV_Expectation.thy
--- a/thys/CryptHOL/GPV_Expectation.thy
+++ b/thys/CryptHOL/GPV_Expectation.thy
@@ -1,937 +1,1310 @@
 (* Title: GPV_Expectation.thy
   Author: Andreas Lochbihler, ETH Zurich *)
 
 subsection \<open>Expectation transformer semantics\<close>
 
 theory GPV_Expectation imports
-  Generative_Probabilistic_Value
+  Computational_Model
 begin
 
 lemma le_enn2realI: "\<lbrakk> ennreal x \<le> y; y = \<top> \<Longrightarrow> x \<le> 0 \<rbrakk> \<Longrightarrow> x \<le> enn2real y"
 by(cases y) simp_all
 
 lemma enn2real_leD: "\<lbrakk> enn2real x < y; x \<noteq> \<top> \<rbrakk> \<Longrightarrow> x < ennreal y"
 by(cases x)(simp_all add: ennreal_lessI)
 
 lemma ennreal_mult_le_self2I: "\<lbrakk> y > 0 \<Longrightarrow> x \<le> 1 \<rbrakk> \<Longrightarrow> x * y \<le> y" for x y :: ennreal
 apply(cases x; cases y)
 apply(auto simp add: top_unique ennreal_top_mult ennreal_mult[symmetric] intro: ccontr)
 using mult_left_le_one_le by force
 
 lemma ennreal_leI: "x \<le> enn2real y \<Longrightarrow> ennreal x \<le> y"
 by(cases y) simp_all
 
 lemma enn2real_INF: "\<lbrakk> A \<noteq> {}; \<forall>x\<in>A. f x < \<top> \<rbrakk> \<Longrightarrow> enn2real (INF x\<in>A. f x) = (INF x\<in>A. enn2real (f x))"
 apply(rule antisym)
  apply(rule cINF_greatest)
   apply simp
  apply(rule enn2real_mono)
   apply(erule INF_lower)
  apply simp
 apply(rule le_enn2realI)
  apply simp_all
 apply(rule INF_greatest)
 apply(rule ennreal_leI)
 apply(rule cINF_lower)
 apply(rule bdd_belowI[where m=0])
 apply auto
 done
 
 lemma monotone_times_ennreal1: "monotone (\<le>) (\<le>) (\<lambda>x. x * y :: ennreal)"
 by(auto intro!: monotoneI mult_right_mono)
 
 lemma monotone_times_ennreal2: "monotone (\<le>) (\<le>) (\<lambda>x. y * x :: ennreal)"
 by(auto intro!: monotoneI mult_left_mono)
 
 lemma mono2mono_times_ennreal[THEN lfp.mono2mono2, cont_intro, simp]:
   shows monotone_times_ennreal: "monotone (rel_prod (\<le>) (\<le>)) (\<le>) (\<lambda>(x, y). x * y :: ennreal)"
 by(simp add: monotone_times_ennreal1 monotone_times_ennreal2)
 
 lemma mcont_times_ennreal1: "mcont Sup (\<le>) Sup (\<le>) (\<lambda>y. x * y :: ennreal)"
 by(auto intro!: mcontI contI simp add: SUP_mult_left_ennreal[symmetric])
 
 lemma mcont_times_ennreal2: "mcont Sup (\<le>) Sup (\<le>) (\<lambda>y. y * x :: ennreal)"
 by(subst mult.commute)(rule mcont_times_ennreal1)
 
 lemma mcont2mcont_times_ennreal [cont_intro, simp]:
   "\<lbrakk> mcont lub ord Sup (\<le>) (\<lambda>x. f x);
     mcont lub ord Sup (\<le>) (\<lambda>x. g x) \<rbrakk>
   \<Longrightarrow> mcont lub ord Sup (\<le>) (\<lambda>x. f x * g x :: ennreal)"
 by(best intro: ccpo.mcont2mcont'[OF complete_lattice_ccpo] mcont_times_ennreal1 mcont_times_ennreal2 ccpo.mcont_const[OF complete_lattice_ccpo])
 
 lemma ereal_INF_cmult: "0 < c \<Longrightarrow> (INF i\<in>I. c * f i) = ereal c * (INF i\<in>I. f i)"
 using ereal_Inf_cmult[where P="\<lambda>x. \<exists>i\<in>I. x = f i", of c]
 by(rule box_equals)(auto intro!: arg_cong[where f="Inf"] arg_cong2[where f="(*)"])
 
 lemma ereal_INF_multc: "0 < c \<Longrightarrow> (INF i\<in>I. f i * c) = (INF i\<in>I. f i) * ereal c"
 using ereal_INF_cmult[of c f I] by(simp add: mult.commute)
 
 lemma INF_mult_left_ennreal: 
   assumes "I = {} \<Longrightarrow> c \<noteq> 0"
   and "\<lbrakk> c = \<top>; \<exists>i\<in>I. f i > 0 \<rbrakk> \<Longrightarrow> \<exists>p>0. \<forall>i\<in>I. f i \<ge> p"
   shows "c * (INF i\<in>I. f i) = (INF i\<in>I. c * f i ::ennreal)"
 proof -
   consider (empty) "I = {}" | (top) "c = \<top>" | (zero) "c = 0" | (normal) "I \<noteq> {}" "c \<noteq> \<top>" "c \<noteq> 0" by auto
   then show ?thesis
   proof cases
     case empty then show ?thesis by(simp add: ennreal_mult_top assms(1))
   next
     case top
     show ?thesis
     proof(cases "\<exists>i\<in>I. f i > 0")
       case True
       with assms(2) top obtain p where "p > 0" and p: "\<And>i. i \<in> I \<Longrightarrow> f i \<ge> p" by auto
       then have *: "\<And>i. i \<in> I \<Longrightarrow> f i > 0" by(auto intro: less_le_trans)
       note \<open>0 < p\<close> also from p have "p \<le> (INF i\<in>I. f i)" by(rule INF_greatest)
       finally show ?thesis using top by(auto simp add: ennreal_top_mult dest: *)
     next
       case False
       hence "f i = 0" if "i \<in> I" for i using that by auto
       thus ?thesis using top by(simp add: INF_constant ennreal_mult_top)
     qed
   next
     case zero
     then show ?thesis using assms(1) by(auto simp add: INF_constant)
   next
     case normal
     then show ?thesis including ennreal.lifting
       apply transfer
       subgoal for I c f by(cases c)(simp_all add: top_ereal_def ereal_INF_cmult)
       done
   qed
 qed
 
 lemma pmf_map_spmf_None: "pmf (map_spmf f p) None = pmf p None"
 by(simp add: pmf_None_eq_weight_spmf)
 
 lemma nn_integral_try_spmf:
   "nn_integral (measure_spmf (try_spmf p q)) f = nn_integral (measure_spmf p) f + nn_integral (measure_spmf q) f * pmf p None"
 by(simp add: nn_integral_measure_spmf spmf_try_spmf distrib_right nn_integral_add ennreal_mult mult.assoc nn_integral_cmult)
   (simp add: mult.commute)
 
 lemma INF_UNION: "(INF z \<in> \<Union>x\<in>A. B x. f z) = (INF x\<in>A. INF z\<in>B x. f z)" for f :: "_ \<Rightarrow> 'b::complete_lattice"
 by(auto intro!: antisym INF_greatest intro: INF_lower2)
 
 
 definition nn_integral_spmf :: "'a spmf \<Rightarrow> ('a \<Rightarrow> ennreal) \<Rightarrow> ennreal" where
   "nn_integral_spmf p = nn_integral (measure_spmf p)"
 
 lemma nn_integral_spmf_parametric [transfer_rule]:
   includes lifting_syntax
   shows "(rel_spmf A ===> (A ===> (=)) ===> (=)) nn_integral_spmf nn_integral_spmf"
   unfolding nn_integral_spmf_def
 proof(rule rel_funI)+
   fix p q and f g :: "_ \<Rightarrow> ennreal"
   assume pq: "rel_spmf A p q" and fg: "(A ===> (=)) f g"
   from pq obtain pq where pq [rule_format]: "\<forall>(x, y)\<in>set_spmf pq. A x y"
     and p: "p = map_spmf fst pq" and q: "q = map_spmf snd pq"
     by(cases rule: rel_spmfE) auto
   show "nn_integral (measure_spmf p) f = nn_integral (measure_spmf q) g"
     by(simp add: p q)(auto simp add: nn_integral_measure_spmf spmf_eq_0_set_spmf dest!: pq rel_funD[OF fg] intro: ennreal_mult_left_cong intro!: nn_integral_cong)
 qed
 
 lemma weight_spmf_mcont2mcont [THEN lfp.mcont2mcont, cont_intro]:
   shows weight_spmf_mcont: "mcont (lub_spmf) (ord_spmf (=)) Sup (\<le>) (\<lambda>p. ennreal (weight_spmf p))"
 apply(simp add: mcont_def cont_def weight_spmf_def measure_spmf.emeasure_eq_measure[symmetric] emeasure_lub_spmf)
 apply(rule call_mono[THEN lfp.mono2mono])
 apply(unfold fun_ord_def)
 apply(rule monotone_emeasure_spmf[unfolded le_fun_def])
 done
 
 lemma mono2mono_nn_integral_spmf [THEN lfp.mono2mono, cont_intro]:
   shows monotone_nn_integral_spmf: "monotone (ord_spmf (=)) (\<le>) (\<lambda>p. integral\<^sup>N (measure_spmf p) f)"
 by(rule monotoneI)(auto simp add: nn_integral_measure_spmf intro!: nn_integral_mono mult_right_mono dest: monotone_spmf[THEN monotoneD])
 
 lemma cont_nn_integral_spmf:
   "cont lub_spmf (ord_spmf (=)) Sup (\<le>) (\<lambda>p :: 'a spmf. nn_integral (measure_spmf p) f)"
 proof
   fix Y :: "'a spmf set"
   assume Y: "Complete_Partial_Order.chain (ord_spmf (=)) Y" "Y \<noteq> {}"
   let ?M = "count_space (set_spmf (lub_spmf Y))"
   have "nn_integral (measure_spmf (lub_spmf Y)) f = \<integral>\<^sup>+ x. ennreal (spmf (lub_spmf Y) x) * f x \<partial>?M"
     by(simp add: nn_integral_measure_spmf')
   also have "\<dots> = \<integral>\<^sup>+ x. (SUP p\<in>Y. ennreal (spmf p x) * f x) \<partial>?M"
     by(simp add: spmf_lub_spmf Y ennreal_SUP[OF SUP_spmf_neq_top'] SUP_mult_right_ennreal)
   also have "\<dots> = (SUP p\<in>Y. \<integral>\<^sup>+ x. ennreal (spmf p x) * f x \<partial>?M)"
   proof(rule nn_integral_monotone_convergence_SUP_countable)
     show "Complete_Partial_Order.chain (\<le>) ((\<lambda>i x. ennreal (spmf i x) * f x) ` Y)"
       using Y(1) by(rule chain_imageI)(auto simp add: le_fun_def intro!: mult_right_mono dest: monotone_spmf[THEN monotoneD])
   qed(simp_all add: Y(2))
   also have "\<dots> = (SUP p\<in>Y. nn_integral (measure_spmf p) f)"
     by(auto simp add: nn_integral_measure_spmf Y nn_integral_count_space_indicator set_lub_spmf spmf_eq_0_set_spmf split: split_indicator intro!: SUP_cong nn_integral_cong)
   finally show "nn_integral (measure_spmf (lub_spmf Y)) f = (SUP p\<in>Y. nn_integral (measure_spmf p) f)" .
 qed
 
 lemma mcont2mcont_nn_integral_spmf [THEN lfp.mcont2mcont, cont_intro]:
   shows mcont_nn_integral_spmf:
   "mcont lub_spmf (ord_spmf (=)) Sup (\<le>) (\<lambda>p :: 'a spmf. nn_integral (measure_spmf p) f)"
 by(rule mcontI)(simp_all add: cont_nn_integral_spmf)
  
 
 lemma nn_integral_mono2mono:
   assumes "\<And>x. x \<in> space M \<Longrightarrow> monotone ord (\<le>) (\<lambda>f. F f x)"
   shows "monotone ord (\<le>) (\<lambda>f. nn_integral M (F f))"
   by(rule monotoneI nn_integral_mono monotoneD[OF assms])+
 
 lemma nn_integral_mono_lfp [partial_function_mono]:
   \<comment> \<open>@{ML Partial_Function.mono_tac} does not like conditional assumptions (more precisely the case splitter)\<close>
   "(\<And>x. lfp.mono_body (\<lambda>f. F f x)) \<Longrightarrow> lfp.mono_body (\<lambda>f. nn_integral M (F f))"
   by(rule nn_integral_mono2mono)
 
 lemma INF_mono_lfp [partial_function_mono]:
   "(\<And>x. lfp.mono_body (\<lambda>f. F f x)) \<Longrightarrow> lfp.mono_body (\<lambda>f. INF x\<in>M. F f x)"
   by(rule monotoneI)(blast dest: monotoneD intro: INF_mono)
 
 lemmas parallel_fixp_induct_1_2 = parallel_fixp_induct_uc[
   of _ _ _ _ "\<lambda>x. x" _ "\<lambda>x. x" "case_prod" _ "curry",
   where P="\<lambda>f g. P f (curry g)",
   unfolded case_prod_curry curry_case_prod curry_K,
   OF _ _ _ _ _ _ refl refl]
   for P
 
 lemma monotone_ennreal_add1: "monotone (\<le>) (\<le>) (\<lambda>x. x + y :: ennreal)"
 by(auto intro!: monotoneI)
 
 lemma monotone_ennreal_add2: "monotone (\<le>) (\<le>) (\<lambda>y. x + y :: ennreal)"
 by(auto intro!: monotoneI)
 
 lemma mono2mono_ennreal_add[THEN lfp.mono2mono2, cont_intro, simp]:
   shows monotone_eadd: "monotone (rel_prod (\<le>) (\<le>)) (\<le>) (\<lambda>(x, y). x + y :: ennreal)"
 by(simp add: monotone_ennreal_add1 monotone_ennreal_add2)
 
 lemma ennreal_add_partial_function_mono [partial_function_mono]:
   "\<lbrakk> monotone (fun_ord (\<le>)) (\<le>) f; monotone (fun_ord (\<le>)) (\<le>) g \<rbrakk>
   \<Longrightarrow> monotone (fun_ord (\<le>)) (\<le>) (\<lambda>x. f x + g x :: ennreal)"
 by(rule mono2mono_ennreal_add)
 
 context
   fixes fail :: ennreal
   and \<I> :: "('out, 'ret) \<I>"
   and f :: "'a \<Rightarrow> ennreal"
   notes [[function_internals]]
 begin
 
 partial_function (lfp_strong) expectation_gpv :: "('a, 'out, 'ret) gpv \<Rightarrow> ennreal" where
   "expectation_gpv gpv = 
   (\<integral>\<^sup>+ generat. (case generat of Pure x \<Rightarrow> f x 
               | IO out c \<Rightarrow> INF r\<in>responses_\<I> \<I> out. expectation_gpv (c r)) \<partial>measure_spmf (the_gpv gpv))
    + fail * pmf (the_gpv gpv) None"
 
 lemma expectation_gpv_fixp_induct [case_names adm bottom step]:
   assumes "lfp.admissible P"
     and "P (\<lambda>_. 0)"
     and "\<And>expectation_gpv'. \<lbrakk> \<And>gpv. expectation_gpv' gpv \<le> expectation_gpv gpv; P expectation_gpv' \<rbrakk> \<Longrightarrow>
          P (\<lambda>gpv. (\<integral>\<^sup>+ generat. (case generat of Pure x \<Rightarrow> f x | IO out c \<Rightarrow> INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<partial>measure_spmf (the_gpv gpv)) + fail * pmf (the_gpv gpv) None)"
   shows "P expectation_gpv"
   by(rule expectation_gpv.fixp_induct)(simp_all add: bot_ennreal_def assms fun_ord_def)
   
 lemma expectation_gpv_Done [simp]: "expectation_gpv (Done x) = f x"
   by(subst expectation_gpv.simps)(simp add: measure_spmf_return_spmf nn_integral_return)
 
 lemma expectation_gpv_Fail [simp]: "expectation_gpv Fail = fail"
   by(subst expectation_gpv.simps) simp
 
 lemma expectation_gpv_lift_spmf [simp]: 
   "expectation_gpv (lift_spmf p) = (\<integral>\<^sup>+ x. f x \<partial>measure_spmf p) + fail * pmf p None"
   by(subst expectation_gpv.simps)(auto simp add: o_def pmf_map vimage_def measure_pmf_single)
 
 lemma expectation_gpv_Pause [simp]:
   "expectation_gpv (Pause out c) = (INF r\<in>responses_\<I> \<I> out. expectation_gpv (c r))"
   by(subst expectation_gpv.simps)(simp add: measure_spmf_return_spmf nn_integral_return)
 
 end
 
 context begin
 private definition "weight_spmf' p = weight_spmf p"
 lemmas weight_spmf'_parametric = weight_spmf_parametric[folded weight_spmf'_def]
 lemma expectation_gpv_parametric':
   includes lifting_syntax notes weight_spmf'_parametric[transfer_rule]
   shows "((=) ===> rel_\<I> C R ===> (A ===> (=)) ===> rel_gpv'' A C R ===> (=)) expectation_gpv expectation_gpv"
   unfolding expectation_gpv_def
   apply(rule rel_funI)
   apply(rule rel_funI)
   apply(rule rel_funI)
   apply(rule fixp_lfp_parametric_eq[OF expectation_gpv.mono expectation_gpv.mono])
   apply(fold nn_integral_spmf_def Set.is_empty_def pmf_None_eq_weight_spmf[symmetric])
   apply(simp only: weight_spmf'_def[symmetric])
   subgoal premises [transfer_rule] supply the_gpv_parametric'[transfer_rule] by transfer_prover
   done
 end
 
 lemma expectation_gpv_parametric [transfer_rule]:
   includes lifting_syntax
   shows "((=) ===> rel_\<I> C (=) ===> (A ===> (=)) ===> rel_gpv A C ===> (=)) expectation_gpv expectation_gpv"
 using expectation_gpv_parametric'[of C "(=)" A] by(simp add: rel_gpv_conv_rel_gpv'')
 
 lemma expectation_gpv_cong:
   fixes fail fail'
   assumes fail: "fail = fail'"
   and \<I>: "\<I> = \<I>'"
   and gpv: "gpv = gpv'"
   and f: "\<And>x. x \<in> results_gpv \<I>' gpv' \<Longrightarrow> f x = g x"
   shows "expectation_gpv fail \<I> f gpv = expectation_gpv fail' \<I>' g gpv'"
 using f unfolding \<I>[symmetric] gpv[symmetric] fail[symmetric]
 proof(induction arbitrary: gpv rule: parallel_fixp_induct_1_1[OF complete_lattice_partial_function_definitions complete_lattice_partial_function_definitions expectation_gpv.mono expectation_gpv.mono expectation_gpv_def expectation_gpv_def, case_names adm bottom step])
   case adm show ?case by simp
   case bottom show ?case by simp
   case (step expectation_gpv' expectation_gpv'') show ?case
     by(rule arg_cong2[where f="(+)"] nn_integral_cong_AE)+(clarsimp simp add: step.prems results_gpv.intros split!: generat.split intro!: INF_cong[OF refl] step.IH)+
 qed
 
 lemma expectation_gpv_cong_fail:
   "colossless_gpv \<I> gpv \<Longrightarrow> expectation_gpv fail \<I> f gpv = expectation_gpv fail' \<I> f gpv" for fail
 proof(induction arbitrary: gpv rule: parallel_fixp_induct_1_1[OF complete_lattice_partial_function_definitions complete_lattice_partial_function_definitions expectation_gpv.mono expectation_gpv.mono expectation_gpv_def expectation_gpv_def, case_names adm bottom step])
   case adm show ?case by simp
   case bottom show ?case by simp
   case (step expectation_gpv' expectation_gpv'')
   from colossless_gpv_lossless_spmfD[OF step.prems] show ?case
     by(auto simp add: lossless_iff_pmf_None intro!: nn_integral_cong_AE INF_cong step.IH intro: colossless_gpv_continuationD[OF step.prems] split: generat.split)
 qed
 
 lemma expectation_gpv_mono:
   fixes fail fail'
   assumes fail: "fail \<le> fail'"
   and fg: "f \<le> g"
   shows "expectation_gpv fail \<I> f gpv \<le> expectation_gpv fail' \<I> g gpv"
 proof(induction arbitrary: gpv rule: parallel_fixp_induct_1_1[OF complete_lattice_partial_function_definitions complete_lattice_partial_function_definitions expectation_gpv.mono expectation_gpv.mono expectation_gpv_def expectation_gpv_def, case_names adm bottom step])
   case adm show ?case by simp
   case bottom show ?case by simp
   case (step expectation_gpv' expectation_gpv'')
   show ?case
     by(intro add_mono mult_right_mono fail nn_integral_mono_AE)
       (auto split: generat.split simp add: fg[THEN le_funD] INF_mono rev_bexI step.IH)
 qed
 
 lemma expectation_gpv_mono_strong:
   fixes fail fail'
   assumes fail: "\<not> colossless_gpv \<I> gpv \<Longrightarrow> fail \<le> fail'"
   and fg: "\<And>x. x \<in> results_gpv \<I> gpv \<Longrightarrow> f x \<le> g x"
   shows "expectation_gpv fail \<I> f gpv \<le> expectation_gpv fail' \<I> g gpv"
 proof -
   let ?fail = "if colossless_gpv \<I> gpv then fail' else fail"
     and ?f = "\<lambda>x. if x \<in> results_gpv \<I> gpv then f x else g x"
   have "expectation_gpv fail \<I> f gpv = expectation_gpv ?fail \<I> f gpv" by(simp cong: expectation_gpv_cong_fail)
   also have "\<dots> = expectation_gpv ?fail \<I> ?f gpv" by(rule expectation_gpv_cong; simp)
   also have "\<dots> \<le> expectation_gpv fail' \<I> g gpv" using assms by(simp add: expectation_gpv_mono le_fun_def)
   finally show ?thesis .
 qed
 
 lemma expectation_gpv_bind [simp]:
   fixes \<I> f g fail
   defines "expectation_gpv1 \<equiv> expectation_gpv fail \<I> f"
   and "expectation_gpv2 \<equiv> expectation_gpv fail \<I> (expectation_gpv fail \<I> f \<circ> g)"
   shows "expectation_gpv1 (bind_gpv gpv g) = expectation_gpv2 gpv" (is "?lhs = ?rhs")
 proof(rule antisym)
   note [simp] = case_map_generat o_def
     and [cong del] = generat.case_cong_weak
   show "?lhs \<le> ?rhs" unfolding expectation_gpv1_def
   proof(induction arbitrary: gpv rule: expectation_gpv_fixp_induct)
     case adm show ?case by simp
     case bottom show ?case by simp
     case (step expectation_gpv')
     show ?case unfolding expectation_gpv2_def
       apply(rewrite bind_gpv.sel)
       apply(simp add: map_spmf_bind_spmf measure_spmf_bind)
       apply(rewrite nn_integral_bind[where B="measure_spmf _"])
         apply(simp_all add: space_subprob_algebra)
       apply(rewrite expectation_gpv.simps)
       apply(simp add: pmf_bind_spmf_None distrib_left nn_integral_eq_integral[symmetric] measure_spmf.integrable_const_bound[where B=1] pmf_le_1 nn_integral_cmult[symmetric] nn_integral_add[symmetric])
       apply(rule disjI2)
       apply(rule nn_integral_mono)
       apply(clarsimp split!: generat.split)
        apply(rewrite expectation_gpv.simps)
        apply simp
        apply(rule disjI2)
        apply(rule nn_integral_mono)
        apply(clarsimp split: generat.split)
        apply(rule INF_mono)
        apply(erule rev_bexI)
        apply(rule step.hyps)
       apply(clarsimp simp add: measure_spmf_return_spmf nn_integral_return)
       apply(rule INF_mono)
       apply(erule rev_bexI)
       apply(rule step.IH[unfolded expectation_gpv2_def o_def])
       done
   qed
   show "?rhs \<le> ?lhs" unfolding expectation_gpv2_def
   proof(induction arbitrary: gpv rule: expectation_gpv_fixp_induct)
     case adm show ?case by simp
     case bottom show ?case by simp
     case (step expectation_gpv')
     show ?case unfolding expectation_gpv1_def
       apply(rewrite in "_ \<le> \<hole>" expectation_gpv.simps)
       apply(rewrite bind_gpv.sel)
       apply(simp add: measure_spmf_bind)
       apply(rewrite nn_integral_bind[where B="measure_spmf _"])
         apply(simp_all add: space_subprob_algebra)
       apply(simp add: pmf_bind_spmf_None distrib_left nn_integral_eq_integral[symmetric] measure_spmf.integrable_const_bound[where B=1] pmf_le_1 nn_integral_cmult[symmetric] nn_integral_add[symmetric])
       apply(rule disjI2)
       apply(rule nn_integral_mono)
       apply(clarsimp split!: generat.split)
        apply(rewrite expectation_gpv.simps)
-       apply(simp cong del: if_weak_cong)
+       apply(simp cong del: if_weak_cong add: generat.map_comp id_def[symmetric] generat.map_id)
       apply(simp add: measure_spmf_return_spmf nn_integral_return)
       apply(rule INF_mono)
       apply(erule rev_bexI)
       apply(rule step.IH[unfolded expectation_gpv1_def])
       done
   qed
 qed
 
 lemma expectation_gpv_try_gpv [simp]:
   fixes fail \<I> f gpv'
   defines "expectation_gpv1 \<equiv> expectation_gpv fail \<I> f"
     and "expectation_gpv2 \<equiv> expectation_gpv (expectation_gpv fail \<I> f gpv') \<I> f"
   shows "expectation_gpv1 (try_gpv gpv gpv') = expectation_gpv2 gpv"
 proof(rule antisym)
   show "expectation_gpv1 (try_gpv gpv gpv') \<le> expectation_gpv2 gpv" unfolding expectation_gpv1_def
   proof(induction arbitrary: gpv rule: expectation_gpv_fixp_induct)
     case adm show ?case by simp
     case bottom show ?case by simp
     case step [unfolded expectation_gpv2_def]: (step expectation_gpv')
     show ?case unfolding expectation_gpv2_def
       apply(rewrite expectation_gpv.simps)
       apply(rewrite in "_ \<le> _ + \<hole>" expectation_gpv.simps)
       apply(simp add: pmf_map_spmf_None nn_integral_try_spmf o_def generat.map_comp case_map_generat distrib_right cong del: generat.case_cong_weak)
       apply(simp add: mult_ac add.assoc ennreal_mult)
       apply(intro disjI2 add_mono mult_left_mono nn_integral_mono; clarsimp split: generat.split intro!: INF_mono step elim!: rev_bexI)
       done
   qed
   show "expectation_gpv2 gpv \<le> expectation_gpv1 (try_gpv gpv gpv')" unfolding expectation_gpv2_def
   proof(induction arbitrary: gpv rule: expectation_gpv_fixp_induct)
     case adm show ?case by simp
     case bottom show ?case by simp
     case step [unfolded expectation_gpv1_def]: (step expectation_gpv')
     show ?case unfolding expectation_gpv1_def
       apply(rewrite in "_ \<le> \<hole>" expectation_gpv.simps)
       apply(rewrite in "\<hole> \<le> _" expectation_gpv.simps)
-      apply(simp add: pmf_map_spmf_None nn_integral_try_spmf o_def generat.map_comp case_map_generat distrib_left ennreal_mult mult_ac cong del: generat.case_cong_weak)
+      apply(simp add: pmf_map_spmf_None nn_integral_try_spmf o_def generat.map_comp case_map_generat distrib_left ennreal_mult mult_ac id_def[symmetric] generat.map_id cong del: generat.case_cong_weak)
       apply(rule disjI2 nn_integral_mono)+
       apply(clarsimp split: generat.split intro!: INF_mono step(2) elim!: rev_bexI)
       done
   qed
 qed
 
 lemma expectation_gpv_restrict_gpv:
   "\<I> \<turnstile>g gpv \<surd> \<Longrightarrow> expectation_gpv fail \<I> f (restrict_gpv \<I> gpv) = expectation_gpv fail \<I> f gpv" for fail
 proof(induction arbitrary: gpv rule: expectation_gpv_fixp_induct)
   case adm show ?case by simp
   case bottom show ?case by simp
   case (step expectation_gpv'')
   show ?case
     apply(simp add: pmf_map vimage_def)
     apply(rule arg_cong2[where f="(+)"])
     subgoal by(clarsimp simp add: measure_spmf_def nn_integral_distr nn_integral_restrict_space step.IH WT_gpv_ContD[OF step.prems] AE_measure_pmf_iff in_set_spmf[symmetric] WT_gpv_OutD[OF step.prems] split!: option.split generat.split intro!: nn_integral_cong_AE INF_cong[OF refl])
     apply(simp add: measure_pmf_single[symmetric])
     apply(rule arg_cong[where f="\<lambda>x. _ * ennreal x"])
     apply(rule measure_pmf.finite_measure_eq_AE)
     apply(auto simp add: AE_measure_pmf_iff in_set_spmf[symmetric] intro: WT_gpv_OutD[OF step.prems] split: option.split_asm generat.split_asm if_split_asm)
     done
 qed
 
 lemma expectation_gpv_const_le: "\<I> \<turnstile>g gpv \<surd> \<Longrightarrow> expectation_gpv fail \<I> (\<lambda>_. c) gpv \<le> max c fail" for fail
 proof(induction arbitrary: gpv rule: expectation_gpv_fixp_induct)
   case adm show ?case by simp
   case bottom show ?case by simp
   case (step expectation_gpv')
   have "integral\<^sup>N (measure_spmf (the_gpv gpv)) (case_generat (\<lambda>x. c) (\<lambda>out c. INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r))) \<le> integral\<^sup>N (measure_spmf (the_gpv gpv)) (\<lambda>_. max c fail)"
     using step.prems
     by(intro nn_integral_mono_AE)(auto 4 4 split: generat.split intro: INF_lower2 step.IH WT_gpv_ContD[OF step.prems] dest!: WT_gpv_OutD simp add: in_outs_\<I>_iff_responses_\<I>)
   also have "\<dots> + fail * pmf (the_gpv gpv) None \<le> \<dots> + max c fail * pmf (the_gpv gpv) None"
     by(intro add_left_mono mult_right_mono) simp_all
   also have "\<dots> \<le> max c fail"
     by(simp add: measure_spmf.emeasure_eq_measure pmf_None_eq_weight_spmf ennreal_minus[symmetric])
       (metis (no_types, hide_lams) add_diff_eq_iff_ennreal distrib_left ennreal_le_1 le_max_iff_disj max.cobounded2 mult.commute mult.left_neutral weight_spmf_le_1)
   finally show ?case by(simp add: add_mono)
 qed
 
 lemma expectation_gpv_no_results:
    "\<lbrakk> results_gpv \<I> gpv = {}; \<I> \<turnstile>g gpv \<surd> \<rbrakk> \<Longrightarrow> expectation_gpv 0 \<I> f gpv = 0"
 proof(induction arbitrary: gpv rule: expectation_gpv_fixp_induct)
   case adm show ?case by simp
   case bottom show ?case by simp
   case (step expectation_gpv')
   have "results_gpv \<I> (c x) = {}" if "IO out c \<in> set_spmf (the_gpv gpv)" "x \<in> responses_\<I> \<I> out"
     for out c x using that step.prems(1) by(auto intro: results_gpv.IO)
   then show ?case using step.prems
     by(auto 4 4 intro!: nn_integral_zero' split: generat.split intro: results_gpv.Pure cong: INF_cong simp add: step.IH WT_gpv_ContD INF_constant in_outs_\<I>_iff_responses_\<I> dest: WT_gpv_OutD)
 qed
 
 lemma expectation_gpv_cmult:
   fixes fail
   assumes "0 < c" and "c \<noteq> \<top>"
   shows "c * expectation_gpv fail \<I> f gpv = expectation_gpv (c * fail) \<I> (\<lambda>x. c * f x) gpv"
 proof(induction arbitrary: gpv rule: parallel_fixp_induct_1_1[OF complete_lattice_partial_function_definitions complete_lattice_partial_function_definitions expectation_gpv.mono expectation_gpv.mono expectation_gpv_def expectation_gpv_def, case_names adm bottom step])
   case adm show ?case by simp
   case bottom show ?case by(simp add: bot_ennreal_def)
   case (step expectation_gpv' expectation_gpv'')
   show ?case using assms
     apply(simp add: distrib_left mult_ac nn_integral_cmult[symmetric] generat.case_distrib[where h="(*) _"])
     apply(subst INF_mult_left_ennreal, simp_all add: step.IH)
     done
 qed
 
 lemma expectation_gpv_le_exec_gpv:
   assumes callee: "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> lossless_spmf (callee s x)"
     and WT_gpv: "\<I> \<turnstile>g gpv \<surd>"
     and WT_callee: "\<And>s. \<I> \<turnstile>c callee s \<surd>"
   shows "expectation_gpv 0 \<I> f gpv \<le> \<integral>\<^sup>+ (x, s). f x \<partial>measure_spmf (exec_gpv callee gpv s)"
 using WT_gpv
 proof(induction arbitrary: gpv s rule: parallel_fixp_induct_1_2[OF complete_lattice_partial_function_definitions partial_function_definitions_spmf expectation_gpv.mono exec_gpv.mono expectation_gpv_def exec_gpv_def, case_names adm bottom step])
   case adm show ?case by simp
   case bottom show ?case by(simp add: bot_ennreal_def)
   case (step expectation_gpv'' exec_gpv')
   have *: "(INF r\<in>responses_\<I> \<I> out. expectation_gpv'' (c r)) \<le> \<integral>\<^sup>+ (x, s). f x \<partial>measure_spmf (bind_spmf (callee s out) (\<lambda>(r, s'). exec_gpv' (c r) s'))" (is "?lhs \<le> ?rhs")
     if "IO out c \<in> set_spmf (the_gpv gpv)" for out c 
   proof -
     from step.prems that have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpvD)
     have "?lhs = \<integral>\<^sup>+ _. ?lhs \<partial>measure_spmf (callee s out)" using callee[OF out, THEN lossless_weight_spmfD]
       by(simp add: measure_spmf.emeasure_eq_measure)
     also have "\<dots> \<le> \<integral>\<^sup>+ (r, s'). expectation_gpv'' (c r) \<partial>measure_spmf (callee s out)"
       by(rule nn_integral_mono_AE)(auto intro: WT_calleeD[OF WT_callee _ out] INF_lower)
     also have "\<dots> \<le> \<integral>\<^sup>+ (r, s'). \<integral>\<^sup>+ (x, _). f x \<partial>measure_spmf (exec_gpv' (c r) s') \<partial>measure_spmf (callee s out)"
       by(rule nn_integral_mono_AE)(auto intro!: step.IH intro: WT_gpv_ContD[OF step.prems that] WT_calleeD[OF WT_callee _ out])
     also have "\<dots> = ?rhs" by(simp add: measure_spmf_bind split_def nn_integral_bind[where B="measure_spmf _"] o_def space_subprob_algebra)
     finally show ?thesis .
   qed
   show ?case
     by(simp add: measure_spmf_bind nn_integral_bind[where B="measure_spmf _"] space_subprob_algebra)
       (simp split!: generat.split add: measure_spmf_return_spmf nn_integral_return * nn_integral_mono_AE)
 qed
 
 definition weight_gpv :: "('out, 'ret) \<I> \<Rightarrow> ('a, 'out, 'ret) gpv \<Rightarrow> real"
   where "weight_gpv \<I> gpv = enn2real (expectation_gpv 0 \<I> (\<lambda>_. 1) gpv)"
 
 lemma weight_gpv_Done [simp]: "weight_gpv \<I> (Done x) = 1"
 by(simp add: weight_gpv_def)
 
 lemma weight_gpv_Fail [simp]: "weight_gpv \<I> Fail = 0"
 by(simp add: weight_gpv_def)
 
 lemma weight_gpv_lift_spmf [simp]: "weight_gpv \<I> (lift_spmf p) = weight_spmf p"
 by(simp add: weight_gpv_def measure_spmf.emeasure_eq_measure)
 
 lemma weight_gpv_Pause [simp]:
   "(\<And>r. r \<in> responses_\<I> \<I> out \<Longrightarrow> \<I> \<turnstile>g c r \<surd>)
    \<Longrightarrow> weight_gpv \<I> (Pause out c) = (if out \<in> outs_\<I> \<I> then INF r\<in>responses_\<I> \<I> out. weight_gpv \<I> (c r) else 0)"
 apply(clarsimp simp add: weight_gpv_def in_outs_\<I>_iff_responses_\<I>)
 apply(erule enn2real_INF)
 apply(clarsimp simp add: expectation_gpv_const_le[THEN le_less_trans])
 done
 
 lemma weight_gpv_nonneg: "0 \<le> weight_gpv \<I> gpv"
 by(simp add: weight_gpv_def)
 
 lemma weight_gpv_le_1: "\<I> \<turnstile>g gpv \<surd> \<Longrightarrow> weight_gpv \<I> gpv \<le> 1"
 using expectation_gpv_const_le[of \<I> gpv 0 1] by(simp add: weight_gpv_def enn2real_leI max_def)
 
 theorem weight_exec_gpv:
   assumes callee: "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> lossless_spmf (callee s x)"
     and WT_gpv: "\<I> \<turnstile>g gpv \<surd>"
     and WT_callee: "\<And>s. \<I> \<turnstile>c callee s \<surd>"
   shows "weight_gpv \<I> gpv \<le> weight_spmf (exec_gpv callee gpv s)"
 proof -
   have "expectation_gpv 0 \<I> (\<lambda>_. 1) gpv \<le> \<integral>\<^sup>+ (x, s). 1 \<partial>measure_spmf (exec_gpv callee gpv s)"
     using assms by(rule expectation_gpv_le_exec_gpv)
   also have "\<dots> = weight_spmf (exec_gpv callee gpv s)"
     by(simp add: split_def measure_spmf.emeasure_eq_measure)
   finally show ?thesis by(simp add: weight_gpv_def enn2real_leI)
 qed
 
 lemma (in callee_invariant_on) weight_exec_gpv:
   assumes callee: "\<And>s x. \<lbrakk> x \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> lossless_spmf (callee s x)"
   and WT_gpv: "\<I> \<turnstile>g gpv \<surd>"
   and I: "I s"
   shows "weight_gpv \<I> gpv \<le> weight_spmf (exec_gpv callee gpv s)"
 including lifting_syntax
 proof -
   { assume "\<exists>(Rep :: 's' \<Rightarrow> 's) Abs. type_definition Rep Abs {s. I s}"
     then obtain Rep :: "'s' \<Rightarrow> 's" and Abs where td: "type_definition Rep Abs {s. I s}" by blast
     then interpret td: type_definition Rep Abs "{s. I s}" .
     define cr where "cr \<equiv> \<lambda>x y. x = Rep y"
     have [transfer_rule]: "bi_unique cr" "right_total cr" using td cr_def by(rule typedef_bi_unique typedef_right_total)+
     have [transfer_domain_rule]: "Domainp cr = I" using type_definition_Domainp[OF td cr_def] by simp
     
     let ?C = "eq_onp (\<lambda>x. x \<in> outs_\<I> \<I>)"
 
     define callee' where "callee' \<equiv> (Rep ---> id ---> map_spmf (map_prod id Abs)) callee"
     have [transfer_rule]: "(cr ===> ?C ===> rel_spmf (rel_prod (=) cr)) callee callee'"
       by(auto simp add: callee'_def rel_fun_def cr_def spmf_rel_map prod.rel_map td.Abs_inverse eq_onp_def intro!: rel_spmf_reflI intro: td.Rep[simplified] dest: callee_invariant)
     define s' where "s' \<equiv> Abs s"
     have [transfer_rule]: "cr s s'" using I by(simp add: cr_def s'_def td.Abs_inverse)
 
     have [transfer_rule]: "rel_\<I> ?C (=) \<I> \<I>"
       by(rule rel_\<I>I)(auto simp add: rel_set_eq set_relator_eq_onp eq_onp_same_args dest: eq_onp_to_eq)
     note [transfer_rule] = bi_unique_eq_onp bi_unique_eq
 
     define gpv' where "gpv' \<equiv> restrict_gpv \<I> gpv"
     have [transfer_rule]: "rel_gpv (=) ?C gpv' gpv'"
       by(fold eq_onp_top_eq_eq)(auto simp add: gpv.rel_eq_onp eq_onp_same_args pred_gpv_def gpv'_def dest: in_outs'_restrict_gpvD)
 
     define weight_spmf' :: "('c \<times> 's') spmf \<Rightarrow> real" where "weight_spmf' \<equiv> weight_spmf"
     define weight_spmf'' :: "('c \<times> 's) spmf \<Rightarrow> real" where "weight_spmf'' \<equiv> weight_spmf"
     have [transfer_rule]: "(rel_spmf (rel_prod (=) cr) ===> (=)) weight_spmf'' weight_spmf'"
       by(simp add: weight_spmf'_def weight_spmf''_def weight_spmf_parametric)
 
     have [rule_format]: "\<And>s. \<forall>x \<in> outs_\<I> \<I>. lossless_spmf (callee' s x)"
       by(transfer)(blast intro: callee)
     moreover have "\<I> \<turnstile>g gpv' \<surd>" by(simp add: gpv'_def)
     moreover have "\<And>s. \<I> \<turnstile>c callee' s \<surd>" by transfer(rule WT_callee)
     ultimately have **: "weight_gpv \<I> gpv' \<le> weight_spmf' (exec_gpv callee' gpv' s')"
       unfolding weight_spmf'_def by(rule weight_exec_gpv)
     have [transfer_rule]: "((=) ===> ?C ===> rel_spmf (rel_prod (=) (=))) callee callee"
       by(simp add: rel_fun_def eq_onp_def prod.rel_eq)
     have "weight_gpv \<I> gpv' \<le> weight_spmf'' (exec_gpv callee gpv' s)" using ** by transfer
     also have "exec_gpv callee gpv' s = exec_gpv callee gpv s"
       unfolding gpv'_def using WT_gpv I by(rule exec_gpv_restrict_gpv_invariant)
     also have "weight_gpv \<I> gpv' = weight_gpv \<I> gpv" using WT_gpv 
       by(simp add: gpv'_def expectation_gpv_restrict_gpv weight_gpv_def)
     finally have ?thesis by(simp add: weight_spmf''_def) }
   from this[cancel_type_definition] I show ?thesis by blast
 qed
 
 subsection \<open>Probabilistic termination\<close>
 
 definition pgen_lossless_gpv :: "ennreal \<Rightarrow> ('c, 'r) \<I> \<Rightarrow> ('a, 'c, 'r) gpv \<Rightarrow> bool"
 where "pgen_lossless_gpv fail \<I> gpv = (expectation_gpv fail \<I> (\<lambda>_. 1) gpv = 1)" for fail
 
 abbreviation plossless_gpv :: "('c, 'r) \<I> \<Rightarrow> ('a, 'c, 'r) gpv \<Rightarrow> bool"
 where "plossless_gpv \<equiv> pgen_lossless_gpv 0"
 
 abbreviation pfinite_gpv :: "('c, 'r) \<I> \<Rightarrow> ('a, 'c, 'r) gpv \<Rightarrow> bool"
 where "pfinite_gpv \<equiv> pgen_lossless_gpv 1"
 
 lemma pgen_lossless_gpvI [intro?]: "expectation_gpv fail \<I> (\<lambda>_. 1) gpv = 1 \<Longrightarrow> pgen_lossless_gpv fail \<I> gpv" for fail
 by(simp add: pgen_lossless_gpv_def)
 
 lemma pgen_lossless_gpvD: "pgen_lossless_gpv fail \<I> gpv \<Longrightarrow> expectation_gpv fail \<I> (\<lambda>_. 1) gpv = 1" for fail
 by(simp add: pgen_lossless_gpv_def)
 
 lemma lossless_imp_plossless_gpv:
   assumes "lossless_gpv \<I> gpv" "\<I> \<turnstile>g gpv \<surd>"
   shows "plossless_gpv \<I> gpv"
 proof
   show "expectation_gpv 0 \<I> (\<lambda>_. 1) gpv = 1" using assms
   proof(induction rule: lossless_WT_gpv_induct)
     case (lossless_gpv p)
     have "expectation_gpv 0 \<I> (\<lambda>_. 1) (GPV p) = nn_integral (measure_spmf p) (case_generat (\<lambda>_. 1) (\<lambda>out c. INF r\<in>responses_\<I> \<I> out. 1))"
       by(subst expectation_gpv.simps)(clarsimp split: generat.split cong: INF_cong simp add: lossless_gpv.IH intro!: nn_integral_cong_AE)
     also have "\<dots> = nn_integral (measure_spmf p) (\<lambda>_. 1)"
       by(intro nn_integral_cong_AE)(auto split: generat.split dest!: lossless_gpv.hyps(2) simp add: in_outs_\<I>_iff_responses_\<I>)
     finally show ?case by(simp add: measure_spmf.emeasure_eq_measure lossless_weight_spmfD lossless_gpv.hyps(1))
   qed
 qed
 
 lemma finite_imp_pfinite_gpv:
   assumes "finite_gpv \<I> gpv" "\<I> \<turnstile>g gpv \<surd>"
   shows "pfinite_gpv \<I> gpv"
 proof
   show "expectation_gpv 1 \<I> (\<lambda>_. 1) gpv = 1" using assms
   proof(induction rule: finite_gpv_induct)
     case (finite_gpv gpv)
     then have "expectation_gpv 1 \<I> (\<lambda>_. 1) gpv = nn_integral (measure_spmf (the_gpv gpv)) (case_generat (\<lambda>_. 1) (\<lambda>out c. INF r\<in>responses_\<I> \<I> out. 1)) + pmf (the_gpv gpv) None"
       by(subst expectation_gpv.simps)(clarsimp intro!: nn_integral_cong_AE INF_cong[OF refl] split!: generat.split simp add: WT_gpv_ContD)
     also have "\<dots> = nn_integral (measure_spmf (the_gpv gpv)) (\<lambda>_. 1) + pmf (the_gpv gpv) None"
       by(intro arg_cong2[where f="(+)"] nn_integral_cong_AE)
         (auto split: generat.split dest!: WT_gpv_OutD[OF finite_gpv.prems] simp add: in_outs_\<I>_iff_responses_\<I>)
     finally show ?case
       by(simp add: measure_spmf.emeasure_eq_measure ennreal_plus[symmetric] del: ennreal_plus)
         (simp add: pmf_None_eq_weight_spmf)
   qed
 qed
 
 lemma plossless_gpv_lossless_spmfD:
   assumes lossless: "plossless_gpv \<I> gpv"
   and WT: "\<I> \<turnstile>g gpv \<surd>"
   shows "lossless_spmf (the_gpv gpv)"
 proof -
   have "1 = expectation_gpv 0 \<I> (\<lambda>_. 1) gpv"
     using lossless by(auto dest: pgen_lossless_gpvD simp add: weight_gpv_def)
   also have "\<dots> = \<integral>\<^sup>+ generat. (case generat of Pure x \<Rightarrow> 1 | IO out c \<Rightarrow> INF r\<in>responses_\<I> \<I> out. expectation_gpv 0 \<I> (\<lambda>_. 1) (c r)) \<partial>measure_spmf (the_gpv gpv)"
     by(subst expectation_gpv.simps)(auto)
   also have "\<dots> \<le> \<integral>\<^sup>+ generat. (case generat of Pure x \<Rightarrow> 1 | IO out c \<Rightarrow> 1) \<partial>measure_spmf (the_gpv gpv)"
     apply(rule nn_integral_mono_AE)
     apply(clarsimp split: generat.split)
     apply(frule WT_gpv_OutD[OF WT])
     using expectation_gpv_const_le[of \<I> _ 0 1]
     apply(auto simp add: in_outs_\<I>_iff_responses_\<I> max_def intro: INF_lower2 WT_gpv_ContD[OF WT] dest: WT_gpv_OutD[OF WT])
     done
   also have "\<dots> = weight_spmf (the_gpv gpv)"
     by(auto simp add: weight_spmf_eq_nn_integral_spmf nn_integral_measure_spmf intro!: nn_integral_cong split: generat.split)
   finally show ?thesis using weight_spmf_le_1[of "the_gpv gpv"] by(simp add: lossless_spmf_def)
 qed
 
 lemma
   shows plossless_gpv_ContD:
   "\<lbrakk> plossless_gpv \<I> gpv; IO out c \<in> set_spmf (the_gpv gpv); input \<in> responses_\<I> \<I> out; \<I> \<turnstile>g gpv \<surd> \<rbrakk>
   \<Longrightarrow> plossless_gpv \<I> (c input)"
   and pfinite_gpv_ContD:
   "\<lbrakk> pfinite_gpv \<I> gpv; IO out c \<in> set_spmf (the_gpv gpv); input \<in> responses_\<I> \<I> out; \<I> \<turnstile>g gpv \<surd> \<rbrakk>
   \<Longrightarrow> pfinite_gpv \<I> (c input)"
 proof(rule_tac [!] pgen_lossless_gpvI, rule_tac [!] antisym[rotated], rule_tac ccontr, rule_tac [3] ccontr)
   assume IO: "IO out c \<in> set_spmf (the_gpv gpv)"
     and input: "input \<in> responses_\<I> \<I> out"
     and WT: "\<I> \<turnstile>g gpv \<surd>"
   from WT IO input have WT': "\<I> \<turnstile>g c input \<surd>" by(rule WT_gpv_ContD)
   from expectation_gpv_const_le[OF this, of 0 1] expectation_gpv_const_le[OF this, of 1 1]
   show "expectation_gpv 0 \<I> (\<lambda>_. 1) (c input) \<le> 1"
     and "expectation_gpv 1 \<I> (\<lambda>_. 1) (c input) \<le> 1" by(simp_all add: max_def)
 
   have less: "expectation_gpv fail \<I> (\<lambda>_. 1) gpv < weight_spmf (the_gpv gpv) + fail * pmf (the_gpv gpv) None"
     if fail: "fail \<le> 1" and *: "\<not> 1 \<le> expectation_gpv fail \<I> (\<lambda>_. 1) (c input)" for fail :: ennreal
   proof -
     have "expectation_gpv fail \<I> (\<lambda>_. 1) gpv = (\<integral>\<^sup>+ generat. (case generat of Pure x \<Rightarrow> 1 | IO out c \<Rightarrow> INF r\<in>responses_\<I> \<I> out. expectation_gpv fail \<I> (\<lambda>_. 1) (c r)) * spmf (the_gpv gpv) generat * indicator (UNIV - {IO out c}) generat + (INF r\<in>responses_\<I> \<I> out. expectation_gpv fail \<I> (\<lambda>_. 1) (c r)) * spmf (the_gpv gpv) (IO out c) * indicator {IO out c} generat \<partial>count_space UNIV) + fail * pmf (the_gpv gpv) None"
       by(subst expectation_gpv.simps)(auto simp add: nn_integral_measure_spmf mult.commute intro!: nn_integral_cong split: split_indicator generat.split)
     also have "\<dots> = (\<integral>\<^sup>+ generat. (case generat of Pure x \<Rightarrow> 1 | IO out c \<Rightarrow> INF r\<in>responses_\<I> \<I> out. expectation_gpv fail \<I> (\<lambda>_. 1) (c r)) * spmf (the_gpv gpv) generat * indicator (UNIV - {IO out c}) generat \<partial>count_space UNIV) +
       (INF r\<in>responses_\<I> \<I> out. expectation_gpv fail \<I> (\<lambda>_. 1) (c r)) * spmf (the_gpv gpv) (IO out c) + fail * pmf (the_gpv gpv) None" (is "_ = ?rest + ?cr + _")
       by(subst nn_integral_add) simp_all
     also from calculation expectation_gpv_const_le[OF WT, of fail 1] fail have fin: "?rest \<noteq> \<infinity>"
       by(auto simp add: top_add top_unique max_def split: if_split_asm)
     have "?cr \<le> expectation_gpv fail \<I> (\<lambda>_. 1) (c input) * spmf (the_gpv gpv) (IO out c)"
       by(rule mult_right_mono INF_lower[OF input])+ simp
     also have "?rest + \<dots> < ?rest + 1 * ennreal (spmf (the_gpv gpv) (IO out c))"
       unfolding ennreal_add_left_cancel_less using * IO
       by(intro conjI fin ennreal_mult_strict_right_mono)(simp_all add: not_le weight_gpv_def in_set_spmf_iff_spmf)
     also have "?rest \<le> \<integral>\<^sup>+ generat. spmf (the_gpv gpv) generat * indicator (UNIV - {IO out c}) generat \<partial>count_space UNIV"
       apply(rule nn_integral_mono)
       apply(clarsimp split: generat.split split_indicator)
       apply(rule ennreal_mult_le_self2I)
       apply simp
       subgoal premises prems for out' c'
         apply(subgoal_tac "IO out' c' \<in> set_spmf (the_gpv gpv)")
          apply(frule WT_gpv_OutD[OF WT])
          apply(simp add: in_outs_\<I>_iff_responses_\<I>)
          apply safe
          apply(erule notE)
          apply(rule INF_lower2, assumption)
          apply(rule expectation_gpv_const_le[THEN order_trans])
           apply(erule (1) WT_gpv_ContD[OF WT])
          apply(simp add: fail)
         using prems by(simp add: in_set_spmf_iff_spmf)
       done
     also have "\<dots> + 1 * ennreal (spmf (the_gpv gpv) (IO out c)) = 
       (\<integral>\<^sup>+ generat. spmf (the_gpv gpv) generat * indicator (UNIV - {IO out c}) generat + ennreal (spmf (the_gpv gpv) (IO out c)) * indicator {IO out c} generat \<partial>count_space UNIV)"
       by(subst nn_integral_add)(simp_all)
     also have "\<dots> = \<integral>\<^sup>+ generat. spmf (the_gpv gpv) generat \<partial>count_space UNIV" 
       by(auto intro!: nn_integral_cong split: split_indicator)
     also have "\<dots> = weight_spmf (the_gpv gpv)" by(simp add: nn_integral_spmf measure_spmf.emeasure_eq_measure space_measure_spmf)
     finally show ?thesis using fail
       by(fastforce simp add: top_unique add_mono ennreal_plus[symmetric] ennreal_mult_eq_top_iff)
   qed
   
   show False if *: "\<not> 1 \<le> expectation_gpv 0 \<I> (\<lambda>_. 1) (c input)" and lossless: "plossless_gpv \<I> gpv"
     using less[OF _ *] plossless_gpv_lossless_spmfD[OF lossless WT] lossless[THEN pgen_lossless_gpvD]
     by(simp add: lossless_spmf_def)
 
   show False if *: "\<not> 1 \<le> expectation_gpv 1 \<I> (\<lambda>_. 1) (c input)" and finite: "pfinite_gpv \<I> gpv"
     using less[OF _ *] finite[THEN pgen_lossless_gpvD] by(simp add: ennreal_plus[symmetric] del: ennreal_plus)(simp add: pmf_None_eq_weight_spmf)
 qed
 
 lemma plossless_iff_colossless_pfinite:
   assumes WT: "\<I> \<turnstile>g gpv \<surd>"
   shows "plossless_gpv \<I> gpv \<longleftrightarrow> colossless_gpv \<I> gpv \<and> pfinite_gpv \<I> gpv"
 proof(intro iffI conjI; (elim conjE)?)
   assume *: "plossless_gpv \<I> gpv"
   show "colossless_gpv \<I> gpv" using * WT
   proof(coinduction arbitrary: gpv)
     case (colossless_gpv gpv)
     have ?lossless_spmf using colossless_gpv by(rule plossless_gpv_lossless_spmfD)
     moreover have ?continuation using colossless_gpv
       by(auto intro: plossless_gpv_ContD WT_gpv_ContD)
     ultimately show ?case ..
   qed
 
   show "pfinite_gpv \<I> gpv" unfolding pgen_lossless_gpv_def
   proof(rule antisym)
     from expectation_gpv_const_le[OF WT, of 1 1] show "expectation_gpv 1 \<I> (\<lambda>_. 1) gpv \<le> 1" by simp
     have "1 = expectation_gpv 0 \<I> (\<lambda>_. 1) gpv" using * by(simp add: pgen_lossless_gpv_def)
     also have "\<dots> \<le> expectation_gpv 1 \<I> (\<lambda>_. 1) gpv" by(rule expectation_gpv_mono) simp_all
     finally show "1 \<le> \<dots>" .
   qed
 next
   show "plossless_gpv \<I> gpv" if "colossless_gpv \<I> gpv" and "pfinite_gpv \<I> gpv" using that
     by(simp add: pgen_lossless_gpv_def cong: expectation_gpv_cong_fail)
 qed
 
 lemma pgen_lossless_gpv_Done [simp]: "pgen_lossless_gpv fail \<I> (Done x)" for fail
 by(simp add: pgen_lossless_gpv_def)
 
 lemma pgen_lossless_gpv_Fail [simp]: "pgen_lossless_gpv fail \<I> Fail \<longleftrightarrow> fail = 1" for fail
 by(simp add: pgen_lossless_gpv_def)
 
 lemma pgen_lossless_gpv_PauseI [simp, intro!]: 
   "\<lbrakk> out \<in> outs_\<I> \<I>; \<And>r. r \<in> responses_\<I> \<I> out \<Longrightarrow> pgen_lossless_gpv fail \<I> (c r) \<rbrakk>
    \<Longrightarrow> pgen_lossless_gpv fail \<I> (Pause out c)" for fail
 by(simp add: pgen_lossless_gpv_def weight_gpv_def in_outs_\<I>_iff_responses_\<I>)
 
 lemma pgen_lossless_gpv_bindI [simp, intro!]:
   "\<lbrakk> pgen_lossless_gpv fail \<I> gpv; \<And>x. x \<in> results_gpv \<I> gpv \<Longrightarrow> pgen_lossless_gpv fail \<I> (f x) \<rbrakk>
   \<Longrightarrow> pgen_lossless_gpv fail \<I> (bind_gpv gpv f)" for fail
 by(simp add: pgen_lossless_gpv_def weight_gpv_def o_def cong: expectation_gpv_cong)
 
 lemma pgen_lossless_gpv_lift_spmf [simp]: 
   "pgen_lossless_gpv fail \<I> (lift_spmf p) \<longleftrightarrow> lossless_spmf p \<or> fail = 1" for fail
 apply(cases fail)
 subgoal
   by(simp add: pgen_lossless_gpv_def lossless_spmf_def measure_spmf.emeasure_eq_measure pmf_None_eq_weight_spmf ennreal_minus ennreal_mult[symmetric] weight_spmf_le_1 ennreal_plus[symmetric] del: ennreal_plus)
     (metis add_diff_cancel_left' diff_add_cancel eq_iff_diff_eq_0 mult_cancel_right1)
 subgoal by(simp add: pgen_lossless_gpv_def measure_spmf.emeasure_eq_measure ennreal_top_mult lossless_spmf_def add_top weight_spmf_conv_pmf_None)
 done
 
 lemma expectation_gpv_top_pfinite:
   assumes "pfinite_gpv \<I> gpv"
   shows "expectation_gpv \<top> \<I> (\<lambda>_. \<top>) gpv = \<top>"
 proof(rule ccontr)
   assume *: "\<not> ?thesis"
   have "1 = expectation_gpv 1 \<I> (\<lambda>_. 1) gpv" using assms by(simp add: pgen_lossless_gpv_def)
   also have "\<dots> \<le> expectation_gpv \<top> \<I> (\<lambda>_. \<top>) gpv" by(rule expectation_gpv_mono)(simp_all add: le_fun_def)
   also have "\<dots> = 0"  using expectation_gpv_cmult[of "2" \<top> \<I> "\<lambda>_. \<top>" gpv] *
     by(simp add: ennreal_mult_top) (metis ennreal_mult_cancel_left mult.commute mult_numeral_1_right not_gr_zero numeral_eq_one_iff semiring_norm(85) zero_neq_numeral)
   finally show False by simp
 qed
 
 lemma pfinite_INF_le_expectation_gpv:
   fixes fail \<I> gpv f
   defines "c \<equiv> min (INF x\<in>results_gpv \<I> gpv. f x) fail"
   assumes fin: "pfinite_gpv \<I> gpv"
   shows "c \<le> expectation_gpv fail \<I> f gpv" (is "?lhs \<le> ?rhs")
 proof(cases "c > 0")
   case True
   have "c = c * expectation_gpv 1 \<I> (\<lambda>_. 1) gpv" using assms by(simp add: pgen_lossless_gpv_def)
   also have "\<dots> = expectation_gpv c \<I> (\<lambda>_. c) gpv" using fin True
     by(cases "c = \<top>")(simp_all add: expectation_gpv_top_pfinite ennreal_top_mult expectation_gpv_cmult, simp add: pgen_lossless_gpv_def)
   also have "\<dots> \<le> ?rhs" by(rule expectation_gpv_mono_strong)(auto simp add: c_def min_def intro: INF_lower2)
   finally show ?thesis .
 qed simp
 
 lemma plossless_INF_le_expectation_gpv:
   fixes fail
   assumes "plossless_gpv \<I> gpv" and "\<I> \<turnstile>g gpv \<surd>"
   shows "(INF x\<in>results_gpv \<I> gpv. f x) \<le> expectation_gpv fail \<I> f gpv" (is "?lhs \<le> ?rhs")
 proof -
   from assms have fin: "pfinite_gpv \<I> gpv" and co: "colossless_gpv \<I> gpv"
     by(simp_all add: plossless_iff_colossless_pfinite)
   have "?lhs \<le> min ?lhs \<top>" by(simp add: min_def)
   also have "\<dots> \<le> expectation_gpv \<top> \<I> f gpv" using fin by(rule pfinite_INF_le_expectation_gpv)
   also have "\<dots> = ?rhs" using co by(simp add: expectation_gpv_cong_fail)
   finally show ?thesis .
 qed
 
 
 lemma expectation_gpv_le_inline:
   fixes \<I>'
   defines "expectation_gpv2 \<equiv> expectation_gpv 0 \<I>'"
   assumes callee: "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> plossless_gpv \<I>' (callee s x)"
     and callee': "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> results_gpv \<I>' (callee s x) \<subseteq> responses_\<I> \<I> x \<times> UNIV"
     and WT_gpv: "\<I> \<turnstile>g gpv \<surd>"
     and WT_callee: "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> \<I>' \<turnstile>g callee s x \<surd>"
   shows "expectation_gpv 0 \<I> f gpv \<le> expectation_gpv2 (\<lambda>(x, s). f x) (inline callee gpv s)"
   using WT_gpv
 proof(induction arbitrary: gpv s rule: expectation_gpv_fixp_induct)
   case adm show ?case by simp
   case bottom show ?case by simp
   case (step expectation_gpv')
   { fix out c
     assume IO: "IO out c \<in> set_spmf (the_gpv gpv)"
     with step.prems have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpv_OutD)
     have "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) = \<integral>\<^sup>+ generat. (INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<partial>measure_spmf (the_gpv (callee s out))"
       using WT_callee[OF out, of s] callee[OF out, of s]
       by(clarsimp simp add: measure_spmf.emeasure_eq_measure plossless_iff_colossless_pfinite colossless_gpv_lossless_spmfD lossless_weight_spmfD)
     also have "\<dots> \<le> \<integral>\<^sup>+ generat. (case generat of Pure (x, s') \<Rightarrow>
             \<integral>\<^sup>+ xx. (case xx of Inl (x, _) \<Rightarrow> f x 
                | Inr (out', callee', rpv) \<Rightarrow> INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r, s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (rpv r) s')) (callee' r'))
             \<partial>measure_spmf (inline1 callee (c x) s')
          | IO out' rpv \<Rightarrow> INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r', s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (c r') s')) (rpv r'))
        \<partial>measure_spmf (the_gpv (callee s out))"
     proof(rule nn_integral_mono_AE; simp split!: generat.split)
       fix x s'
       assume Pure: "Pure (x, s') \<in> set_spmf (the_gpv (callee s out))"
       hence "(x, s') \<in> results_gpv \<I>' (callee s out)" by(rule results_gpv.Pure)
       with callee'[OF out, of s] have x: "x \<in> responses_\<I> \<I> out" by blast
       hence "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> expectation_gpv' (c x)" by(rule INF_lower)
       also have "\<dots> \<le> expectation_gpv2 (\<lambda>(x, s). f x) (inline callee (c x) s')"
         by(rule step.IH)(rule WT_gpv_ContD[OF step.prems(1) IO x] step.prems|assumption)+
       also have "\<dots> = \<integral>\<^sup>+ xx. (case xx of Inl (x, _) \<Rightarrow> f x 
                | Inr (out', callee', rpv) \<Rightarrow> INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r, s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (rpv r) s')) (callee' r'))
             \<partial>measure_spmf (inline1 callee (c x) s')"
         unfolding expectation_gpv2_def
         by(subst expectation_gpv.simps)(auto simp add: inline_sel split_def o_def intro!: nn_integral_cong split: generat.split sum.split)
       finally show "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> \<dots>" .
     next
       fix out' rpv
       assume IO': "IO out' rpv \<in> set_spmf (the_gpv (callee s out))"
       have "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> (INF (r, s')\<in>(\<Union>r'\<in>responses_\<I> \<I>' out'. results_gpv \<I>' (rpv r')). expectation_gpv' (c r))"
         using IO' callee'[OF out, of s] by(intro INF_mono)(auto intro: results_gpv.IO)
       also have "\<dots> = (INF r'\<in>responses_\<I> \<I>' out'. INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv' (c r))"
         by(simp add: INF_UNION)
       also have "\<dots> \<le> (INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r', s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (c r') s')) (rpv r'))"
       proof(rule INF_mono, rule bexI)
         fix r'
         assume r': "r' \<in> responses_\<I> \<I>' out'"
         have "(INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv' (c r)) \<le> (INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv2 (\<lambda>(x, s). f x) (inline callee (c r) s'))"
           using IO IO' step.prems out callee'[OF out, of s] r'
           by(auto intro!: INF_mono rev_bexI step.IH dest: WT_gpv_ContD intro: results_gpv.IO)
         also have "\<dots> \<le>  expectation_gpv 0 \<I>' (\<lambda>(r', s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (c r') s')) (rpv r')"
           unfolding expectation_gpv2_def using plossless_gpv_ContD[OF callee, OF out IO' r'] WT_callee[OF out, of s] IO' r'
           by(intro plossless_INF_le_expectation_gpv)(auto intro: WT_gpv_ContD)
         finally show "(INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv' (c r)) \<le> \<dots>" .
       qed
       finally show "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> \<dots>" .
     qed
     also note calculation }
   then show ?case unfolding expectation_gpv2_def
     apply(rewrite expectation_gpv.simps)
     apply(rewrite inline_sel)
     apply(simp add: o_def pmf_map_spmf_None)
     apply(rewrite sum.case_distrib[where h="case_generat _ _"])
     apply(simp cong del: sum.case_cong_weak)
     apply(simp add: split_beta o_def cong del: sum.case_cong_weak)
     apply(rewrite inline1.simps)
     apply(rewrite measure_spmf_bind)
     apply(rewrite nn_integral_bind[where B="measure_spmf _"])
       apply simp
      apply(simp add: space_subprob_algebra)
     apply(rule nn_integral_mono_AE)
     apply(clarsimp split!: generat.split)
      apply(simp add: measure_spmf_return_spmf nn_integral_return)
     apply(rewrite measure_spmf_bind)
     apply(simp add: nn_integral_bind[where B="measure_spmf _"] space_subprob_algebra)
     apply(subst generat.case_distrib[where h="measure_spmf"])
     apply(subst generat.case_distrib[where h="\<lambda>x. nn_integral x _"])
     apply(simp add: measure_spmf_return_spmf nn_integral_return split_def)
     done
 qed
 
 lemma plossless_inline:
   assumes lossless: "plossless_gpv \<I> gpv"
     and WT: "\<I> \<turnstile>g gpv \<surd>"
     and callee: "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> plossless_gpv \<I>' (callee s x)"
     and callee': "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> results_gpv \<I>' (callee s x) \<subseteq> responses_\<I> \<I> x \<times> UNIV"
     and WT_callee: "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> \<I>' \<turnstile>g callee s x \<surd>"
   shows "plossless_gpv \<I>' (inline callee gpv s)"
 unfolding pgen_lossless_gpv_def
 proof(rule antisym)
   have WT': "\<I>' \<turnstile>g inline callee gpv s \<surd>" using callee' WT_callee WT by(rule WT_gpv_inline)
   from expectation_gpv_const_le[OF WT', of 0 1]
   show "expectation_gpv 0 \<I>' (\<lambda>_. 1) (inline callee gpv s) \<le> 1" by(simp add: max_def)
 
   have "1 = expectation_gpv 0 \<I> (\<lambda>_. 1) gpv" using lossless by(simp add: pgen_lossless_gpv_def)
   also have "\<dots> \<le> expectation_gpv 0 \<I>' (\<lambda>_. 1) (inline callee gpv s)"
     by(rule expectation_gpv_le_inline[unfolded split_def]; rule callee callee' WT WT_callee)
   finally show "1 \<le> \<dots>" .
 qed
 
 lemma plossless_exec_gpv:
   assumes lossless: "plossless_gpv \<I> gpv"
     and WT: "\<I> \<turnstile>g gpv \<surd>"
     and callee: "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> lossless_spmf (callee s x)"
     and callee': "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> set_spmf (callee s x) \<subseteq> responses_\<I> \<I> x \<times> UNIV"
   shows "lossless_spmf (exec_gpv callee gpv s)"
 proof -
   have "plossless_gpv \<I>_full (inline (\<lambda>s x. lift_spmf (callee s x)) gpv s)"
     using lossless WT by(rule plossless_inline)(simp_all add: callee callee')
   from this[THEN plossless_gpv_lossless_spmfD] show ?thesis
     unfolding exec_gpv_conv_inline1 by(simp add: inline_sel)
 qed
 
+lemma expectation_gpv_\<I>_mono:
+  defines "expectation_gpv' \<equiv> expectation_gpv"
+  assumes le: "\<I> \<le> \<I>'"
+    and WT: "\<I> \<turnstile>g gpv \<surd>"
+  shows "expectation_gpv fail \<I> f gpv \<le> expectation_gpv' fail \<I>' f gpv"
+  using WT
+proof(induction arbitrary: gpv rule: expectation_gpv_fixp_induct)
+  case adm show ?case by simp
+  case bottom show ?case by simp
+  case step [unfolded expectation_gpv'_def]: (step expectation_gpv')
+  show ?case unfolding expectation_gpv'_def
+    by(subst expectation_gpv.simps)
+      (clarsimp intro!: add_mono nn_integral_mono_AE INF_mono split: generat.split
+        , auto intro!: bexI step add_mono nn_integral_mono_AE INF_mono split: generat.split dest: WT_gpvD[OF step.prems] intro!: step dest: responses_\<I>_mono[OF le])
+qed
+
+lemma pgen_lossless_gpv_mono:
+  assumes *: "pgen_lossless_gpv fail \<I> gpv"
+    and le: "\<I> \<le> \<I>'"
+    and WT: "\<I> \<turnstile>g gpv \<surd>"
+    and fail: "fail \<le> 1"
+  shows "pgen_lossless_gpv fail \<I>' gpv"
+  unfolding pgen_lossless_gpv_def
+proof(rule antisym)
+  from WT le have "\<I>' \<turnstile>g gpv \<surd>" by(rule WT_gpv_\<I>_mono)
+  from expectation_gpv_const_le[OF this, of fail 1] fail
+  show "expectation_gpv fail \<I>' (\<lambda>_. 1) gpv \<le> 1" by(simp add: max_def split: if_split_asm)
+  from expectation_gpv_\<I>_mono[OF le WT, of fail "\<lambda>_. 1"] *
+  show "expectation_gpv fail \<I>' (\<lambda>_. 1) gpv \<ge> 1" by(simp add: pgen_lossless_gpv_def)
+qed
+
+lemma plossless_gpv_mono:
+  "\<lbrakk> plossless_gpv \<I> gpv; \<I> \<le> \<I>'; \<I> \<turnstile>g gpv \<surd> \<rbrakk> \<Longrightarrow> plossless_gpv \<I>' gpv"
+  by(erule pgen_lossless_gpv_mono; simp)
+
+lemma pfinite_gpv_mono:
+  "\<lbrakk> pfinite_gpv \<I> gpv; \<I> \<le> \<I>'; \<I> \<turnstile>g gpv \<surd> \<rbrakk> \<Longrightarrow> pfinite_gpv \<I>' gpv"
+  by(erule pgen_lossless_gpv_mono; simp)
+
+lemma pgen_lossless_gpv_parametric': includes lifting_syntax shows
+  "((=) ===> rel_\<I> C R ===> rel_gpv'' A C R ===> (=)) pgen_lossless_gpv pgen_lossless_gpv"
+  unfolding pgen_lossless_gpv_def supply expectation_gpv_parametric'[transfer_rule] by transfer_prover
+
+lemma pgen_lossless_gpv_parametric: includes lifting_syntax shows
+  "((=) ===> rel_\<I> C (=) ===> rel_gpv A C ===> (=)) pgen_lossless_gpv pgen_lossless_gpv"
+  using pgen_lossless_gpv_parametric'[of C "(=)" A] by(simp add: rel_gpv_conv_rel_gpv'')
+
+lemma pgen_lossless_gpv_map_gpv_id [simp]:
+  "pgen_lossless_gpv fail \<I> (map_gpv f id gpv) = pgen_lossless_gpv fail \<I> gpv"
+  using pgen_lossless_gpv_parametric[of "BNF_Def.Grp UNIV id" "BNF_Def.Grp UNIV f"]
+  unfolding gpv.rel_Grp
+  by(auto simp add: eq_alt[symmetric] rel_\<I>_eq rel_fun_def Grp_iff)
+
+context raw_converter_invariant begin
+
+lemma expectation_gpv_le_inline:
+  defines "expectation_gpv2 \<equiv> expectation_gpv 0 \<I>'"
+  assumes callee: "\<And>s x. \<lbrakk> x \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> plossless_gpv \<I>' (callee s x)"
+    and WT_gpv: "\<I> \<turnstile>g gpv \<surd>"
+    and I: "I s"
+  shows "expectation_gpv 0 \<I> f gpv \<le> expectation_gpv2 (\<lambda>(x, s). f x) (inline callee gpv s)"
+  using WT_gpv I
+proof(induction arbitrary: gpv s rule: expectation_gpv_fixp_induct)
+  case adm show ?case by simp
+  case bottom show ?case by simp
+  case (step expectation_gpv')
+  { fix out c
+    assume IO: "IO out c \<in> set_spmf (the_gpv gpv)"
+    with step.prems (1) have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpv_OutD)
+    have "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) = \<integral>\<^sup>+ generat. (INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<partial>measure_spmf (the_gpv (callee s out))"
+      using WT_callee[OF out, of s] callee[OF out, of s] \<open>I s\<close>
+      by(clarsimp simp add: measure_spmf.emeasure_eq_measure plossless_iff_colossless_pfinite colossless_gpv_lossless_spmfD lossless_weight_spmfD)
+    also have "\<dots> \<le> \<integral>\<^sup>+ generat. (case generat of Pure (x, s') \<Rightarrow>
+            \<integral>\<^sup>+ xx. (case xx of Inl (x, _) \<Rightarrow> f x 
+               | Inr (out', callee', rpv) \<Rightarrow> INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r, s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (rpv r) s')) (callee' r'))
+            \<partial>measure_spmf (inline1 callee (c x) s')
+         | IO out' rpv \<Rightarrow> INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r', s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (c r') s')) (rpv r'))
+       \<partial>measure_spmf (the_gpv (callee s out))"
+    proof(rule nn_integral_mono_AE; simp split!: generat.split)
+      fix x s'
+      assume Pure: "Pure (x, s') \<in> set_spmf (the_gpv (callee s out))"
+      hence "(x, s') \<in> results_gpv \<I>' (callee s out)" by(rule results_gpv.Pure)
+      with results_callee[OF out, of s] \<open>I s\<close> have x: "x \<in> responses_\<I> \<I> out" and "I s'" by blast+
+      from x have "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> expectation_gpv' (c x)" by(rule INF_lower)
+      also have "\<dots> \<le> expectation_gpv2 (\<lambda>(x, s). f x) (inline callee (c x) s')"
+        by(rule step.IH)(rule WT_gpv_ContD[OF step.prems(1) IO x] step.prems \<open>I s'\<close>|assumption)+
+      also have "\<dots> = \<integral>\<^sup>+ xx. (case xx of Inl (x, _) \<Rightarrow> f x 
+               | Inr (out', callee', rpv) \<Rightarrow> INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r, s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (rpv r) s')) (callee' r'))
+            \<partial>measure_spmf (inline1 callee (c x) s')"
+        unfolding expectation_gpv2_def
+        by(subst expectation_gpv.simps)(auto simp add: inline_sel split_def o_def intro!: nn_integral_cong split: generat.split sum.split)
+      finally show "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> \<dots>" .
+    next
+      fix out' rpv
+      assume IO': "IO out' rpv \<in> set_spmf (the_gpv (callee s out))"
+      have "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> (INF (r, s')\<in>(\<Union>r'\<in>responses_\<I> \<I>' out'. results_gpv \<I>' (rpv r')). expectation_gpv' (c r))"
+        using IO' results_callee[OF out, of s] \<open>I s\<close> by(intro INF_mono)(auto intro: results_gpv.IO)
+      also have "\<dots> = (INF r'\<in>responses_\<I> \<I>' out'. INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv' (c r))"
+        by(simp add: INF_UNION)
+      also have "\<dots> \<le> (INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r', s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (c r') s')) (rpv r'))"
+      proof(rule INF_mono, rule bexI)
+        fix r'
+        assume r': "r' \<in> responses_\<I> \<I>' out'"
+        have "(INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv' (c r)) \<le> (INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv2 (\<lambda>(x, s). f x) (inline callee (c r) s'))"
+          using IO IO' step.prems out results_callee[OF out, of s] r'
+          by(auto intro!: INF_mono rev_bexI step.IH dest: WT_gpv_ContD intro: results_gpv.IO)
+        also have "\<dots> \<le>  expectation_gpv 0 \<I>' (\<lambda>(r', s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (c r') s')) (rpv r')"
+          unfolding expectation_gpv2_def using plossless_gpv_ContD[OF callee, OF out \<open>I s\<close> IO' r'] WT_callee[OF out \<open>I s\<close>] IO' r'
+          by(intro plossless_INF_le_expectation_gpv)(auto intro: WT_gpv_ContD)
+        finally show "(INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv' (c r)) \<le> \<dots>" .
+      qed
+      finally show "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> \<dots>" .
+    qed
+    also note calculation }
+  then show ?case unfolding expectation_gpv2_def
+    apply(rewrite expectation_gpv.simps)
+    apply(rewrite inline_sel)
+    apply(simp add: o_def pmf_map_spmf_None)
+    apply(rewrite sum.case_distrib[where h="case_generat _ _"])
+    apply(simp cong del: sum.case_cong_weak)
+    apply(simp add: split_beta o_def cong del: sum.case_cong_weak)
+    apply(rewrite inline1.simps)
+    apply(rewrite measure_spmf_bind)
+    apply(rewrite nn_integral_bind[where B="measure_spmf _"])
+      apply simp
+     apply(simp add: space_subprob_algebra)
+    apply(rule nn_integral_mono_AE)
+    apply(clarsimp split!: generat.split)
+     apply(simp add: measure_spmf_return_spmf nn_integral_return)
+    apply(rewrite measure_spmf_bind)
+    apply(simp add: nn_integral_bind[where B="measure_spmf _"] space_subprob_algebra)
+    apply(subst generat.case_distrib[where h="measure_spmf"])
+    apply(subst generat.case_distrib[where h="\<lambda>x. nn_integral x _"])
+    apply(simp add: measure_spmf_return_spmf nn_integral_return split_def)
+    done
+qed
+
+lemma plossless_inline:
+  assumes lossless: "plossless_gpv \<I> gpv"
+    and WT: "\<I> \<turnstile>g gpv \<surd>"
+    and callee: "\<And>s x. \<lbrakk> I s; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> plossless_gpv \<I>' (callee s x)"
+    and I: "I s"
+  shows "plossless_gpv \<I>' (inline callee gpv s)"
+  unfolding pgen_lossless_gpv_def
+proof(rule antisym)
+  have WT': "\<I>' \<turnstile>g inline callee gpv s \<surd>" using WT I by(rule WT_gpv_inline_invar)
+  from expectation_gpv_const_le[OF WT', of 0 1]
+  show "expectation_gpv 0 \<I>' (\<lambda>_. 1) (inline callee gpv s) \<le> 1" by(simp add: max_def)
+
+  have "1 = expectation_gpv 0 \<I> (\<lambda>_. 1) gpv" using lossless by(simp add: pgen_lossless_gpv_def)
+  also have "\<dots> \<le> expectation_gpv 0 \<I>' (\<lambda>_. 1) (inline callee gpv s)"
+    by(rule expectation_gpv_le_inline[unfolded split_def]; rule callee I WT)
+  finally show "1 \<le> \<dots>" .
+qed
+
 end
+
+lemma expectation_left_gpv [simp]:
+  "expectation_gpv fail (\<I> \<oplus>\<^sub>\<I> \<I>') f (left_gpv gpv) = expectation_gpv fail \<I> f gpv"
+proof(induction arbitrary: gpv rule: parallel_fixp_induct_1_1[OF complete_lattice_partial_function_definitions complete_lattice_partial_function_definitions expectation_gpv.mono expectation_gpv.mono expectation_gpv_def expectation_gpv_def, case_names adm bottom step])
+  case adm show ?case by simp
+  case bottom show ?case by simp
+  case (step expectation_gpv' expectation_gpv'')
+  show ?case
+    by (auto simp add: pmf_map_spmf_None o_def case_map_generat image_comp
+      split: generat.split intro!: nn_integral_cong_AE INF_cong step.IH)
+qed
+
+lemma expectation_right_gpv [simp]:
+  "expectation_gpv fail (\<I> \<oplus>\<^sub>\<I> \<I>') f (right_gpv gpv) = expectation_gpv fail \<I>' f gpv"
+proof(induction arbitrary: gpv rule: parallel_fixp_induct_1_1[OF complete_lattice_partial_function_definitions complete_lattice_partial_function_definitions expectation_gpv.mono expectation_gpv.mono expectation_gpv_def expectation_gpv_def, case_names adm bottom step])
+  case adm show ?case by simp
+  case bottom show ?case by simp
+  case (step expectation_gpv' expectation_gpv'')
+  show ?case
+    by (auto simp add: pmf_map_spmf_None o_def case_map_generat image_comp
+      split: generat.split intro!: nn_integral_cong_AE INF_cong step.IH)
+qed
+
+lemma pgen_lossless_left_gpv [simp]: "pgen_lossless_gpv fail (\<I> \<oplus>\<^sub>\<I> \<I>') (left_gpv gpv) = pgen_lossless_gpv fail \<I> gpv"
+  by(simp add: pgen_lossless_gpv_def)
+
+lemma pgen_lossless_right_gpv [simp]: "pgen_lossless_gpv fail (\<I> \<oplus>\<^sub>\<I> \<I>') (right_gpv gpv) = pgen_lossless_gpv fail \<I>' gpv"
+  by(simp add: pgen_lossless_gpv_def)
+
+lemma (in raw_converter_invariant) expectation_gpv_le_inline_invariant:
+  defines "expectation_gpv2 \<equiv> expectation_gpv 0 \<I>'"
+  assumes callee: "\<And>s x. \<lbrakk> x \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> plossless_gpv \<I>' (callee s x)"
+    and WT_gpv: "\<I> \<turnstile>g gpv \<surd>"
+    and I: "I s"
+  shows "expectation_gpv 0 \<I> f gpv \<le> expectation_gpv2 (\<lambda>(x, s). f x) (inline callee gpv s)"
+  using WT_gpv I
+proof(induction arbitrary: gpv s rule: expectation_gpv_fixp_induct)
+  case adm show ?case by simp
+  case bottom show ?case by simp
+  case (step expectation_gpv')
+  { fix out c
+    assume IO: "IO out c \<in> set_spmf (the_gpv gpv)"
+    with step.prems(1) have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpv_OutD)
+    have "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) = \<integral>\<^sup>+ generat. (INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<partial>measure_spmf (the_gpv (callee s out))"
+      using WT_callee[OF out, of s] callee[OF out, of s] step.prems(2)
+      by(clarsimp simp add: measure_spmf.emeasure_eq_measure plossless_iff_colossless_pfinite colossless_gpv_lossless_spmfD lossless_weight_spmfD)
+    also have "\<dots> \<le> \<integral>\<^sup>+ generat. (case generat of Pure (x, s') \<Rightarrow>
+            \<integral>\<^sup>+ xx. (case xx of Inl (x, _) \<Rightarrow> f x 
+               | Inr (out', callee', rpv) \<Rightarrow> INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r, s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (rpv r) s')) (callee' r'))
+            \<partial>measure_spmf (inline1 callee (c x) s')
+         | IO out' rpv \<Rightarrow> INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r', s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (c r') s')) (rpv r'))
+       \<partial>measure_spmf (the_gpv (callee s out))"
+    proof(rule nn_integral_mono_AE; simp split!: generat.split)
+      fix x s'
+      assume Pure: "Pure (x, s') \<in> set_spmf (the_gpv (callee s out))"
+      hence "(x, s') \<in> results_gpv \<I>' (callee s out)" by(rule results_gpv.Pure)
+      with results_callee[OF out step.prems(2)] have x: "x \<in> responses_\<I> \<I> out" and s': "I s'" by blast+
+      from this(1) have "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> expectation_gpv' (c x)" by(rule INF_lower)
+      also have "\<dots> \<le> expectation_gpv2 (\<lambda>(x, s). f x) (inline callee (c x) s')"
+        by(rule step.IH)(rule WT_gpv_ContD[OF step.prems(1) IO x] step.prems s'|assumption)+
+      also have "\<dots> = \<integral>\<^sup>+ xx. (case xx of Inl (x, _) \<Rightarrow> f x 
+               | Inr (out', callee', rpv) \<Rightarrow> INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r, s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (rpv r) s')) (callee' r'))
+            \<partial>measure_spmf (inline1 callee (c x) s')"
+        unfolding expectation_gpv2_def
+        by(subst expectation_gpv.simps)(auto simp add: inline_sel split_def o_def intro!: nn_integral_cong split: generat.split sum.split)
+      finally show "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> \<dots>" .
+    next
+      fix out' rpv
+      assume IO': "IO out' rpv \<in> set_spmf (the_gpv (callee s out))"
+      have "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> (INF (r, s')\<in>(\<Union>r'\<in>responses_\<I> \<I>' out'. results_gpv \<I>' (rpv r')). expectation_gpv' (c r))"
+        using IO' results_callee[OF out step.prems(2)] by(intro INF_mono)(auto intro: results_gpv.IO)
+      also have "\<dots> = (INF r'\<in>responses_\<I> \<I>' out'. INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv' (c r))"
+        by(simp add: INF_UNION)
+      also have "\<dots> \<le> (INF r'\<in>responses_\<I> \<I>' out'. expectation_gpv 0 \<I>' (\<lambda>(r', s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (c r') s')) (rpv r'))"
+      proof(rule INF_mono, rule bexI)
+        fix r'
+        assume r': "r' \<in> responses_\<I> \<I>' out'"
+        have "(INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv' (c r)) \<le> (INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv2 (\<lambda>(x, s). f x) (inline callee (c r) s'))"
+          using IO IO' step.prems out results_callee[OF out, of s] r'
+          by(auto intro!: INF_mono rev_bexI step.IH dest: WT_gpv_ContD intro: results_gpv.IO)
+        also have "\<dots> \<le>  expectation_gpv 0 \<I>' (\<lambda>(r', s'). expectation_gpv 0 \<I>' (\<lambda>(x, s). f x) (inline callee (c r') s')) (rpv r')"
+          unfolding expectation_gpv2_def using plossless_gpv_ContD[OF callee, OF out step.prems(2) IO' r'] WT_callee[OF out step.prems(2)] IO' r'
+          by(intro plossless_INF_le_expectation_gpv)(auto intro: WT_gpv_ContD)
+        finally show "(INF (r, s')\<in>results_gpv \<I>' (rpv r'). expectation_gpv' (c r)) \<le> \<dots>" .
+      qed
+      finally show "(INF r\<in>responses_\<I> \<I> out. expectation_gpv' (c r)) \<le> \<dots>" .
+    qed
+    also note calculation }
+  then show ?case unfolding expectation_gpv2_def
+    apply(rewrite expectation_gpv.simps)
+    apply(rewrite inline_sel)
+    apply(simp add: o_def pmf_map_spmf_None)
+    apply(rewrite sum.case_distrib[where h="case_generat _ _"])
+    apply(simp cong del: sum.case_cong_weak)
+    apply(simp add: split_beta o_def cong del: sum.case_cong_weak)
+    apply(rewrite inline1.simps)
+    apply(rewrite measure_spmf_bind)
+    apply(rewrite nn_integral_bind[where B="measure_spmf _"])
+      apply simp
+     apply(simp add: space_subprob_algebra)
+    apply(rule nn_integral_mono_AE)
+    apply(clarsimp split!: generat.split)
+     apply(simp add: measure_spmf_return_spmf nn_integral_return)
+    apply(rewrite measure_spmf_bind)
+    apply(simp add: nn_integral_bind[where B="measure_spmf _"] space_subprob_algebra)
+    apply(subst generat.case_distrib[where h="measure_spmf"])
+    apply(subst generat.case_distrib[where h="\<lambda>x. nn_integral x _"])
+    apply(simp add: measure_spmf_return_spmf nn_integral_return split_def)
+    done
+qed
+
+lemma (in raw_converter_invariant) plossless_inline_invariant:
+  assumes lossless: "plossless_gpv \<I> gpv"
+    and WT: "\<I> \<turnstile>g gpv \<surd>"
+    and callee: "\<And>s x. \<lbrakk> x \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> plossless_gpv \<I>' (callee s x)"
+    and I: "I s"
+  shows "plossless_gpv \<I>' (inline callee gpv s)"
+  unfolding pgen_lossless_gpv_def
+proof(rule antisym)
+  have WT': "\<I>' \<turnstile>g inline callee gpv s \<surd>" using WT I by(rule WT_gpv_inline_invar)
+  from expectation_gpv_const_le[OF WT', of 0 1]
+  show "expectation_gpv 0 \<I>' (\<lambda>_. 1) (inline callee gpv s) \<le> 1" by(simp add: max_def)
+
+  have "1 = expectation_gpv 0 \<I> (\<lambda>_. 1) gpv" using lossless by(simp add: pgen_lossless_gpv_def)
+  also have "\<dots> \<le> expectation_gpv 0 \<I>' (\<lambda>_. 1) (inline callee gpv s)"
+    by(rule expectation_gpv_le_inline[unfolded split_def]; rule callee WT WT_callee I)
+  finally show "1 \<le> \<dots>" .
+qed
+
+context callee_invariant_on begin
+
+lemma raw_converter_invariant: "raw_converter_invariant \<I> \<I>' (\<lambda>s x. lift_spmf (callee s x)) I"
+  by(unfold_locales)(auto dest: callee_invariant WT_callee WT_calleeD)
+
+lemma (in callee_invariant_on) plossless_exec_gpv:
+  assumes lossless: "plossless_gpv \<I> gpv"
+    and WT: "\<I> \<turnstile>g gpv \<surd>"
+    and callee: "\<And>s x. \<lbrakk> x \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> lossless_spmf (callee s x)"
+    and I: "I s"
+  shows "lossless_spmf (exec_gpv callee gpv s)"
+proof -
+  interpret raw_converter_invariant \<I> \<I>' "\<lambda>s x. lift_spmf (callee s x)" I for \<I>'
+    by(rule raw_converter_invariant)
+  have "plossless_gpv \<I>_full (inline (\<lambda>s x. lift_spmf (callee s x)) gpv s)"
+    using lossless WT by(rule plossless_inline)(simp_all add: callee I)
+  from this[THEN plossless_gpv_lossless_spmfD] show ?thesis
+    unfolding exec_gpv_conv_inline1 by(simp add: inline_sel)
+qed
+
+end
+
+lemma expectation_gpv_mk_lossless_gpv:
+  fixes \<I> y
+  defines "rhs \<equiv> expectation_gpv 0 \<I> (\<lambda>_. y)"
+  assumes WT: "\<I>' \<turnstile>g gpv \<surd>"
+    and outs: "outs_\<I> \<I> = outs_\<I> \<I>'"
+  shows "expectation_gpv 0 \<I>' (\<lambda>_. y) gpv \<le> rhs (mk_lossless_gpv (responses_\<I> \<I>') x gpv)"
+  using WT
+proof(induction arbitrary: gpv rule: expectation_gpv_fixp_induct)
+  case adm show ?case by simp
+  case bottom show ?case by simp
+  case step [unfolded rhs_def]: (step expectation_gpv')
+  show ?case using step.prems outs unfolding rhs_def
+    apply(subst expectation_gpv.simps)
+    apply(clarsimp intro!: nn_integral_mono_AE INF_mono split!: generat.split if_split)
+    subgoal
+      by(frule (1) WT_gpv_OutD)(auto simp add: in_outs_\<I>_iff_responses_\<I> intro!: bexI step.IH[unfolded rhs_def] dest: WT_gpv_ContD)
+    apply(frule (1) WT_gpv_OutD; clarsimp simp add: in_outs_\<I>_iff_responses_\<I> ex_in_conv[symmetric])
+    subgoal for out c input input'
+      using step.hyps[of "c input'"] expectation_gpv_const_le[of \<I>' "c input'" 0 y]
+      by- (drule (2) WT_gpv_ContD, fastforce intro: rev_bexI simp add: max_def)
+    done
+qed
+
+lemma plossless_gpv_mk_lossless_gpv:
+  assumes "plossless_gpv \<I> gpv"
+    and "\<I> \<turnstile>g gpv \<surd>"
+    and "outs_\<I> \<I> = outs_\<I> \<I>'"
+  shows "plossless_gpv \<I>' (mk_lossless_gpv (responses_\<I> \<I>) x gpv)"
+  using assms expectation_gpv_mk_lossless_gpv[OF assms(2), of \<I>' 1 x]
+  unfolding pgen_lossless_gpv_def
+  by -(rule antisym[OF expectation_gpv_const_le[THEN order_trans]]; simp add: WT_gpv_mk_lossless_gpv)
+
+lemma (in callee_invariant_on) exec_gpv_mk_lossless_gpv:
+  assumes "\<I> \<turnstile>g gpv \<surd>"
+    and "I s"
+  shows "exec_gpv callee (mk_lossless_gpv (responses_\<I> \<I>) x gpv) s = exec_gpv callee gpv s"
+  using assms
+proof(induction arbitrary: gpv s rule: exec_gpv_fixp_induct)
+  case adm show ?case by simp
+  case bottom show ?case by simp
+  case (step exec_gpv')
+  show ?case using step.prems WT_gpv_OutD[OF step.prems(1)]
+    by(clarsimp simp add: bind_map_spmf intro!: bind_spmf_cong[OF refl] split!: generat.split if_split)
+      (force intro!: step.IH dest: WT_callee[THEN WT_calleeD] WT_gpv_OutD callee_invariant WT_gpv_ContD)+
+qed
+
+
+lemma expectation_gpv_map_gpv' [simp]:
+  "expectation_gpv fail \<I> f (map_gpv' g h k gpv) =
+   expectation_gpv fail (map_\<I> h k \<I>) (f \<circ> g) gpv"
+proof(induction arbitrary: gpv rule: parallel_fixp_induct_1_1[OF complete_lattice_partial_function_definitions complete_lattice_partial_function_definitions expectation_gpv.mono expectation_gpv.mono expectation_gpv_def expectation_gpv_def, case_names adm bottom step])
+  case adm show ?case by simp
+  case bottom show ?case by simp
+  case (step exp1 exp2)
+  have "pmf (the_gpv (map_gpv' g h k gpv)) None = pmf (the_gpv gpv) None"
+    by(simp add: pmf_map_spmf_None)
+  then show ?case 
+    by simp
+      (auto simp add: nn_integral_measure_spmf step.IH image_comp
+        split: generat.split intro!: nn_integral_cong)
+qed
+
+lemma plossless_gpv_map_gpv' [simp]:
+  "pgen_lossless_gpv b \<I> (map_gpv' f g h gpv) \<longleftrightarrow> pgen_lossless_gpv b (map_\<I> g h \<I>) gpv"
+  unfolding pgen_lossless_gpv_def by(simp add: o_def)
+
+end
diff --git a/thys/CryptHOL/Generat.thy b/thys/CryptHOL/Generat.thy
--- a/thys/CryptHOL/Generat.thy
+++ b/thys/CryptHOL/Generat.thy
@@ -1,197 +1,226 @@
 (* Title: Generat.thy
   Author: Andreas Lochbihler, ETH Zurich *)
 
 section \<open>Generative probabilistic values\<close>
 
 theory Generat imports 
   Misc_CryptHOL
 begin
 
 subsection \<open>Single-step generative\<close>
 
 datatype (generat_pures: 'a, generat_outs: 'b, generat_conts: 'c) generat 
   = Pure (result: 'a)
   | IO ("output": 'b) (continuation: "'c")
 
 datatype_compat generat
 
 lemma IO_code_cong: "out = out' \<Longrightarrow> IO out c = IO out' c" by simp
 setup \<open>Code_Simp.map_ss (Simplifier.add_cong @{thm IO_code_cong})\<close>
 
 lemma is_Pure_map_generat [simp]: "is_Pure (map_generat f g h x) = is_Pure x"
 by(cases x) simp_all
 
 lemma result_map_generat [simp]: "is_Pure x \<Longrightarrow> result (map_generat f g h x) = f (result x)"
 by(cases x) simp_all
 
 lemma output_map_generat [simp]: "\<not> is_Pure x \<Longrightarrow> output (map_generat f g h x) = g (output x)"
 by(cases x) simp_all
 
 lemma continuation_map_generat [simp]: "\<not> is_Pure x \<Longrightarrow> continuation (map_generat f g h x) = h (continuation x)"
 by(cases x) simp_all
 
 lemma [simp]:
   shows map_generat_eq_Pure:
   "map_generat f g h generat = Pure x \<longleftrightarrow> (\<exists>x'. generat = Pure x' \<and> x = f x')"
   and Pure_eq_map_generat:
   "Pure x = map_generat f g h generat \<longleftrightarrow> (\<exists>x'. generat = Pure x' \<and> x = f x')"
 by(cases generat; auto; fail)+
 
 lemma [simp]:
   shows map_generat_eq_IO:
   "map_generat f g h generat = IO out c \<longleftrightarrow> (\<exists>out' c'. generat = IO out' c' \<and> out = g out' \<and> c = h c')"
   and IO_eq_map_generat:
   "IO out c = map_generat f g h generat \<longleftrightarrow> (\<exists>out' c'. generat = IO out' c' \<and> out = g out' \<and> c = h c')"
 by(cases generat; auto; fail)+
 
 lemma is_PureE [cases pred]:
   assumes "is_Pure generat"
   obtains (Pure) x where "generat = Pure x"
 using assms by(auto simp add: is_Pure_def)
 
 lemma not_is_PureE:
   assumes "\<not> is_Pure generat"
   obtains (IO) out c where "generat = IO out c"
 using assms by(cases generat) auto
 
 lemma rel_generatI:
   "\<lbrakk> is_Pure x \<longleftrightarrow> is_Pure y;
      \<lbrakk> is_Pure x; is_Pure y \<rbrakk> \<Longrightarrow> A (result x) (result y);
      \<lbrakk> \<not> is_Pure x; \<not> is_Pure y \<rbrakk> \<Longrightarrow> Out (output x) (output y) \<and> R (continuation x) (continuation y) \<rbrakk>
   \<Longrightarrow> rel_generat A Out R x y"
 by(cases x y rule: generat.exhaust[case_product generat.exhaust]) simp_all
 
 lemma rel_generatD':
   "rel_generat A Out R x y
   \<Longrightarrow> (is_Pure x \<longleftrightarrow> is_Pure y) \<and> 
      (is_Pure x \<longrightarrow> is_Pure y \<longrightarrow> A (result x) (result y)) \<and> 
      (\<not> is_Pure x \<longrightarrow> \<not> is_Pure y \<longrightarrow> Out (output x) (output y) \<and> R (continuation x) (continuation y))"
 by(cases x y rule: generat.exhaust[case_product generat.exhaust]) simp_all
 
 lemma rel_generatD:
   assumes "rel_generat A Out R x y"
   shows rel_generat_is_PureD: "is_Pure x \<longleftrightarrow> is_Pure y"
   and rel_generat_resultD: "is_Pure x \<or> is_Pure y \<Longrightarrow> A (result x) (result y)"
   and rel_generat_outputD: "\<not> is_Pure x \<or> \<not> is_Pure y \<Longrightarrow> Out (output x) (output y)"
   and rel_generat_continuationD: "\<not> is_Pure x \<or> \<not> is_Pure y \<Longrightarrow> R (continuation x) (continuation y)"
 using rel_generatD'[OF assms] by simp_all
 
 lemma rel_generat_mono:
   "\<lbrakk> rel_generat A B C x y; \<And>x y. A x y \<Longrightarrow> A' x y; \<And>x y. B x y \<Longrightarrow> B' x y; \<And>x y. C x y \<Longrightarrow> C' x y \<rbrakk>
   \<Longrightarrow> rel_generat A' B' C' x y"
 using generat.rel_mono[of A A' B B' C C'] by(auto simp add: le_fun_def)
 
 lemma rel_generat_mono' [mono]:
   "\<lbrakk> \<And>x y. A x y \<longrightarrow> A' x y; \<And>x y. B x y \<longrightarrow> B' x y; \<And>x y. C x y \<longrightarrow> C' x y \<rbrakk>
   \<Longrightarrow> rel_generat A B C x y \<longrightarrow> rel_generat A' B' C' x y"
 by(blast intro: rel_generat_mono)
 
 lemma rel_generat_same:
   "rel_generat A B C r r \<longleftrightarrow> 
   (\<forall>x \<in> generat_pures r. A x x) \<and>
   (\<forall>out \<in> generat_outs r. B out out) \<and>
   (\<forall>c \<in>generat_conts r. C c c)"
 by(cases r)(auto simp add: rel_fun_def)
 
 lemma rel_generat_reflI:
   "\<lbrakk> \<And>y. y \<in> generat_pures x \<Longrightarrow> A y y; 
      \<And>out. out \<in> generat_outs x \<Longrightarrow> B out out;
      \<And>cont. cont \<in> generat_conts x \<Longrightarrow> C cont cont \<rbrakk>
   \<Longrightarrow> rel_generat A B C x x"
 by(cases x) auto
 
 lemma reflp_rel_generat [simp]: "reflp (rel_generat A B C) \<longleftrightarrow> reflp A \<and> reflp B \<and> reflp C"
 by(auto 4 3 intro!: reflpI rel_generatI dest: reflpD reflpD[where x="Pure _"] reflpD[where x="IO _ _"])
 
 lemma transp_rel_generatI:
   assumes "transp A" "transp B" "transp C"
   shows "transp (rel_generat A B C)"
 by(rule transpI)(auto 6 5 dest: rel_generatD' intro!: rel_generatI intro: assms[THEN transpD] simp add: rel_fun_def)
 
 lemma rel_generat_inf:
   "inf (rel_generat A B C) (rel_generat A' B' C') = rel_generat (inf A A') (inf B B') (inf C C')"
   (is "?lhs = ?rhs")
 proof(rule antisym)
   show "?lhs \<le> ?rhs"
     by(auto elim!: generat.rel_cases simp add: rel_fun_def)
 qed(auto elim: rel_generat_mono)
 
 lemma rel_generat_Pure1: "rel_generat A B C (Pure x) = (\<lambda>r. \<exists>y. r = Pure y \<and> A x y)"
 by(rule ext)(case_tac r, simp_all)
 
 lemma rel_generat_IO1: "rel_generat A B C (IO out c) = (\<lambda>r. \<exists>out' c'. r = IO out' c' \<and> B out out' \<and> C c c')"
 by(rule ext)(case_tac r, simp_all)
 
 lemma not_is_Pure_conv: "\<not> is_Pure r \<longleftrightarrow> (\<exists>out c. r = IO out c)"
 by(cases r) auto
 
 lemma finite_generat_outs [simp]: "finite (generat_outs generat)"
 by(cases generat) auto
 
 lemma countable_generat_outs [simp]: "countable (generat_outs generat)"
 by(simp add: countable_finite)
 
 lemma case_map_generat:
   "case_generat pure io (map_generat a b d r) = 
    case_generat (pure \<circ> a) (\<lambda>out. io (b out) \<circ> d) r"
 by(cases r) simp_all
 
 lemma continuation_in_generat_conts:
   "\<not> is_Pure r \<Longrightarrow> continuation r \<in> generat_conts r"
 by(cases r) auto
 
 
 fun dest_IO :: "('a, 'out, 'c) generat \<Rightarrow> ('out \<times> 'c) option"
 where
   "dest_IO (Pure _) = None"
 | "dest_IO (IO out c) = Some (out, c)"
 
 lemma dest_IO_eq_Some_iff [simp]: "dest_IO generat = Some (out, c) \<longleftrightarrow> generat = IO out c"
 by(cases generat) simp_all
 
 lemma dest_IO_eq_None_iff [simp]: "dest_IO generat = None \<longleftrightarrow> is_Pure generat"
 by(cases generat) simp_all
 
 lemma dest_IO_comp_Pure [simp]: "dest_IO \<circ> Pure = (\<lambda>_. None)"
 by(simp add: fun_eq_iff)
 
 lemma dom_dest_IO: "dom dest_IO = {x. \<not> is_Pure x}"
 by(auto simp add: not_is_Pure_conv)
 
 
 definition generat_lub :: "('a set \<Rightarrow> 'b) \<Rightarrow> ('out set \<Rightarrow> 'out') \<Rightarrow> ('cont set \<Rightarrow> 'cont') 
   \<Rightarrow> ('a, 'out, 'cont) generat set \<Rightarrow> ('b, 'out', 'cont') generat"
 where
   "generat_lub lub1 lub2 lub3 A =
   (if \<exists>x\<in>A. is_Pure x then Pure (lub1 (result ` (A \<inter> {f. is_Pure f})))
    else IO (lub2 (output ` (A \<inter> {f. \<not> is_Pure f}))) (lub3 (continuation ` (A \<inter> {f. \<not> is_Pure f}))))"
 
 lemma is_Pure_generat_lub [simp]:
   "is_Pure (generat_lub lub1 lub2 lub3 A) \<longleftrightarrow> (\<exists>x\<in>A. is_Pure x)"
 by(simp add: generat_lub_def)
 
 lemma result_generat_lub [simp]:
   "\<exists>x\<in>A. is_Pure x \<Longrightarrow> result (generat_lub lub1 lub2 lub3 A) = lub1 (result ` (A \<inter> {f. is_Pure f}))"
 by(simp add: generat_lub_def)
 
 lemma output_generat_lub: 
   "\<forall>x\<in>A. \<not> is_Pure x \<Longrightarrow> output (generat_lub lub1 lub2 lub3 A) = lub2 (output ` (A \<inter> {f. \<not> is_Pure f}))"
 by(simp add: generat_lub_def)
 
 lemma continuation_generat_lub:
   "\<forall>x\<in>A. \<not> is_Pure x \<Longrightarrow> continuation (generat_lub lub1 lub2 lub3 A) = lub3 (continuation ` (A \<inter> {f. \<not> is_Pure f}))"
 by(simp add: generat_lub_def)
 
 lemma generat_lub_map [simp]:
   "generat_lub lub1 lub2 lub3 (map_generat f g h ` A) = generat_lub (lub1 \<circ> (`) f) (lub2 \<circ> (`) g) (lub3 \<circ> (`) h) A"
 by(auto 4 3 simp add: generat_lub_def intro: arg_cong[where f=lub1] arg_cong[where f=lub2] arg_cong[where f=lub3] rev_image_eqI del: ext intro!: ext)
 
 lemma map_generat_lub [simp]:
   "map_generat f g h (generat_lub lub1 lub2 lub3 A) = generat_lub (f \<circ> lub1) (g \<circ> lub2) (h \<circ> lub3) A"
 by(simp add: generat_lub_def o_def)
 
 
 abbreviation generat_lub' :: "('cont set \<Rightarrow> 'cont') \<Rightarrow> ('a, 'out, 'cont) generat set \<Rightarrow> ('a, 'out, 'cont') generat"
 where "generat_lub' \<equiv> generat_lub (\<lambda>A. THE x. x \<in> A) (\<lambda>A. THE x. x \<in> A)"
 
+fun rel_witness_generat :: "('a, 'c, 'e) generat \<times> ('b, 'd, 'f) generat \<Rightarrow> ('a \<times> 'b, 'c \<times> 'd, 'e \<times> 'f) generat" where
+  "rel_witness_generat (Pure x, Pure y) = Pure (x, y)"
+| "rel_witness_generat (IO out c, IO out' c') = IO (out, out') (c, c')"
+
+lemma rel_witness_generat: 
+  assumes "rel_generat A C R x y"
+  shows pures_rel_witness_generat: "generat_pures (rel_witness_generat (x, y)) \<subseteq> {(a, b). A a b}"
+    and outs_rel_witness_generat: "generat_outs (rel_witness_generat (x, y)) \<subseteq> {(c, d). C c d}"
+    and conts_rel_witness_generat: "generat_conts (rel_witness_generat (x, y)) \<subseteq> {(e, f). R e f}"
+    and map1_rel_witness_generat: "map_generat fst fst fst (rel_witness_generat (x, y)) = x"
+    and map2_rel_witness_generat: "map_generat snd snd snd (rel_witness_generat (x, y)) = y"
+  using assms by(cases; simp; fail)+
+
+lemmas set_rel_witness_generat = pures_rel_witness_generat outs_rel_witness_generat conts_rel_witness_generat
+
+lemma rel_witness_generat1:
+  assumes "rel_generat A C R x y"
+  shows "rel_generat (\<lambda>a (a', b). a = a' \<and> A a' b) (\<lambda>c (c', d). c = c' \<and> C c' d) (\<lambda>r (r', s). r = r' \<and> R r' s) x (rel_witness_generat (x, y))"
+  using map1_rel_witness_generat[OF assms, symmetric]
+  unfolding generat.rel_eq[symmetric] generat.rel_map
+  by(rule generat.rel_mono_strong)(auto dest: set_rel_witness_generat[OF assms, THEN subsetD])
+
+lemma rel_witness_generat2:
+  assumes "rel_generat A C R x y"
+  shows "rel_generat (\<lambda>(a, b') b. b = b' \<and> A a b') (\<lambda>(c, d') d. d = d' \<and> C c d') (\<lambda>(r, s') s. s = s' \<and> R r s') (rel_witness_generat (x, y)) y"
+  using map2_rel_witness_generat[OF assms]
+  unfolding generat.rel_eq[symmetric] generat.rel_map
+  by(rule generat.rel_mono_strong)(auto dest: set_rel_witness_generat[OF assms, THEN subsetD])
+
 end
diff --git a/thys/CryptHOL/Generative_Probabilistic_Value.thy b/thys/CryptHOL/Generative_Probabilistic_Value.thy
--- a/thys/CryptHOL/Generative_Probabilistic_Value.thy
+++ b/thys/CryptHOL/Generative_Probabilistic_Value.thy
@@ -1,5212 +1,6051 @@
 (* Title: Generative_Probabilistic_Value.thy
   Author: Andreas Lochbihler, ETH Zurich *)
 
 theory Generative_Probabilistic_Value imports
   Resumption
   Generat
   "HOL-Types_To_Sets.Types_To_Sets"
 begin
 
 hide_const (open) Done
 
 subsection \<open>Type definition\<close>
 
 context notes [[bnf_internals]] begin
 
 codatatype (results'_gpv: 'a, outs'_gpv: 'out, 'in) gpv
   = GPV (the_gpv: "('a, 'out, 'in \<Rightarrow> ('a, 'out, 'in) gpv) generat spmf")
 
 end
 
 declare gpv.rel_eq [relator_eq]
 
 text \<open>Reactive values are like generative, except that they take an input first.\<close>
 
 type_synonym ('a, 'out, 'in) rpv = "'in \<Rightarrow> ('a, 'out, 'in) gpv"
 print_translation \<comment> \<open>pretty printing for @{typ "('a, 'out, 'in) rpv"}\<close> \<open>
   let
     fun tr' [in1, Const (@{type_syntax gpv}, _) $ a $ out $ in2] =
       if in1 = in2 then Syntax.const @{type_syntax rpv} $ a $ out $ in1
       else raise Match;
   in [(@{type_syntax "fun"}, K tr')]
   end
 \<close>
 typ "('a, 'out, 'in) rpv"
 text \<open>
   Effectively, @{typ "('a, 'out, 'in) gpv"} and @{typ "('a, 'out, 'in) rpv"} are mutually recursive.
 \<close>
 
 lemma eq_GPV_iff: "f = GPV g \<longleftrightarrow> the_gpv f = g"
 by(cases f) auto
 
 declare gpv.set[simp del]
 
 declare gpv.set_map[simp]
 
 lemma rel_gpv_def':
   "rel_gpv A B gpv gpv' \<longleftrightarrow>
   (\<exists>gpv''. (\<forall>(x, y) \<in> results'_gpv gpv''. A x y) \<and> (\<forall>(x, y) \<in> outs'_gpv gpv''. B x y) \<and>
            map_gpv fst fst gpv'' = gpv \<and> map_gpv snd snd gpv'' = gpv')"
 unfolding rel_gpv_def by(auto simp add: BNF_Def.Grp_def)
 
 definition results'_rpv :: "('a, 'out, 'in) rpv \<Rightarrow> 'a set"
 where "results'_rpv rpv = range rpv \<bind> results'_gpv"
 
 definition outs'_rpv :: "('a, 'out, 'in) rpv \<Rightarrow> 'out set"
 where "outs'_rpv rpv = range rpv \<bind> outs'_gpv"
 
 abbreviation rel_rpv
   :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('out \<Rightarrow> 'out' \<Rightarrow> bool)
   \<Rightarrow> ('in \<Rightarrow> ('a, 'out, 'in) gpv) \<Rightarrow> ('in \<Rightarrow> ('b, 'out', 'in) gpv) \<Rightarrow> bool"
 where "rel_rpv A B \<equiv> rel_fun (=) (rel_gpv A B)"
 
 lemma in_results'_rpv [iff]: "x \<in> results'_rpv rpv \<longleftrightarrow> (\<exists>input. x \<in> results'_gpv (rpv input))"
 by(simp add: results'_rpv_def)
 
 lemma in_outs_rpv [iff]: "out \<in> outs'_rpv rpv \<longleftrightarrow> (\<exists>input. out \<in> outs'_gpv (rpv input))"
 by(simp add: outs'_rpv_def)
 
 lemma results'_GPV [simp]:
   "results'_gpv (GPV r) =
    (set_spmf r \<bind> generat_pures) \<union> 
    ((set_spmf r \<bind> generat_conts) \<bind> results'_rpv)"
 by(auto simp add: gpv.set bind_UNION set_spmf_def)
 
 lemma outs'_GPV [simp]:
   "outs'_gpv (GPV r) =
    (set_spmf r \<bind> generat_outs) \<union> 
    ((set_spmf r \<bind> generat_conts) \<bind> outs'_rpv)"
 by(auto simp add: gpv.set bind_UNION set_spmf_def)
 
 lemma outs'_gpv_unfold:
   "outs'_gpv r =
    (set_spmf (the_gpv r) \<bind> generat_outs) \<union> 
    ((set_spmf (the_gpv r) \<bind> generat_conts) \<bind> outs'_rpv)"
 by(cases r) simp
 
 lemma outs'_gpv_induct [consumes 1, case_names Out Cont, induct set: outs'_gpv]:
   assumes x: "x \<in> outs'_gpv gpv"
   and Out: "\<And>generat gpv. \<lbrakk> generat \<in> set_spmf (the_gpv gpv); x \<in> generat_outs generat \<rbrakk> \<Longrightarrow> P gpv"
   and Cont: "\<And>generat gpv c input.
     \<lbrakk> generat \<in> set_spmf (the_gpv gpv); c \<in> generat_conts generat; x \<in> outs'_gpv (c input); P (c input) \<rbrakk> \<Longrightarrow> P gpv"
   shows "P gpv"
 using x
 apply(induction y\<equiv>"x" gpv)
  apply(rule Out, simp add: in_set_spmf, simp)
 apply(erule imageE, rule Cont, simp add: in_set_spmf, simp, simp, simp)
 .
 
 lemma outs'_gpv_cases [consumes 1, case_names Out Cont, cases set: outs'_gpv]:
   assumes "x \<in> outs'_gpv gpv"
   obtains (Out) generat where "generat \<in> set_spmf (the_gpv gpv)" "x \<in> generat_outs generat"
     | (Cont) generat c input where "generat \<in> set_spmf (the_gpv gpv)" "c \<in> generat_conts generat" "x \<in> outs'_gpv (c input)"
 using assms by cases(auto simp add: in_set_spmf)
 
 lemma outs'_gpvI [intro?]:
   shows outs'_gpv_Out: "\<lbrakk> generat \<in> set_spmf (the_gpv gpv); x \<in> generat_outs generat \<rbrakk> \<Longrightarrow> x \<in> outs'_gpv gpv"
   and outs'_gpv_Cont: "\<lbrakk> generat \<in> set_spmf (the_gpv gpv); c \<in> generat_conts generat; x \<in> outs'_gpv (c input) \<rbrakk> \<Longrightarrow> x \<in> outs'_gpv gpv"
 by(auto intro: gpv.set_sel simp add: in_set_spmf)
 
 lemma results'_gpv_induct [consumes 1, case_names Pure Cont, induct set: results'_gpv]:
   assumes x: "x \<in> results'_gpv gpv"
   and Pure: "\<And>generat gpv. \<lbrakk> generat \<in> set_spmf (the_gpv gpv); x \<in> generat_pures generat \<rbrakk> \<Longrightarrow> P gpv"
   and Cont: "\<And>generat gpv c input.
     \<lbrakk> generat \<in> set_spmf (the_gpv gpv); c \<in> generat_conts generat; x \<in> results'_gpv (c input); P (c input) \<rbrakk> \<Longrightarrow> P gpv"
   shows "P gpv"
 using x
 apply(induction y\<equiv>"x" gpv)
  apply(rule Pure; simp add: in_set_spmf)
 apply(erule imageE, rule Cont, simp add: in_set_spmf, simp, simp, simp)
 .
 
 lemma results'_gpv_cases [consumes 1, case_names Pure Cont, cases set: results'_gpv]:
   assumes "x \<in> results'_gpv gpv"
   obtains (Pure) generat where "generat \<in> set_spmf (the_gpv gpv)" "x \<in> generat_pures generat"
     | (Cont) generat c input where "generat \<in> set_spmf (the_gpv gpv)" "c \<in> generat_conts generat" "x \<in> results'_gpv (c input)"
 using assms by cases(auto simp add: in_set_spmf)
 
 lemma results'_gpvI [intro?]:
   shows results'_gpv_Pure: "\<lbrakk> generat \<in> set_spmf (the_gpv gpv); x \<in> generat_pures generat \<rbrakk> \<Longrightarrow> x \<in> results'_gpv gpv"
   and results'_gpv_Cont: "\<lbrakk> generat \<in> set_spmf (the_gpv gpv); c \<in> generat_conts generat; x \<in> results'_gpv (c input) \<rbrakk> \<Longrightarrow> x \<in> results'_gpv gpv"
 by(auto intro: gpv.set_sel simp add: in_set_spmf)
 
 lemma left_unique_rel_gpv [transfer_rule]:
   "\<lbrakk> left_unique A; left_unique B \<rbrakk> \<Longrightarrow> left_unique (rel_gpv A B)"
 unfolding left_unique_alt_def gpv.rel_conversep[symmetric] gpv.rel_compp[symmetric]
 by(subst gpv.rel_eq[symmetric])(rule gpv.rel_mono)
 
 lemma right_unique_rel_gpv [transfer_rule]:
   "\<lbrakk> right_unique A; right_unique B \<rbrakk> \<Longrightarrow> right_unique (rel_gpv A B)"
 unfolding right_unique_alt_def gpv.rel_conversep[symmetric] gpv.rel_compp[symmetric]
 by(subst gpv.rel_eq[symmetric])(rule gpv.rel_mono)
 
 lemma bi_unique_rel_gpv [transfer_rule]:
   "\<lbrakk> bi_unique A; bi_unique B \<rbrakk> \<Longrightarrow> bi_unique (rel_gpv A B)"
 unfolding bi_unique_alt_def by(simp add: left_unique_rel_gpv right_unique_rel_gpv)
 
 lemma left_total_rel_gpv [transfer_rule]:
   "\<lbrakk> left_total A; left_total B \<rbrakk> \<Longrightarrow> left_total (rel_gpv A B)"
 unfolding left_total_alt_def gpv.rel_conversep[symmetric] gpv.rel_compp[symmetric]
 by(subst gpv.rel_eq[symmetric])(rule gpv.rel_mono)
 
 lemma right_total_rel_gpv [transfer_rule]:
   "\<lbrakk> right_total A; right_total B \<rbrakk> \<Longrightarrow> right_total (rel_gpv A B)"
 unfolding right_total_alt_def gpv.rel_conversep[symmetric] gpv.rel_compp[symmetric]
 by(subst gpv.rel_eq[symmetric])(rule gpv.rel_mono)
 
 lemma bi_total_rel_gpv [transfer_rule]: "\<lbrakk> bi_total A; bi_total B \<rbrakk> \<Longrightarrow> bi_total (rel_gpv A B)"
 unfolding bi_total_alt_def by(simp add: left_total_rel_gpv right_total_rel_gpv)
 
 declare gpv.map_transfer[transfer_rule]
 
 lemma if_distrib_map_gpv [if_distribs]:
   "map_gpv f g (if b then gpv else gpv') = (if b then map_gpv f g gpv else map_gpv f g gpv')"
 by simp
 
 lemma gpv_pred_mono_strong:
   "\<lbrakk> pred_gpv P Q x; \<And>a. \<lbrakk> a \<in> results'_gpv x; P a \<rbrakk> \<Longrightarrow> P' a; \<And>b. \<lbrakk> b \<in> outs'_gpv x; Q b \<rbrakk> \<Longrightarrow> Q' b \<rbrakk> \<Longrightarrow> pred_gpv P' Q' x"
 by(simp add: pred_gpv_def)
 
 lemma pred_gpv_top [simp]:
   "pred_gpv (\<lambda>_. True) (\<lambda>_. True) = (\<lambda>_. True)"
 by(simp add: pred_gpv_def)
 
 lemma pred_gpv_conj [simp]:
   shows pred_gpv_conj1: "\<And>P Q R. pred_gpv (\<lambda>x. P x \<and> Q x) R = (\<lambda>x. pred_gpv P R x \<and> pred_gpv Q R x)"
   and pred_gpv_conj2: "\<And>P Q R. pred_gpv P (\<lambda>x. Q x \<and> R x) = (\<lambda>x. pred_gpv P Q x \<and> pred_gpv P R x)"
 by(auto simp add: pred_gpv_def)
 
 lemma rel_gpv_restrict_relp1I [intro?]:
   "\<lbrakk> rel_gpv R R' x y; pred_gpv P P' x; pred_gpv Q Q' y \<rbrakk> \<Longrightarrow> rel_gpv (R \<upharpoonleft> P \<otimes> Q) (R' \<upharpoonleft> P' \<otimes> Q') x y"
 by(erule gpv.rel_mono_strong)(simp_all add: pred_gpv_def)
 
 lemma rel_gpv_restrict_relpE [elim?]:
   assumes "rel_gpv (R \<upharpoonleft> P \<otimes> Q) (R' \<upharpoonleft> P' \<otimes> Q') x y"
   obtains "rel_gpv R R' x y" "pred_gpv P P' x" "pred_gpv Q Q' y"
 proof
   show "rel_gpv R R' x y" using assms by(auto elim!: gpv.rel_mono_strong)
   have "pred_gpv (Domainp (R \<upharpoonleft> P \<otimes> Q)) (Domainp (R' \<upharpoonleft> P' \<otimes> Q')) x" using assms by(fold gpv.Domainp_rel) blast
   then show "pred_gpv P P' x" by(rule gpv_pred_mono_strong)(blast dest!: restrict_relp_DomainpD)+
   have "pred_gpv (Domainp (R \<upharpoonleft> P \<otimes> Q)\<inverse>\<inverse>) (Domainp (R' \<upharpoonleft> P' \<otimes> Q')\<inverse>\<inverse>) y" using assms
     by(fold gpv.Domainp_rel)(auto simp only: gpv.rel_conversep Domainp_conversep)
   then show "pred_gpv Q Q' y" by(rule gpv_pred_mono_strong)(auto dest!: restrict_relp_DomainpD)
 qed
 
 lemma gpv_pred_map [simp]: "pred_gpv P Q (map_gpv f g gpv) = pred_gpv (P \<circ> f) (Q \<circ> g) gpv"
 by(simp add: pred_gpv_def)
 
 subsection \<open>Generalised mapper and relator\<close>
 
 context includes lifting_syntax begin
 
 primcorec map_gpv' :: "('a \<Rightarrow> 'b) \<Rightarrow> ('out \<Rightarrow> 'out') \<Rightarrow> ('ret' \<Rightarrow> 'ret) \<Rightarrow> ('a, 'out, 'ret) gpv \<Rightarrow> ('b, 'out', 'ret') gpv"
 where
   "map_gpv' f g h gpv = 
    GPV (map_spmf (map_generat f g ((\<circ>) (map_gpv' f g h))) (map_spmf (map_generat id id (map_fun h id)) (the_gpv gpv)))"
 
 declare map_gpv'.sel [simp del]
 
 lemma map_gpv'_sel [simp]:
   "the_gpv (map_gpv' f g h gpv) = map_spmf (map_generat f g (h ---> map_gpv' f g h)) (the_gpv gpv)"
 by(simp add: map_gpv'.sel spmf.map_comp o_def generat.map_comp map_fun_def[abs_def])
 
 lemma map_gpv'_GPV [simp]:
   "map_gpv' f g h (GPV p) = GPV (map_spmf (map_generat f g (h ---> map_gpv' f g h)) p)"
 by(rule gpv.expand) simp
 
 lemma map_gpv'_id: "map_gpv' id id id = id"
 apply(rule ext)
 apply(coinduction)
 apply(auto simp add: spmf_rel_map generat.rel_map rel_fun_def intro!: rel_spmf_reflI generat.rel_refl)
 done
 
 lemma map_gpv'_comp: "map_gpv' f g h (map_gpv' f' g' h' gpv) = map_gpv' (f \<circ> f') (g \<circ> g') (h' \<circ> h) gpv"
 by(coinduction arbitrary: gpv)(auto simp add: spmf.map_comp spmf_rel_map generat.rel_map rel_fun_def intro!: rel_spmf_reflI generat.rel_refl)
 
 functor gpv: map_gpv' by(simp_all add: map_gpv'_comp map_gpv'_id o_def) 
 
 lemma map_gpv_conv_map_gpv': "map_gpv f g = map_gpv' f g id"
 apply(rule ext)
 apply(coinduction)
 apply(auto simp add: gpv.map_sel spmf_rel_map generat.rel_map rel_fun_def intro!: generat.rel_refl_strong rel_spmf_reflI)
 done
 
 coinductive rel_gpv'' :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('out \<Rightarrow> 'out' \<Rightarrow> bool) \<Rightarrow> ('ret \<Rightarrow> 'ret' \<Rightarrow> bool) \<Rightarrow> ('a, 'out, 'ret) gpv \<Rightarrow> ('b, 'out', 'ret') gpv \<Rightarrow> bool"
   for A C R
 where
   "rel_spmf (rel_generat A C (R ===> rel_gpv'' A C R)) (the_gpv gpv) (the_gpv gpv')
   \<Longrightarrow> rel_gpv'' A C R gpv gpv'"
 
 lemma rel_gpv''_coinduct [consumes 1, case_names rel_gpv'', coinduct pred: rel_gpv'']:
   "\<lbrakk>X gpv gpv';
     \<And>gpv gpv'. X gpv gpv'
      \<Longrightarrow> rel_spmf (rel_generat A C (R ===> (\<lambda>gpv gpv'. X gpv gpv' \<or> rel_gpv'' A C R gpv gpv')))
            (the_gpv gpv) (the_gpv gpv') \<rbrakk>
    \<Longrightarrow> rel_gpv'' A C R gpv gpv'"
 by(erule rel_gpv''.coinduct) blast
 
 lemma rel_gpv''D:
   "rel_gpv'' A C R gpv gpv' 
   \<Longrightarrow> rel_spmf (rel_generat A C (R ===> rel_gpv'' A C R)) (the_gpv gpv) (the_gpv gpv')"
 by(simp add: rel_gpv''.simps)
 
 lemma rel_gpv''_GPV [simp]:
   "rel_gpv'' A C R (GPV p) (GPV q) \<longleftrightarrow>
    rel_spmf (rel_generat A C (R ===> rel_gpv'' A C R)) p q"
 by(simp add: rel_gpv''.simps)
 
 lemma rel_gpv_conv_rel_gpv'': "rel_gpv A C = rel_gpv'' A C (=)"
 proof(rule ext iffI)+
   show "rel_gpv A C gpv gpv'" if "rel_gpv'' A C (=) gpv gpv'" for gpv :: "('a, 'b, 'c) gpv" and gpv' :: "('d, 'e, 'c) gpv"
     using that by(coinduct)(blast dest: rel_gpv''D)
   show "rel_gpv'' A C (=) gpv gpv'" if "rel_gpv A C gpv gpv'" for gpv :: "('a, 'b, 'c) gpv" and gpv' :: "('d, 'e, 'c) gpv"
     using that by(coinduct)(auto elim!: gpv.rel_cases rel_spmf_mono generat.rel_mono_strong rel_fun_mono)
 qed
 
 lemma rel_gpv''_eq (* [relator_eq] do not use this attribute unless all transfer rules for gpv have been changed to rel_gvp'' *):
   "rel_gpv'' (=) (=) (=) = (=)"
 by(simp add: rel_gpv_conv_rel_gpv''[symmetric] gpv.rel_eq)
 
 lemma rel_gpv''_mono:
   assumes "A \<le> A'" "C \<le> C'" "R' \<le> R"
   shows "rel_gpv'' A C R \<le> rel_gpv'' A' C' R'"
 proof
   show "rel_gpv'' A' C' R' gpv gpv'" if "rel_gpv'' A C R gpv gpv'" for gpv gpv' using that
     by(coinduct)(auto dest: rel_gpv''D elim!: rel_spmf_mono generat.rel_mono_strong rel_fun_mono intro: assms[THEN predicate2D])
 qed
 
 lemma rel_gpv''_conversep: "rel_gpv'' A\<inverse>\<inverse> C\<inverse>\<inverse> R\<inverse>\<inverse> = (rel_gpv'' A C R)\<inverse>\<inverse>"
 proof(intro ext iffI; simp)
   show "rel_gpv'' A C R gpv gpv'" if "rel_gpv'' A\<inverse>\<inverse> C\<inverse>\<inverse> R\<inverse>\<inverse> gpv' gpv"
     for A :: "'a1 \<Rightarrow> 'a2 \<Rightarrow> bool" and C :: "'c1 \<Rightarrow> 'c2 \<Rightarrow> bool" and R :: "'r1 \<Rightarrow> 'r2 \<Rightarrow> bool" and gpv gpv'
     using that apply(coinduct)
     apply(drule rel_gpv''D)
     apply(rewrite in \<hole> conversep_iff[symmetric])
     apply(subst spmf_rel_conversep[symmetric])
     apply(erule rel_spmf_mono)
     apply(subst generat.rel_conversep[symmetric])
     apply(erule generat.rel_mono_strong)
     apply(auto simp add: rel_fun_def conversep_iff[abs_def])
     done
   from this[of "A\<inverse>\<inverse>" "C\<inverse>\<inverse>" "R\<inverse>\<inverse>"]
   show "rel_gpv'' A\<inverse>\<inverse> C\<inverse>\<inverse> R\<inverse>\<inverse> gpv' gpv" if "rel_gpv'' A C R gpv gpv'" for gpv gpv' using that by simp
 qed
 
 
 lemma rel_gpv''_pos_distr:
   "rel_gpv'' A C R OO rel_gpv'' A' C' R' \<le> rel_gpv'' (A OO A') (C OO C') (R OO R')"
 proof(rule predicate2I; erule relcomppE)
   show "rel_gpv'' (A OO A') (C OO C') (R OO R') gpv gpv''"
     if "rel_gpv'' A C R gpv gpv'" "rel_gpv'' A' C' R' gpv' gpv''"
     for gpv gpv' gpv'' using that
     apply(coinduction arbitrary: gpv gpv' gpv'')
     apply(drule rel_gpv''D)+
     apply(drule (1) rel_spmf_pos_distr[THEN predicate2D, OF relcomppI])
     apply(erule spmf_rel_mono_strong)
     apply(subst (asm) generat.rel_compp[symmetric])
     apply(erule generat.rel_mono_strong, assumption, assumption)
     apply(drule pos_fun_distr[THEN predicate2D])
     apply(auto simp add: rel_fun_def)
     done
 qed
 
 lemma left_unique_rel_gpv'':
   "\<lbrakk> left_unique A; left_unique C; left_total R \<rbrakk> \<Longrightarrow> left_unique (rel_gpv'' A C R)"
 unfolding left_unique_alt_def left_total_alt_def rel_gpv''_conversep[symmetric]
 apply(subst rel_gpv''_eq[symmetric])
 apply(rule order_trans[OF rel_gpv''_pos_distr])
 apply(erule (2) rel_gpv''_mono)
 done
 
 lemma right_unique_rel_gpv'':
   "\<lbrakk> right_unique A; right_unique C; right_total R \<rbrakk> \<Longrightarrow> right_unique (rel_gpv'' A C R)"
 unfolding right_unique_alt_def right_total_alt_def rel_gpv''_conversep[symmetric]
 apply(subst rel_gpv''_eq[symmetric])
 apply(rule order_trans[OF rel_gpv''_pos_distr])
 apply(erule (2) rel_gpv''_mono)
 done
 
 lemma bi_unique_rel_gpv'' [transfer_rule]:
   "\<lbrakk> bi_unique A; bi_unique C; bi_total R \<rbrakk> \<Longrightarrow> bi_unique (rel_gpv'' A C R)"
 unfolding bi_unique_alt_def bi_total_alt_def by(blast intro: left_unique_rel_gpv'' right_unique_rel_gpv'')
 
+lemma rel_gpv''_map_gpv1:
+  "rel_gpv'' A C R (map_gpv f g gpv) gpv' = rel_gpv'' (\<lambda>a. A (f a)) (\<lambda>c. C (g c)) R gpv gpv'" (is "?lhs = ?rhs")
+proof
+  show ?rhs if ?lhs using that
+    apply(coinduction arbitrary: gpv gpv')
+    apply(drule rel_gpv''D)
+    apply(simp add: gpv.map_sel spmf_rel_map)
+    apply(erule rel_spmf_mono)
+    by(auto simp add: generat.rel_map rel_fun_comp elim!: generat.rel_mono_strong rel_fun_mono)
+  show ?lhs if ?rhs using that
+    apply(coinduction arbitrary: gpv gpv')
+    apply(drule rel_gpv''D)
+    apply(simp add: gpv.map_sel spmf_rel_map)
+    apply(erule rel_spmf_mono)
+    by(auto simp add: generat.rel_map rel_fun_comp elim!: generat.rel_mono_strong rel_fun_mono)
+qed
+
+lemma rel_gpv''_map_gpv2:
+  "rel_gpv'' A C R gpv (map_gpv f g gpv') = rel_gpv'' (\<lambda>a b. A a (f b)) (\<lambda>c d. C c (g d)) R gpv gpv'"
+  using rel_gpv''_map_gpv1[of "conversep A" "conversep C" "conversep R" f g gpv' gpv]
+  apply(rewrite in "\<hole> = _" conversep_iff[symmetric])
+  apply(rewrite in "_ = \<hole>" conversep_iff[symmetric])
+  apply(simp only: rel_gpv''_conversep)
+  apply(simp only: rel_gpv''_conversep[symmetric])
+  apply(simp only: conversep_iff[abs_def])
+  done
+
+lemmas rel_gpv''_map_gpv = rel_gpv''_map_gpv1[abs_def] rel_gpv''_map_gpv2
+
+lemma rel_gpv''_map_gpv' [simp]:
+  shows "\<And>f g h gpv. NO_MATCH id f \<or> NO_MATCH id g 
+    \<Longrightarrow> rel_gpv'' A C R (map_gpv' f g h gpv) = rel_gpv'' (\<lambda>a. A (f a)) (\<lambda>c. C (g c)) R (map_gpv' id id h gpv)"
+    and "\<And>f g h gpv gpv'. NO_MATCH id f \<or> NO_MATCH id g 
+    \<Longrightarrow> rel_gpv'' A C R gpv (map_gpv' f g h gpv') = rel_gpv'' (\<lambda>a b. A a (f b)) (\<lambda>c d. C c (g d)) R gpv (map_gpv' id id h gpv')"
+proof (goal_cases)
+  case (1 f g h gpv)
+  then show ?case using map_gpv'_comp[of f g id id id h gpv, symmetric] by(simp add: rel_gpv''_map_gpv[unfolded map_gpv_conv_map_gpv'])
+next
+  case (2 f g h gpv gpv')
+  then show ?case using map_gpv'_comp[of f g id id id h gpv', symmetric] by(simp add: rel_gpv''_map_gpv[unfolded map_gpv_conv_map_gpv'])
+qed
+
+lemmas rel_gpv_map_gpv' = rel_gpv''_map_gpv'[where R="(=)", folded rel_gpv_conv_rel_gpv'']
+
+definition rel_witness_gpv :: "('a \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'e \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'g \<Rightarrow> bool) \<Rightarrow> ('g \<Rightarrow> 'f \<Rightarrow> bool) \<Rightarrow> ('a, 'b, 'c) gpv \<times> ('d, 'e, 'f) gpv \<Rightarrow> ('a \<times> 'd, 'b \<times> 'e, 'g) gpv" where
+  "rel_witness_gpv A C R R' = corec_gpv (
+     map_spmf (map_generat id id (\<lambda>(rpv, rpv'). (Inr \<circ> rel_witness_fun R R' (rpv, rpv'))) \<circ> rel_witness_generat) \<circ>
+     rel_witness_spmf (rel_generat A C (rel_fun (R OO R') (rel_gpv'' A C (R OO R')))) \<circ> map_prod the_gpv the_gpv)"
+
+lemma rel_witness_gpv_sel [simp]:
+  "the_gpv (rel_witness_gpv A C R R' (gpv, gpv')) = 
+    map_spmf (map_generat id id (\<lambda>(rpv, rpv'). (rel_witness_gpv A C R R' \<circ> rel_witness_fun R R' (rpv, rpv'))) \<circ> rel_witness_generat)
+     (rel_witness_spmf (rel_generat A C (rel_fun (R OO R') (rel_gpv'' A C (R OO R')))) (the_gpv gpv, the_gpv gpv'))"
+  unfolding rel_witness_gpv_def
+  by(auto simp add: spmf.map_comp generat.map_comp o_def intro!: map_spmf_cong generat.map_cong)
+
+lemma assumes "rel_gpv'' A C (R OO R') gpv gpv'"
+  and R: "left_unique R" "right_total R"
+  and R': "right_unique R'" "left_total R'"
+shows rel_witness_gpv1: "rel_gpv'' (\<lambda>a (a', b). a = a' \<and> A a' b) (\<lambda>c (c', d). c = c' \<and> C c' d) R gpv (rel_witness_gpv A C R R' (gpv, gpv'))" (is "?thesis1")
+  and rel_witness_gpv2: "rel_gpv'' (\<lambda>(a, b') b. b = b' \<and> A a b') (\<lambda>(c, d') d. d = d' \<and> C c d') R' (rel_witness_gpv A C R R' (gpv, gpv')) gpv'" (is "?thesis2")
+proof -
+  show ?thesis1 using assms(1)
+  proof(coinduction arbitrary: gpv gpv')
+    case rel_gpv''
+    from this[THEN rel_gpv''D] show ?case
+      by(auto simp add: spmf_rel_map generat.rel_map rel_fun_comp elim!: rel_fun_mono[OF rel_witness_fun1[OF _ R R']]
+          rel_spmf_mono[OF rel_witness_spmf1] generat.rel_mono[THEN predicate2D, rotated -1, OF rel_witness_generat1])
+  qed
+  show ?thesis2 using assms(1)
+  proof(coinduction arbitrary: gpv gpv')
+    case rel_gpv''
+    from this[THEN rel_gpv''D] show ?case
+      by(simp add: spmf_rel_map) 
+        (erule rel_spmf_mono[OF rel_witness_spmf2]
+          , auto simp add: generat.rel_map rel_fun_comp elim!: rel_fun_mono[OF rel_witness_fun2[OF _ R R']]
+          generat.rel_mono[THEN predicate2D, rotated -1, OF rel_witness_generat2])
+  qed
+qed
+
 lemma rel_gpv''_neg_distr:
   assumes R: "left_unique R" "right_total R"
-  and R': "right_unique R'" "left_total R'"
+    and R': "right_unique R'" "left_total R'"
   shows "rel_gpv'' (A OO A') (C OO C') (R OO R') \<le> rel_gpv'' A C R OO rel_gpv'' A' C' R'"
 proof(rule predicate2I relcomppI)+
   fix gpv gpv''
   assume *: "rel_gpv'' (A OO A') (C OO C') (R OO R') gpv gpv''"
-  let ?P_spmf = "\<lambda>gpv gpv'' pq. 
-    (\<forall>(generat, generat'') \<in> set_spmf pq. rel_generat (A OO A') (C OO C') (R OO R' ===> rel_gpv'' (A OO A') (C OO C') (R OO R')) generat generat'') \<and>
-    map_spmf fst pq = the_gpv gpv \<and>
-    map_spmf snd pq = the_gpv gpv''"
-  define pq where "pq gpv gpv'' = Eps (?P_spmf gpv gpv'')" for gpv gpv''
-  let ?P_generat = "\<lambda>generat generat'' gg'. 
-    (\<forall>(a, a'') \<in> generat_pures gg'. (A OO A') a a'') \<and> (\<forall>(out, out'') \<in> generat_outs gg'. (C OO C') out out'') \<and> (\<forall>(c, c'')\<in>generat_conts gg'. (R OO R' ===> rel_gpv'' (A OO A') (C OO C') (R OO R')) c c'') \<and>
-    map_generat fst fst fst gg' = generat \<and> 
-    map_generat snd snd snd gg' = generat''"
-  define gg' where "gg' generat generat'' = Eps (?P_generat generat generat'')" for generat generat''
-  define middle where "middle \<equiv> corec_gpv (\<lambda>(gpv, gpv''). 
-     map_spmf (\<lambda>(generat, generat''). 
-       map_generat (\<lambda>(a, a''). SOME a'. A a a' \<and> A' a' a'') (\<lambda>(out, out''). SOME out'. C out out' \<and> C' out' out'')
-            (\<lambda>(rpv, rpv'') input. Inr (rpv (THE x. R x input), rpv'' (THE z. R' input z))) (gg' generat generat'')
-     ) (pq gpv gpv''))"
-  have sel_middle:
-    "the_gpv (middle (gpv, gpv'')) = map_spmf (\<lambda>(generat, generat''). map_generat
-           (\<lambda>(a, a''). SOME a'. A a a' \<and> A' a' a'')
-           (\<lambda>(out, out''). SOME out'. C out out' \<and> C' out' out'')
-           (\<lambda>(rpv, rpv'') xa. middle (rpv (THE x. R x xa), rpv'' (THE x''. R' xa x'')))
-           (gg' generat generat''))
-       (pq gpv gpv'')"
-    for gpv gpv'' unfolding middle_def by(simp add: spmf.map_comp split_def o_def generat.map_comp)
-  from * show "rel_gpv'' A C R gpv (middle (gpv, gpv''))"
-  proof(coinduction arbitrary: gpv gpv'')
-    case (rel_gpv'' gpv gpv'')
-    let ?X = "\<lambda>gpv gpv'. (\<exists>gpv''. gpv' = middle (gpv, gpv'') \<and> rel_gpv'' (A OO A') (C OO C') (R OO R') gpv gpv'') \<or> rel_gpv'' A C R gpv gpv'"
-    from rel_gpv''D[OF rel_gpv''] have "Ex (?P_spmf gpv gpv'')" by(auto simp add: rel_spmf_simps)
-    hence pq: "?P_spmf gpv gpv'' (pq gpv gpv'')" unfolding pq_def by(rule someI_ex)
-    hence "rel_spmf (\<lambda>generat (generat', generat''). generat = generat')\<inverse>\<inverse> (pq gpv gpv'') (the_gpv gpv)"
-      by(fold spmf_rel_eq)(auto simp add: spmf_rel_map split_def elim: rel_spmf_mono)
-    then show ?case
-    proof(clarsimp simp add: sel_middle spmf_rel_conversep spmf_rel_map generat.rel_map prod.case_distrib[where h="A _"] prod.case_distrib[where h="C _"] prod.case_distrib[where h="rel_fun _ _ _"] elim!: rel_spmf_mono_strong)
-      fix generat generat''
-      assume "(generat, generat'') \<in> set_spmf (pq gpv gpv'')"
-      with pq have "rel_generat (A OO A') (C OO C') (R OO R' ===> rel_gpv'' (A OO A') (C OO C') (R OO R')) generat generat''"
-        by blast
-      hence "Ex (?P_generat generat generat'')" by(auto simp add: Grp_def generat.rel_compp_Grp)
-      hence gg': "?P_generat generat generat'' (gg' generat generat'')" unfolding gg'_def by(rule someI_ex)
-      hence "rel_generat (\<lambda>a aa''. a = fst aa'')\<inverse>\<inverse> (\<lambda>out outout''. out = fst outout'')\<inverse>\<inverse> (\<lambda>rpv rpvrpv''. rpv = fst rpvrpv'')\<inverse>\<inverse> (gg' generat generat'') generat"
-        by(fold generat.rel_eq)(auto simp add: generat.rel_map elim!: generat.rel_mono_strong)
-      then show "rel_generat (\<lambda>a (aa, a''). A a (SOME a'. A aa a' \<and> A' a' a''))
-                 (\<lambda>out (outt, out''). C out (SOME out'. C outt out' \<and> C' out' out''))
-                 (\<lambda>rpv (rpvv, rpv''). (R ===> ?X) rpv (\<lambda>y. middle (rpvv (THE x. R x y), rpv'' (THE z. R' y z))))
-                 generat (gg' generat generat'')"
-        unfolding generat.rel_conversep conversep_iff apply(rule generat.rel_mono_strong)
-      proof(safe, simp_all)
-        fix a a''
-        assume "(a, a'') \<in> generat_pures (gg' generat generat'')"
-        with gg' have "\<exists>a'. A a a' \<and> A' a' a''" by blast
-        from someI_ex[OF this] show "A a (SOME a'. A a a' \<and> A' a' a'')" ..
-      next
-        fix out out''
-        assume "(out, out'') \<in> generat_outs (gg' generat generat'')"
-        with gg' have "\<exists>out'. C out out' \<and> C' out' out''" by blast
-        from someI_ex[OF this] show "C out (SOME out'. C out out' \<and> C' out' out'')" ..
-      next
-        fix rpv rpv''
-        assume "(rpv, rpv'') \<in> generat_conts (gg' generat generat'')"
-        with gg' have *: "(R OO R' ===> rel_gpv'' (A OO A') (C OO C') (R OO R')) rpv rpv''" by blast
-        show "(R ===> ?X) rpv (\<lambda>y. middle (rpv (THE x. R x y), rpv'' (THE z. R' y z)))"
-        proof(rule rel_funI)
-          fix x y
-          assume xy: "R x y"
-          from R' obtain z where yz: "R' y z" by(blast elim: left_totalE)
-          with xy have "(R OO R') x z" by blast
-          with * have "rel_gpv'' (A OO A') (C OO C') (R OO R') (rpv x) (rpv'' z)" by(rule rel_funD)
-          moreover have "(THE x. R x y) = x" using xy
-            by(rule the_equality)(blast dest: left_uniqueD[OF R(1) xy])
-          moreover have "(THE z. R' y z) = z" using yz
-            by(rule the_equality)(blast dest: right_uniqueD[OF R'(1) yz])
-          ultimately show "?X (rpv x) (middle (rpv (THE x. R x y), rpv'' (THE z. R' y z)))" by blast
-        qed
-      qed
-    qed
-  qed
-  from * show "rel_gpv'' A' C' R' (middle (gpv, gpv'')) gpv''"
-  proof(coinduction arbitrary: gpv gpv'')
-    case (rel_gpv'' gpv gpv'')
-    let ?X = "\<lambda>gpv' gpv''. (\<exists>gpv. gpv' = middle (gpv, gpv'') \<and> rel_gpv'' (A OO A') (C OO C') (R OO R') gpv gpv'') \<or> rel_gpv'' A' C' R' gpv' gpv''"
-    from rel_gpv''D[OF rel_gpv''] have "Ex (?P_spmf gpv gpv'')" by(auto simp add: rel_spmf_simps)
-    hence pq: "?P_spmf gpv gpv'' (pq gpv gpv'')" unfolding pq_def by(rule someI_ex)
-    hence "rel_spmf (\<lambda>(generat', generat'') generat. generat = generat'') (pq gpv gpv'') (the_gpv gpv'')"
-      by(fold spmf_rel_eq)(auto simp add: spmf_rel_map split_def elim: rel_spmf_mono)
-    then show ?case
-    proof(clarsimp simp add: sel_middle spmf_rel_conversep spmf_rel_map generat.rel_map prod.case_distrib[where h="A'"] prod.case_distrib[where h="C'"] prod.case_distrib[where h="rel_fun _ _"] elim!: rel_spmf_mono_strong)
-      fix generat generat''
-      assume "(generat, generat'') \<in> set_spmf (pq gpv gpv'')"
-      with pq have "rel_generat (A OO A') (C OO C') (R OO R' ===> rel_gpv'' (A OO A') (C OO C') (R OO R')) generat generat''"
-        by blast
-      hence "Ex (?P_generat generat generat'')" by(auto simp add: Grp_def generat.rel_compp_Grp)
-      hence gg': "?P_generat generat generat'' (gg' generat generat'')" unfolding gg'_def by(rule someI_ex)
-      hence "rel_generat (\<lambda>aa'' a. a = snd aa'') (\<lambda>outout'' out. out = snd outout'') (\<lambda>rpvrpv'' rpv. rpv = snd rpvrpv'') (gg' generat generat'') generat''"
-        by(fold generat.rel_eq)(auto simp add: generat.rel_map elim!: generat.rel_mono_strong)
-      then show "rel_generat (\<lambda>(a, aa'') a''. A' (SOME a'. A a a' \<and> A' a' aa'') a'')
-                 (\<lambda>(out, outt'') out''. C' (SOME out'. C out out' \<and> C' out' outt'') out'')
-                 (\<lambda>(rpv, rpvv'') rpv''. (R' ===> ?X) (\<lambda>y. middle (rpv (THE x. R x y), rpvv'' (THE z. R' y z))) rpv'')
-                 (gg' generat generat'') generat''"
-        apply(rule generat.rel_mono_strong)
-      proof(safe, simp_all)
-        fix a a''
-        assume "(a, a'') \<in> generat_pures (gg' generat generat'')"
-        with gg' have "\<exists>a'. A a a' \<and> A' a' a''" by blast
-        from someI_ex[OF this] show "A' (SOME a'. A a a' \<and> A' a' a'') a''" ..
-      next
-        fix out out''
-        assume "(out, out'') \<in> generat_outs (gg' generat generat'')"
-        with gg' have "\<exists>out'. C out out' \<and> C' out' out''" by blast
-        from someI_ex[OF this] show "C' (SOME out'. C out out' \<and> C' out' out'') out''" ..
-      next
-        fix rpv rpv''
-        assume "(rpv, rpv'') \<in> generat_conts (gg' generat generat'')"
-        with gg' have *: "(R OO R' ===> rel_gpv'' (A OO A') (C OO C') (R OO R')) rpv rpv''" by blast
-        show "(R' ===> ?X) (\<lambda>y. middle (rpv (THE x. R x y), rpv'' (THE z. R' y z))) rpv''"
-        proof(rule rel_funI)
-          fix y z
-          assume yz: "R' y z"
-          from R obtain x where xy: "R x y" by(blast elim: right_totalE)
-          with yz have "(R OO R') x z" by blast
-          with * have "rel_gpv'' (A OO A') (C OO C') (R OO R') (rpv x) (rpv'' z)" by(rule rel_funD)
-          moreover have "(THE x. R x y) = x" using xy
-            by(rule the_equality)(blast dest: left_uniqueD[OF R(1) xy])
-          moreover have "(THE z. R' y z) = z" using yz
-            by(rule the_equality)(blast dest: right_uniqueD[OF R'(1) yz])
-          ultimately show "?X (middle (rpv (THE x. R x y), rpv'' (THE z. R' y z))) (rpv'' z)" by blast
-        qed
-      qed
-    qed
-  qed
+  let ?gpv' = "map_gpv (relcompp_witness A A') (relcompp_witness C C') (rel_witness_gpv (A OO A') (C OO C') R R' (gpv, gpv''))"
+  show "rel_gpv'' A C R gpv ?gpv'" using rel_witness_gpv1[OF * R R'] unfolding rel_gpv''_map_gpv
+    by(rule rel_gpv''_mono[THEN predicate2D, rotated -1]; clarify del: relcomppE elim!: relcompp_witness)
+  show "rel_gpv'' A' C' R' ?gpv' gpv''" using rel_witness_gpv2[OF * R R'] unfolding rel_gpv''_map_gpv
+    by(rule rel_gpv''_mono[THEN predicate2D, rotated -1]; clarify del: relcomppE elim!: relcompp_witness)
 qed
 
+lemma rel_gpv''_mono' [mono]:
+  assumes "\<And>x y. A x y \<longrightarrow> A' x y"
+    and "\<And>x y. C x y \<longrightarrow> C' x y"
+    and "\<And>x y. R' x y \<longrightarrow> R x y"
+  shows "rel_gpv'' A C R gpv gpv' \<longrightarrow> rel_gpv'' A' C' R' gpv gpv'"
+  using rel_gpv''_mono[of A A' C C' R' R] assms by(blast)
+
 lemma left_total_rel_gpv':
   "\<lbrakk> left_total A; left_total C; left_unique R; right_total R \<rbrakk> \<Longrightarrow> left_total (rel_gpv'' A C R)"
 unfolding left_unique_alt_def left_total_alt_def rel_gpv''_conversep[symmetric]
 apply(subst rel_gpv''_eq[symmetric])
 apply(rule order_trans[rotated])
 apply(rule rel_gpv''_neg_distr; simp add: left_unique_alt_def)
 apply(rule rel_gpv''_mono; assumption)
 done
 
 lemma right_total_rel_gpv':
   "\<lbrakk> right_total A; right_total C; right_unique R; left_total R \<rbrakk> \<Longrightarrow> right_total (rel_gpv'' A C R)"
 unfolding right_unique_alt_def right_total_alt_def rel_gpv''_conversep[symmetric]
 apply(subst rel_gpv''_eq[symmetric])
 apply(rule order_trans[rotated])
 apply(rule rel_gpv''_neg_distr; simp add: right_unique_alt_def)
 apply(rule rel_gpv''_mono; assumption)
 done
 
 lemma bi_total_rel_gpv' [transfer_rule]:
   "\<lbrakk> bi_total A; bi_total C; bi_unique R; bi_total R \<rbrakk> \<Longrightarrow> bi_total (rel_gpv'' A C R)"
 unfolding bi_total_alt_def bi_unique_alt_def by(blast intro: left_total_rel_gpv' right_total_rel_gpv')
 
 lemma rel_fun_conversep_grp_grp:
   "rel_fun (conversep (BNF_Def.Grp UNIV f)) (BNF_Def.Grp B g) = BNF_Def.Grp {x. (x \<circ> f) ` UNIV \<subseteq> B} (map_fun f g)"
 unfolding rel_fun_def Grp_def simp_thms fun_eq_iff conversep_iff by auto
 
 lemma Quotient_gpv:
   assumes Q1: "Quotient R1 Abs1 Rep1 T1"
   and Q2: "Quotient R2 Abs2 Rep2 T2"
   and Q3: "Quotient R3 Abs3 Rep3 T3"
   shows "Quotient (rel_gpv'' R1 R2 R3) (map_gpv' Abs1 Abs2 Rep3) (map_gpv' Rep1 Rep2 Abs3) (rel_gpv'' T1 T2 T3)"
   (is "Quotient ?R ?abs ?rep ?T")
 unfolding Quotient_alt_def2
 proof(intro conjI strip iffI; (elim conjE exE)?)
   note [simp] = spmf_rel_map generat.rel_map
     and [elim!] = rel_spmf_mono generat.rel_mono_strong
     and [rule del] = rel_funI and [intro!] = rel_funI
   have Abs1 [simp]: "Abs1 x = y" if "T1 x y" for x y using Q1 that by(simp add: Quotient_alt_def)
   have Abs2 [simp]: "Abs2 x = y" if "T2 x y" for x y using Q2 that by(simp add: Quotient_alt_def)
   have Abs3 [simp]: "Abs3 x = y" if "T3 x y" for x y using Q3 that by(simp add: Quotient_alt_def)
   have Rep1: "T1 (Rep1 x) x" for x using Q1 by(simp add: Quotient_alt_def)
   have Rep2: "T2 (Rep2 x) x" for x using Q2 by(simp add: Quotient_alt_def)
   have Rep3: "T3 (Rep3 x) x" for x using Q3 by(simp add: Quotient_alt_def)
   have T1: "T1 x (Abs1 y)" if "R1 x y" for x y using Q1 that by(simp add: Quotient_alt_def2)
   have T2: "T2 x (Abs2 y)" if "R2 x y" for x y using Q2 that by(simp add: Quotient_alt_def2)
   have T1': "T1 x (Abs1 y)" if "R1 y x" for x y using Q1 that by(simp add: Quotient_alt_def2)
   have T2': "T2 x (Abs2 y)" if "R2 y x" for x y using Q2 that by(simp add: Quotient_alt_def2)
   have R3: "R3 x (Rep3 y)" if "T3 x y" for x y using Q3 that by(simp add: Quotient_alt_def2 Abs3[OF Rep3])
   have R3': "R3 (Rep3 y) x" if "T3 x y" for x y using Q3 that by(simp add: Quotient_alt_def2 Abs3[OF Rep3])
   have r1: "R1 = T1 OO T1\<inverse>\<inverse>" using Q1 by(simp add: Quotient_alt_def4)
   have r2: "R2 = T2 OO T2\<inverse>\<inverse>" using Q2 by(simp add: Quotient_alt_def4)
   have r3: "R3 = T3 OO T3\<inverse>\<inverse>" using Q3 by(simp add: Quotient_alt_def4)
   show abs: "?abs gpv = gpv'" if "?T gpv gpv'" for gpv gpv' using that
     by(coinduction arbitrary: gpv gpv')(drule rel_gpv''D; auto 4 4 intro: Rep3 dest: rel_funD)
   show "?T (?rep gpv) gpv" for gpv
     by(coinduction arbitrary: gpv)(auto simp add: Rep1 Rep2 intro!: rel_spmf_reflI generat.rel_refl_strong)
   show "?T gpv (?abs gpv')" if "?R gpv gpv'" for gpv gpv' using that
     by(coinduction arbitrary: gpv gpv')(drule rel_gpv''D; auto 4 3 simp add: T1 T2 intro!: R3 dest: rel_funD)
   show "?T gpv (?abs gpv')" if "?R gpv' gpv" for gpv gpv'
   proof -
     from that have "rel_gpv'' R1\<inverse>\<inverse> R2\<inverse>\<inverse> R3\<inverse>\<inverse> gpv gpv'" unfolding rel_gpv''_conversep by simp
     then show ?thesis
       by(coinduction arbitrary: gpv gpv')(drule rel_gpv''D; auto 4 3 simp add: T1' T2' intro!: R3' dest: rel_funD)
   qed
   show "?R gpv gpv'" if "?T gpv (?abs gpv')" "?T gpv' (?abs gpv)" for gpv gpv'
   proof -
     from that[THEN abs] have "?abs gpv' = ?abs gpv" by simp
-    with that have "(?T OO ?T\<inverse>\<inverse>) gpv gpv'" by auto
+    with that have "(?T OO ?T\<inverse>\<inverse>) gpv gpv'" by(auto simp del: rel_gpv''_map_gpv')
     hence "rel_gpv'' (T1 OO T1\<inverse>\<inverse>) (T2 OO T2\<inverse>\<inverse>) (T3 OO T3\<inverse>\<inverse>) gpv gpv'"
       unfolding rel_gpv''_conversep[symmetric]
       by(rule rel_gpv''_pos_distr[THEN predicate2D])
     thus ?thesis by(simp add: r1 r2 r3)
   qed
 qed
 
-lemma rel_gpv''_Grp: (* does not hold! *)
-  "rel_gpv'' (BNF_Def.Grp A f) (BNF_Def.Grp B g) (BNF_Def.Grp UNIV h)\<inverse>\<inverse> = 
-   BNF_Def.Grp {x. results'_gpv x \<subseteq> A \<and> outs'_gpv x \<subseteq> B} (map_gpv' f g h)"
-   (is "?lhs = ?rhs")
-proof(intro ext GrpI iffI CollectI conjI subsetI)
-  fix gpv gpv'
-  assume *: "?lhs gpv gpv'"
-  then show "map_gpv' f g h gpv = gpv'"
-    apply(coinduction arbitrary: gpv gpv')
-    apply(drule rel_gpv''D)
-    apply(auto 4 5 simp add: spmf_rel_map generat.rel_map elim!: rel_spmf_mono generat.rel_mono_strong GrpE intro!: GrpI dest: rel_funD)
-    done
-  show "x \<in> A" if "x \<in> results'_gpv gpv" for x using that *
-  proof(induction arbitrary: gpv')
-    case (Pure generat gpv)
-    have "pred_spmf (Domainp (rel_generat (BNF_Def.Grp A f) (BNF_Def.Grp B g) ((BNF_Def.Grp UNIV h)\<inverse>\<inverse> ===> rel_gpv'' (BNF_Def.Grp A f) (BNF_Def.Grp B g) (BNF_Def.Grp UNIV h)\<inverse>\<inverse>))) (the_gpv gpv)"
-      using Pure.prems[THEN rel_gpv''D] unfolding spmf_Domainp_rel[symmetric] by(rule DomainPI)
-    with Pure.hyps show ?case by(simp add: generat.Domainp_rel pred_spmf_def pred_generat_def Domainp_Grp)
-  next
-    case (Cont generat gpv c input)
-    have "pred_spmf (Domainp (rel_generat (BNF_Def.Grp A f) (BNF_Def.Grp B g) ((BNF_Def.Grp UNIV h)\<inverse>\<inverse> ===> rel_gpv'' (BNF_Def.Grp A f) (BNF_Def.Grp B g) (BNF_Def.Grp UNIV h)\<inverse>\<inverse>))) (the_gpv gpv)"
-      using Cont.prems[THEN rel_gpv''D] unfolding spmf_Domainp_rel[symmetric] by(rule DomainPI)
-    with Cont.hyps show ?case apply(clarsimp simp add: generat.Domainp_rel pred_spmf_def pred_generat_def)
-      apply(drule (1) bspec)+
-      apply clarsimp
-      apply(drule rel_funD)
-      prefer 2
-      apply(erule Cont.IH)
-      apply(simp add: Grp_def)
-      oops
-
-
 lemma the_gpv_parametric':
   "(rel_gpv'' A C R ===> rel_spmf (rel_generat A C (R ===> rel_gpv'' A C R))) the_gpv the_gpv"
 by(rule rel_funI)(auto elim: rel_gpv''.cases)
 
 lemma GPV_parametric':
   "(rel_spmf (rel_generat A C (R ===> rel_gpv'' A C R)) ===> rel_gpv'' A C R) GPV GPV"
 by(rule rel_funI)(auto)
 
 lemma corec_gpv_parametric':
   "((S ===> rel_spmf (rel_generat A C (R ===> rel_sum (rel_gpv'' A C R) S))) ===> S ===> rel_gpv'' A C R)
   corec_gpv corec_gpv"
 proof(rule rel_funI)+
   fix f g s1 s2
   assume fg: "(S ===> rel_spmf (rel_generat A C (R ===> rel_sum (rel_gpv'' A C R) S))) f g"
     and s: "S s1 s2"
   from s show "rel_gpv'' A C R (corec_gpv f s1) (corec_gpv g s2)"
     apply(coinduction arbitrary: s1 s2)
     apply(drule fg[THEN rel_funD])
     apply(simp add: spmf_rel_map)
     apply(erule rel_spmf_mono)
     apply(simp add: generat.rel_map)
     apply(erule generat.rel_mono_strong; clarsimp simp add: o_def)
     apply(rule rel_funI)
     apply(drule (1) rel_funD)
     apply(auto 4 3 elim!: rel_sum.cases)
     done
 qed
 
 lemma map_gpv'_parametric [transfer_rule]:
   "((A ===> A') ===> (C ===> C') ===> (R' ===> R) ===> rel_gpv'' A C R ===> rel_gpv'' A' C' R') map_gpv' map_gpv'"
   unfolding map_gpv'_def
   supply corec_gpv_parametric'[transfer_rule] the_gpv_parametric'[transfer_rule]
   by(transfer_prover)
 
 lemma map_gpv_parametric': "((A ===> A') ===> (C ===> C') ===> rel_gpv'' A C R ===> rel_gpv'' A' C' R) map_gpv map_gpv"
   unfolding map_gpv_conv_map_gpv'[abs_def] by transfer_prover
 
 end
 
 subsection \<open>Simple, derived operations\<close>
 
 primcorec Done :: "'a \<Rightarrow> ('a, 'out, 'in) gpv"
 where "the_gpv (Done a) = return_spmf (Pure a)"
 
 primcorec Pause :: "'out \<Rightarrow> ('in \<Rightarrow> ('a, 'out, 'in) gpv) \<Rightarrow> ('a, 'out, 'in) gpv"
 where "the_gpv (Pause out c) = return_spmf (IO out c)"
 
 primcorec lift_spmf :: "'a spmf \<Rightarrow> ('a, 'out, 'in) gpv"
 where "the_gpv (lift_spmf p) = map_spmf Pure p"
 
 definition Fail :: "('a, 'out, 'in) gpv"
 where "Fail = GPV (return_pmf None)"
 
 definition React :: "('in \<Rightarrow> 'out \<times> ('a, 'out, 'in) rpv) \<Rightarrow> ('a, 'out, 'in) rpv"
 where "React f input = case_prod Pause (f input)"
 
 definition rFail :: "('a, 'out, 'in) rpv"
 where "rFail = (\<lambda>_. Fail)"
 
 lemma Done_inject [simp]: "Done x = Done y \<longleftrightarrow> x = y"
 by(simp add: Done.ctr)
 
 lemma Pause_inject [simp]: "Pause out c = Pause out' c' \<longleftrightarrow> out = out' \<and> c = c'"
 by(simp add: Pause.ctr)
 
 lemma [simp]:
   shows Done_neq_Pause: "Done x \<noteq> Pause out c"
   and Pause_neq_Done: "Pause out c \<noteq> Done x"
 by(simp_all add: Done.ctr Pause.ctr)
 
 lemma outs'_gpv_Done [simp]: "outs'_gpv (Done x) = {}"
 by(auto elim: outs'_gpv_cases)
 
 lemma results'_gpv_Done [simp]: "results'_gpv (Done x) = {x}"
 by(auto intro: results'_gpvI elim: results'_gpv_cases)
 
 lemma pred_gpv_Done [simp]: "pred_gpv P Q (Done x) = P x"
 by(simp add: pred_gpv_def)
 
 lemma outs'_gpv_Pause [simp]: "outs'_gpv (Pause out c) = insert out (\<Union>input. outs'_gpv (c input))"
 by(auto 4 4 intro: outs'_gpvI elim: outs'_gpv_cases)
 
 lemma results'_gpv_Pause [simp]: "results'_gpv (Pause out rpv) = results'_rpv rpv"
 by(auto 4 4 intro: results'_gpvI elim: results'_gpv_cases)
 
 lemma pred_gpv_Pause [simp]: "pred_gpv P Q (Pause x c) = (Q x \<and> All (pred_gpv P Q \<circ> c))"
 by(auto simp add: pred_gpv_def o_def)
 
 lemma lift_spmf_return [simp]: "lift_spmf (return_spmf x) = Done x"
 by(simp add: lift_spmf.ctr Done.ctr)
 
 lemma lift_spmf_None [simp]: "lift_spmf (return_pmf None) = Fail"
 by(rule gpv.expand)(simp add: Fail_def)
 
 lemma the_gpv_lift_spmf [simp]: "the_gpv (lift_spmf r) = map_spmf Pure r"
 by(simp)
 
 lemma outs'_gpv_lift_spmf [simp]: "outs'_gpv (lift_spmf p) = {}"
 by(auto 4 3 elim: outs'_gpv_cases)
 
 lemma results'_gpv_lift_spmf [simp]: "results'_gpv (lift_spmf p) = set_spmf p"
 by(auto 4 3 elim: results'_gpv_cases intro: results'_gpvI)
 
 lemma pred_gpv_lift_spmf [simp]: "pred_gpv P Q (lift_spmf p) = pred_spmf P p"
 by(simp add: pred_gpv_def pred_spmf_def)
 
 lemma lift_spmf_inject [simp]: "lift_spmf p = lift_spmf q \<longleftrightarrow> p = q"
 by(auto simp add: lift_spmf.code dest!: pmf.inj_map_strong[rotated] option.inj_map_strong[rotated])
 
 lemma map_lift_spmf: "map_gpv f g (lift_spmf p) = lift_spmf (map_spmf f p)"
 by(rule gpv.expand)(simp add: gpv.map_sel spmf.map_comp o_def)
 
 lemma lift_map_spmf: "lift_spmf (map_spmf f p) = map_gpv f id (lift_spmf p)"
 by(rule gpv.expand)(simp add: gpv.map_sel spmf.map_comp o_def)
 
 lemma [simp]:
   shows Fail_neq_Pause: "Fail \<noteq> Pause out c"
   and Pause_neq_Fail: "Pause out c \<noteq> Fail"
   and Fail_neq_Done: "Fail \<noteq> Done x"
   and Done_neq_Fail: "Done x \<noteq> Fail"
 by(simp_all add: Fail_def Pause.ctr Done.ctr)
 
 text \<open>Add @{typ unit} closure to circumvent SML value restriction\<close>
 
 definition Fail' :: "unit \<Rightarrow> ('a, 'out, 'in) gpv"
 where [code del]: "Fail' _ = Fail"
 
 lemma Fail_code [code_unfold]: "Fail = Fail' ()"
 by(simp add: Fail'_def)
 
 lemma Fail'_code [code]:
   "Fail' x = GPV (return_pmf None)"
 by(simp add: Fail'_def Fail_def)
 
 lemma Fail_sel [simp]:
   "the_gpv Fail = return_pmf None"
 by(simp add: Fail_def)
 
 lemma Fail_eq_GPV_iff [simp]: "Fail = GPV f \<longleftrightarrow> f = return_pmf None"
 by(auto simp add: Fail_def)
 
 lemma outs'_gpv_Fail [simp]: "outs'_gpv Fail = {}"
 by(auto elim: outs'_gpv_cases)
 
 lemma results'_gpv_Fail [simp]: "results'_gpv Fail = {}"
 by(auto elim: results'_gpv_cases)
 
 lemma pred_gpv_Fail [simp]: "pred_gpv P Q Fail"
 by(simp add: pred_gpv_def)
 
 lemma React_inject [iff]: "React f = React f' \<longleftrightarrow> f = f'"
 by(auto simp add: React_def fun_eq_iff split_def intro: prod.expand)
 
 lemma React_apply [simp]: "f input = (out, c) \<Longrightarrow> React f input = Pause out c"
 by(simp add: React_def)
 
 lemma rFail_apply [simp]: "rFail input = Fail"
 by(simp add: rFail_def)
 
 lemma [simp]:
   shows rFail_neq_React: "rFail \<noteq> React f"
   and React_neq_rFail: "React f \<noteq> rFail"
 by(simp_all add: React_def fun_eq_iff split_beta)
 
 lemma rel_gpv_FailI [simp]: "rel_gpv A C Fail Fail"
 by(subst gpv.rel_sel) simp
 
 lemma rel_gpv_Done [iff]: "rel_gpv A C (Done x) (Done y) \<longleftrightarrow> A x y"
 by(subst gpv.rel_sel) simp
 
 lemma rel_gpv''_Done [iff]: "rel_gpv'' A C R (Done x) (Done y) \<longleftrightarrow> A x y"
 by(subst rel_gpv''.simps) simp
 
 lemma rel_gpv_Pause [iff]:
   "rel_gpv A C (Pause out c) (Pause out' c') \<longleftrightarrow> C out out' \<and> (\<forall>x. rel_gpv A C (c x) (c' x))"
 by(subst gpv.rel_sel)(simp add: rel_fun_def)
 
 lemma rel_gpv''_Pause [iff]:
   "rel_gpv'' A C R (Pause out c) (Pause out' c') \<longleftrightarrow> C out out' \<and> (\<forall>x x'. R x x' \<longrightarrow> rel_gpv'' A C R (c x) (c' x'))"
 by(subst rel_gpv''.simps)(simp add: rel_fun_def)
 
 lemma rel_gpv_lift_spmf [iff]: "rel_gpv A C (lift_spmf p) (lift_spmf q) \<longleftrightarrow> rel_spmf A p q"
 by(subst gpv.rel_sel)(simp add: spmf_rel_map)
 
 lemma rel_gpv''_lift_spmf [iff]:
   "rel_gpv'' A C R (lift_spmf p) (lift_spmf q) \<longleftrightarrow> rel_spmf A p q"
 by(subst rel_gpv''.simps)(simp add: spmf_rel_map)
 
 context includes lifting_syntax begin
 lemmas Fail_parametric [transfer_rule] = rel_gpv_FailI
 
 lemma Fail_parametric' [simp]: "rel_gpv'' A C R Fail Fail"
 unfolding Fail_def by simp
 
 lemma Done_parametric [transfer_rule]: "(A ===> rel_gpv A C) Done Done"
 by(rule rel_funI) simp
 
 lemma Done_parametric': "(A ===> rel_gpv'' A C R) Done Done"
 by(rule rel_funI) simp
 
 lemma Pause_parametric [transfer_rule]:
   "(C ===> ((=) ===> rel_gpv A C) ===> rel_gpv A C) Pause Pause"
 by(simp add: rel_fun_def)
 
 lemma Pause_parametric':
   "(C ===> (R ===> rel_gpv'' A C R) ===> rel_gpv'' A C R) Pause Pause"
 by(simp add: rel_fun_def)
 
 lemma lift_spmf_parametric [transfer_rule]:
   "(rel_spmf A ===> rel_gpv A C) lift_spmf lift_spmf"
 by(simp add: rel_fun_def)
 
 lemma lift_spmf_parametric':
   "(rel_spmf A ===> rel_gpv'' A C R) lift_spmf lift_spmf"
 by(simp add: rel_fun_def)
 end
 
 lemma map_gpv_Done [simp]: "map_gpv f g (Done x) = Done (f x)"
 by(simp add: Done.code)
 
 lemma map_gpv'_Done [simp]: "map_gpv' f g h (Done x) = Done (f x)"
 by(simp add: Done.code)
 
 lemma map_gpv_Pause [simp]: "map_gpv f g (Pause x c) = Pause (g x) (map_gpv f g \<circ> c)"
 by(simp add: Pause.code)
 
 lemma map_gpv'_Pause [simp]: "map_gpv' f g h (Pause x c) = Pause (g x) (map_gpv' f g h \<circ> c \<circ> h)"
 by(simp add: Pause.code map_fun_def)
 
 lemma map_gpv_Fail [simp]: "map_gpv f g Fail = Fail"
 by(simp add: Fail_def)
 
 lemma map_gpv'_Fail [simp]: "map_gpv' f g h Fail = Fail"
 by(simp add: Fail_def)
 
 subsection \<open>Monad structure\<close>
 
 primcorec bind_gpv :: "('a, 'out, 'in) gpv \<Rightarrow> ('a \<Rightarrow> ('b, 'out, 'in) gpv) \<Rightarrow> ('b, 'out, 'in) gpv"
 where
   "the_gpv (bind_gpv r f) =
    map_spmf (map_generat id id ((\<circ>) (case_sum id (\<lambda>r. bind_gpv r f))))
      (the_gpv r \<bind>
       (case_generat
         (\<lambda>x. map_spmf (map_generat id id ((\<circ>) Inl)) (the_gpv (f x)))
         (\<lambda>out c. return_spmf (IO out (\<lambda>input. Inr (c input))))))"
 
 declare bind_gpv.sel [simp del]
 
 adhoc_overloading Monad_Syntax.bind bind_gpv
 
 lemma bind_gpv_unfold [code]:
   "r \<bind> f = GPV (
    do {
      generat \<leftarrow> the_gpv r;
      case generat of Pure x \<Rightarrow> the_gpv (f x)
        | IO out c \<Rightarrow> return_spmf (IO out (\<lambda>input. c input \<bind> f))
    })"
 unfolding bind_gpv_def
 apply(rule gpv.expand)
 apply(simp add: map_spmf_bind_spmf)
 apply(rule arg_cong[where f="bind_spmf (the_gpv r)"])
 apply(auto split: generat.split simp add: map_spmf_bind_spmf fun_eq_iff spmf.map_comp o_def generat.map_comp id_def[symmetric] generat.map_id pmf.map_id option.map_id)
 done
 
 lemma bind_gpv_code_cong: "f = f' \<Longrightarrow> bind_gpv f g = bind_gpv f' g" by simp
 setup \<open>Code_Simp.map_ss (Simplifier.add_cong @{thm bind_gpv_code_cong})\<close>
 
 lemma bind_gpv_sel:
   "the_gpv (r \<bind> f) =
    do {
      generat \<leftarrow> the_gpv r;
      case generat of Pure x \<Rightarrow> the_gpv (f x)
        | IO out c \<Rightarrow> return_spmf (IO out (\<lambda>input. bind_gpv (c input) f))
    }"
 by(subst bind_gpv_unfold) simp
 
 lemma bind_gpv_sel' [simp]:
   "the_gpv (r \<bind> f) =
    do {
      generat \<leftarrow> the_gpv r;
      if is_Pure generat then the_gpv (f (result generat))
      else return_spmf (IO (output generat) (\<lambda>input. bind_gpv (continuation generat input) f))
    }"
 unfolding bind_gpv_sel
 by(rule arg_cong[where f="bind_spmf (the_gpv r)"])(simp add: fun_eq_iff split: generat.split)
 
 lemma Done_bind_gpv [simp]: "Done a \<bind> f = f a"
 by(rule gpv.expand)(simp)
 
 lemma bind_gpv_Done [simp]: "f \<bind> Done = f"
 proof(coinduction arbitrary: f rule: gpv.coinduct)
   case (Eq_gpv f)
   have *: "the_gpv f \<bind> (case_generat (\<lambda>x. return_spmf (Pure x)) (\<lambda>out c. return_spmf (IO out (\<lambda>input. Inr (c input))))) =
            map_spmf (map_generat id id ((\<circ>) Inr)) (bind_spmf (the_gpv f) return_spmf)"
     unfolding map_spmf_bind_spmf
     by(rule arg_cong2[where f=bind_spmf])(auto simp add: fun_eq_iff split: generat.split)
   show ?case
     by(auto simp add: * bind_gpv.simps pmf.rel_map option.rel_map[abs_def] generat.rel_map[abs_def] simp del: bind_gpv_sel' intro!: rel_generatI rel_spmf_reflI)
 qed
 
 lemma if_distrib_bind_gpv2 [if_distribs]:
   "bind_gpv gpv (\<lambda>y. if b then f y else g y) = (if b then bind_gpv gpv f else bind_gpv gpv g)"
 by simp
 
 lemma lift_spmf_bind: "lift_spmf r \<bind> f = GPV (r \<bind> the_gpv \<circ> f)"
 by(coinduction arbitrary: r f rule: gpv.coinduct_strong)(auto simp add: bind_map_spmf o_def intro: rel_pmf_reflI rel_optionI rel_generatI)
 
 lemma the_gpv_bind_gpv_lift_spmf [simp]:
   "the_gpv (bind_gpv (lift_spmf p) f) = bind_spmf p (the_gpv \<circ> f)"
 by(simp add: bind_map_spmf o_def)
 
 lemma lift_spmf_bind_spmf: "lift_spmf (p \<bind> f) = lift_spmf p \<bind> (\<lambda>x. lift_spmf (f x))"
 by(rule gpv.expand)(simp add: lift_spmf_bind o_def map_spmf_bind_spmf)
 
 lemma lift_bind_spmf: "lift_spmf (bind_spmf p f) = bind_gpv (lift_spmf p) (lift_spmf \<circ> f)"
 by(rule gpv.expand)(simp add: bind_map_spmf map_spmf_bind_spmf o_def)
 
 lemma GPV_bind:
   "GPV f \<bind> g = 
    GPV (f \<bind> (\<lambda>generat. case generat of Pure x \<Rightarrow> the_gpv (g x) | IO out c \<Rightarrow> return_spmf (IO out (\<lambda>input. c input \<bind> g))))"
 by(subst bind_gpv_unfold) simp
 
 lemma GPV_bind':
   "GPV f \<bind> g = GPV (f \<bind> (\<lambda>generat. if is_Pure generat then the_gpv (g (result generat)) else return_spmf (IO (output generat) (\<lambda>input. continuation generat input \<bind> g))))"
 unfolding GPV_bind gpv.inject
 by(rule arg_cong[where f="bind_spmf f"])(simp add: fun_eq_iff split: generat.split)
 
 lemma bind_gpv_assoc:
   fixes f :: "('a, 'out, 'in) gpv"
   shows "(f \<bind> g) \<bind> h = f \<bind> (\<lambda>x. g x \<bind> h)"
 proof(coinduction arbitrary: f g h rule: gpv.coinduct_strong)
   case (Eq_gpv f g h)
   show ?case
     apply(simp cong del: if_weak_cong)
     apply(rule rel_spmf_bindI[where R="(=)"])
      apply(simp add: option.rel_eq pmf.rel_eq)
     apply(fastforce intro: rel_pmf_return_pmfI rel_generatI rel_spmf_reflI)
     done
 qed
 
 lemma map_gpv_bind_gpv: "map_gpv f g (bind_gpv gpv h) = bind_gpv (map_gpv id g gpv) (\<lambda>x. map_gpv f g (h x))"
 apply(coinduction arbitrary: gpv rule: gpv.coinduct_strong)
 apply(simp add: bind_gpv.sel gpv.map_sel spmf_rel_map generat.rel_map o_def bind_map_spmf del: bind_gpv_sel')
 apply(rule rel_spmf_bind_reflI)
 apply(auto simp add: spmf_rel_map generat.rel_map split: generat.split del: rel_funI intro!: rel_spmf_reflI generat.rel_refl rel_funI)
 done
 
 lemma map_gpv_id_bind_gpv: "map_gpv f id (bind_gpv gpv g) = bind_gpv gpv (map_gpv f id \<circ> g)"
 by(simp add: map_gpv_bind_gpv gpv.map_id o_def)
 
 lemma map_gpv_conv_bind:
   "map_gpv f (\<lambda>x. x) x = bind_gpv x (\<lambda>x. Done (f x))"
 using map_gpv_bind_gpv[of f "\<lambda>x. x" x Done] by(simp add: id_def[symmetric] gpv.map_id)
 
 lemma bind_map_gpv: "bind_gpv (map_gpv f id gpv) g = bind_gpv gpv (g \<circ> f)"
 by(simp add: map_gpv_conv_bind id_def bind_gpv_assoc o_def)
 
 lemma outs_bind_gpv:
   "outs'_gpv (bind_gpv x f) = outs'_gpv x \<union> (\<Union>x \<in> results'_gpv x. outs'_gpv (f x))"
   (is "?lhs = ?rhs")
 proof(rule Set.set_eqI iffI)+
   fix out
   assume "out \<in> ?lhs"
   then show "out \<in> ?rhs"
   proof(induction g\<equiv>"x \<bind> f" arbitrary: x)
     case (Out generat)
     then obtain generat' where *: "generat' \<in> set_spmf (the_gpv x)"
       and **: "generat \<in> set_spmf (if is_Pure generat' then the_gpv (f (result generat'))
                                 else return_spmf (IO (output generat') (\<lambda>input. continuation generat' input \<bind> f)))"
       by(auto)
     show ?case
     proof(cases "is_Pure generat'")
       case True
       then have "out \<in> outs'_gpv (f (result generat'))" using Out(2) ** by(auto intro: outs'_gpvI)
       moreover have "result generat' \<in> results'_gpv x" using * True
         by(auto intro: results'_gpvI generat.set_sel)
       ultimately show ?thesis by blast
     next
       case False
       hence "out \<in> outs'_gpv x" using * ** Out(2) by(auto intro: outs'_gpvI generat.set_sel)
       thus ?thesis by blast
     qed
   next
     case (Cont generat c input)
     then obtain generat' where *: "generat' \<in> set_spmf (the_gpv x)"
       and **: "generat \<in> set_spmf (if is_Pure generat' then the_gpv (f (generat.result generat'))
                                  else return_spmf (IO (generat.output generat') (\<lambda>input. continuation generat' input \<bind> f)))"
       by(auto)
     show ?case
     proof(cases "is_Pure generat'")
       case True
       then have "out \<in> outs'_gpv (f (result generat'))" using Cont(2-3) ** by(auto intro: outs'_gpvI)
       moreover have "result generat' \<in> results'_gpv x" using * True
         by(auto intro: results'_gpvI generat.set_sel)
       ultimately show ?thesis by blast
     next
       case False
       then have generat: "generat = IO (output generat') (\<lambda>input. continuation generat' input \<bind> f)"
         using ** by simp
       with Cont(2) have "c input = continuation generat' input \<bind> f" by auto
       hence "out \<in> outs'_gpv (continuation generat' input) \<union> (\<Union>x\<in>results'_gpv (continuation generat' input). outs'_gpv (f x))"
         by(rule Cont)
       thus ?thesis
       proof
         assume "out \<in> outs'_gpv (continuation generat' input)"
         with * ** False have "out \<in> outs'_gpv x" by(auto intro: outs'_gpvI generat.set_sel)
         thus ?thesis ..
       next
         assume "out \<in> (\<Union>x\<in>results'_gpv (continuation generat' input). outs'_gpv (f x))"
         then obtain y where "y \<in> results'_gpv (continuation generat' input)" "out \<in> outs'_gpv (f y)" ..
         from \<open>y \<in> _\<close> * ** False have "y \<in> results'_gpv x" 
           by(auto intro: results'_gpvI generat.set_sel)
         with \<open>out \<in> outs'_gpv (f y)\<close> show ?thesis by blast
       qed
     qed
   qed
 next
   fix out
   assume "out \<in> ?rhs"
   then show "out \<in> ?lhs"
   proof
     assume "out \<in> outs'_gpv x"
     thus ?thesis
     proof(induction)
       case (Out generat gpv)
       then show ?case
         by(cases generat)(fastforce intro: outs'_gpvI rev_bexI)+
     next
       case (Cont generat gpv gpv')
       then show ?case
         by(cases generat)(auto 4 4 intro: outs'_gpvI rev_bexI simp add: in_set_spmf set_pmf_bind_spmf simp del: set_bind_spmf)
     qed
   next
     assume "out \<in> (\<Union>x\<in>results'_gpv x. outs'_gpv (f x))"
     then obtain y where "y \<in> results'_gpv x" "out \<in> outs'_gpv (f y)" ..
     from \<open>y \<in> _\<close> show ?thesis
     proof(induction)
       case (Pure generat gpv)
       thus ?case using \<open>out \<in> outs'_gpv _\<close>
         by(cases generat)(auto 4 5 intro: outs'_gpvI rev_bexI elim: outs'_gpv_cases)
     next
       case (Cont generat gpv gpv')
       thus ?case
         by(cases generat)(auto 4 4 simp add: in_set_spmf simp add: set_pmf_bind_spmf intro: outs'_gpvI rev_bexI simp del: set_bind_spmf)
     qed
   qed
 qed
 
 lemma bind_gpv_Fail [simp]: "Fail \<bind> f = Fail"
 by(subst bind_gpv_unfold)(simp add: Fail_def)
 
 lemma bind_gpv_eq_Fail:
   "bind_gpv gpv f = Fail \<longleftrightarrow> (\<forall>x\<in>set_spmf (the_gpv gpv). is_Pure x) \<and> (\<forall>x\<in>results'_gpv gpv. f x = Fail)"
   (is "?lhs = ?rhs")
 proof(intro iffI conjI strip)
   show ?lhs if ?rhs using that
     by(intro gpv.expand)(auto 4 4 simp add: bind_eq_return_pmf_None intro: results'_gpv_Pure generat.set_sel dest: bspec)
 
   assume ?lhs
   hence *: "the_gpv (bind_gpv gpv f) = return_pmf None" by simp
   from * show "is_Pure x" if "x \<in> set_spmf (the_gpv gpv)" for x using that
     by(simp add: bind_eq_return_pmf_None split: if_split_asm)
   show "f x = Fail" if "x \<in> results'_gpv gpv" for x using that *
     by(cases)(auto 4 3 simp add: bind_eq_return_pmf_None elim!: generat.set_cases intro: gpv.expand dest: bspec)
 qed
 
 context includes lifting_syntax begin
 
 lemma bind_gpv_parametric [transfer_rule]:
   "(rel_gpv A C ===> (A ===> rel_gpv B C) ===> rel_gpv B C) bind_gpv bind_gpv"
 unfolding bind_gpv_def by transfer_prover
 
 lemma bind_gpv_parametric':
   "(rel_gpv'' A C R ===> (A ===> rel_gpv'' B C R) ===> rel_gpv'' B C R) bind_gpv bind_gpv"
 unfolding bind_gpv_def supply corec_gpv_parametric'[transfer_rule] the_gpv_parametric'[transfer_rule]
 by(transfer_prover)
 
 end
 
 lemma monad_gpv [locale_witness]: "monad Done bind_gpv"
 by(unfold_locales)(simp_all add: bind_gpv_assoc)
 
 lemma monad_fail_gpv [locale_witness]: "monad_fail Done bind_gpv Fail"
 by unfold_locales auto
 
 lemma rel_gpv_bindI:
   "\<lbrakk> rel_gpv A C gpv gpv'; \<And>x y. A x y \<Longrightarrow> rel_gpv B C (f x) (g y) \<rbrakk>
   \<Longrightarrow> rel_gpv B C (bind_gpv gpv f) (bind_gpv gpv' g)"
 by(fact bind_gpv_parametric[THEN rel_funD, THEN rel_funD, OF _ rel_funI])
 
 lemma bind_gpv_cong:
   "\<lbrakk> gpv = gpv'; \<And>x. x \<in> results'_gpv gpv' \<Longrightarrow> f x = g x \<rbrakk> \<Longrightarrow> bind_gpv gpv f = bind_gpv gpv' g"
 apply(subst gpv.rel_eq[symmetric])
 apply(rule rel_gpv_bindI[where A="eq_onp (\<lambda>x. x \<in> results'_gpv gpv')"])
  apply(subst (asm) gpv.rel_eq[symmetric])
  apply(erule gpv.rel_mono_strong)
   apply(simp add: eq_onp_def)
  apply simp
 apply(clarsimp simp add: gpv.rel_eq eq_onp_def)
 done
 
 definition bind_rpv :: "('a, 'in, 'out) rpv \<Rightarrow> ('a \<Rightarrow> ('b, 'in, 'out) gpv) \<Rightarrow> ('b, 'in, 'out) rpv"
 where "bind_rpv rpv f = (\<lambda>input. bind_gpv (rpv input) f)"
 
 lemma bind_rpv_apply [simp]: "bind_rpv rpv f input = bind_gpv (rpv input) f"
 by(simp add: bind_rpv_def fun_eq_iff)
 
 adhoc_overloading Monad_Syntax.bind bind_rpv
 
 lemma bind_rpv_code_cong: "rpv = rpv' \<Longrightarrow> bind_rpv rpv f = bind_rpv rpv' f" by simp
 setup \<open>Code_Simp.map_ss (Simplifier.add_cong @{thm bind_rpv_code_cong})\<close>
 
 lemma bind_rpv_rDone [simp]: "bind_rpv rpv Done = rpv"
 by(simp add: bind_rpv_def)
 
 lemma bind_gpv_Pause [simp]: "bind_gpv (Pause out rpv) f = Pause out (bind_rpv rpv f)"
 by(rule gpv.expand)(simp add: fun_eq_iff)
 
 lemma bind_rpv_React [simp]: "bind_rpv (React f) g = React (apsnd (\<lambda>rpv. bind_rpv rpv g) \<circ> f)"
 by(simp add: React_def split_beta fun_eq_iff)
 
 lemma bind_rpv_assoc: "bind_rpv (bind_rpv rpv f) g = bind_rpv rpv ((\<lambda>gpv. bind_gpv gpv g) \<circ> f)"
 by(simp add: fun_eq_iff bind_gpv_assoc o_def)
 
 lemma bind_rpv_Done [simp]: "bind_rpv Done f = f"
 by(simp add: bind_rpv_def)
 
 lemma results'_rpv_Done [simp]: "results'_rpv Done = UNIV"
 by(auto simp add: results'_rpv_def)
 
 
 subsection \<open> Embedding @{typ "'a spmf"} as a monad \<close>
 
 lemma neg_fun_distr3:
   includes lifting_syntax
   assumes 1: "left_unique R" "right_total R"
   assumes 2: "right_unique S" "left_total S"
   shows "(R OO R' ===> S OO S') \<le> ((R ===> S) OO (R' ===> S'))"
 using functional_relation[OF 2] functional_converse_relation[OF 1]
 unfolding rel_fun_def OO_def
 apply clarify
 apply (subst all_comm)
 apply (subst all_conj_distrib[symmetric])
 apply (intro choice)
 by metis
 
 locale spmf_to_gpv begin
 
 text \<open>
   The lifting package cannot handle free term variables in the merging of transfer rules,
   so for the embedding we define a specialised relator \<open>rel_gpv'\<close>
   which acts only on the returned values.
 \<close>
 
 definition rel_gpv' :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> ('b, 'out, 'in) gpv \<Rightarrow> bool"
 where "rel_gpv' A = rel_gpv A (=)"
 
 lemma rel_gpv'_eq [relator_eq]: "rel_gpv' (=) = (=)"
 unfolding rel_gpv'_def gpv.rel_eq ..
 
 lemma rel_gpv'_mono [relator_mono]: "A \<le> B \<Longrightarrow> rel_gpv' A \<le> rel_gpv' B"
 unfolding rel_gpv'_def by(rule gpv.rel_mono; simp)
 
 lemma rel_gpv'_distr [relator_distr]: "rel_gpv' A OO rel_gpv' B = rel_gpv' (A OO B)"
 unfolding rel_gpv'_def by (metis OO_eq gpv.rel_compp) 
 
 lemma left_unique_rel_gpv' [transfer_rule]: "left_unique A \<Longrightarrow> left_unique (rel_gpv' A)"
 unfolding rel_gpv'_def by(simp add: left_unique_rel_gpv left_unique_eq)
 
 lemma right_unique_rel_gpv' [transfer_rule]: "right_unique A \<Longrightarrow> right_unique (rel_gpv' A)"
 unfolding rel_gpv'_def by(simp add: right_unique_rel_gpv right_unique_eq)
 
 lemma bi_unique_rel_gpv' [transfer_rule]: "bi_unique A \<Longrightarrow> bi_unique (rel_gpv' A)"
 unfolding rel_gpv'_def by(simp add: bi_unique_rel_gpv bi_unique_eq)
 
 lemma left_total_rel_gpv' [transfer_rule]: "left_total A \<Longrightarrow> left_total (rel_gpv' A)"
 unfolding rel_gpv'_def by(simp add: left_total_rel_gpv left_total_eq)
 
 lemma right_total_rel_gpv' [transfer_rule]: "right_total A \<Longrightarrow> right_total (rel_gpv' A)"
 unfolding rel_gpv'_def by(simp add: right_total_rel_gpv right_total_eq)
 
 lemma bi_total_rel_gpv' [transfer_rule]: "bi_total A \<Longrightarrow> bi_total (rel_gpv' A)"
 unfolding rel_gpv'_def by(simp add: bi_total_rel_gpv bi_total_eq)
 
 
 text \<open>
   We cannot use \<open>setup_lifting\<close> because @{typ "('a, 'out, 'in) gpv"} contains
   type variables which do not appear in @{typ "'a spmf"}.
 \<close>
 
 definition cr_spmf_gpv :: "'a spmf \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> bool"
 where "cr_spmf_gpv p gpv \<longleftrightarrow> gpv = lift_spmf p"
 
 definition spmf_of_gpv :: "('a, 'out, 'in) gpv \<Rightarrow> 'a spmf"
 where "spmf_of_gpv gpv = (THE p. gpv = lift_spmf p)"
 
 lemma spmf_of_gpv_lift_spmf [simp]: "spmf_of_gpv (lift_spmf p) = p"
 unfolding spmf_of_gpv_def by auto
 
 lemma rel_spmf_setD2:
   "\<lbrakk> rel_spmf A p q; y \<in> set_spmf q \<rbrakk> \<Longrightarrow> \<exists>x\<in>set_spmf p. A x y"
 by(erule rel_spmfE) force
 
 lemma rel_gpv_lift_spmf1: "rel_gpv A B (lift_spmf p) gpv \<longleftrightarrow> (\<exists>q. gpv = lift_spmf q \<and> rel_spmf A p q)"
 apply(subst gpv.rel_sel)
 apply(simp add: spmf_rel_map rel_generat_Pure1)
 apply safe
  apply(rule exI[where x="map_spmf result (the_gpv gpv)"])
  apply(clarsimp simp add: spmf_rel_map)
  apply(rule conjI)
   apply(rule gpv.expand)
   apply(simp add: spmf.map_comp)
   apply(subst map_spmf_cong[OF refl, where g=id])
    apply(drule (1) rel_spmf_setD2)
    apply clarsimp
   apply simp
  apply(erule rel_spmf_mono)
  apply clarsimp
 apply(clarsimp simp add: spmf_rel_map)
 done
 
 lemma rel_gpv_lift_spmf2: "rel_gpv A B gpv (lift_spmf q) \<longleftrightarrow> (\<exists>p. gpv = lift_spmf p \<and> rel_spmf A p q)"
 by(subst gpv.rel_flip[symmetric])(simp add: rel_gpv_lift_spmf1 pmf.rel_flip option.rel_conversep)
 
 definition pcr_spmf_gpv :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a spmf \<Rightarrow> ('b, 'out, 'in) gpv \<Rightarrow> bool"
 where "pcr_spmf_gpv A = cr_spmf_gpv OO rel_gpv A (=)"
 
 lemma pcr_cr_eq_spmf_gpv: "pcr_spmf_gpv (=) = cr_spmf_gpv"
 by(simp add: pcr_spmf_gpv_def gpv.rel_eq OO_eq)
 
 lemma left_unique_cr_spmf_gpv: "left_unique cr_spmf_gpv"
 by(rule left_uniqueI)(simp add: cr_spmf_gpv_def)
 
 lemma left_unique_pcr_spmf_gpv [transfer_rule]:
   "left_unique A \<Longrightarrow> left_unique (pcr_spmf_gpv A)"
 unfolding pcr_spmf_gpv_def by(intro left_unique_OO left_unique_cr_spmf_gpv left_unique_rel_gpv left_unique_eq)
 
 lemma right_unique_cr_spmf_gpv: "right_unique cr_spmf_gpv"
 by(rule right_uniqueI)(simp add: cr_spmf_gpv_def)
 
 lemma right_unique_pcr_spmf_gpv [transfer_rule]:
   "right_unique A \<Longrightarrow> right_unique (pcr_spmf_gpv A)"
 unfolding pcr_spmf_gpv_def by(intro right_unique_OO right_unique_cr_spmf_gpv right_unique_rel_gpv right_unique_eq)
 
 lemma bi_unique_cr_spmf_gpv: "bi_unique cr_spmf_gpv"
 by(simp add: bi_unique_alt_def left_unique_cr_spmf_gpv right_unique_cr_spmf_gpv)
 
 lemma bi_unique_pcr_spmf_gpv [transfer_rule]: "bi_unique A \<Longrightarrow> bi_unique (pcr_spmf_gpv A)"
 by(simp add: bi_unique_alt_def left_unique_pcr_spmf_gpv right_unique_pcr_spmf_gpv)
 
 lemma left_total_cr_spmf_gpv: "left_total cr_spmf_gpv"
 by(rule left_totalI)(simp add: cr_spmf_gpv_def)
 
 lemma left_total_pcr_spmf_gpv [transfer_rule]: "left_total A ==> left_total (pcr_spmf_gpv A)"
 unfolding pcr_spmf_gpv_def by(intro left_total_OO left_total_cr_spmf_gpv left_total_rel_gpv left_total_eq)
 
 context includes lifting_syntax begin
 
 lemma return_spmf_gpv_transfer':
   "((=) ===> cr_spmf_gpv) return_spmf Done"
 by(rule rel_funI)(simp add: cr_spmf_gpv_def)
 
 lemma return_spmf_gpv_transfer [transfer_rule]:
   "(A ===> pcr_spmf_gpv A) return_spmf Done"
 unfolding pcr_spmf_gpv_def
 apply(rewrite in "(\<hole> ===> _) _ _" eq_OO[symmetric])
 apply(rule pos_fun_distr[THEN le_funD, THEN le_funD, THEN le_boolD, THEN mp])
 apply(rule relcomppI)
  apply(rule return_spmf_gpv_transfer')
 apply transfer_prover
 done
 
 lemma bind_spmf_gpv_transfer':
   "(cr_spmf_gpv ===> ((=) ===> cr_spmf_gpv) ===> cr_spmf_gpv) bind_spmf bind_gpv"
 apply(clarsimp simp add: rel_fun_def cr_spmf_gpv_def)
 apply(rule gpv.expand)
 apply(simp add: bind_map_spmf map_spmf_bind_spmf o_def)
 done
 
 lemma bind_spmf_gpv_transfer [transfer_rule]:
   "(pcr_spmf_gpv A ===> (A ===> pcr_spmf_gpv B) ===> pcr_spmf_gpv B) bind_spmf bind_gpv"
 unfolding pcr_spmf_gpv_def
 apply(rewrite in "(_ ===> (\<hole> ===> _) ===> _) _ _" eq_OO[symmetric])
 apply(rule fun_mono[THEN le_funD, THEN le_funD, THEN le_boolD, THEN mp])
   apply(rule order.refl)
  apply(rule fun_mono)
   apply(rule neg_fun_distr3[OF left_unique_eq right_total_eq right_unique_cr_spmf_gpv left_total_cr_spmf_gpv])
  apply(rule order.refl)
 apply(rule fun_mono[THEN le_funD, THEN le_funD, THEN le_boolD, THEN mp])
   apply(rule order.refl)
  apply(rule pos_fun_distr)
 apply(rule pos_fun_distr[THEN le_funD, THEN le_funD, THEN le_boolD, THEN mp])
 apply(rule relcomppI)
  apply(rule bind_spmf_gpv_transfer')
 apply transfer_prover
 done
 
 lemma lift_spmf_gpv_transfer':
   "((=) ===> cr_spmf_gpv) (\<lambda>x. x) lift_spmf"
 by(simp add: rel_fun_def cr_spmf_gpv_def)
 
 lemma lift_spmf_gpv_transfer [transfer_rule]:
   "(rel_spmf A ===> pcr_spmf_gpv A) (\<lambda>x. x) lift_spmf"
 unfolding pcr_spmf_gpv_def
 apply(rewrite in "(\<hole> ===> _) _ _" eq_OO[symmetric])
 apply(rule pos_fun_distr[THEN le_funD, THEN le_funD, THEN le_boolD, THEN mp])
 apply(rule relcomppI)
  apply(rule lift_spmf_gpv_transfer')
 apply transfer_prover
 done
 
 lemma fail_spmf_gpv_transfer': "cr_spmf_gpv (return_pmf None) Fail"
 by(simp add: cr_spmf_gpv_def)
 
 lemma fail_spmf_gpv_transfer [transfer_rule]: "pcr_spmf_gpv A (return_pmf None) Fail"
 unfolding pcr_spmf_gpv_def
 apply(rule relcomppI)
  apply(rule fail_spmf_gpv_transfer')
 apply transfer_prover
 done
 
 lemma map_spmf_gpv_transfer':
   "((=) ===> R ===> cr_spmf_gpv ===> cr_spmf_gpv) (\<lambda>f g. map_spmf f) map_gpv"
 by(simp add: rel_fun_def cr_spmf_gpv_def map_lift_spmf)
 
 lemma map_spmf_gpv_transfer [transfer_rule]:
   "((A ===> B) ===> R ===> pcr_spmf_gpv A ===> pcr_spmf_gpv B) (\<lambda>f g. map_spmf f) map_gpv"
 unfolding pcr_spmf_gpv_def
 apply(rewrite in "((\<hole> ===> _) ===> _)  _ _" eq_OO[symmetric])
 apply(rewrite in "((_ ===> \<hole>) ===> _)  _ _" eq_OO[symmetric])
 apply(rewrite in "(_ ===> \<hole> ===> _)  _ _" OO_eq[symmetric])
 apply(rule fun_mono[THEN le_funD, THEN le_funD, THEN le_boolD, THEN mp])
   apply(rule neg_fun_distr3[OF left_unique_eq right_total_eq right_unique_eq left_total_eq])
  apply(rule fun_mono[OF order.refl])
  apply(rule pos_fun_distr)
 apply(rule fun_mono[THEN le_funD, THEN le_funD, THEN le_boolD, THEN mp])
   apply(rule order.refl)
  apply(rule pos_fun_distr)
 apply(rule pos_fun_distr[THEN le_funD, THEN le_funD, THEN le_boolD, THEN mp])
 apply(rule relcomppI)
  apply(unfold rel_fun_eq)
  apply(rule map_spmf_gpv_transfer')
 apply(unfold rel_fun_eq[symmetric])
 apply transfer_prover
 done
 
 end
 
 end
 
 subsection \<open> Embedding @{typ "'a option"} as a monad \<close>
 
 locale option_to_gpv begin
 
 interpretation option_to_spmf .
 interpretation spmf_to_gpv .
 
 definition cr_option_gpv :: "'a option \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> bool"
 where "cr_option_gpv x gpv \<longleftrightarrow> gpv = (lift_spmf \<circ> return_pmf) x"
 
 lemma cr_option_gpv_conv_OO:
   "cr_option_gpv = cr_spmf_option\<inverse>\<inverse> OO cr_spmf_gpv"
 by(simp add: fun_eq_iff relcompp.simps cr_option_gpv_def cr_spmf_gpv_def cr_spmf_option_def)
 
 context includes lifting_syntax begin
 
 text \<open>These transfer rules should follow from merging the transfer rules, but this has not yet been implemented.\<close>
 
 lemma return_option_gpv_transfer [transfer_rule]:
   "((=) ===> cr_option_gpv) Some Done"
 by(simp add: cr_option_gpv_def rel_fun_def)
 
 lemma bind_option_gpv_transfer [transfer_rule]:
   "(cr_option_gpv ===> ((=) ===> cr_option_gpv) ===> cr_option_gpv) Option.bind bind_gpv"
 apply(clarsimp simp add: cr_option_gpv_def rel_fun_def)
 subgoal for x f g by(cases x; simp)
 done
 
 lemma fail_option_gpv_transfer [transfer_rule]: "cr_option_gpv None Fail"
 by(simp add: cr_option_gpv_def)
 
 lemma map_option_gpv_transfer [transfer_rule]:
   "((=) ===> R ===> cr_option_gpv ===> cr_option_gpv) (\<lambda>f g. map_option f) map_gpv"
 unfolding rel_fun_eq by(simp add: rel_fun_def cr_option_gpv_def map_lift_spmf)
 
 end
 
 end
 
 locale option_le_gpv begin
 
 interpretation option_le_spmf .
 interpretation spmf_to_gpv .
 
 definition cr_option_le_gpv :: "'a option \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> bool"
 where "cr_option_le_gpv x gpv \<longleftrightarrow> gpv = (lift_spmf \<circ> return_pmf) x \<or> x = None"
 
 context includes lifting_syntax begin
 
 lemma return_option_le_gpv_transfer [transfer_rule]:
   "((=) ===> cr_option_le_gpv) Some Done"
 by(simp add: cr_option_le_gpv_def rel_fun_def)
 
 lemma bind_option_gpv_transfer [transfer_rule]:
   "(cr_option_le_gpv ===> ((=) ===> cr_option_le_gpv) ===> cr_option_le_gpv) Option.bind bind_gpv"
 apply(clarsimp simp add: cr_option_le_gpv_def rel_fun_def bind_eq_Some_conv)
 subgoal for f g x y by(erule allE[where x=y]) auto
 done
 
 lemma fail_option_gpv_transfer [transfer_rule]:
   "cr_option_le_gpv None Fail"
 by(simp add: cr_option_le_gpv_def)
 
 lemma map_option_gpv_transfer [transfer_rule]:
   "(((=) ===> (=)) ===> cr_option_le_gpv ===> cr_option_le_gpv) map_option (\<lambda>f. map_gpv f id)"
 unfolding rel_fun_eq by(simp add: rel_fun_def cr_option_le_gpv_def map_lift_spmf)
 
 end
 
 end
 
 subsection \<open>Embedding resumptions\<close>
 
 primcorec lift_resumption :: "('a, 'out, 'in) resumption \<Rightarrow> ('a, 'out, 'in) gpv"
 where
   "the_gpv (lift_resumption r) = 
   (case r of resumption.Done None \<Rightarrow> return_pmf None
     | resumption.Done (Some x') => return_spmf (Pure x')
     | resumption.Pause out c => map_spmf (map_generat id id ((\<circ>) lift_resumption)) (return_spmf (IO out c)))"
 
 lemma the_gpv_lift_resumption:
   "the_gpv (lift_resumption r) = 
    (if is_Done r then if Option.is_none (resumption.result r) then return_pmf None else return_spmf (Pure (the (resumption.result r)))
     else return_spmf (IO (resumption.output r) (lift_resumption \<circ> resume r)))"
 by(simp split: option.split resumption.split)
 
 declare lift_resumption.simps [simp del]
 
 lemma lift_resumption_Done [code]:
   "lift_resumption (resumption.Done x) = (case x of None \<Rightarrow> Fail | Some x' \<Rightarrow> Done x')"
 by(rule gpv.expand)(simp add: the_gpv_lift_resumption split: option.split)
 
 lemma lift_resumption_DONE [simp]:
   "lift_resumption (DONE x) = Done x"
 by(simp add: DONE_def lift_resumption_Done)
 
 lemma lift_resumption_ABORT [simp]:
   "lift_resumption ABORT = Fail"
 by(simp add: ABORT_def lift_resumption_Done)
 
 lemma lift_resumption_Pause [simp, code]:
   "lift_resumption (resumption.Pause out c) = Pause out (lift_resumption \<circ> c)"
 by(rule gpv.expand)(simp add: the_gpv_lift_resumption)
 
 lemma lift_resumption_Done_Some [simp]: "lift_resumption (resumption.Done (Some x)) = Done x"
 using lift_resumption_DONE unfolding DONE_def by simp
 
 lemma results'_gpv_lift_resumption [simp]:
   "results'_gpv (lift_resumption r) = results r" (is "?lhs = ?rhs")
 proof(rule set_eqI iffI)+
   show "x \<in> ?rhs" if "x \<in> ?lhs" for x using that
     by(induction gpv\<equiv>"lift_resumption r" arbitrary: r)
       (auto intro: resumption.set_sel simp add: lift_resumption.sel split: resumption.split_asm option.split_asm)
   show "x \<in> ?lhs" if "x \<in> ?rhs" for x using that by induction(auto simp add: lift_resumption.sel)
 qed
 
 lemma outs'_gpv_lift_resumption [simp]:
   "outs'_gpv (lift_resumption r) = outputs r" (is "?lhs = ?rhs")
 proof(rule set_eqI iffI)+
   show "x \<in> ?rhs" if "x \<in> ?lhs" for x using that
     by(induction gpv\<equiv>"lift_resumption r" arbitrary: r)
       (auto simp add: lift_resumption.sel split: resumption.split_asm option.split_asm)
   show "x \<in> ?lhs" if "x \<in> ?rhs" for x using that by induction auto
 qed
 
 lemma pred_gpv_lift_resumption [simp]:
   "\<And>A. pred_gpv A C (lift_resumption r) = pred_resumption A C r"
 by(simp add: pred_gpv_def pred_resumption_def)
 
 lemma lift_resumption_bind: "lift_resumption (r \<bind> f) = lift_resumption r \<bind> lift_resumption \<circ> f"
 by(coinduction arbitrary: r rule: gpv.coinduct_strong)
   (auto simp add: lift_resumption.sel Done_bind split: resumption.split option.split del: rel_funI intro!: rel_funI)
 
 subsection \<open>Assertions\<close>
 
 definition assert_gpv :: "bool \<Rightarrow> (unit, 'out, 'in) gpv"
 where "assert_gpv b = (if b then Done () else Fail)"
 
 lemma assert_gpv_simps [simp]:
   "assert_gpv True = Done ()"
   "assert_gpv False = Fail"
 by(simp_all add: assert_gpv_def)
 
 lemma [simp]:
   shows assert_gpv_eq_Done: "assert_gpv b = Done x \<longleftrightarrow> b"
   and Done_eq_assert_gpv: "Done x = assert_gpv b \<longleftrightarrow> b"
   and Pause_neq_assert_gpv: "Pause out rpv \<noteq> assert_gpv b"
   and assert_gpv_neq_Pause: "assert_gpv b \<noteq> Pause out rpv"
   and assert_gpv_eq_Fail: "assert_gpv b = Fail \<longleftrightarrow> \<not> b"
   and Fail_eq_assert_gpv: "Fail = assert_gpv b \<longleftrightarrow> \<not> b"
 by(simp_all add: assert_gpv_def)
 
 lemma assert_gpv_inject [simp]: "assert_gpv b = assert_gpv b' \<longleftrightarrow> b = b'"
 by(simp add: assert_gpv_def)
 
 lemma assert_gpv_sel [simp]:
   "the_gpv (assert_gpv b) = map_spmf Pure (assert_spmf b)"
 by(simp add: assert_gpv_def)
 
 lemma the_gpv_bind_assert [simp]:
   "the_gpv (bind_gpv (assert_gpv b) f) =
    bind_spmf (assert_spmf b) (the_gpv \<circ> f)"
 by(cases b) simp_all
 
 lemma pred_gpv_assert [simp]: "pred_gpv P Q (assert_gpv b) = (b \<longrightarrow> P ())"
 by(cases b) simp_all
 
 primcorec try_gpv :: "('a, 'call, 'ret) gpv \<Rightarrow> ('a, 'call, 'ret) gpv \<Rightarrow> ('a, 'call, 'ret) gpv" ("TRY _ ELSE _" [0,60] 59)
 where
   "the_gpv (TRY gpv ELSE gpv') = 
    map_spmf (map_generat id id (\<lambda>c input. case c input of Inl gpv \<Rightarrow> try_gpv gpv gpv' | Inr gpv' \<Rightarrow> gpv'))
      (try_spmf (map_spmf (map_generat id id (map_fun id Inl)) (the_gpv gpv))
                (map_spmf (map_generat id id (map_fun id Inr)) (the_gpv gpv')))"
 
 lemma try_gpv_sel:
   "the_gpv (TRY gpv ELSE gpv') =
    TRY map_spmf (map_generat id id (\<lambda>c input. TRY c input ELSE gpv')) (the_gpv gpv) ELSE the_gpv gpv'"
 by(simp add: try_gpv_def map_try_spmf spmf.map_comp o_def generat.map_comp generat.map_ident id_def)
 
 lemma try_gpv_Done [simp]: "TRY Done x ELSE gpv' = Done x"
 by(rule gpv.expand)(simp)
 
 lemma try_gpv_Fail [simp]: "TRY Fail ELSE gpv' = gpv'"
 by(rule gpv.expand)(simp add: spmf.map_comp o_def generat.map_comp generat.map_ident)
 
 lemma try_gpv_Pause [simp]: "TRY Pause out c ELSE gpv' = Pause out (\<lambda>input. TRY c input ELSE gpv')"
 by(rule gpv.expand) simp
 
 lemma try_gpv_Fail2 [simp]: "TRY gpv ELSE Fail = gpv"
 by(coinduction arbitrary: gpv rule: gpv.coinduct_strong)
   (auto simp add: spmf_rel_map generat.rel_map intro!: rel_spmf_reflI generat.rel_refl)
 
 lemma lift_try_spmf: "lift_spmf (TRY p ELSE q) = TRY lift_spmf p ELSE lift_spmf q" 
 by(rule gpv.expand)(simp add: map_try_spmf spmf.map_comp o_def)
 
 lemma try_assert_gpv: "TRY assert_gpv b ELSE gpv' = (if b then Done () else gpv')"
 by(simp)
 
 context includes lifting_syntax begin
 lemma try_gpv_parametric [transfer_rule]:
   "(rel_gpv A C ===> rel_gpv A C ===> rel_gpv A C) try_gpv try_gpv"
 unfolding try_gpv_def by transfer_prover
 
 lemma try_gpv_parametric':
   "(rel_gpv'' A C R ===> rel_gpv'' A C R ===> rel_gpv'' A C R) try_gpv try_gpv"
 unfolding try_gpv_def
 supply corec_gpv_parametric'[transfer_rule] the_gpv_parametric'[transfer_rule]
 by transfer_prover
 end
 
 lemma map_try_gpv: "map_gpv f g (TRY gpv ELSE gpv') = TRY map_gpv f g gpv ELSE map_gpv f g gpv'"
 by(simp add: gpv.rel_map try_gpv_parametric[THEN rel_funD, THEN rel_funD] gpv.rel_refl gpv.rel_eq[symmetric])
 
 lemma map'_try_gpv: "map_gpv' f g h (TRY gpv ELSE gpv') = TRY map_gpv' f g h gpv ELSE map_gpv' f g h gpv'"
 by(coinduction arbitrary: gpv rule: gpv.coinduct_strong)(auto 4 3 simp add: spmf_rel_map generat.rel_map intro!: rel_spmf_reflI generat.rel_refl rel_funI rel_spmf_try_spmf)
   
 
 lemma try_bind_assert_gpv:
   "TRY (assert_gpv b \<bind> f) ELSE gpv = (if b then TRY (f ()) ELSE gpv else gpv)"
 by(simp)
 
 
 
 subsection \<open>Order for @{typ "('a, 'out, 'in) gpv"}\<close>
 
 coinductive ord_gpv :: "('a, 'out, 'in) gpv \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> bool"
 where
   "ord_spmf (rel_generat (=) (=) (rel_fun (=) ord_gpv)) f g \<Longrightarrow> ord_gpv (GPV f) (GPV g)"
 
 inductive_simps ord_gpv_simps [simp]:
   "ord_gpv (GPV f) (GPV g)"
 
 lemma ord_gpv_coinduct [consumes 1, case_names ord_gpv, coinduct pred: ord_gpv]:
   assumes "X f g"
   and step: "\<And>f g. X f g \<Longrightarrow> ord_spmf (rel_generat (=) (=) (rel_fun (=) X)) (the_gpv f) (the_gpv g)"
   shows "ord_gpv f g"
 using \<open>X f g\<close>
 by(coinduct)(auto dest: step simp add: eq_GPV_iff intro: ord_spmf_mono rel_generat_mono rel_fun_mono)
 
 lemma ord_gpv_the_gpvD:
   "ord_gpv f g \<Longrightarrow> ord_spmf (rel_generat (=) (=) (rel_fun (=) ord_gpv)) (the_gpv f) (the_gpv g)"
 by(erule ord_gpv.cases) simp
 
 lemma reflp_equality: "reflp (=)"
 by(simp add: reflp_def)
 
 lemma ord_gpv_reflI [simp]: "ord_gpv f f"
 by(coinduction arbitrary: f)(auto intro: ord_spmf_reflI simp add: rel_generat_same rel_fun_def)
 
 lemma reflp_ord_gpv: "reflp ord_gpv"
 by(rule reflpI)(rule ord_gpv_reflI)
 
 lemma ord_gpv_trans:
   assumes "ord_gpv f g" "ord_gpv g h"
   shows "ord_gpv f h"
 using assms
 proof(coinduction arbitrary: f g h)
   case (ord_gpv f g h)
   have *: "ord_spmf (rel_generat (=) (=) (rel_fun (=) (\<lambda>f h. \<exists>g. ord_gpv f g \<and> ord_gpv g h))) (the_gpv f) (the_gpv h) =
     ord_spmf (rel_generat ((=) OO (=)) ((=) OO (=)) (rel_fun (=) (ord_gpv OO ord_gpv))) (the_gpv f) (the_gpv h)"
     by(simp add: relcompp.simps[abs_def])
   then show ?case using ord_gpv
     by(auto elim!: ord_gpv.cases simp add: generat.rel_compp ord_spmf_compp fun.rel_compp)
 qed
 
 lemma ord_gpv_compp: "(ord_gpv OO ord_gpv) = ord_gpv"
 by(auto simp add: fun_eq_iff intro: ord_gpv_trans)
 
 lemma transp_ord_gpv [simp]: "transp ord_gpv"
 by(blast intro: transpI ord_gpv_trans)
 
 lemma ord_gpv_antisym:
   "\<lbrakk> ord_gpv f g; ord_gpv g f \<rbrakk> \<Longrightarrow> f = g"
 proof(coinduction arbitrary: f g)
   case (Eq_gpv f g)
   let ?R = "rel_generat (=) (=) (rel_fun (=) ord_gpv)"
   from \<open>ord_gpv f g\<close> have "ord_spmf ?R (the_gpv f) (the_gpv g)" by cases simp
   moreover
   from \<open>ord_gpv g f\<close> have "ord_spmf ?R (the_gpv g) (the_gpv f)" by cases simp
   ultimately have "rel_spmf (inf ?R ?R\<inverse>\<inverse>) (the_gpv f) (the_gpv g)"
     by(rule rel_spmf_inf)(auto 4 3 intro: transp_rel_generatI transp_ord_gpv reflp_ord_gpv reflp_equality reflp_fun1 is_equality_eq transp_rel_fun)
   also have "inf ?R ?R\<inverse>\<inverse> = rel_generat (inf (=) (=)) (inf (=) (=)) (rel_fun (=) (inf ord_gpv ord_gpv\<inverse>\<inverse>))"
     unfolding rel_generat_inf[symmetric] rel_fun_inf[symmetric]
     by(simp add: generat.rel_conversep[symmetric] fun.rel_conversep)
   finally show ?case by(simp add: inf_fun_def)
 qed
 
 lemma RFail_least [simp]: "ord_gpv Fail f"
 by(coinduction arbitrary: f)(simp add: eq_GPV_iff)
 
 subsection \<open>Bounds on interaction\<close>
 
 context
   fixes "consider" :: "'out \<Rightarrow> bool"
   notes monotone_SUP[partial_function_mono] [[function_internals]]
 begin
 declaration \<open>Partial_Function.init "lfp_strong" @{term lfp.fixp_fun} @{term lfp.mono_body}
   @{thm lfp.fixp_rule_uc} @{thm lfp.fixp_induct_strong2_uc} NONE\<close>
 
 partial_function (lfp_strong) interaction_bound :: "('a, 'out, 'in) gpv \<Rightarrow> enat"
 where
   "interaction_bound gpv =
   (SUP generat\<in>set_spmf (the_gpv gpv). case generat of Pure _ \<Rightarrow> 0 
      | IO out c \<Rightarrow> if consider out then eSuc (SUP input. interaction_bound (c input)) else (SUP input. interaction_bound (c input)))"
 
 lemma interaction_bound_fixp_induct [case_names adm bottom step]:
   "\<lbrakk> ccpo.admissible (fun_lub Sup) (fun_ord (\<le>)) P;
      P (\<lambda>_. 0);
     \<And>interaction_bound'. 
     \<lbrakk> P interaction_bound'; 
       \<And>gpv. interaction_bound' gpv \<le> interaction_bound gpv;
       \<And>gpv. interaction_bound' gpv \<le> (SUP generat\<in>set_spmf (the_gpv gpv). case generat of Pure _ \<Rightarrow> 0 
      | IO out c \<Rightarrow> if consider out then eSuc (SUP input. interaction_bound' (c input)) else (SUP input. interaction_bound' (c input)))
       \<rbrakk>
       \<Longrightarrow> P (\<lambda>gpv. \<Squnion>generat\<in>set_spmf (the_gpv gpv). case generat of Pure x \<Rightarrow> 0
          | IO out c \<Rightarrow> if consider out then eSuc (\<Squnion>input. interaction_bound' (c input)) else (\<Squnion>input. interaction_bound' (c input))) \<rbrakk>
    \<Longrightarrow> P interaction_bound"
 by(erule interaction_bound.fixp_induct)(simp_all add: bot_enat_def fun_ord_def)
 
 lemma interaction_bound_IO:
    "IO out c \<in> set_spmf (the_gpv gpv)
    \<Longrightarrow> (if consider out then eSuc (interaction_bound (c input)) else interaction_bound (c input)) \<le> interaction_bound gpv"
 by(rewrite in "_ \<le> \<hole>" interaction_bound.simps)(auto intro!: SUP_upper2)
 
 lemma interaction_bound_IO_consider:
    "\<lbrakk> IO out c \<in> set_spmf (the_gpv gpv); consider out \<rbrakk>
    \<Longrightarrow> eSuc (interaction_bound (c input)) \<le> interaction_bound gpv"
 by(drule interaction_bound_IO) simp
 
 lemma interaction_bound_IO_ignore:
    "\<lbrakk> IO out c \<in> set_spmf (the_gpv gpv); \<not> consider out \<rbrakk>
    \<Longrightarrow> interaction_bound (c input) \<le> interaction_bound gpv"
 by(drule interaction_bound_IO) simp
 
 lemma interaction_bound_Done [simp]: "interaction_bound (Done x) = 0"
 by(simp add: interaction_bound.simps)
 
 lemma interaction_bound_Fail [simp]: "interaction_bound Fail = 0"
 by(simp add: interaction_bound.simps bot_enat_def)
 
 lemma interaction_bound_Pause [simp]:
   "interaction_bound (Pause out c) = 
    (if consider out then eSuc (SUP input. interaction_bound (c input)) else (SUP input. interaction_bound (c input)))"
 by(simp add: interaction_bound.simps)
 
 lemma interaction_bound_lift_spmf [simp]: "interaction_bound (lift_spmf p) = 0"
 by(simp add: interaction_bound.simps SUP_constant bot_enat_def)
 
 lemma interaction_bound_assert_gpv [simp]: "interaction_bound (assert_gpv b) = 0"
 by(cases b) simp_all
 
 lemma interaction_bound_bind_step:
   assumes IH: "\<And>p. interaction_bound' (p \<bind> f) \<le> interaction_bound p + (\<Squnion>x\<in>results'_gpv p. interaction_bound' (f x))"
   and unfold: "\<And>gpv. interaction_bound' gpv \<le> (\<Squnion>generat\<in>set_spmf (the_gpv gpv). case generat of Pure x \<Rightarrow> 0
              | IO out c \<Rightarrow> if consider out then eSuc (\<Squnion>input. interaction_bound' (c input)) else \<Squnion>input. interaction_bound' (c input))"
   shows "(\<Squnion>generat\<in>set_spmf (the_gpv (p \<bind> f)).
              case generat of Pure x \<Rightarrow> 0
              | IO out c \<Rightarrow>
                  if consider out then eSuc (\<Squnion>input. interaction_bound' (c input))
                  else \<Squnion>input. interaction_bound' (c input))
          \<le> interaction_bound p +
             (\<Squnion>x\<in>results'_gpv p.
                 \<Squnion>generat\<in>set_spmf (the_gpv (f x)).
                    case generat of Pure x \<Rightarrow> 0
                    | IO out c \<Rightarrow>
                        if consider out then eSuc (\<Squnion>input. interaction_bound' (c input))
                        else \<Squnion>input. interaction_bound' (c input))"
     (is "(SUP generat'\<in>?bind. ?g generat') \<le> ?p + ?f")
 proof(rule SUP_least)
   fix generat'
   assume "generat' \<in> ?bind"
   then obtain generat where generat: "generat \<in> set_spmf (the_gpv p)"
     and *: "case generat of Pure x \<Rightarrow> generat' \<in> set_spmf (the_gpv (f x)) 
          | IO out c \<Rightarrow> generat' = IO out (\<lambda>input. c input \<bind> f)"
     by(clarsimp simp add: bind_gpv.sel simp del: bind_gpv_sel')
       (clarsimp split: generat.split_asm simp add: generat.map_comp o_def generat.map_id[unfolded id_def])
   show "?g generat' \<le> ?p + ?f"
   proof(cases generat)
     case (Pure x)
     have "?g generat' \<le> (SUP generat'\<in>set_spmf (the_gpv (f x)). (case generat' of Pure x \<Rightarrow> 0 | IO out c \<Rightarrow> if consider out then eSuc (\<Squnion>input. interaction_bound' (c input)) else \<Squnion>input. interaction_bound' (c input)))"
       using * Pure by(auto intro: SUP_upper)
     also have "\<dots> \<le> 0 + ?f" using generat Pure
       by(auto 4 3 intro: SUP_upper results'_gpv_Pure)
     also have "\<dots> \<le> ?p + ?f" by simp
     finally show ?thesis .
   next
     case (IO out c)
     with * have "?g generat' = (if consider out then eSuc (SUP input. interaction_bound' (c input \<bind> f)) else (SUP input. interaction_bound' (c input \<bind> f)))" by simp
     also have "\<dots> \<le> (if consider out then eSuc (SUP input. interaction_bound (c input) + (\<Squnion>x\<in>results'_gpv (c input). interaction_bound' (f x))) else (SUP input. interaction_bound (c input) + (\<Squnion>x\<in>results'_gpv (c input). interaction_bound' (f x))))"
       by(auto intro: SUP_mono IH)
     also have "\<dots> \<le> (case IO out c of Pure (x :: 'a) \<Rightarrow> 0 | IO out c \<Rightarrow> if consider out then eSuc (SUP input. interaction_bound (c input)) else (SUP input. interaction_bound (c input))) + (SUP input. SUP x\<in>results'_gpv (c input). interaction_bound' (f x))"
       by(simp add: iadd_Suc SUP_le_iff)(meson SUP_upper2 UNIV_I add_mono order_refl)
     also have "\<dots> \<le> ?p + ?f"
       apply(rewrite in "_ \<le> \<hole>" interaction_bound.simps)
       apply(rule add_mono SUP_least SUP_upper generat[unfolded IO])+
       apply(rule order_trans[OF unfold])
       apply(auto 4 3 intro: results'_gpv_Cont[OF generat] SUP_upper simp add: IO)
       done
     finally show ?thesis .
   qed
 qed
 
 lemma interaction_bound_bind:
   defines "ib1 \<equiv> interaction_bound"
   shows "interaction_bound (p \<bind> f) \<le> ib1 p + (SUP x\<in>results'_gpv p. interaction_bound (f x))"
 proof(induction arbitrary: p rule: interaction_bound_fixp_induct)
   case adm show ?case by simp
   case bottom show ?case by simp
   case (step interaction_bound') then show ?case unfolding ib1_def by -(rule interaction_bound_bind_step)
 qed
 
 lemma interaction_bound_bind_lift_spmf [simp]:
   "interaction_bound (lift_spmf p \<bind> f) = (SUP x\<in>set_spmf p. interaction_bound (f x))"
 by(subst (1 2) interaction_bound.simps)(simp add: bind_UNION SUP_UNION)
 
 end
 
+lemma interaction_bound_map_gpv':
+  assumes "surj h"
+  shows "interaction_bound consider (map_gpv' f g h gpv) = interaction_bound (consider \<circ> g) gpv"
+proof(induction arbitrary: gpv rule: parallel_fixp_induct_1_1[OF lattice_partial_function_definition lattice_partial_function_definition interaction_bound.mono interaction_bound.mono interaction_bound_def interaction_bound_def, case_names adm bottom step])
+  case (step interaction_bound' interaction_bound'' gpv)
+  have *: "IO out c \<in> set_spmf (the_gpv gpv) \<Longrightarrow>  x \<in> UNIV \<Longrightarrow> interaction_bound'' (c x) \<le> (\<Squnion>x. interaction_bound'' (c (h x)))" for out c x
+    using assms[THEN surjD, of x] by (clarsimp intro!: SUP_upper)
+
+  show ?case 
+    by (auto simp add: * step.IH image_comp split: generat.split
+      intro!: SUP_cong [OF refl] antisym SUP_upper SUP_least)
+qed simp_all
+
 abbreviation interaction_any_bound :: "('a, 'out, 'in) gpv \<Rightarrow> enat"
 where "interaction_any_bound \<equiv> interaction_bound (\<lambda>_. True)"
 
 lemma interaction_any_bound_coinduct [consumes 1, case_names interaction_bound]:
   assumes X: "X gpv n"
   and *: "\<And>gpv n out c input. \<lbrakk> X gpv n; IO out c \<in> set_spmf (the_gpv gpv) \<rbrakk> 
     \<Longrightarrow> \<exists>n'. (X (c input) n' \<or> interaction_any_bound (c input) \<le> n') \<and> eSuc n' \<le> n"
   shows "interaction_any_bound gpv \<le> n"
 using X
 proof(induction arbitrary: gpv n rule: interaction_bound_fixp_induct)
   case adm show ?case by(intro cont_intro)
   case bottom show ?case by simp
 next
   case (step interaction_bound')
   { fix out c
     assume IO: "IO out c \<in> set_spmf (the_gpv gpv)"
     from *[OF step.prems IO] obtain n' where n: "n = eSuc n'"
       by(cases n rule: co.enat.exhaust) auto
     moreover 
     { fix input
       have "\<exists>n''. (X (c input) n'' \<or> interaction_any_bound (c input) \<le> n'') \<and> eSuc n'' \<le> n"
         using step.prems IO \<open>n = eSuc n'\<close> by(auto 4 3 dest: *)
       then have "interaction_bound' (c input) \<le> n'" using n
         by(auto dest: step.IH intro: step.hyps[THEN order_trans] elim!: order_trans simp add: neq_zero_conv_eSuc) }
     ultimately have "eSuc (\<Squnion>input. interaction_bound' (c input)) \<le> n"
       by(auto intro: SUP_least) }
   then show ?case by(auto intro!: SUP_least split: generat.split)
 qed
 
 context includes lifting_syntax begin
 lemma interaction_bound_parametric':
   assumes [transfer_rule]: "bi_total R"
   shows "((C ===> (=)) ===> rel_gpv'' A C R ===> (=)) interaction_bound interaction_bound"
 unfolding interaction_bound_def[abs_def]
 apply(rule rel_funI)
 apply(rule fixp_lfp_parametric_eq[OF interaction_bound.mono interaction_bound.mono])
 subgoal premises [transfer_rule]
   supply the_gpv_parametric'[transfer_rule] rel_gpv''_eq[relator_eq]
   by transfer_prover
 done
 
 lemma interaction_bound_parametric [transfer_rule]:
   "((C ===> (=)) ===> rel_gpv A C ===> (=)) interaction_bound interaction_bound"
 unfolding rel_gpv_conv_rel_gpv'' by(rule interaction_bound_parametric')(rule bi_total_eq)
 end
 
 text \<open>
   There is no nice @{const interaction_bound} equation for @{const bind_gpv}, as it computes
   an exact bound, but we only need an upper bound.
   As @{typ enat} is hard to work with (and @{term \<infinity>} does not constrain a gpv in any way),
   we work with @{typ nat}.
 \<close>
 
 inductive interaction_bounded_by :: "('out \<Rightarrow> bool) \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> enat \<Rightarrow> bool"
 for "consider" gpv n where
   interaction_bounded_by: "\<lbrakk> interaction_bound consider gpv \<le> n \<rbrakk> \<Longrightarrow> interaction_bounded_by consider gpv n"
 
 lemmas interaction_bounded_byI = interaction_bounded_by
 hide_fact (open) interaction_bounded_by
 
 context includes lifting_syntax begin
 lemma interaction_bounded_by_parametric [transfer_rule]:
   "((C ===> (=)) ===> rel_gpv A C ===> (=) ===> (=)) interaction_bounded_by interaction_bounded_by"
 unfolding interaction_bounded_by.simps[abs_def] by transfer_prover
 
 lemma interaction_bounded_by_parametric':
   notes interaction_bound_parametric'[transfer_rule]
   assumes [transfer_rule]: "bi_total R"
   shows "((C ===> (=)) ===> rel_gpv'' A C R ===> (=) ===> (=)) 
          interaction_bounded_by interaction_bounded_by"
 unfolding interaction_bounded_by.simps[abs_def] by transfer_prover
 end
 
 lemma interaction_bounded_by_mono:
   "\<lbrakk> interaction_bounded_by consider gpv n; n \<le> m \<rbrakk> \<Longrightarrow> interaction_bounded_by consider gpv m"
 unfolding interaction_bounded_by.simps by(erule order_trans) simp
 
 lemma interaction_bounded_by_contD:
   "\<lbrakk> interaction_bounded_by consider gpv n; IO out c \<in> set_spmf (the_gpv gpv); consider out \<rbrakk>
   \<Longrightarrow> n > 0 \<and> interaction_bounded_by consider (c input) (n - 1)"
 unfolding interaction_bounded_by.simps
 by(subst (asm) interaction_bound.simps)(auto simp add: SUP_le_iff eSuc_le_iff enat_eSuc_iff dest!: bspec)
 
 lemma interaction_bounded_by_contD_ignore:
   "\<lbrakk> interaction_bounded_by consider gpv n; IO out c \<in> set_spmf (the_gpv gpv) \<rbrakk>
   \<Longrightarrow> interaction_bounded_by consider (c input) n"
 unfolding interaction_bounded_by.simps
 by(subst (asm) interaction_bound.simps)(auto 4 4 simp add: SUP_le_iff eSuc_le_iff enat_eSuc_iff dest!: bspec split: if_split_asm elim: order_trans)
 
 lemma interaction_bounded_byI_epred:
   assumes "\<And>out c. \<lbrakk> IO out c \<in> set_spmf (the_gpv gpv); consider out \<rbrakk> \<Longrightarrow> n \<noteq> 0 \<and> (\<forall>input. interaction_bounded_by consider (c input) (n - 1))"
   and "\<And>out c input. \<lbrakk> IO out c \<in> set_spmf (the_gpv gpv); \<not> consider out \<rbrakk> \<Longrightarrow> interaction_bounded_by consider (c input) n"
   shows "interaction_bounded_by consider gpv n"
 unfolding interaction_bounded_by.simps
 by(subst interaction_bound.simps)(auto 4 5 intro!: SUP_least split: generat.split dest: assms simp add: eSuc_le_iff enat_eSuc_iff gr0_conv_Suc neq_zero_conv_eSuc interaction_bounded_by.simps)
 
 lemma interaction_bounded_by_IO:
   "\<lbrakk> IO out c \<in> set_spmf (the_gpv gpv); interaction_bounded_by consider gpv n; consider out \<rbrakk>
   \<Longrightarrow> n \<noteq> 0 \<and> interaction_bounded_by consider (c input) (n - 1)"
 by(drule interaction_bound_IO[where input=input and ?consider="consider"])(auto simp add: interaction_bounded_by.simps epred_conv_minus eSuc_le_iff enat_eSuc_iff)
 
 lemma interaction_bounded_by_0: "interaction_bounded_by consider gpv 0 \<longleftrightarrow> interaction_bound consider gpv = 0"
 by(simp add: interaction_bounded_by.simps zero_enat_def[symmetric])
 
 abbreviation interaction_bounded_by' :: "('out \<Rightarrow> bool) \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> nat \<Rightarrow> bool"
 where "interaction_bounded_by' consider gpv n \<equiv> interaction_bounded_by consider gpv (enat n)"
 
 named_theorems interaction_bound
 
 lemmas interaction_bounded_by_start = interaction_bounded_by_mono
 
 method interaction_bound_start = (rule interaction_bounded_by_start)
 method interaction_bound_step uses add simp =
   ((match conclusion in "interaction_bounded_by _ _ _" \<Rightarrow> fail \<bar> _ \<Rightarrow> \<open>solves \<open>clarsimp simp add: simp\<close>\<close>) | rule add interaction_bound)
 method interaction_bound_rec uses add simp = 
   (interaction_bound_step add: add simp: simp; (interaction_bound_rec add: add simp: simp)?)
 method interaction_bound uses add simp =
   ((* use in *) interaction_bound_start, interaction_bound_rec add: add simp: simp)
 
 lemma interaction_bounded_by_Done [simp]: "interaction_bounded_by consider (Done x) n"
 by(simp add: interaction_bounded_by.simps)
 
 lemma interaction_bounded_by_DoneI [interaction_bound]:
   "interaction_bounded_by consider (Done x) 0"
 by simp
 
 lemma interaction_bounded_by_Fail [simp]: "interaction_bounded_by consider Fail n"
 by(simp add: interaction_bounded_by.simps)
 
 lemma interaction_bounded_by_FailI [interaction_bound]: "interaction_bounded_by consider Fail 0"
 by simp
 
 lemma interaction_bounded_by_lift_spmf [simp]: "interaction_bounded_by consider (lift_spmf p) n"
 by(simp add: interaction_bounded_by.simps)
 
 lemma interaction_bounded_by_lift_spmfI [interaction_bound]:
   "interaction_bounded_by consider (lift_spmf p) 0"
 by simp
 
 lemma interaction_bounded_by_assert_gpv [simp]: "interaction_bounded_by consider (assert_gpv b) n"
 by(cases b) simp_all
 
 lemma interaction_bounded_by_assert_gpvI [interaction_bound]:
   "interaction_bounded_by consider (assert_gpv b) 0"
 by simp
 
 lemma interaction_bounded_by_Pause [simp]:
   "interaction_bounded_by consider (Pause out c) n \<longleftrightarrow> 
   (if consider out then 0 < n \<and> (\<forall>input. interaction_bounded_by consider (c input) (n - 1)) else (\<forall>input. interaction_bounded_by consider (c input) n))"
 by(cases n rule: co.enat.exhaust)
   (auto 4 3 simp add: interaction_bounded_by.simps eSuc_le_iff enat_eSuc_iff gr0_conv_Suc intro: SUP_least dest: order_trans[OF SUP_upper, rotated])
 
 lemma interaction_bounded_by_PauseI [interaction_bound]:
   "(\<And>input. interaction_bounded_by consider (c input) (n input))
   \<Longrightarrow> interaction_bounded_by consider (Pause out c) (if consider out then 1 + (SUP input. n input) else (SUP input. n input))"
 by(auto simp add: iadd_is_0 enat_add_sub_same intro: interaction_bounded_by_mono SUP_upper)
 
 lemma interaction_bounded_by_bindI [interaction_bound]:
   "\<lbrakk> interaction_bounded_by consider gpv n; \<And>x. x \<in> results'_gpv gpv \<Longrightarrow> interaction_bounded_by consider (f x) (m x) \<rbrakk>
   \<Longrightarrow> interaction_bounded_by consider (gpv \<bind> f) (n + (SUP x\<in>results'_gpv gpv. m x))"
 unfolding interaction_bounded_by.simps plus_enat_simps(1)[symmetric]
 by(rule interaction_bound_bind[THEN order_trans])(auto intro: add_mono SUP_mono)
 
 lemma interaction_bounded_by_bind_PauseI [interaction_bound]:
   "(\<And>input. interaction_bounded_by consider (c input \<bind> f) (n input))
   \<Longrightarrow> interaction_bounded_by consider (Pause out c \<bind> f) (if consider out then SUP input. n input + 1 else SUP input. n input)"
 by(auto 4 3 simp add: interaction_bounded_by.simps SUP_enat_add_left eSuc_plus_1 intro: SUP_least SUP_upper2)
 
 lemma interaction_bounded_by_bind_lift_spmf [simp]:
   "interaction_bounded_by consider (lift_spmf p \<bind> f) n \<longleftrightarrow> (\<forall>x\<in>set_spmf p. interaction_bounded_by consider (f x) n)"
 by(simp add: interaction_bounded_by.simps SUP_le_iff)
 
 lemma interaction_bounded_by_bind_lift_spmfI [interaction_bound]:
   "(\<And>x. x \<in> set_spmf p \<Longrightarrow> interaction_bounded_by consider (f x) (n x))
   \<Longrightarrow> interaction_bounded_by consider (lift_spmf p \<bind> f) (SUP x\<in>set_spmf p. n x)"
 by(auto intro: interaction_bounded_by_mono SUP_upper)
 
 lemma interaction_bounded_by_bind_DoneI [interaction_bound]:
   "interaction_bounded_by consider (f x) n \<Longrightarrow> interaction_bounded_by consider (Done x \<bind> f) n"
 by(simp)
 
 lemma interaction_bounded_by_if [interaction_bound]:
   "\<lbrakk> b \<Longrightarrow> interaction_bounded_by consider gpv1 n; \<not> b \<Longrightarrow> interaction_bounded_by consider gpv2 m \<rbrakk>
   \<Longrightarrow> interaction_bounded_by consider (if b then gpv1 else gpv2) (if b then n else m)"
 by(auto 4 3 simp add: max_def not_le elim: interaction_bounded_by_mono)
 
 lemma interaction_bounded_by_case_bool [interaction_bound]:
   "\<lbrakk> b \<Longrightarrow> interaction_bounded_by consider t bt; \<not> b \<Longrightarrow> interaction_bounded_by consider f bf \<rbrakk>
   \<Longrightarrow> interaction_bounded_by consider (case_bool t f b) (if b then bt else bf)"
 by(cases b)(auto)
 
 lemma interaction_bounded_by_case_sum [interaction_bound]:
   "\<lbrakk> \<And>y. x = Inl y \<Longrightarrow> interaction_bounded_by consider (l y) (bl y);
      \<And>y. x = Inr y \<Longrightarrow> interaction_bounded_by consider (r y) (br y) \<rbrakk>
   \<Longrightarrow> interaction_bounded_by consider (case_sum l r x) (case_sum bl br x)"
 by(cases x)(auto)
 
 lemma interaction_bounded_by_case_prod [interaction_bound]:
   "(\<And>a b. x = (a, b) \<Longrightarrow> interaction_bounded_by consider (f a b) (n a b))
   \<Longrightarrow> interaction_bounded_by consider (case_prod f x) (case_prod n x)"
 by(simp split: prod.split)
 
 lemma interaction_bounded_by_let [interaction_bound]: \<comment> \<open>This rule unfolds let's\<close>
   "interaction_bounded_by consider (f t) m \<Longrightarrow> interaction_bounded_by consider (Let t f) m"
 by(simp add: Let_def)
 
 lemma interaction_bounded_by_map_gpv_id [interaction_bound]:
   assumes [interaction_bound]: "interaction_bounded_by P gpv n"
   shows "interaction_bounded_by P (map_gpv f id gpv) n"
 unfolding id_def map_gpv_conv_bind by interaction_bound simp
 
 abbreviation interaction_any_bounded_by :: "('a, 'out, 'in) gpv \<Rightarrow> enat \<Rightarrow> bool"
 where "interaction_any_bounded_by \<equiv> interaction_bounded_by (\<lambda>_. True)"
 
+lemma interaction_any_bounded_by_map_gpv':
+  assumes "interaction_any_bounded_by gpv n"
+    and "surj h"
+  shows "interaction_any_bounded_by (map_gpv' f g h gpv) n"
+  using assms by(simp add: interaction_bounded_by.simps interaction_bound_map_gpv' o_def)
+
 subsection \<open>Typing\<close>
 
 subsubsection \<open>Interface between gpvs and rpvs / callees\<close>
 
 lemma is_empty_parametric [transfer_rule]: "rel_fun (rel_set A) (=) Set.is_empty Set.is_empty" (* Move *)
 by(auto simp add: rel_fun_def Set.is_empty_def dest: rel_setD1 rel_setD2)
 
 typedef ('call, 'ret) \<I> = "UNIV :: ('call \<Rightarrow> 'ret set) set" ..
 
 setup_lifting type_definition_\<I>
 
 lemma outs_\<I>_tparametric:
   includes lifting_syntax 
   assumes [transfer_rule]: "bi_total A"
   shows "((A ===> rel_set B) ===> rel_set A) (\<lambda>resps. {out. resps out \<noteq> {}}) (\<lambda>resps. {out. resps out \<noteq> {}})"
   by(fold Set.is_empty_def) transfer_prover
 
 lift_definition outs_\<I> :: "('call, 'ret) \<I> \<Rightarrow> 'call set" is "\<lambda>resps. {out. resps out \<noteq> {}}" parametric outs_\<I>_tparametric .
 lift_definition responses_\<I> :: "('call, 'ret) \<I> \<Rightarrow> 'call \<Rightarrow> 'ret set" is "\<lambda>x. x" parametric id_transfer[unfolded id_def] .
 
 lift_definition rel_\<I> :: "('call \<Rightarrow> 'call' \<Rightarrow> bool) \<Rightarrow> ('ret \<Rightarrow> 'ret' \<Rightarrow> bool) \<Rightarrow> ('call, 'ret) \<I> \<Rightarrow> ('call', 'ret') \<I> \<Rightarrow> bool"
 is "\<lambda>C R resp1 resp2. rel_set C {out. resp1 out \<noteq> {}} {out. resp2 out \<noteq> {}} \<and> rel_fun C (rel_set R) resp1 resp2"
 .
 
 lemma rel_\<I>I [intro?]:
   "\<lbrakk> rel_set C (outs_\<I> \<I>1) (outs_\<I> \<I>2); \<And>x y. C x y \<Longrightarrow> rel_set R (responses_\<I> \<I>1 x) (responses_\<I> \<I>2 y) \<rbrakk>
   \<Longrightarrow> rel_\<I> C R \<I>1 \<I>2"
 by transfer(auto simp add: rel_fun_def)
 
 lemma rel_\<I>_eq [relator_eq]: "rel_\<I> (=) (=) = (=)"
 unfolding fun_eq_iff by transfer(auto simp add: relator_eq)
 
 lemma rel_\<I>_conversep [simp]: "rel_\<I> C\<inverse>\<inverse> R\<inverse>\<inverse> = (rel_\<I> C R)\<inverse>\<inverse>"
 unfolding fun_eq_iff conversep_iff
 apply transfer
 apply(rewrite in "rel_fun \<hole>" conversep_iff[symmetric])
 apply(rewrite in "rel_set \<hole>" conversep_iff[symmetric])
 apply(rewrite in "rel_fun _ \<hole>" conversep_iff[symmetric])
 apply(simp del: conversep_iff add: rel_fun_conversep)
 apply(simp)
 done
 
 lemma rel_\<I>_conversep1_eq [simp]: "rel_\<I> C\<inverse>\<inverse> (=) = (rel_\<I> C (=))\<inverse>\<inverse>"
 by(rewrite in "\<hole> = _" conversep_eq[symmetric])(simp del: conversep_eq)
 
 lemma rel_\<I>_conversep2_eq [simp]: "rel_\<I> (=) R\<inverse>\<inverse> = (rel_\<I> (=) R)\<inverse>\<inverse>"
 by(rewrite in "\<hole> = _" conversep_eq[symmetric])(simp del: conversep_eq)
 
 lemma responses_\<I>_empty_iff: "responses_\<I> \<I> out = {} \<longleftrightarrow> out \<notin> outs_\<I> \<I>"
 including \<I>.lifting by transfer auto
 
 lemma in_outs_\<I>_iff_responses_\<I>: "out \<in> outs_\<I> \<I> \<longleftrightarrow> responses_\<I> \<I> out \<noteq> {}"
 by(simp add: responses_\<I>_empty_iff)
 
 lift_definition \<I>_full :: "('call, 'ret) \<I>" is "\<lambda>_. UNIV" .
 
 lemma \<I>_full_sel [simp]:
   shows outs_\<I>_full: "outs_\<I> \<I>_full = UNIV"
   and responses_\<I>_full: "responses_\<I> \<I>_full x = UNIV"
 by(transfer; simp; fail)+
 
 context includes lifting_syntax begin
 lemma outs_\<I>_parametric [transfer_rule]: "(rel_\<I> C R ===> rel_set C) outs_\<I> outs_\<I>"
 unfolding rel_fun_def by transfer simp
 
 lemma responses_\<I>_parametric [transfer_rule]: 
   "(rel_\<I> C R ===> C ===> rel_set R) responses_\<I> responses_\<I>"
 unfolding rel_fun_def by transfer(auto dest: rel_funD)
 
 end
 
 definition \<I>_trivial :: "('out, 'in) \<I> \<Rightarrow> bool"
 where "\<I>_trivial \<I> \<longleftrightarrow> outs_\<I> \<I> = UNIV"
 
 lemma \<I>_trivialI [intro?]: "(\<And>x. x \<in> outs_\<I> \<I>) \<Longrightarrow> \<I>_trivial \<I>"
 by(auto simp add: \<I>_trivial_def)
 
 lemma \<I>_trivialD: "\<I>_trivial \<I> \<Longrightarrow> outs_\<I> \<I> = UNIV"
 by(simp add: \<I>_trivial_def)
 
 lemma \<I>_trivial_\<I>_full [simp]: "\<I>_trivial \<I>_full"
 by(simp add: \<I>_trivial_def)
 
 lifting_update \<I>.lifting
 lifting_forget \<I>.lifting
 
+context includes \<I>.lifting begin
+
+lift_definition \<I>_uniform :: "'out set \<Rightarrow> 'in set \<Rightarrow> ('out, 'in) \<I>" is "\<lambda>A B x. if x \<in> A then B else {}" .
+
+lemma outs_\<I>_uniform [simp]: "outs_\<I> (\<I>_uniform A B) = (if B = {} then {} else A)"
+  by transfer simp
+
+lemma responses_\<I>_uniform [simp]: "responses_\<I> (\<I>_uniform A B) x = (if x \<in> A then B else {})"
+  by transfer simp
+
+lemma \<I>_uniform_UNIV [simp]: "\<I>_uniform UNIV UNIV = \<I>_full" (* TODO: make \<I>_full an abbreviation *)
+  by transfer simp
+
+lift_definition map_\<I> :: "('out' \<Rightarrow> 'out) \<Rightarrow> ('in \<Rightarrow> 'in') \<Rightarrow> ('out, 'in) \<I> \<Rightarrow> ('out', 'in') \<I>"
+  is "\<lambda>f g resp x. g ` resp (f x)" .
+
+lemma outs_\<I>_map_\<I> [simp]:
+  "outs_\<I> (map_\<I> f g \<I>) = f -` outs_\<I> \<I>"
+  by transfer simp
+
+lemma responses_\<I>_map_\<I> [simp]:
+  "responses_\<I> (map_\<I> f g \<I>) x = g ` responses_\<I> \<I> (f x)"
+  by transfer simp
+
+lemma map_\<I>_\<I>_uniform [simp]:
+  "map_\<I> f g (\<I>_uniform A B) = \<I>_uniform (f -` A) (g ` B)"
+  by transfer(auto simp add: fun_eq_iff)
+
+lemma map_\<I>_id [simp]: "map_\<I> id id \<I> = \<I>"
+  by transfer simp
+
+lemma map_\<I>_id0: "map_\<I> id id = id"
+  by(simp add: fun_eq_iff)
+
+lemma map_\<I>_comp [simp]: "map_\<I> f g (map_\<I> f' g' \<I>) = map_\<I> (f' \<circ> f) (g \<circ> g') \<I>"
+  by transfer auto
+
+lemma map_\<I>_cong: "map_\<I> f g \<I> = map_\<I> f' g' \<I>'"
+  if "\<I> = \<I>'" and f: "f = f'" and "\<And>x y. \<lbrakk> x \<in> outs_\<I> \<I>'; y \<in> responses_\<I> \<I>' x \<rbrakk> \<Longrightarrow> g y = g' y"
+  unfolding that(1,2) using that(3-)
+  by transfer(auto simp add: fun_eq_iff intro!: image_cong)
+
+lifting_update \<I>.lifting
+lifting_forget \<I>.lifting
+end
+
+functor map_\<I> by(simp_all add: fun_eq_iff)
+
+lemma \<I>_eqI: "\<lbrakk> outs_\<I> \<I> = outs_\<I> \<I>'; \<And>x. x \<in> outs_\<I> \<I>' \<Longrightarrow> responses_\<I> \<I> x = responses_\<I> \<I>' x \<rbrakk> \<Longrightarrow> \<I> = \<I>'"
+  including \<I>.lifting by transfer auto
+
+instantiation \<I> :: (type, type) order begin
+
+definition less_eq_\<I> :: "('a, 'b) \<I> \<Rightarrow> ('a, 'b) \<I> \<Rightarrow> bool"
+  where le_\<I>_def: "less_eq_\<I> \<I> \<I>' \<longleftrightarrow> outs_\<I> \<I> \<subseteq> outs_\<I> \<I>' \<and> (\<forall>x\<in>outs_\<I> \<I>. responses_\<I> \<I>' x \<subseteq> responses_\<I> \<I> x)"
+
+definition less_\<I> :: "('a, 'b) \<I> \<Rightarrow> ('a, 'b) \<I> \<Rightarrow> bool"
+  where "less_\<I> = mk_less (\<le>)"
+
+instance
+proof
+  show "\<I> < \<I>' \<longleftrightarrow> \<I> \<le> \<I>' \<and> \<not> \<I>' \<le> \<I>" for \<I> \<I>' :: "('a, 'b) \<I>" by(simp add: less_\<I>_def mk_less_def)
+  show "\<I> \<le> \<I>" for \<I> :: "('a, 'b) \<I>" by(simp add: le_\<I>_def)
+  show "\<I> \<le> \<I>''" if "\<I> \<le> \<I>'" "\<I>' \<le> \<I>''" for \<I> \<I>' \<I>'' :: "('a, 'b) \<I>" using that
+    by(fastforce simp add: le_\<I>_def)
+  show "\<I> = \<I>'" if "\<I> \<le> \<I>'" "\<I>' \<le> \<I>" for \<I> \<I>' :: "('a, 'b) \<I>" using that
+    by(auto simp add: le_\<I>_def intro!: \<I>_eqI)
+qed
+end
+
+instantiation \<I> :: (type, type) order_bot begin
+definition bot_\<I> :: "('a, 'b) \<I>" where "bot_\<I> = \<I>_uniform {} UNIV"
+instance by standard(auto simp add: bot_\<I>_def le_\<I>_def)
+end
+
+lemma outs_\<I>_bot [simp]: "outs_\<I> bot = {}"
+  by(simp add: bot_\<I>_def)
+
+lemma respones_\<I>_bot [simp]: "responses_\<I> bot x = {}"
+  by(simp add: bot_\<I>_def)
+
+lemma outs_\<I>_mono: "\<I> \<le> \<I>' \<Longrightarrow> outs_\<I> \<I> \<subseteq> outs_\<I> \<I>'"
+  by(simp add: le_\<I>_def)
+
+lemma responses_\<I>_mono: "\<lbrakk> \<I> \<le> \<I>'; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> responses_\<I> \<I>' x \<subseteq> responses_\<I> \<I> x"
+  by(simp add: le_\<I>_def)
+
+lemma \<I>_uniform_empty [simp]: "\<I>_uniform {} A = bot" 
+  unfolding bot_\<I>_def including \<I>.lifting by transfer simp
+
+lemma \<I>_uniform_mono:
+  "\<I>_uniform A B \<le> \<I>_uniform C D" if "A \<subseteq> C" "D \<subseteq> B" "D = {} \<longrightarrow> B = {}"
+  unfolding le_\<I>_def using that by auto
+
 
 context begin
 qualified inductive resultsp_gpv :: "('out, 'in) \<I> \<Rightarrow> 'a \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> bool"
   for \<Gamma> x
 where
   Pure: "Pure x \<in> set_spmf (the_gpv gpv) \<Longrightarrow> resultsp_gpv \<Gamma> x gpv"
 | IO:
   "\<lbrakk> IO out c \<in> set_spmf (the_gpv gpv); input \<in> responses_\<I> \<Gamma> out; resultsp_gpv \<Gamma> x (c input) \<rbrakk>
   \<Longrightarrow> resultsp_gpv \<Gamma> x gpv"
 
 definition results_gpv :: "('out, 'in) \<I> \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> 'a set"
 where "results_gpv \<Gamma> gpv \<equiv> {x. resultsp_gpv \<Gamma> x gpv}"
 
 lemma resultsp_gpv_results_gpv_eq [pred_set_conv]: "resultsp_gpv \<Gamma> x gpv \<longleftrightarrow> x \<in> results_gpv \<Gamma> gpv"
 by(simp add: results_gpv_def)
 
 context begin
 local_setup \<open>Local_Theory.map_background_naming (Name_Space.mandatory_path "results_gpv")\<close>
 
 lemmas intros [intro?] = resultsp_gpv.intros[to_set]
   and Pure = Pure[to_set]
   and IO = IO[to_set]
   and induct [consumes 1, case_names Pure IO, induct set: results_gpv] = resultsp_gpv.induct[to_set]
   and cases [consumes 1, case_names Pure IO, cases set: results_gpv] = resultsp_gpv.cases[to_set]
   and simps = resultsp_gpv.simps[to_set]
 end
 
 inductive_simps results_gpv_GPV [to_set, simp]: "resultsp_gpv \<Gamma> x (GPV gpv)"
 
 end
 
 lemma results_gpv_Done [iff]: "results_gpv \<Gamma> (Done x) = {x}"
 by(auto simp add: Done.ctr)
 
 lemma results_gpv_Fail [iff]: "results_gpv \<Gamma> Fail = {}"
 by(auto simp add: Fail_def)
 
 lemma results_gpv_Pause [simp]:
   "results_gpv \<Gamma> (Pause out c) = (\<Union>input\<in>responses_\<I> \<Gamma> out. results_gpv \<Gamma> (c input))"
 by(auto simp add: Pause.ctr)
 
 lemma results_gpv_lift_spmf [iff]: "results_gpv \<Gamma> (lift_spmf p) = set_spmf p"
 by(auto simp add: lift_spmf.ctr)
 
 lemma results_gpv_assert_gpv [simp]: "results_gpv \<Gamma> (assert_gpv b) = (if b then {()} else {})"
 by auto
 
 lemma results_gpv_bind_gpv [simp]:
   "results_gpv \<Gamma> (gpv \<bind> f) = (\<Union>x\<in>results_gpv \<Gamma> gpv. results_gpv \<Gamma> (f x))"
   (is "?lhs = ?rhs")
 proof(intro set_eqI iffI)
   fix x
   assume "x \<in> ?lhs"
   then show "x \<in> ?rhs"
   proof(induction gpv'\<equiv>"gpv \<bind> f" arbitrary: gpv)
     case Pure thus ?case
       by(auto 4 3 split: if_split_asm intro: results_gpv.intros rev_bexI)
   next
     case (IO out c input)
     from \<open>IO out c \<in> _\<close>
     obtain generat where generat: "generat \<in> set_spmf (the_gpv gpv)"
       and *: "IO out c \<in> set_spmf (if is_Pure generat then the_gpv (f (result generat))
                                    else return_spmf (IO (output generat) (\<lambda>input. continuation generat input \<bind> f)))"
       by(auto)
     thus ?case
     proof(cases generat)
       case (Pure y)
       with generat have "y \<in> results_gpv \<Gamma> gpv" by(auto intro: results_gpv.intros)
       thus ?thesis using * Pure \<open>input \<in> responses_\<I> \<Gamma> out\<close> \<open>x \<in> results_gpv \<Gamma> (c input)\<close>
         by(auto intro: results_gpv.IO)
     next
       case (IO out' c')
       hence [simp]: "out' = out"
         and c: "\<And>input. c input = bind_gpv (c' input) f" using * by simp_all
       from IO.hyps(4)[OF c] obtain y where y: "y \<in> results_gpv \<Gamma> (c' input)"
         and "x \<in> results_gpv \<Gamma> (f y)" by blast
       from y IO generat have "y \<in> results_gpv \<Gamma> gpv" using \<open>input \<in> responses_\<I> \<Gamma> out\<close>
         by(auto intro: results_gpv.IO)
       with \<open>x \<in> results_gpv \<Gamma> (f y)\<close> show ?thesis by blast
     qed
   qed
 next
   fix x
   assume "x \<in> ?rhs"
   then obtain y where y: "y \<in> results_gpv \<Gamma> gpv"
     and x: "x \<in> results_gpv \<Gamma> (f y)" by blast
   from y show "x \<in> ?lhs"
   proof(induction)
     case (Pure gpv)
     with x show ?case
       by cases(auto 4 4 intro: results_gpv.intros rev_bexI)
   qed(auto 4 4 intro: rev_bexI results_gpv.IO)
 qed
 
 lemma results_gpv_\<I>_full: "results_gpv \<I>_full = results'_gpv"
 proof(intro ext set_eqI iffI)
   show "x \<in> results'_gpv gpv" if "x \<in> results_gpv \<I>_full gpv" for x gpv
     using that by induction(auto intro: results'_gpvI)
   show "x \<in> results_gpv \<I>_full gpv" if "x \<in> results'_gpv gpv" for x gpv
     using that by induction(auto intro: results_gpv.intros elim!: generat.set_cases)
 qed
 
 lemma results'_bind_gpv [simp]:
   "results'_gpv (bind_gpv gpv f) = (\<Union>x\<in>results'_gpv gpv. results'_gpv (f x))"
 unfolding results_gpv_\<I>_full[symmetric] by simp
 
 lemma results_gpv_map_gpv_id [simp]: "results_gpv \<I> (map_gpv f id gpv) = f ` results_gpv \<I> gpv"
   by(auto simp add: map_gpv_conv_bind id_def)
 
 lemma results_gpv_map_gpv_id' [simp]: "results_gpv \<I> (map_gpv f (\<lambda>x. x) gpv) = f ` results_gpv \<I> gpv"
   by(auto simp add: map_gpv_conv_bind id_def)
 
 lemma pred_gpv_bind [simp]: "pred_gpv P Q (bind_gpv gpv f) = pred_gpv (pred_gpv P Q \<circ> f) Q gpv"
 by(auto simp add: pred_gpv_def outs_bind_gpv)
 
 lemma results'_gpv_bind_option [simp]:
   "results'_gpv (monad.bind_option Fail x f) = (\<Union>y\<in>set_option x. results'_gpv (f y))"
 by(cases x) simp_all
 
+lemma results'_gpv_map_gpv':
+  assumes "surj h"
+  shows "results'_gpv (map_gpv' f g h gpv) = f ` results'_gpv gpv" (is "?lhs = ?rhs")
+proof -
+  have *:"IO z c \<in> set_spmf (the_gpv gpv) \<Longrightarrow> x \<in> results'_gpv (c input) \<Longrightarrow>
+     f x \<in> results'_gpv (map_gpv' f g h (c input)) \<Longrightarrow> f x \<in> results'_gpv (map_gpv' f g h gpv)" for x z gpv c input
+    using surjD[OF assms, of input] by(fastforce intro: results'_gpvI elim!: generat.set_cases intro: rev_image_eqI simp add: map_fun_def o_def)
+
+  show ?thesis 
+  proof(intro Set.set_eqI iffI; (elim imageE; hypsubst)?)
+    show "x \<in> ?rhs" if "x \<in> ?lhs" for x using that
+      by(induction gpv'\<equiv>"map_gpv' f g h gpv" arbitrary: gpv)(fastforce elim!: generat.set_cases intro: results'_gpvI)+
+    show "f x \<in> ?lhs" if "x \<in> results'_gpv gpv" for x using that
+      by induction (fastforce intro: results'_gpvI elim!: generat.set_cases intro: rev_image_eqI simp add: map_fun_def o_def
+          , clarsimp simp add: *  elim!: generat.set_cases)
+  qed
+qed
+
 lemma bind_gpv_bind_option_assoc:
   "bind_gpv (monad.bind_option Fail x f) g = monad.bind_option Fail x (\<lambda>x. bind_gpv (f x) g)"
 by(cases x) simp_all
 
+context begin
+qualified inductive outsp_gpv :: "('out, 'in) \<I> \<Rightarrow> 'out \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> bool"
+  for \<I> x where
+    IO: "IO x c \<in> set_spmf (the_gpv gpv) \<Longrightarrow> outsp_gpv \<I> x gpv"
+  | Cont: "\<lbrakk> IO out rpv \<in> set_spmf (the_gpv gpv); input \<in> responses_\<I> \<I> out; outsp_gpv \<I> x (rpv input) \<rbrakk>
+  \<Longrightarrow> outsp_gpv \<I> x gpv"
+
+definition outs_gpv :: "('out, 'in) \<I> \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> 'out set"
+  where "outs_gpv \<I> gpv \<equiv> {x. outsp_gpv \<I> x gpv}"
+
+lemma outsp_gpv_outs_gpv_eq [pred_set_conv]: "outsp_gpv \<I> x = (\<lambda>gpv. x \<in> outs_gpv \<I> gpv)"
+  by(simp add: outs_gpv_def)
+
+context begin
+local_setup \<open>Local_Theory.map_background_naming (Name_Space.mandatory_path "outs_gpv")\<close>
+
+lemmas intros [intro?] = outsp_gpv.intros[to_set]
+  and IO = IO[to_set]
+  and Cont = Cont[to_set]
+  and induct [consumes 1, case_names IO Cont, induct set: outs_gpv] = outsp_gpv.induct[to_set]
+  and cases [consumes 1, case_names IO Cont, cases set: outs_gpv] = outsp_gpv.cases[to_set]
+  and simps = outsp_gpv.simps[to_set]
+end
+
+inductive_simps outs_gpv_GPV [to_set, simp]: "outsp_gpv \<I> x (GPV gpv)"
+
+end
+
+lemma outs_gpv_Done [iff]: "outs_gpv \<I> (Done x) = {}"
+  by(auto simp add: Done.ctr)
+
+lemma outs_gpv_Fail [iff]: "outs_gpv \<I> Fail = {}"
+  by(auto simp add: Fail_def)
+
+lemma outs_gpv_Pause [simp]:
+  "outs_gpv \<I> (Pause out c) = insert out (\<Union>input\<in>responses_\<I> \<I> out. outs_gpv \<I> (c input))"
+  by(auto simp add: Pause.ctr)
+
+lemma outs_gpv_lift_spmf [iff]: "outs_gpv \<I> (lift_spmf p) = {}"
+  by(auto simp add: lift_spmf.ctr)
+
+lemma outs_gpv_assert_gpv [simp]: "outs_gpv \<I> (assert_gpv b) = {}"
+  by(cases b)auto
+
+lemma outs_gpv_bind_gpv [simp]:
+  "outs_gpv \<I> (gpv \<bind> f) = outs_gpv \<I> gpv \<union> (\<Union>x\<in>results_gpv \<I> gpv. outs_gpv \<I> (f x))"
+  (is "?lhs = ?rhs")
+proof(intro Set.set_eqI iffI)
+  fix x
+  assume "x \<in> ?lhs"
+  then show "x \<in> ?rhs"
+  proof(induction gpv'\<equiv>"gpv \<bind> f" arbitrary: gpv)
+    case IO thus ?case
+    proof(clarsimp split: if_split_asm elim!: is_PureE not_is_PureE, goal_cases)
+      case (1 generat)
+      then show ?case by(cases generat)(auto intro: results_gpv.Pure outs_gpv.intros)
+    qed
+  next
+    case (Cont out rpv input)
+    thus ?case
+    proof(clarsimp split: if_split_asm, goal_cases)
+      case (1 generat)
+      then show ?case by(cases generat)(auto 4 3 split: if_split_asm intro: results_gpv.intros outs_gpv.intros)
+    qed
+  qed
+next
+  fix x
+  assume "x \<in> ?rhs"
+  then consider (out) "x \<in> outs_gpv \<I> gpv" | (result) y where "y \<in> results_gpv \<I> gpv" "x \<in> outs_gpv \<I> (f y)" by auto
+  then show "x \<in> ?lhs"
+  proof cases
+    case out then show ?thesis
+      by(induction) (auto 4 4 intro: outs_gpv.IO  outs_gpv.Cont rev_bexI) 
+  next
+    case result then show ?thesis
+      by induction ((erule outs_gpv.cases | rule outs_gpv.Cont), 
+          auto 4 4 intro: outs_gpv.intros rev_bexI elim: outs_gpv.cases)+
+  qed
+qed
+
+lemma outs_gpv_\<I>_full: "outs_gpv \<I>_full = outs'_gpv"
+proof(intro ext Set.set_eqI iffI)
+  show "x \<in> outs'_gpv gpv" if "x \<in> outs_gpv \<I>_full gpv" for x gpv
+    using that by induction(auto intro: outs'_gpvI)
+  show "x \<in> outs_gpv \<I>_full gpv" if "x \<in> outs'_gpv gpv" for x gpv
+    using that by induction(auto intro: outs_gpv.intros elim!: generat.set_cases)
+qed
+
+lemma outs'_bind_gpv [simp]:
+  "outs'_gpv (bind_gpv gpv f) = outs'_gpv gpv \<union> (\<Union>x\<in>results'_gpv gpv. outs'_gpv (f x))"
+  unfolding outs_gpv_\<I>_full[symmetric] results_gpv_\<I>_full[symmetric] by simp
+
+lemma outs_gpv_map_gpv_id [simp]: "outs_gpv \<I> (map_gpv f id gpv) = outs_gpv \<I> gpv"
+  by(auto simp add: map_gpv_conv_bind id_def)
+
+lemma outs_gpv_map_gpv_id' [simp]: "outs_gpv \<I> (map_gpv f (\<lambda>x. x) gpv) = outs_gpv \<I> gpv"
+  by(auto simp add: map_gpv_conv_bind id_def)
+
+lemma outs'_gpv_bind_option [simp]:
+  "outs'_gpv (monad.bind_option Fail x f) = (\<Union>y\<in>set_option x. outs'_gpv (f y))"
+  by(cases x) simp_all
+
+lemma rel_gpv''_Grp: includes lifting_syntax shows
+  "rel_gpv'' (BNF_Def.Grp A f) (BNF_Def.Grp B g) (BNF_Def.Grp UNIV h)\<inverse>\<inverse> = 
+   BNF_Def.Grp {x. results_gpv (\<I>_uniform UNIV (range h)) x \<subseteq> A \<and> outs_gpv (\<I>_uniform UNIV (range h)) x \<subseteq> B} (map_gpv' f g h)"
+  (is "?lhs = ?rhs")
+proof(intro ext GrpI iffI CollectI conjI subsetI)
+  let ?\<I> = "\<I>_uniform UNIV (range h)"
+  fix gpv gpv'
+  assume *: "?lhs gpv gpv'"
+  then show "map_gpv' f g h gpv = gpv'"
+    by(coinduction arbitrary: gpv gpv')
+      (drule rel_gpv''D
+        , auto 4 5 simp add: spmf_rel_map generat.rel_map elim!: rel_spmf_mono generat.rel_mono_strong GrpE intro!: GrpI dest: rel_funD)
+  show "x \<in> A" if "x \<in> results_gpv ?\<I> gpv" for x using that *
+  proof(induction arbitrary: gpv')
+    case (Pure gpv)
+    have "pred_spmf (Domainp (rel_generat (BNF_Def.Grp A f) (BNF_Def.Grp B g) ((BNF_Def.Grp UNIV h)\<inverse>\<inverse> ===> rel_gpv'' (BNF_Def.Grp A f) (BNF_Def.Grp B g) (BNF_Def.Grp UNIV h)\<inverse>\<inverse>))) (the_gpv gpv)"
+      using Pure.prems[THEN rel_gpv''D] unfolding spmf_Domainp_rel[symmetric] ..
+    with Pure.hyps show ?case by(simp add: generat.Domainp_rel pred_spmf_def pred_generat_def Domainp_Grp)
+  next
+    case (IO out c gpv input)
+    have "pred_spmf (Domainp (rel_generat (BNF_Def.Grp A f) (BNF_Def.Grp B g) ((BNF_Def.Grp UNIV h)\<inverse>\<inverse> ===> rel_gpv'' (BNF_Def.Grp A f) (BNF_Def.Grp B g) (BNF_Def.Grp UNIV h)\<inverse>\<inverse>))) (the_gpv gpv)"
+      using IO.prems[THEN rel_gpv''D] unfolding spmf_Domainp_rel[symmetric] by(rule DomainPI)
+    with IO.hyps show ?case 
+      by(auto simp add: generat.Domainp_rel pred_spmf_def pred_generat_def Grp_iff dest: rel_funD intro: IO.IH dest!: bspec)
+  qed
+  show "x \<in> B" if "x \<in> outs_gpv ?\<I> gpv" for x using that *
+  proof(induction arbitrary: gpv')
+    case (IO c gpv)
+    have "pred_spmf (Domainp (rel_generat (BNF_Def.Grp A f) (BNF_Def.Grp B g) ((BNF_Def.Grp UNIV h)\<inverse>\<inverse> ===> rel_gpv'' (BNF_Def.Grp A f) (BNF_Def.Grp B g) (BNF_Def.Grp UNIV h)\<inverse>\<inverse>))) (the_gpv gpv)"
+      using IO.prems[THEN rel_gpv''D] unfolding spmf_Domainp_rel[symmetric] by(rule DomainPI)
+    with IO.hyps show ?case by(simp add: generat.Domainp_rel pred_spmf_def pred_generat_def Domainp_Grp)
+  next
+    case (Cont out rpv gpv input)
+    have "pred_spmf (Domainp (rel_generat (BNF_Def.Grp A f) (BNF_Def.Grp B g) ((BNF_Def.Grp UNIV h)\<inverse>\<inverse> ===> rel_gpv'' (BNF_Def.Grp A f) (BNF_Def.Grp B g) (BNF_Def.Grp UNIV h)\<inverse>\<inverse>))) (the_gpv gpv)"
+      using Cont.prems[THEN rel_gpv''D] unfolding spmf_Domainp_rel[symmetric] by(rule DomainPI)
+    with Cont.hyps show ?case 
+      by(auto simp add: generat.Domainp_rel pred_spmf_def pred_generat_def Grp_iff dest: rel_funD intro: Cont.IH dest!: bspec)
+  qed
+next
+  fix gpv gpv'
+  assume "?rhs gpv gpv'"
+  then have gpv': "gpv' = map_gpv' f g h gpv"
+    and *: "results_gpv (\<I>_uniform UNIV (range h)) gpv \<subseteq> A" "outs_gpv (\<I>_uniform UNIV (range h)) gpv \<subseteq> B" by(auto simp add: Grp_iff)
+  show "?lhs gpv gpv'" using * unfolding gpv'
+    by(coinduction arbitrary: gpv)
+      (fastforce simp add: spmf_rel_map generat.rel_map Grp_iff intro!: rel_spmf_reflI generat.rel_refl_strong rel_funI elim!: generat.set_cases intro: results_gpv.intros outs_gpv.intros)
+qed
+
+inductive pred_gpv' :: "('a \<Rightarrow> bool) \<Rightarrow> ('out \<Rightarrow> bool) \<Rightarrow> 'in set \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> bool" for P Q X gpv where
+  "pred_gpv' P Q X gpv" 
+if "\<And>x. x \<in> results_gpv (\<I>_uniform UNIV X) gpv \<Longrightarrow> P x" "\<And>out. out \<in> outs_gpv (\<I>_uniform UNIV X) gpv \<Longrightarrow> Q out"
+
+lemma pred_gpv_conv_pred_gpv': "pred_gpv P Q = pred_gpv' P Q UNIV"
+  by(auto simp add: fun_eq_iff pred_gpv_def pred_gpv'.simps results_gpv_\<I>_full outs_gpv_\<I>_full)
+
+lemma rel_gpv''_map_gpv'1:
+  "rel_gpv'' A C (BNF_Def.Grp UNIV h)\<inverse>\<inverse> gpv gpv' \<Longrightarrow> rel_gpv'' A C (=) (map_gpv' id id h gpv) gpv'"
+  apply(coinduction arbitrary: gpv gpv')
+  apply(drule rel_gpv''D)
+  apply(simp add: spmf_rel_map)
+  apply(erule rel_spmf_mono)
+  apply(simp add: generat.rel_map)
+  apply(erule generat.rel_mono_strong; simp?)
+  apply(subst map_fun2_id)
+  by(auto simp add: rel_fun_comp intro!: rel_fun_map_fun1 elim: rel_fun_mono)
+
+lemma rel_gpv''_map_gpv'2:
+  "rel_gpv'' A C (eq_on (range h)) gpv gpv' \<Longrightarrow> rel_gpv'' A C (BNF_Def.Grp UNIV h)\<inverse>\<inverse> gpv (map_gpv' id id h gpv')"
+  apply(coinduction arbitrary: gpv gpv')
+  apply(drule rel_gpv''D)
+  apply(simp add: spmf_rel_map)
+  apply(erule rel_spmf_mono_strong)
+  apply(simp add: generat.rel_map)
+  apply(erule generat.rel_mono_strong; simp?)
+  apply(subst map_fun_id2_in)
+  apply(rule rel_fun_map_fun2)
+  by (auto simp add: rel_fun_comp  elim: rel_fun_mono)
+
+context
+  fixes A :: "'a \<Rightarrow> 'd \<Rightarrow> bool"
+    and C :: "'c \<Rightarrow> 'g \<Rightarrow> bool"
+    and R :: "'b \<Rightarrow> 'e \<Rightarrow> bool"
+begin
+
+private lemma f11:" Pure x \<in> set_spmf (the_gpv gpv) \<Longrightarrow>
+   Domainp (rel_generat A C (rel_fun R (rel_gpv'' A C R))) (Pure x) \<Longrightarrow> Domainp A x"
+  by (auto simp add: pred_generat_def elim:bspec dest: generat.Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI])
+
+private lemma f21: "IO out c \<in> set_spmf (the_gpv gpv) \<Longrightarrow> 
+  rel_generat A C (rel_fun R (rel_gpv'' A C R)) (IO out c) ba \<Longrightarrow> Domainp C out"
+  by (auto simp add: pred_generat_def elim:bspec dest: generat.Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI])
+
+private lemma f12:
+  assumes "IO out c \<in> set_spmf (the_gpv gpv)"
+    and "input \<in> responses_\<I> (\<I>_uniform UNIV {x. Domainp R x}) out"
+    and "x \<in> results_gpv (\<I>_uniform UNIV {x. Domainp R x}) (c input)"
+    and "Domainp (rel_gpv'' A C R) gpv"
+  shows "Domainp (rel_gpv'' A C R) (c input)"
+proof -
+  obtain b1 where o1:"rel_gpv'' A C R gpv b1" using assms(4) by clarsimp
+  obtain b2 where o2:"rel_generat A C (rel_fun R (rel_gpv'' A C R)) (IO out c) b2"
+    using assms(1) o1[THEN rel_gpv''D, THEN spmf_Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI]]
+    unfolding pred_spmf_def by - (drule (1) bspec, auto)
+
+  have "Ball (generat_conts (IO out c)) (Domainp (rel_fun R (rel_gpv'' A C R)))"
+    using o2[THEN generat.Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI]]
+    unfolding pred_generat_def by simp
+
+  with assms(2) show ?thesis 
+    apply -
+    apply(drule bspec)
+     apply simp
+    apply clarify
+    apply(drule Domainp_rel_fun_le[THEN predicate1D, OF Domainp_iff[THEN iffD2], OF exI])
+    by simp  
+qed
+
+private lemma f22:
+  assumes "IO out' rpv \<in> set_spmf (the_gpv gpv)"
+    and "input \<in> responses_\<I> (\<I>_uniform UNIV {x. Domainp R x}) out'"
+    and "out \<in> outs_gpv (\<I>_uniform UNIV {x. Domainp R x}) (rpv input)"
+    and "Domainp (rel_gpv'' A C R) gpv"
+  shows "Domainp (rel_gpv'' A C R) (rpv input)"
+proof -
+  obtain b1 where o1:"rel_gpv'' A C R gpv b1" using assms(4) by auto
+  obtain b2 where o2:"rel_generat A C (rel_fun R (rel_gpv'' A C R)) (IO out' rpv) b2"
+    using assms(1) o1[THEN rel_gpv''D, THEN spmf_Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI]]
+    unfolding pred_spmf_def by - (drule (1) bspec, auto)
+
+  have "Ball (generat_conts (IO out' rpv)) (Domainp (rel_fun R (rel_gpv'' A C R)))"
+    using o2[THEN generat.Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI]]
+    unfolding pred_generat_def by simp
+
+  with assms(2) show ?thesis 
+    apply -
+    apply(drule bspec)
+     apply simp
+    apply clarify
+    apply(drule Domainp_rel_fun_le[THEN predicate1D, OF Domainp_iff[THEN iffD2], OF exI])
+    by simp 
+qed
+
+lemma Domainp_rel_gpv''_le:
+  "Domainp (rel_gpv'' A C R) \<le> pred_gpv' (Domainp A) (Domainp C) {x. Domainp R x}"
+proof(rule predicate1I pred_gpv'.intros)+
+  show "Domainp A x" if "x \<in> results_gpv (\<I>_uniform UNIV {x. Domainp R x}) gpv" "Domainp (rel_gpv'' A C R) gpv" for x gpv using that
+  proof(induction)
+    case (Pure gpv)
+    then show ?case 
+      by (clarify) (drule rel_gpv''D
+          , auto simp add: f11 pred_spmf_def dest: spmf_Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI])
+  qed (simp add: f12) 
+  show "Domainp C out" if "out \<in> outs_gpv (\<I>_uniform UNIV {x. Domainp R x}) gpv" "Domainp (rel_gpv'' A C R) gpv" for out gpv using that
+  proof( induction)
+    case (IO c gpv)
+    then show ?case
+      by (clarify) (drule rel_gpv''D
+          , auto simp add: f21 pred_spmf_def dest!: bspec spmf_Domainp_rel[THEN fun_cong, THEN iffD1, OF Domainp_iff[THEN iffD2], OF exI])
+  qed (simp add: f22)
+qed
+
+end
+
+lemma map_gpv'_id12: "map_gpv' f g h gpv = map_gpv' id id h (map_gpv f g gpv)"
+  unfolding map_gpv_conv_map_gpv' map_gpv'_comp by simp
+
+lemma rel_gpv''_refl: "\<lbrakk> (=) \<le> A; (=) \<le> C; R \<le> (=) \<rbrakk> \<Longrightarrow> (=) \<le> rel_gpv'' A C R"
+  by(subst rel_gpv''_eq[symmetric])(rule rel_gpv''_mono)
+
+
+context
+  fixes A A' :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
+    and C C' :: "'c \<Rightarrow> 'd \<Rightarrow> bool"
+    and R R' :: "'e \<Rightarrow> 'f \<Rightarrow> bool"
+   
+begin
+
+private abbreviation foo where 
+  "foo \<equiv> (\<lambda> fx fy gpvx gpvy g1 g2. 
+            \<forall>x y. x \<in> fx (\<I>_uniform UNIV (Collect (Domainp R'))) gpvx \<longrightarrow>
+                  y \<in> fy (\<I>_uniform UNIV (Collect (Rangep R'))) gpvy \<longrightarrow> g1 x y \<longrightarrow> g2 x y)"
+
+private lemma f1: "foo results_gpv results_gpv gpv gpv' A A' \<Longrightarrow>
+       x \<in> set_spmf (the_gpv gpv) \<Longrightarrow> y \<in> set_spmf (the_gpv gpv') \<Longrightarrow>
+       a \<in> generat_conts x \<Longrightarrow> b \<in> generat_conts y \<Longrightarrow>  R' a' \<alpha> \<Longrightarrow> R' \<beta> b' \<Longrightarrow> 
+    foo results_gpv results_gpv (a a') (b b') A A'"
+  by (fastforce elim: generat.set_cases intro: results_gpv.IO)
+
+private lemma f2: "foo outs_gpv outs_gpv gpv gpv' C C' \<Longrightarrow>
+       x \<in> set_spmf (the_gpv gpv) \<Longrightarrow> y \<in> set_spmf (the_gpv gpv') \<Longrightarrow>
+       a \<in> generat_conts x \<Longrightarrow> b \<in> generat_conts y \<Longrightarrow> R' a' \<alpha> \<Longrightarrow> R' \<beta> b' \<Longrightarrow> 
+    foo outs_gpv outs_gpv (a a') (b b') C C'"
+  by (fastforce elim: generat.set_cases intro: outs_gpv.Cont)
+
+lemma rel_gpv''_mono_strong:
+  "\<lbrakk> rel_gpv'' A C R gpv gpv'; 
+     \<And>x y. \<lbrakk> x \<in> results_gpv (\<I>_uniform UNIV {x. Domainp R' x}) gpv; y \<in> results_gpv (\<I>_uniform UNIV {x. Rangep R' x}) gpv'; A x y \<rbrakk> \<Longrightarrow> A' x y;
+     \<And>x y. \<lbrakk> x \<in> outs_gpv (\<I>_uniform UNIV {x. Domainp R' x}) gpv; y \<in> outs_gpv (\<I>_uniform UNIV {x. Rangep R' x}) gpv'; C x y \<rbrakk> \<Longrightarrow> C' x y;
+     R' \<le> R \<rbrakk>
+  \<Longrightarrow> rel_gpv'' A' C' R' gpv gpv'"
+  apply(coinduction arbitrary: gpv gpv')
+  apply(drule rel_gpv''D)
+  apply(erule rel_spmf_mono_strong)
+  apply(erule generat.rel_mono_strong)
+    apply(erule generat.set_cases)+
+    apply(erule allE, rotate_tac -1)
+    apply(erule allE)
+    apply(erule impE)
+     apply(rule results_gpv.Pure)
+     apply simp
+    apply(erule impE)
+     apply(rule results_gpv.Pure)
+     apply simp
+    apply simp
+   apply(erule generat.set_cases)+
+   apply(rotate_tac 1)
+   apply(erule allE, rotate_tac -1)
+   apply(erule allE)
+   apply(erule impE)
+    apply(rule outs_gpv.IO)
+    apply simp
+   apply(erule impE)
+    apply(rule outs_gpv.IO)
+    apply simp
+   apply simp
+  apply(erule (1) rel_fun_mono_strong)
+  by (fastforce simp add: f1[simplified] f2[simplified])
+
+end
+
+lemma rel_gpv''_refl_strong:
+  assumes "\<And>x. x \<in> results_gpv (\<I>_uniform UNIV {x. Domainp R x}) gpv \<Longrightarrow> A x x"
+    and "\<And>x. x \<in> outs_gpv (\<I>_uniform UNIV {x. Domainp R x}) gpv \<Longrightarrow> C x x"
+    and "R \<le> (=)"
+  shows "rel_gpv'' A C R gpv gpv"
+proof -
+  have "rel_gpv'' (=) (=) (=) gpv gpv" unfolding rel_gpv''_eq by simp
+  then show ?thesis using _ _ assms(3) by(rule rel_gpv''_mono_strong)(auto intro: assms(1-2))
+qed
+
+lemma rel_gpv''_refl_eq_on:
+  "\<lbrakk> \<And>x. x \<in> results_gpv (\<I>_uniform UNIV X) gpv \<Longrightarrow> A x x; \<And>out. out \<in> outs_gpv (\<I>_uniform UNIV X) gpv \<Longrightarrow> B out out \<rbrakk>
+  \<Longrightarrow> rel_gpv'' A B (eq_on X) gpv gpv"
+  by(rule rel_gpv''_refl_strong) (auto elim: eq_onE)
+
+lemma pred_gpv'_mono' [mono]:
+  "pred_gpv' A C R gpv \<longrightarrow> pred_gpv' A' C' R gpv"
+  if "\<And>x. A x \<longrightarrow> A' x" "\<And>x. C x \<longrightarrow> C' x"
+  using that unfolding pred_gpv'.simps
+  by auto
+
 subsubsection \<open>Type judgements\<close>
 
 coinductive WT_gpv :: "('out, 'in) \<I> \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> bool" ("((_)/ \<turnstile>g (_) \<surd>)" [100, 0] 99)
   for \<Gamma>
 where
   "(\<And>out c. IO out c \<in> set_spmf gpv \<Longrightarrow> out \<in> outs_\<I> \<Gamma> \<and> (\<forall>input\<in>responses_\<I> \<Gamma> out. \<Gamma> \<turnstile>g c input \<surd>))
   \<Longrightarrow> \<Gamma> \<turnstile>g GPV gpv \<surd>"
 
 lemma WT_gpv_coinduct [consumes 1, case_names WT_gpv, case_conclusion WT_gpv out cont, coinduct pred: WT_gpv]:
   assumes *: "X gpv"
   and step: "\<And>gpv out c.
     \<lbrakk> X gpv; IO out c \<in> set_spmf (the_gpv gpv) \<rbrakk>
     \<Longrightarrow> out \<in> outs_\<I> \<Gamma> \<and> (\<forall>input \<in> responses_\<I> \<Gamma> out. X (c input) \<or> \<Gamma> \<turnstile>g c input \<surd>)"
   shows "\<Gamma> \<turnstile>g gpv \<surd>"
 using * by(coinduct)(auto dest: step simp add: eq_GPV_iff)
 
 lemma WT_gpv_simps:
   "\<Gamma> \<turnstile>g GPV gpv \<surd> \<longleftrightarrow>
    (\<forall>out c. IO out c \<in> set_spmf gpv \<longrightarrow> out \<in> outs_\<I> \<Gamma> \<and> (\<forall>input\<in>responses_\<I> \<Gamma> out. \<Gamma> \<turnstile>g c input \<surd>))"
 by(subst WT_gpv.simps) simp
 
 lemma WT_gpvI:
   "(\<And>out c. IO out c \<in> set_spmf (the_gpv gpv) \<Longrightarrow> out \<in> outs_\<I> \<Gamma> \<and> (\<forall>input\<in>responses_\<I> \<Gamma> out. \<Gamma> \<turnstile>g c input \<surd>))
   \<Longrightarrow> \<Gamma> \<turnstile>g gpv \<surd>"
 by(cases gpv)(simp add: WT_gpv_simps)
 
 lemma WT_gpvD:
   assumes "\<Gamma> \<turnstile>g gpv \<surd>"
   shows WT_gpv_OutD: "IO out c \<in> set_spmf (the_gpv gpv) \<Longrightarrow> out \<in> outs_\<I> \<Gamma>"
   and WT_gpv_ContD: "\<lbrakk> IO out c \<in> set_spmf (the_gpv gpv); input \<in> responses_\<I> \<Gamma> out \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile>g c input \<surd>"
 using assms by(cases, fastforce)+
 
 lemma WT_gpv_mono:
   assumes WT: "\<I>1 \<turnstile>g gpv \<surd>"
   and outs: "outs_\<I> \<I>1 \<subseteq> outs_\<I> \<I>2"
   and responses: "\<And>x. x \<in> outs_\<I> \<I>1 \<Longrightarrow> responses_\<I> \<I>2 x \<subseteq> responses_\<I> \<I>1 x"
   shows "\<I>2 \<turnstile>g gpv \<surd>"
 using WT
 proof coinduct
   case (WT_gpv gpv out c)
   with outs show ?case by(auto 6 4 dest: responses WT_gpvD)
 qed
 
 lemma WT_gpv_Done [iff]: "\<Gamma> \<turnstile>g Done x \<surd>"
 by(rule WT_gpvI) simp_all
 
 lemma WT_gpv_Fail [iff]: "\<Gamma> \<turnstile>g Fail \<surd>"
 by(rule WT_gpvI) simp_all
 
 lemma WT_gpv_PauseI: 
   "\<lbrakk> out \<in> outs_\<I> \<Gamma>; \<And>input. input \<in> responses_\<I> \<Gamma> out \<Longrightarrow> \<Gamma> \<turnstile>g c input \<surd> \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile>g Pause out c \<surd>"
 by(rule WT_gpvI) simp_all
 
 lemma WT_gpv_Pause [iff]:
   "\<Gamma> \<turnstile>g Pause out c \<surd> \<longleftrightarrow> out \<in> outs_\<I> \<Gamma> \<and> (\<forall>input \<in> responses_\<I> \<Gamma> out. \<Gamma> \<turnstile>g c input \<surd>)"
 by(auto intro: WT_gpv_PauseI dest: WT_gpvD)
 
 lemma WT_gpv_bindI:
   "\<lbrakk> \<Gamma> \<turnstile>g gpv \<surd>; \<And>x. x \<in> results_gpv \<Gamma> gpv \<Longrightarrow> \<Gamma> \<turnstile>g f x \<surd> \<rbrakk>
   \<Longrightarrow> \<Gamma> \<turnstile>g gpv \<bind> f \<surd>"
 proof(coinduction arbitrary: gpv)
   case [rule_format]: (WT_gpv out c gpv)
   from \<open>IO out c \<in> _\<close>
   obtain generat where generat: "generat \<in> set_spmf (the_gpv gpv)"
     and *: "IO out c \<in> set_spmf (if is_Pure generat then the_gpv (f (result generat))
                                  else return_spmf (IO (output generat) (\<lambda>input. continuation generat input \<bind> f)))"
     by(auto)
   show ?case
   proof(cases generat)
     case (Pure y)
     with generat have "y \<in> results_gpv \<Gamma> gpv" by(auto intro: results_gpv.Pure)
     hence "\<Gamma> \<turnstile>g f y \<surd>" by(rule WT_gpv)
     with * Pure show ?thesis by(auto dest: WT_gpvD) 
   next
     case (IO out' c')
     hence [simp]: "out' = out"
       and c: "\<And>input. c input = bind_gpv (c' input) f" using * by simp_all
     from generat IO have **: "IO out c' \<in> set_spmf (the_gpv gpv)" by simp
     with \<open>\<Gamma> \<turnstile>g gpv \<surd>\<close> have ?out by(auto dest: WT_gpvD)
     moreover {
       fix input
       assume input: "input \<in> responses_\<I> \<Gamma> out"
       with \<open>\<Gamma> \<turnstile>g gpv \<surd>\<close> ** have "\<Gamma> \<turnstile>g c' input \<surd>" by(rule WT_gpvD)
       moreover {
         fix y
         assume "y \<in> results_gpv \<Gamma> (c' input)"
         with ** input have "y \<in> results_gpv \<Gamma> gpv" by(rule results_gpv.IO)
         hence "\<Gamma> \<turnstile>g f y \<surd>" by(rule WT_gpv) }
       moreover note calculation }
     hence ?cont using c by blast
     ultimately show ?thesis ..
   qed
 qed
 
 lemma WT_gpv_bindD2:
   assumes WT: "\<Gamma> \<turnstile>g gpv \<bind> f \<surd>"
   and x: "x \<in> results_gpv \<Gamma> gpv"
   shows "\<Gamma> \<turnstile>g f x \<surd>"
 using x WT
 proof induction
   case (Pure gpv)
   show ?case
   proof(rule WT_gpvI)
     fix out c
     assume "IO out c \<in> set_spmf (the_gpv (f x))"
     with Pure have "IO out c \<in> set_spmf (the_gpv (gpv \<bind> f))" by(auto intro: rev_bexI)
     with \<open>\<Gamma> \<turnstile>g gpv \<bind> f \<surd>\<close> show "out \<in> outs_\<I> \<Gamma> \<and> (\<forall>input\<in>responses_\<I> \<Gamma> out. \<Gamma> \<turnstile>g c input \<surd>)"
       by(auto dest: WT_gpvD simp del: set_bind_spmf)
   qed
 next
   case (IO out c gpv input)
   from \<open>IO out c \<in> _\<close>
   have "IO out (\<lambda>input. bind_gpv (c input) f) \<in> set_spmf (the_gpv (gpv \<bind> f))"
     by(auto intro: rev_bexI)
   with IO.prems have "\<Gamma> \<turnstile>g c input \<bind> f \<surd>" using \<open>input \<in> _\<close> by(rule WT_gpv_ContD)
   thus ?case by(rule IO.IH)
 qed
 
 lemma WT_gpv_bindD1: "\<Gamma> \<turnstile>g gpv \<bind> f \<surd> \<Longrightarrow> \<Gamma> \<turnstile>g gpv \<surd>"
 proof(coinduction arbitrary: gpv)
   case (WT_gpv out c gpv)
   from \<open>IO out c \<in> _\<close>
   have "IO out (\<lambda>input. bind_gpv (c input) f) \<in> set_spmf (the_gpv (gpv \<bind> f))"
     by(auto intro: rev_bexI)
   with \<open>\<Gamma> \<turnstile>g gpv \<bind> f \<surd>\<close> show ?case
     by(auto simp del: bind_gpv_sel' dest: WT_gpvD)
 qed
 
 lemma WT_gpv_bind [simp]: "\<Gamma> \<turnstile>g gpv \<bind> f \<surd> \<longleftrightarrow> \<Gamma> \<turnstile>g gpv \<surd> \<and> (\<forall>x\<in>results_gpv \<Gamma> gpv. \<Gamma> \<turnstile>g f x \<surd>)"
 by(blast intro: WT_gpv_bindI dest: WT_gpv_bindD1 WT_gpv_bindD2)
 
 lemma WT_gpv_full [simp, intro!]: "\<I>_full \<turnstile>g gpv \<surd>"
 by(coinduction arbitrary: gpv)(auto)
 
 lemma WT_gpv_lift_spmf [simp, intro!]: "\<I> \<turnstile>g lift_spmf p \<surd>"
 by(rule WT_gpvI) auto
 
 lemma WT_gpv_coinduct_bind [consumes 1, case_names WT_gpv, case_conclusion WT_gpv out cont]:
   assumes *: "X gpv"
   and step: "\<And>gpv out c. \<lbrakk> X gpv; IO out c \<in> set_spmf (the_gpv gpv) \<rbrakk>
     \<Longrightarrow> out \<in> outs_\<I> \<I> \<and> (\<forall>input\<in>responses_\<I> \<I> out.
             X (c input) \<or>
             \<I> \<turnstile>g c input \<surd> \<or>
             (\<exists>(gpv' :: ('b, 'call, 'ret) gpv) f. c input = gpv' \<bind> f \<and> \<I> \<turnstile>g gpv' \<surd> \<and> (\<forall>x\<in>results_gpv \<I> gpv'. X (f x))))"
   shows "\<I> \<turnstile>g gpv \<surd>"
 proof -
   fix x
   define gpv' :: "('b, 'call, 'ret) gpv" and f :: "'b \<Rightarrow> ('a, 'call, 'ret) gpv"
     where "gpv' = Done x" and "f = (\<lambda>_. gpv)"
   with * have "\<I> \<turnstile>g gpv' \<surd>" and "\<And>x. x \<in> results_gpv \<I> gpv' \<Longrightarrow> X (f x)" by simp_all
   then have "\<I> \<turnstile>g gpv' \<bind> f \<surd>"
   proof(coinduction arbitrary: gpv' f rule: WT_gpv_coinduct)
     case [rule_format]: (WT_gpv out c gpv')
     from \<open>IO out c \<in> _\<close>
     obtain generat where generat: "generat \<in> set_spmf (the_gpv gpv')"
       and *: "IO out c \<in> set_spmf (if is_Pure generat
         then the_gpv (f (result generat))
         else return_spmf (IO (output generat) (\<lambda>input. continuation generat input \<bind> f)))"
       by(clarsimp)
     show ?case
     proof(cases generat)
       case (Pure x)
       from Pure * have IO: "IO out c \<in> set_spmf (the_gpv (f x))" by simp
       from generat Pure have "x \<in> results_gpv \<I> gpv'" by (simp add: results_gpv.Pure)
       then have "X (f x)" by(rule WT_gpv)
       from step[OF this IO] show ?thesis by(auto 4 4 intro: exI[where x="Done _"])
     next
       case (IO out' c')
       with * have [simp]: "out' = out"
         and c: "c = (\<lambda>input. c' input \<bind> f)" by simp_all
       from IO generat have IO: "IO out c' \<in> set_spmf (the_gpv gpv')" by simp
       then have "\<And>input. input \<in> responses_\<I> \<I> out \<Longrightarrow> results_gpv \<I> (c' input) \<subseteq> results_gpv \<I> gpv'"
         by(auto intro: results_gpv.IO)
       with WT_gpvD[OF \<open>\<I> \<turnstile>g gpv' \<surd>\<close> IO] show ?thesis unfolding c using WT_gpv(2) by blast
     qed
   qed
   then show ?thesis unfolding gpv'_def f_def by simp
 qed
 
 lemma \<I>_trivial_WT_gpvD [simp]: "\<I>_trivial \<I> \<Longrightarrow> \<I> \<turnstile>g gpv \<surd>"
 using WT_gpv_full by(rule WT_gpv_mono)(simp_all add: \<I>_trivial_def)
 
 lemma \<I>_trivial_WT_gpvI: 
   assumes "\<And>gpv :: ('a, 'out, 'in) gpv. \<I> \<turnstile>g gpv \<surd>"
   shows "\<I>_trivial \<I>"
 proof
   fix x
   have "\<I> \<turnstile>g Pause x (\<lambda>_. Fail :: ('a, 'out, 'in) gpv) \<surd>" by(rule assms)
   thus "x \<in> outs_\<I> \<I>" by(simp)
 qed
 
+lemma WT_gpv_\<I>_mono: "\<lbrakk> \<I> \<turnstile>g gpv \<surd>; \<I> \<le> \<I>' \<rbrakk> \<Longrightarrow> \<I>' \<turnstile>g gpv \<surd>"
+  by(erule WT_gpv_mono; rule outs_\<I>_mono responses_\<I>_mono)
+
+lemma results_gpv_mono:
+  assumes le: "\<I>' \<le> \<I>" and WT: "\<I>' \<turnstile>g gpv \<surd>"
+  shows "results_gpv \<I> gpv \<subseteq> results_gpv \<I>' gpv"
+proof(rule subsetI, goal_cases)
+  case (1 x)
+  show ?case using 1 WT by(induction)(auto 4 3 intro: results_gpv.intros responses_\<I>_mono[OF le, THEN subsetD] intro: WT_gpvD)
+qed
+
+lemma WT_gpv_outs_gpv:
+  assumes "\<I> \<turnstile>g gpv \<surd>"
+  shows "outs_gpv \<I> gpv \<subseteq> outs_\<I> \<I>"
+proof
+  show "x \<in> outs_\<I> \<I>" if "x \<in> outs_gpv \<I> gpv" for x using that assms
+    by(induction)(blast intro: WT_gpv_OutD WT_gpv_ContD)+
+qed
+
+lemma WT_gpv_map_gpv': "\<I> \<turnstile>g map_gpv' f g h gpv \<surd>" if "map_\<I> g h \<I> \<turnstile>g gpv \<surd>"
+  using that by(coinduction arbitrary: gpv)(auto 4 4 dest: WT_gpvD)
+
+lemma WT_gpv_map_gpv: "\<I> \<turnstile>g map_gpv f g gpv \<surd>" if "map_\<I> g id \<I> \<turnstile>g gpv \<surd>"
+  unfolding map_gpv_conv_map_gpv' using that by(rule WT_gpv_map_gpv')
+
+lemma results_gpv_map_gpv' [simp]:
+  "results_gpv \<I> (map_gpv' f g h gpv) = f ` (results_gpv (map_\<I> g h \<I>) gpv)"
+proof(intro Set.set_eqI iffI; (elim imageE; hypsubst)?)
+  show "x \<in> f ` results_gpv (map_\<I> g h \<I>) gpv" if "x \<in> results_gpv \<I> (map_gpv' f g h gpv)" for x using that
+    by(induction gpv'\<equiv>"map_gpv' f g h gpv" arbitrary: gpv)(fastforce intro: results_gpv.intros rev_image_eqI)+
+  show "f x \<in> results_gpv \<I> (map_gpv' f g h gpv)" if "x \<in> results_gpv (map_\<I> g h \<I>) gpv" for x using that
+    by(induction)(fastforce intro: results_gpv.intros)+
+qed
+
+lemma WT_gpv_parametric': includes lifting_syntax shows
+  "bi_unique C \<Longrightarrow> (rel_\<I> C R ===> rel_gpv'' A C R ===> (=)) WT_gpv WT_gpv"
+proof(rule rel_funI iffI)+
+  note [transfer_rule] = the_gpv_parametric'
+  show *: "\<I> \<turnstile>g gpv \<surd>" if [transfer_rule]: "rel_\<I> C R \<I> \<I>'" "bi_unique C" 
+    and *: "\<I>' \<turnstile>g gpv' \<surd>" "rel_gpv'' A C R gpv gpv'" for \<I> \<I>' gpv gpv' A C R
+    using *
+  proof(coinduction arbitrary: gpv gpv')
+    case (WT_gpv out c gpv gpv')
+    note [transfer_rule] = WT_gpv(2)
+    have "rel_set (rel_generat A C (R ===> rel_gpv'' A C R)) (set_spmf (the_gpv gpv)) (set_spmf (the_gpv gpv'))" 
+      by transfer_prover
+    from rel_setD1[OF this WT_gpv(3)] obtain out' c'
+      where [transfer_rule]: "C out out'" "(R ===> rel_gpv'' A C R) c c'"
+        and out': "IO out' c' \<in> set_spmf (the_gpv gpv')"
+      by(auto elim: generat.rel_cases)
+    have "out \<in> outs_\<I> \<I> \<longleftrightarrow> out' \<in> outs_\<I> \<I>'" by transfer_prover
+    with WT_gpvD(1)[OF WT_gpv(1) out'] have ?out by simp
+    moreover have ?cont
+    proof(standard; goal_cases cont)
+      case (cont input)
+      have "rel_set R (responses_\<I> \<I> out) (responses_\<I> \<I>' out')" by transfer_prover
+      from rel_setD1[OF this cont] obtain input' where [transfer_rule]: "R input input'"
+        and input': "input' \<in> responses_\<I> \<I>' out'" by blast
+      have "rel_gpv'' A C R (c input) (c' input')" by transfer_prover
+      with WT_gpvD(2)[OF WT_gpv(1) out' input'] show ?case by auto
+    qed
+    ultimately show ?case ..
+  qed
+
+  show "\<I>' \<turnstile>g gpv' \<surd>" if "rel_\<I> C R \<I> \<I>'" "bi_unique C" "\<I> \<turnstile>g gpv \<surd>" "rel_gpv'' A C R gpv gpv'" 
+    for \<I> \<I>' gpv gpv'
+    using *[of "conversep C" "conversep R" \<I>' \<I> gpv "conversep A" gpv'] that
+    by(simp add: rel_gpv''_conversep)
+qed
+
+lemma WT_gpv_map_gpv_id [simp]: "\<I> \<turnstile>g map_gpv f id gpv \<surd> \<longleftrightarrow> \<I> \<turnstile>g gpv \<surd>"
+  using WT_gpv_parametric'[of "BNF_Def.Grp UNIV id" "(=)" "BNF_Def.Grp UNIV f", folded rel_gpv_conv_rel_gpv'']
+  unfolding gpv.rel_Grp unfolding eq_alt[symmetric] relator_eq
+  by(auto simp add: rel_fun_def Grp_def bi_unique_eq)
+
+lemma WT_gpv_outs_gpvI:
+  assumes "outs_gpv \<I> gpv \<subseteq> outs_\<I> \<I>"
+  shows "\<I> \<turnstile>g gpv \<surd>"
+  using assms by(coinduction arbitrary: gpv)(auto intro: outs_gpv.intros)
+
+lemma WT_gpv_iff_outs_gpv:
+  "\<I> \<turnstile>g gpv \<surd> \<longleftrightarrow> outs_gpv \<I> gpv \<subseteq> outs_\<I> \<I>"
+  by(blast intro: WT_gpv_outs_gpvI dest: WT_gpv_outs_gpv)
+
 subsection \<open>Sub-gpvs\<close>
 
 context begin
 qualified inductive sub_gpvsp :: "('out, 'in) \<I> \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> bool"
   for \<I> x
 where
   base:
   "\<lbrakk> IO out c \<in> set_spmf (the_gpv gpv); input \<in> responses_\<I> \<I> out; x = c input \<rbrakk> 
   \<Longrightarrow> sub_gpvsp \<I> x gpv"
 | cont: 
   "\<lbrakk> IO out c \<in> set_spmf (the_gpv gpv); input \<in> responses_\<I> \<I> out; sub_gpvsp \<I> x (c input) \<rbrakk>
   \<Longrightarrow> sub_gpvsp \<I> x gpv"
 
 qualified lemma sub_gpvsp_base:
   "\<lbrakk> IO out c \<in> set_spmf (the_gpv gpv); input \<in> responses_\<I> \<I> out \<rbrakk> 
   \<Longrightarrow> sub_gpvsp \<I> (c input) gpv"
 by(rule base) simp_all
 
 definition sub_gpvs :: "('out, 'in) \<I> \<Rightarrow>  ('a, 'out, 'in) gpv \<Rightarrow> ('a, 'out, 'in) gpv set"
 where "sub_gpvs \<I> gpv \<equiv> {x. sub_gpvsp \<I> x gpv}"
 
 lemma sub_gpvsp_sub_gpvs_eq [pred_set_conv]: "sub_gpvsp \<I> x gpv \<longleftrightarrow> x \<in> sub_gpvs \<I> gpv"
 by(simp add: sub_gpvs_def)
 
 context begin
 local_setup \<open>Local_Theory.map_background_naming (Name_Space.mandatory_path "sub_gpvs")\<close>
 
 lemmas intros [intro?] = sub_gpvsp.intros[to_set]
   and base = sub_gpvsp_base[to_set]
   and cont = cont[to_set]
   and induct [consumes 1, case_names Pure IO, induct set: sub_gpvs] = sub_gpvsp.induct[to_set]
   and cases [consumes 1, case_names Pure IO, cases set: sub_gpvs] = sub_gpvsp.cases[to_set]
   and simps = sub_gpvsp.simps[to_set]
 end
 end
 
 lemma WT_sub_gpvsD:
   assumes "\<I> \<turnstile>g gpv \<surd>" and "gpv' \<in> sub_gpvs \<I> gpv"
   shows "\<I> \<turnstile>g gpv' \<surd>"
 using assms(2,1) by(induction)(auto dest: WT_gpvD)
 
 lemma WT_sub_gpvsI:
   "\<lbrakk> \<And>out c. IO out c \<in> set_spmf (the_gpv gpv) \<Longrightarrow> out \<in> outs_\<I> \<Gamma>; 
      \<And>gpv'. gpv' \<in> sub_gpvs \<Gamma> gpv \<Longrightarrow> \<Gamma> \<turnstile>g gpv' \<surd> \<rbrakk>
   \<Longrightarrow> \<Gamma> \<turnstile>g gpv \<surd>"
 by(rule WT_gpvI)(auto intro: sub_gpvs.base)
 
 subsection \<open>Losslessness\<close>
 
 text \<open>A gpv is lossless iff we are guaranteed to get a result after a finite number of interactions
   that respect the interface. It is colossless if the interactions may go on for ever, but there is
   no non-termination.\<close>
 
 text \<open> We define both notions of losslessness simultaneously by mimicking what the (co)inductive
   package would do internally. Thus, we get a constant which is parametrised by the choice of the
   fixpoint, i.e., for non-recursive gpvs, we can state and prove both versions of losslessness
   in one go.\<close>
 
 context
   fixes co :: bool and \<I> :: "('out, 'in) \<I>"
   and F :: "(('a, 'out, 'in) gpv \<Rightarrow> bool) \<Rightarrow> (('a, 'out, 'in) gpv \<Rightarrow> bool)"
   and co' :: bool
   defines "F \<equiv> \<lambda>gen_lossless_gpv gpv. \<exists>pa. gpv = GPV pa \<and> 
      lossless_spmf pa \<and> (\<forall>out c input. IO out c \<in> set_spmf pa \<longrightarrow> input \<in> responses_\<I> \<I> out \<longrightarrow> gen_lossless_gpv (c input))"
   and "co' \<equiv> co" \<comment> \<open>We use a copy of @{term co} such that we can do case distinctions on @{term co'} without
     the simplifier rewriting the @{term co} in the local abbreviations for the constants.\<close>
 begin
 
 lemma gen_lossless_gpv_mono: "mono F"
 unfolding F_def
 apply(rule monoI le_funI le_boolI')+
 apply(tactic \<open>REPEAT (resolve_tac @{context} (Inductive.get_monos @{context}) 1)\<close>)
 apply(erule le_funE)
 apply(erule le_boolD)
 done
 
 definition gen_lossless_gpv :: "('a, 'out, 'in) gpv \<Rightarrow> bool"
 where "gen_lossless_gpv = (if co' then gfp else lfp) F"
 
 lemma gen_lossless_gpv_unfold: "gen_lossless_gpv = F gen_lossless_gpv"
 by(simp add: gen_lossless_gpv_def gfp_unfold[OF gen_lossless_gpv_mono, symmetric] lfp_unfold[OF gen_lossless_gpv_mono, symmetric])
 
 lemma gen_lossless_gpv_True: "co' = True \<Longrightarrow> gen_lossless_gpv \<equiv> gfp F"
   and gen_lossless_gpv_False: "co' = False \<Longrightarrow> gen_lossless_gpv \<equiv> lfp F"
 by(simp_all add: gen_lossless_gpv_def)
 
 lemma gen_lossless_gpv_cases [elim?, cases pred]:
   assumes "gen_lossless_gpv gpv"
   obtains (gen_lossless_gpv) p where "gpv = GPV p" "lossless_spmf p" 
     "\<And>out c input. \<lbrakk>IO out c \<in> set_spmf p; input \<in> responses_\<I> \<I> out\<rbrakk> \<Longrightarrow> gen_lossless_gpv (c input)"
 proof -
   from assms show ?thesis
     by(rewrite in asm gen_lossless_gpv_unfold)(auto simp add: F_def intro: that)
 qed
 
 lemma gen_lossless_gpvD:
   assumes "gen_lossless_gpv gpv"
   shows gen_lossless_gpv_lossless_spmfD: "lossless_spmf (the_gpv gpv)"
   and gen_lossless_gpv_continuationD:
   "\<lbrakk> IO out c \<in> set_spmf (the_gpv gpv); input \<in> responses_\<I> \<I> out \<rbrakk> \<Longrightarrow> gen_lossless_gpv (c input)"
 using assms by(auto elim: gen_lossless_gpv_cases)
 
 lemma gen_lossless_gpv_intros:
   "\<lbrakk> lossless_spmf p;
      \<And>out c input. \<lbrakk>IO out c \<in> set_spmf p; input \<in> responses_\<I> \<I> out \<rbrakk> \<Longrightarrow> gen_lossless_gpv (c input) \<rbrakk>
   \<Longrightarrow> gen_lossless_gpv (GPV p)"
 by(rewrite gen_lossless_gpv_unfold)(simp add: F_def)
 
 lemma gen_lossless_gpvI [intro?]:
   "\<lbrakk> lossless_spmf (the_gpv gpv);
      \<And>out c input. \<lbrakk> IO out c \<in> set_spmf (the_gpv gpv); input \<in> responses_\<I> \<I> out \<rbrakk>
      \<Longrightarrow> gen_lossless_gpv (c input) \<rbrakk>
   \<Longrightarrow> gen_lossless_gpv gpv"
 by(cases gpv)(auto intro: gen_lossless_gpv_intros)
 
 lemma gen_lossless_gpv_simps:
   "gen_lossless_gpv gpv \<longleftrightarrow>
    (\<exists>p. gpv = GPV p \<and> lossless_spmf p \<and> (\<forall>out c input.
         IO out c \<in> set_spmf p \<longrightarrow> input \<in> responses_\<I> \<I> out \<longrightarrow> gen_lossless_gpv (c input)))"
 by(rewrite gen_lossless_gpv_unfold)(simp add: F_def)
 
 lemma gen_lossless_gpv_Done [iff]: "gen_lossless_gpv (Done x)"
 by(rule gen_lossless_gpvI) auto
 
 lemma gen_lossless_gpv_Fail [iff]: "\<not> gen_lossless_gpv Fail"
 by(auto dest: gen_lossless_gpvD)
 
 lemma gen_lossless_gpv_Pause [simp]:
   "gen_lossless_gpv (Pause out c) \<longleftrightarrow> (\<forall>input \<in> responses_\<I> \<I> out. gen_lossless_gpv (c input))"
 by(auto dest: gen_lossless_gpvD intro: gen_lossless_gpvI)
 
 lemma gen_lossless_gpv_lift_spmf [iff]: "gen_lossless_gpv (lift_spmf p) \<longleftrightarrow> lossless_spmf p"
 by(auto dest: gen_lossless_gpvD intro: gen_lossless_gpvI)
 
 end
 
 lemma gen_lossless_gpv_assert_gpv [iff]: "gen_lossless_gpv co \<I> (assert_gpv b) \<longleftrightarrow> b"
 by(cases b) simp_all
 
 abbreviation lossless_gpv :: "('out, 'in) \<I> \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> bool"
 where "lossless_gpv \<equiv> gen_lossless_gpv False"
 
 abbreviation colossless_gpv :: "('out, 'in) \<I> \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> bool"
 where "colossless_gpv \<equiv> gen_lossless_gpv True"
 
 lemma lossless_gpv_induct [consumes 1, case_names lossless_gpv, induct pred]:
   assumes *: "lossless_gpv \<I> gpv"
   and step: "\<And>p. \<lbrakk> lossless_spmf p;
      \<And>out c input. \<lbrakk>IO out c \<in> set_spmf p; input \<in> responses_\<I> \<I> out\<rbrakk> \<Longrightarrow> lossless_gpv \<I> (c input);
      \<And>out c input. \<lbrakk>IO out c \<in> set_spmf p; input \<in> responses_\<I> \<I> out\<rbrakk> \<Longrightarrow> P (c input) \<rbrakk>
      \<Longrightarrow> P (GPV p)"
   shows "P gpv"
 proof -
   have "lossless_gpv \<I> \<le> P"
     by(rule def_lfp_induct[OF gen_lossless_gpv_False gen_lossless_gpv_mono])(auto intro!: le_funI step)
   then show ?thesis using * by auto
 qed
 
 lemma colossless_gpv_coinduct 
   [consumes 1, case_names colossless_gpv, case_conclusion colossless_gpv lossless_spmf continuation, coinduct pred]:
   assumes *: "X gpv"
   and step: "\<And>gpv. X gpv \<Longrightarrow> lossless_spmf (the_gpv gpv) \<and> (\<forall>out c input. 
        IO out c \<in> set_spmf (the_gpv gpv) \<longrightarrow> input \<in> responses_\<I> \<I> out \<longrightarrow> X (c input) \<or> colossless_gpv \<I> (c input))"
   shows "colossless_gpv \<I> gpv"
 proof -
   have "X \<le> colossless_gpv \<I>"
     by(rule def_coinduct[OF gen_lossless_gpv_True gen_lossless_gpv_mono])
       (auto 4 4 intro!: le_funI dest!: step intro: exI[where x="the_gpv _"])
   then show ?thesis using * by auto
 qed
 
 lemmas lossless_gpvI = gen_lossless_gpvI[where co=False]
   and lossless_gpvD = gen_lossless_gpvD[where co=False]
   and lossless_gpv_lossless_spmfD = gen_lossless_gpv_lossless_spmfD[where co=False]
   and lossless_gpv_continuationD = gen_lossless_gpv_continuationD[where co=False]
 
 lemmas colossless_gpvI = gen_lossless_gpvI[where co=True]
   and colossless_gpvD = gen_lossless_gpvD[where co=True]
   and colossless_gpv_lossless_spmfD = gen_lossless_gpv_lossless_spmfD[where co=True]
   and colossless_gpv_continuationD = gen_lossless_gpv_continuationD[where co=True]
 
 lemma gen_lossless_bind_gpvI:
   assumes "gen_lossless_gpv co \<I> gpv" "\<And>x. x \<in> results_gpv \<I> gpv \<Longrightarrow> gen_lossless_gpv co \<I> (f x)"
   shows "gen_lossless_gpv co \<I> (gpv \<bind> f)"
 proof(cases co)
   case False
   hence eq: "co = False" by simp
   show ?thesis using assms unfolding eq
   proof(induction)
     case (lossless_gpv p)
     { fix x
       assume "Pure x \<in> set_spmf p"
       hence "x \<in> results_gpv \<I> (GPV p)" by simp
       hence "lossless_gpv \<I> (f x)" by(rule lossless_gpv.prems) }
     with \<open>lossless_spmf p\<close> show ?case unfolding GPV_bind
       apply(intro gen_lossless_gpv_intros)
        apply(fastforce dest: lossless_gpvD split: generat.split)
       apply(clarsimp; split generat.split_asm)
       apply(auto dest: lossless_gpvD intro!: lossless_gpv)
       done
   qed
 next
   case True
   hence eq: "co = True" by simp
   show ?thesis using assms unfolding eq
   proof(coinduction arbitrary: gpv rule: colossless_gpv_coinduct)
     case * [rule_format]: (colossless_gpv gpv)
     from *(1) have ?lossless_spmf 
       by(auto 4 3 dest: colossless_gpv_lossless_spmfD elim!: is_PureE intro: *(2)[THEN colossless_gpv_lossless_spmfD] results_gpv.Pure)
     moreover have ?continuation
     proof(intro strip)
       fix out c input
       assume IO: "IO out c \<in> set_spmf (the_gpv (gpv \<bind> f))"
         and input: "input \<in> responses_\<I> \<I> out"
       from IO obtain generat where generat: "generat \<in> set_spmf (the_gpv gpv)"
         and IO: "IO out c \<in> set_spmf (if is_Pure generat then the_gpv (f (result generat))
                  else return_spmf (IO (output generat) (\<lambda>input. continuation generat input \<bind> f)))"
         by(auto)
       show "(\<exists>gpv. c input = gpv \<bind> f \<and> colossless_gpv \<I> gpv \<and> (\<forall>x. x \<in> results_gpv \<I> gpv \<longrightarrow> colossless_gpv \<I> (f x))) \<or>
         colossless_gpv \<I> (c input)"
       proof(cases generat)
         case (Pure x)
         hence "x \<in> results_gpv \<I> gpv" using generat by(auto intro: results_gpv.Pure)
         from *(2)[OF this] have "colossless_gpv \<I> (c input)"
           using IO Pure input by(auto intro: colossless_gpv_continuationD)
         thus ?thesis ..
       next
         case **: (IO out' c')
         with input generat IO have "colossless_gpv \<I> (f x)" if "x \<in> results_gpv \<I> (c' input)" for x
           using that by(auto intro: * results_gpv.IO)
         then show ?thesis using IO input ** *(1) generat by(auto dest: colossless_gpv_continuationD)
       qed
     qed
     ultimately show ?case ..
   qed
 qed
 
 lemmas lossless_bind_gpvI = gen_lossless_bind_gpvI[where co=False]
   and colossless_bind_gpvI = gen_lossless_bind_gpvI[where co=True]
 
 lemma gen_lossless_bind_gpvD1: 
   assumes "gen_lossless_gpv co \<I> (gpv \<bind> f)"
   shows "gen_lossless_gpv co \<I> gpv"
 proof(cases co)
   case False
   hence eq: "co = False" by simp
   show ?thesis using assms unfolding eq
   proof(induction gpv'\<equiv>"gpv \<bind> f" arbitrary: gpv)
     case (lossless_gpv p)
     obtain p' where gpv: "gpv = GPV p'" by(cases gpv)
     from lossless_gpv.hyps gpv have "lossless_spmf p'" by(simp add: GPV_bind)
     then show ?case unfolding gpv
     proof(rule gen_lossless_gpv_intros)
       fix out c input
       assume "IO out c \<in> set_spmf p'" "input \<in> responses_\<I> \<I> out"
       hence "IO out (\<lambda>input. c input \<bind> f) \<in> set_spmf p" using lossless_gpv.hyps gpv
         by(auto simp add: GPV_bind intro: rev_bexI)
       thus "lossless_gpv \<I> (c input)" using \<open>input \<in> _\<close> by(rule lossless_gpv.hyps) simp
     qed
   qed
 next
   case True
   hence eq: "co = True" by simp
   show ?thesis using assms unfolding eq
     by(coinduction arbitrary: gpv)(auto 4 3 intro: rev_bexI elim!: colossless_gpv_continuationD dest: colossless_gpv_lossless_spmfD)
 qed
 
 lemmas lossless_bind_gpvD1 = gen_lossless_bind_gpvD1[where co=False]
   and colossless_bind_gpvD1 = gen_lossless_bind_gpvD1[where co=True]
 
 lemma gen_lossless_bind_gpvD2:
   assumes "gen_lossless_gpv co \<I> (gpv \<bind> f)"
   and "x \<in> results_gpv \<I> gpv"
   shows "gen_lossless_gpv co \<I> (f x)"
 using assms(2,1)
 proof(induction)
   case (Pure gpv)
   thus ?case
     by -(rule gen_lossless_gpvI, auto 4 4 dest: gen_lossless_gpvD intro: rev_bexI)
 qed(auto 4 4 dest: gen_lossless_gpvD intro: rev_bexI)
 
 lemmas lossless_bind_gpvD2 = gen_lossless_bind_gpvD2[where co=False]
   and colossless_bind_gpvD2 = gen_lossless_bind_gpvD2[where co=True]
 
 lemma gen_lossless_bind_gpv [simp]:
   "gen_lossless_gpv co \<I> (gpv \<bind> f) \<longleftrightarrow> gen_lossless_gpv co \<I> gpv \<and> (\<forall>x\<in>results_gpv \<I> gpv. gen_lossless_gpv co \<I> (f x))"
 by(blast intro: gen_lossless_bind_gpvI dest: gen_lossless_bind_gpvD1 gen_lossless_bind_gpvD2)
 
 lemmas lossless_bind_gpv = gen_lossless_bind_gpv[where co=False]
   and colossless_bind_gpv = gen_lossless_bind_gpv[where co=True]
 
 context includes lifting_syntax begin
 
 lemma rel_gpv''_lossless_gpvD1:
   assumes rel: "rel_gpv'' A C R gpv gpv'"
   and gpv: "lossless_gpv \<I> gpv"
   and [transfer_rule]: "rel_\<I> C R \<I> \<I>'"
   shows "lossless_gpv \<I>' gpv'"
 using gpv rel
 proof(induction arbitrary: gpv')
   case (lossless_gpv p)
   from lossless_gpv.prems obtain q where q: "gpv' = GPV q"
     and [transfer_rule]: "rel_spmf (rel_generat A C (R ===> rel_gpv'' A C R)) p q"
     by(cases gpv') auto
   show ?case
   proof(rule lossless_gpvI)
     have "lossless_spmf p = lossless_spmf q" by transfer_prover
     with lossless_gpv.hyps(1) q show "lossless_spmf (the_gpv gpv')" by simp
 
     fix out' c' input'
     assume IO': "IO out' c' \<in> set_spmf (the_gpv gpv')"
       and input': "input' \<in> responses_\<I> \<I>' out'"
     have "rel_set (rel_generat A C (R ===> rel_gpv'' A C R)) (set_spmf p) (set_spmf q)"
       by transfer_prover
     with IO' q obtain out c where IO: "IO out c \<in> set_spmf p"
       and [transfer_rule]: "C out out'" "(R ===> rel_gpv'' A C R) c c'"
       by(auto dest!: rel_setD2 elim: generat.rel_cases)
     have "rel_set R (responses_\<I> \<I> out) (responses_\<I> \<I>' out')" by transfer_prover
     moreover
     from this[THEN rel_setD2, OF input'] obtain input
       where [transfer_rule]: "R input input'" and input: "input \<in> responses_\<I> \<I> out" by blast
     have "rel_gpv'' A C R (c input) (c' input')" by transfer_prover
     ultimately show "lossless_gpv \<I>' (c' input')" using input IO by(auto intro: lossless_gpv.IH)
   qed
 qed
 
 lemma rel_gpv''_lossless_gpvD2:
   "\<lbrakk> rel_gpv'' A C R gpv gpv'; lossless_gpv \<I>' gpv'; rel_\<I> C R \<I> \<I>' \<rbrakk>
   \<Longrightarrow> lossless_gpv \<I> gpv"
 using rel_gpv''_lossless_gpvD1[of "A\<inverse>\<inverse>" "C\<inverse>\<inverse>" "R\<inverse>\<inverse>" gpv' gpv \<I>' \<I>]
 by(simp add: rel_gpv''_conversep prod.rel_conversep rel_fun_eq_conversep)
 
 lemma rel_gpv_lossless_gpvD1:
   "\<lbrakk> rel_gpv A C gpv gpv'; lossless_gpv \<I> gpv; rel_\<I> C (=) \<I> \<I>' \<rbrakk> \<Longrightarrow> lossless_gpv \<I>' gpv'"
 using rel_gpv''_lossless_gpvD1[of A C "(=)" gpv gpv' \<I> \<I>'] by(simp add: rel_gpv_conv_rel_gpv'')
 
 lemma rel_gpv_lossless_gpvD2:
   "\<lbrakk> rel_gpv A C gpv gpv'; lossless_gpv \<I>' gpv'; rel_\<I> C (=) \<I> \<I>' \<rbrakk>
   \<Longrightarrow> lossless_gpv \<I> gpv"
 using rel_gpv_lossless_gpvD1[of "A\<inverse>\<inverse>" "C\<inverse>\<inverse>" gpv' gpv \<I>' \<I>]
 by(simp add: gpv.rel_conversep prod.rel_conversep rel_fun_eq_conversep)
 
 lemma rel_gpv''_colossless_gpvD1:
   assumes rel: "rel_gpv'' A C R gpv gpv'"
   and gpv: "colossless_gpv \<I> gpv"
   and [transfer_rule]: "rel_\<I> C R \<I> \<I>'"
   shows "colossless_gpv \<I>' gpv'"
 using gpv rel
 proof(coinduction arbitrary: gpv gpv')
   case (colossless_gpv gpv gpv')
   note [transfer_rule] = \<open>rel_gpv'' A C R gpv gpv'\<close> the_gpv_parametric'
     and co = \<open>colossless_gpv \<I> gpv\<close>
   have "lossless_spmf (the_gpv gpv) = lossless_spmf (the_gpv gpv')" by transfer_prover
   with co have "?lossless_spmf" by(auto dest: colossless_gpv_lossless_spmfD)
   moreover have "?continuation"
   proof(intro strip disjI1)
     fix out' c' input'
     assume IO': "IO out' c' \<in> set_spmf (the_gpv gpv')"
       and input': "input' \<in> responses_\<I> \<I>' out'"
     have "rel_set (rel_generat A C (R ===> rel_gpv'' A C R)) (set_spmf (the_gpv gpv)) (set_spmf (the_gpv gpv'))"
       by transfer_prover
     with IO' obtain out c where IO: "IO out c \<in> set_spmf (the_gpv gpv)"
       and [transfer_rule]: "C out out'" "(R ===> rel_gpv'' A C R) c c'"
       by(auto dest!: rel_setD2 elim: generat.rel_cases)
     have "rel_set R (responses_\<I> \<I> out) (responses_\<I> \<I>' out')" by transfer_prover
     moreover 
     from this[THEN rel_setD2, OF input'] obtain input
       where [transfer_rule]: "R input input'" and input: "input \<in> responses_\<I> \<I> out" by blast
     have "rel_gpv'' A C R (c input) (c' input')" by transfer_prover
     ultimately show "\<exists>gpv gpv'. c' input' = gpv' \<and> colossless_gpv \<I> gpv \<and> rel_gpv'' A C R gpv gpv'"
       using input IO co by(auto dest: colossless_gpv_continuationD)
   qed
   ultimately show ?case ..
 qed
 
 lemma rel_gpv''_colossless_gpvD2:
   "\<lbrakk> rel_gpv'' A C R gpv gpv'; colossless_gpv \<I>' gpv'; rel_\<I> C R \<I> \<I>' \<rbrakk>
   \<Longrightarrow> colossless_gpv \<I> gpv"
 using rel_gpv''_colossless_gpvD1[of "A\<inverse>\<inverse>" "C\<inverse>\<inverse>" "R\<inverse>\<inverse>" gpv' gpv \<I>' \<I>]
 by(simp add: rel_gpv''_conversep prod.rel_conversep rel_fun_eq_conversep)
 
 lemma rel_gpv_colossless_gpvD1:
   "\<lbrakk> rel_gpv A C gpv gpv'; colossless_gpv \<I> gpv; rel_\<I> C (=) \<I> \<I>' \<rbrakk> \<Longrightarrow> colossless_gpv \<I>' gpv'"
 using rel_gpv''_colossless_gpvD1[of A C "(=)" gpv gpv' \<I> \<I>'] by(simp add: rel_gpv_conv_rel_gpv'')
 
 lemma rel_gpv_colossless_gpvD2:
   "\<lbrakk> rel_gpv A C gpv gpv'; colossless_gpv \<I>' gpv'; rel_\<I> C (=) \<I> \<I>' \<rbrakk>
   \<Longrightarrow> colossless_gpv \<I> gpv"
 using rel_gpv_colossless_gpvD1[of "A\<inverse>\<inverse>" "C\<inverse>\<inverse>" gpv' gpv \<I>' \<I>]
 by(simp add: gpv.rel_conversep prod.rel_conversep rel_fun_eq_conversep)
 
 lemma gen_lossless_gpv_parametric':
   "((=) ===> rel_\<I> C R ===> rel_gpv'' A C R ===> (=))
    gen_lossless_gpv gen_lossless_gpv"
 proof(rule rel_funI; hypsubst)
   show "(rel_\<I> C R ===> rel_gpv'' A C R ===> (=)) (gen_lossless_gpv b) (gen_lossless_gpv b)" for b
     by(cases b)(auto intro!: rel_funI dest: rel_gpv''_colossless_gpvD1 rel_gpv''_colossless_gpvD2 rel_gpv''_lossless_gpvD1 rel_gpv''_lossless_gpvD2)
 qed
 
 lemma gen_lossless_gpv_parametric [transfer_rule]:
   "((=) ===> rel_\<I> C (=) ===> rel_gpv A C ===> (=))
    gen_lossless_gpv gen_lossless_gpv"
 proof(rule rel_funI; hypsubst)
   show "(rel_\<I> C (=) ===> rel_gpv A C ===> (=)) (gen_lossless_gpv b) (gen_lossless_gpv b)" for b
     by(cases b)(auto intro!: rel_funI dest: rel_gpv_colossless_gpvD1 rel_gpv_colossless_gpvD2 rel_gpv_lossless_gpvD1 rel_gpv_lossless_gpvD2)
 qed
 
 end
 
 lemma gen_lossless_gpv_map_full [simp]:
   "gen_lossless_gpv b \<I>_full (map_gpv f g gpv) = gen_lossless_gpv b \<I>_full gpv"
   (is "?lhs = ?rhs")
 proof(cases "b = True")
   case True
   show "?lhs = ?rhs"
   proof
     show ?rhs if ?lhs using that unfolding True
       by(coinduction arbitrary: gpv)(auto 4 3 dest: colossless_gpvD simp add: gpv.map_sel intro!: rev_image_eqI)
     show ?lhs if ?rhs using that unfolding True
       by(coinduction arbitrary: gpv)(auto 4 4 dest: colossless_gpvD simp add: gpv.map_sel intro!: rev_image_eqI)
   qed
 next
   case False
   hence False: "b = False" by simp
   show "?lhs = ?rhs"
   proof
     show ?rhs if ?lhs using that unfolding False
       apply(induction gpv'\<equiv>"map_gpv f g gpv" arbitrary: gpv)
       subgoal for p gpv by(cases gpv)(rule lossless_gpvI; fastforce intro: rev_image_eqI)
       done
     show ?lhs if ?rhs using that unfolding False
       by induction(auto 4 4 intro: lossless_gpvI)
   qed
 qed
 
 lemma gen_lossless_gpv_map_id [simp]:
   "gen_lossless_gpv b \<I> (map_gpv f id gpv) = gen_lossless_gpv b \<I> gpv"
   using gen_lossless_gpv_parametric[of "BNF_Def.Grp UNIV id" "BNF_Def.Grp UNIV f"] unfolding gpv.rel_Grp
   by(simp add: rel_fun_def eq_alt[symmetric] rel_\<I>_eq)(auto simp add: Grp_def)
 
 lemma results_gpv_try_gpv [simp]:
   "results_gpv \<I> (TRY gpv ELSE gpv') = 
    results_gpv \<I> gpv \<union> (if colossless_gpv \<I> gpv then {} else results_gpv \<I> gpv')"
   (is "?lhs = ?rhs")
 proof(intro set_eqI iffI)
   show "x \<in> ?rhs" if "x \<in> ?lhs" for x using that
   proof(induction gpv''\<equiv>"try_gpv gpv gpv'" arbitrary: gpv)
     case Pure thus ?case
       by(auto split: if_split_asm intro: results_gpv.Pure dest: colossless_gpv_lossless_spmfD)
   next
     case (IO out c input)
     then show ?case
       apply(auto dest: colossless_gpv_lossless_spmfD split: if_split_asm)
       apply(force intro: results_gpv.IO dest: colossless_gpv_continuationD split: if_split_asm)+
       done
   qed
 next
   fix x
   assume "x \<in> ?rhs"
   then consider (left) "x \<in> results_gpv \<I> gpv" | (right) "\<not> colossless_gpv \<I> gpv" "x \<in> results_gpv \<I> gpv'"
     by(auto split: if_split_asm)
   thus "x \<in> ?lhs"
   proof cases
     case left
     thus ?thesis 
       by(induction)(auto 4 4 intro: results_gpv.intros rev_image_eqI split del: if_split)
   next
     case right
     from right(1) show ?thesis
     proof(rule contrapos_np)
       assume "x \<notin> ?lhs"
       with right(2) show "colossless_gpv \<I> gpv"
       proof(coinduction arbitrary: gpv)
         case (colossless_gpv gpv)
         then have ?lossless_spmf
           apply(rewrite in asm try_gpv.code)
           apply(rule ccontr)
           apply(erule results_gpv.cases)
           apply(fastforce simp add: image_Un image_image generat.map_comp o_def)+
           done
         moreover have "?continuation" using colossless_gpv
           by(auto 4 4 split del: if_split simp add: image_Un image_image generat.map_comp o_def intro: rev_image_eqI results_gpv.IO)
         ultimately show ?case ..
       qed
     qed
   qed
 qed
 
 lemma results'_gpv_try_gpv [simp]:
   "results'_gpv (TRY gpv ELSE gpv') = 
    results'_gpv gpv \<union> (if colossless_gpv \<I>_full gpv then {} else results'_gpv gpv')"
 by(simp add: results_gpv_\<I>_full[symmetric])
 
 lemma outs'_gpv_try_gpv [simp]:
   "outs'_gpv (TRY gpv ELSE gpv') =
    outs'_gpv gpv \<union> (if colossless_gpv \<I>_full gpv then {} else outs'_gpv gpv')"
   (is "?lhs = ?rhs")
 proof(intro set_eqI iffI)
   show "x \<in> ?rhs" if "x \<in> ?lhs" for x using that
   proof(induction gpv''\<equiv>"try_gpv gpv gpv'" arbitrary: gpv)
     case Out thus ?case
       by(auto 4 3 simp add: generat.map_comp o_def elim!: generat.set_cases(2) intro: outs'_gpv_Out split: if_split_asm dest: colossless_gpv_lossless_spmfD)
   next
     case (Cont generat c input)
     then show ?case
       apply(auto dest: colossless_gpv_lossless_spmfD split: if_split_asm elim!: generat.set_cases(3))
       apply(auto 4 3 dest: colossless_gpv_continuationD split: if_split_asm intro: outs'_gpv_Cont elim!: meta_allE meta_impE[OF _ refl])+
       done
   qed
 next
   fix x
   assume "x \<in> ?rhs"
   then consider (left) "x \<in> outs'_gpv gpv" | (right) "\<not> colossless_gpv \<I>_full gpv" "x \<in> outs'_gpv gpv'"
     by(auto split: if_split_asm)
   thus "x \<in> ?lhs"
   proof cases
     case left
     thus ?thesis 
       by(induction)(auto elim!: generat.set_cases(2,3) intro: outs'_gpvI intro!: rev_image_eqI split del: if_split simp add: image_Un image_image generat.map_comp o_def)
   next
     case right
     from right(1) show ?thesis
     proof(rule contrapos_np)
       assume "x \<notin> ?lhs"
       with right(2) show "colossless_gpv \<I>_full gpv"
       proof(coinduction arbitrary: gpv)
         case (colossless_gpv gpv)
         then have ?lossless_spmf
           apply(rewrite in asm try_gpv.code)
           apply(erule contrapos_np)
           apply(erule gpv.set_cases)
           apply(auto 4 3 simp add: image_Un image_image generat.map_comp o_def generat.set_map in_set_spmf[symmetric] bind_UNION generat.map_id[unfolded id_def] elim!: generat.set_cases)
           done
         moreover have "?continuation" using colossless_gpv
           by(auto simp add: image_Un image_image generat.map_comp o_def split del: if_split intro!: rev_image_eqI intro: outs'_gpv_Cont)
         ultimately show ?case ..
       qed
     qed
   qed
 qed
 
 lemma pred_gpv_try [simp]:
   "pred_gpv P Q (try_gpv gpv gpv') = (pred_gpv P Q gpv \<and> (\<not> colossless_gpv \<I>_full gpv \<longrightarrow> pred_gpv P Q gpv'))"
 by(auto simp add: pred_gpv_def)
 
 lemma lossless_WT_gpv_induct [consumes 2, case_names lossless_gpv]:
   assumes lossless: "lossless_gpv \<I> gpv"
   and WT: "\<I> \<turnstile>g gpv \<surd>"
   and step: "\<And>p. \<lbrakk>
        lossless_spmf p;
        \<And>out c. IO out c \<in> set_spmf p \<Longrightarrow> out \<in> outs_\<I> \<I>;
        \<And>out c input. \<lbrakk>IO out c \<in> set_spmf p; out \<in> outs_\<I> \<I> \<Longrightarrow> input \<in> responses_\<I> \<I> out\<rbrakk> \<Longrightarrow> lossless_gpv \<I> (c input);
        \<And>out c input. \<lbrakk>IO out c \<in> set_spmf p; out \<in> outs_\<I> \<I> \<Longrightarrow> input \<in> responses_\<I> \<I> out\<rbrakk> \<Longrightarrow> \<I> \<turnstile>g c input \<surd>;
        \<And>out c input. \<lbrakk>IO out c \<in> set_spmf p; out \<in> outs_\<I> \<I> \<Longrightarrow> input \<in> responses_\<I> \<I> out\<rbrakk> \<Longrightarrow> P (c input)\<rbrakk>
       \<Longrightarrow> P (GPV p)"
   shows "P gpv"
 using lossless WT
 apply(induction)
 apply(erule step)
 apply(auto elim: WT_gpvD simp add: WT_gpv_simps)
 done
 
 lemma lossless_gpv_induct_strong [consumes 1, case_names lossless_gpv]:
   assumes gpv: "lossless_gpv \<I> gpv"
   and step:
   "\<And>p. \<lbrakk> lossless_spmf p;
           \<And>gpv. gpv \<in> sub_gpvs \<I> (GPV p) \<Longrightarrow> lossless_gpv \<I> gpv;
           \<And>gpv. gpv \<in> sub_gpvs \<I> (GPV p) \<Longrightarrow> P gpv \<rbrakk>
        \<Longrightarrow> P (GPV p)"
   shows "P gpv"
 proof -
   define gpv' where "gpv' = gpv"
   then have "gpv' \<in> insert gpv (sub_gpvs \<I> gpv)" by simp
   with gpv have "lossless_gpv \<I> gpv' \<and> P gpv'"
   proof(induction arbitrary: gpv')
     case (lossless_gpv p)
     from \<open>gpv' \<in> insert (GPV p) _\<close> show ?case
     proof(rule insertE)
       assume "gpv' = GPV p"
       moreover have "lossless_gpv \<I> (GPV p)"
         by(auto 4 3 intro: lossless_gpvI lossless_gpv.hyps)
       moreover have "P (GPV p)" using lossless_gpv.hyps(1)
         by(rule step)(fastforce elim: sub_gpvs.cases lossless_gpv.IH[THEN conjunct1] lossless_gpv.IH[THEN conjunct2])+
       ultimately show ?case by simp
     qed(fastforce elim: sub_gpvs.cases lossless_gpv.IH[THEN conjunct1] lossless_gpv.IH[THEN conjunct2])
   qed
   thus ?thesis by(simp add: gpv'_def)
 qed
 
 lemma lossless_sub_gpvsI:
   assumes spmf: "lossless_spmf (the_gpv gpv)"
   and sub: "\<And>gpv'. gpv' \<in> sub_gpvs \<I> gpv \<Longrightarrow> lossless_gpv \<I> gpv'"
   shows "lossless_gpv \<I> gpv"
 using spmf by(rule lossless_gpvI)(rule sub[OF sub_gpvs.base])
 
 lemma lossless_sub_gpvsD:
   assumes "lossless_gpv \<I> gpv" "gpv' \<in> sub_gpvs \<I> gpv"
   shows "lossless_gpv \<I> gpv'"
 using assms(2,1) by(induction)(auto dest: lossless_gpvD)
 
 lemma lossless_WT_gpv_induct_strong [consumes 2, case_names lossless_gpv]:
   assumes lossless: "lossless_gpv \<I> gpv"
   and WT: "\<I> \<turnstile>g gpv \<surd>"
   and step: "\<And>p. \<lbrakk> lossless_spmf p;
        \<And>out c. IO out c \<in> set_spmf p \<Longrightarrow> out \<in> outs_\<I> \<I>;
        \<And>gpv. gpv \<in> sub_gpvs \<I> (GPV p) \<Longrightarrow> lossless_gpv \<I> gpv;
        \<And>gpv. gpv \<in> sub_gpvs \<I> (GPV p) \<Longrightarrow> \<I> \<turnstile>g gpv \<surd>;
        \<And>gpv. gpv \<in> sub_gpvs \<I> (GPV p) \<Longrightarrow> P gpv \<rbrakk>
       \<Longrightarrow> P (GPV p)"
   shows "P gpv"
 using lossless WT
 apply(induction rule: lossless_gpv_induct_strong)
 apply(erule step)
 apply(auto elim: WT_gpvD dest: WT_sub_gpvsD)
 done
 
 lemma try_gpv_gen_lossless: \<comment> \<open>TODO: generalise to arbitrary typings ?\<close>
   "gen_lossless_gpv b \<I>_full gpv \<Longrightarrow> (TRY gpv ELSE gpv') = gpv"
 proof(coinduction arbitrary: gpv)
   case (Eq_gpv gpv)
   from Eq_gpv[THEN gen_lossless_gpv_lossless_spmfD]
   have eq: "the_gpv gpv = (TRY the_gpv gpv ELSE the_gpv gpv')" by(simp)
   show ?case
     by(subst eq)(auto simp add: spmf_rel_map generat.rel_map[abs_def] intro!: rel_spmf_try_spmf rel_spmf_reflI rel_generat_reflI elim!: generat.set_cases gen_lossless_gpv_continuationD[OF Eq_gpv] simp add: Eq_gpv[THEN gen_lossless_gpv_lossless_spmfD])
 qed
 
 \<comment> \<open>We instantiate the parameter @{term b} such that it can be used as a conditional simp rule.\<close>
 lemmas try_gpv_lossless [simp] = try_gpv_gen_lossless[where b=False]
   and try_gpv_colossless [simp] = try_gpv_gen_lossless[where b=True]
 
 lemma try_gpv_bind_gen_lossless: \<comment> \<open>TODO: generalise to arbitrary typings?\<close>
   "gen_lossless_gpv b \<I>_full gpv \<Longrightarrow> TRY bind_gpv gpv f ELSE gpv' = bind_gpv gpv (\<lambda>x. TRY f x ELSE gpv')"
 proof(coinduction arbitrary: gpv rule: gpv.coinduct_strong)
   case (Eq_gpv gpv)
   note [simp] = spmf_rel_map generat.rel_map map_spmf_bind_spmf
     and [intro!] = rel_spmf_reflI rel_generat_reflI rel_funI
   show ?case using gen_lossless_gpvD[OF Eq_gpv]
     by(auto 4 3 simp del: bind_gpv_sel' simp add: bind_gpv.sel try_spmf_bind_spmf_lossless split: generat.split intro!: rel_spmf_bind_reflI rel_spmf_try_spmf)
 qed
 
 \<comment> \<open>We instantiate the parameter @{term b} such that it can be used as a conditional simp rule.\<close>
 lemmas try_gpv_bind_lossless = try_gpv_bind_gen_lossless[where b=False]
   and try_gpv_bind_colossless = try_gpv_bind_gen_lossless[where b=True]
 
 lemma try_gpv_cong:
   "\<lbrakk> gpv = gpv''; \<not> colossless_gpv \<I>_full gpv'' \<Longrightarrow> gpv' = gpv''' \<rbrakk>
   \<Longrightarrow> try_gpv gpv gpv' = try_gpv gpv'' gpv'''"
 by(cases "colossless_gpv \<I>_full gpv''") simp_all
 
 (* lemma try_gpv_bind_colossless2:
   "colossless_gpv \<I>_full gpv' \<Longrightarrow> try_gpv (bind_gpv gpv f) gpv' = try_gpv (bind_gpv gpv (\<lambda>x. try_gpv (f x) gpv')) gpv'"
 apply(coinduction arbitrary: gpv rule: gpv.coinduct_strong)
 apply(simp add: spmf_rel_map bind_gpv_sel del: bind_gpv_sel')
 apply(rule rel_spmf_try_spmf)
  apply(simp add: spmf_rel_map)
  apply(rule rel_spmf_bind_reflI)
  apply(simp split: generat.split)
  apply(rule conjI; clarsimp)
  apply(simp add: spmf_rel_map generat.map_comp o_def generat.rel_map rel_fun_def)
  apply(subst map_try_spmf[symmetric])
  *)
 
+context fixes B :: "'b \<Rightarrow> 'c set" and x :: 'a begin
+
+primcorec mk_lossless_gpv :: "('a, 'b, 'c) gpv \<Rightarrow> ('a, 'b, 'c) gpv" where
+  "the_gpv (mk_lossless_gpv gpv) =
+   map_spmf (\<lambda>generat. case generat of Pure x \<Rightarrow> Pure x 
+      | IO out c \<Rightarrow> IO out (\<lambda>input. if input \<in> B out then mk_lossless_gpv (c input) else Done x))
+    (the_gpv gpv)"
+
+end
+
+lemma WT_gpv_mk_lossless_gpv:
+  assumes "\<I> \<turnstile>g gpv \<surd>"
+    and outs: "outs_\<I> \<I>' = outs_\<I> \<I>"
+  shows "\<I>' \<turnstile>g mk_lossless_gpv (responses_\<I> \<I>) x gpv \<surd>"
+  using assms(1)
+  by(coinduction arbitrary: gpv)(auto 4 3 split: generat.split_asm simp add: outs dest: WT_gpvD)
+
 subsection \<open>Sequencing with failure handling included\<close>
 
 definition catch_gpv :: "('a, 'out, 'in) gpv \<Rightarrow> ('a option, 'out, 'in) gpv"
 where "catch_gpv gpv = TRY map_gpv Some id gpv ELSE Done None"
 
 lemma catch_gpv_Done [simp]: "catch_gpv (Done x) = Done (Some x)"
 by(simp add: catch_gpv_def)
 
 lemma catch_gpv_Fail [simp]: "catch_gpv Fail = Done None"
 by(simp add: catch_gpv_def)
 
 lemma catch_gpv_Pause [simp]: "catch_gpv (Pause out rpv) = Pause out (\<lambda>input. catch_gpv (rpv input))"
 by(simp add: catch_gpv_def)
 
 lemma catch_gpv_lift_spmf [simp]: "catch_gpv (lift_spmf p) = lift_spmf (spmf_of_pmf p)"
 by(rule gpv.expand)(auto simp add: catch_gpv_def spmf_of_pmf_def map_lift_spmf try_spmf_def o_def map_pmf_def bind_assoc_pmf bind_return_pmf intro!: bind_pmf_cong[OF refl] split: option.split)
 
 lemma catch_gpv_assert [simp]: "catch_gpv (assert_gpv b) = Done (assert_option b)"
 by(cases b) simp_all
 
 lemma catch_gpv_sel [simp]:
   "the_gpv (catch_gpv gpv) = 
    TRY map_spmf (map_generat Some id (\<lambda>rpv input. catch_gpv (rpv input))) (the_gpv gpv)
    ELSE return_spmf (Pure None)"
 by(simp add: catch_gpv_def gpv.map_sel spmf.map_comp o_def generat.map_comp map_try_spmf id_def)
 
 lemma catch_gpv_bind_gpv: "catch_gpv (bind_gpv gpv f) = bind_gpv (catch_gpv gpv) (\<lambda>x. case x of None \<Rightarrow> Done None | Some x' \<Rightarrow> catch_gpv (f x'))"
   using [[show_variants]]
   apply(coinduction arbitrary: gpv rule: gpv.coinduct_strong)
   apply(clarsimp simp add: map_bind_pmf bind_gpv.sel spmf.map_comp o_def[abs_def] map_bind_spmf generat.map_comp simp del: bind_gpv_sel')
   apply(subst bind_spmf_def)
   apply(subst try_spmf_bind_pmf)
   apply(subst (2) try_spmf_def)
   apply(subst bind_spmf_pmf_assoc)
   apply(simp add: bind_map_pmf)
   apply(rule rel_pmf_bind_reflI)
   apply(auto split!: option.split generat.split simp add: spmf_rel_map spmf.map_comp o_def generat.map_comp id_def[symmetric] generat.map_id rel_spmf_reflI generat.rel_refl refl rel_fun_def)
   done
 
 context includes lifting_syntax begin
 lemma catch_gpv_parametric [transfer_rule]:
   "(rel_gpv A C ===> rel_gpv (rel_option A) C) catch_gpv catch_gpv"
 unfolding catch_gpv_def by transfer_prover
 
 lemma catch_gpv_parametric':
   notes [transfer_rule] = try_gpv_parametric' map_gpv_parametric' Done_parametric'
   shows "(rel_gpv'' A C R ===> rel_gpv'' (rel_option A) C R) catch_gpv catch_gpv"
 unfolding catch_gpv_def by transfer_prover
 end
 
 lemma catch_gpv_map': "catch_gpv (map_gpv' f g h gpv) = map_gpv' (map_option f) g h (catch_gpv gpv)"
 by(simp add: catch_gpv_def map'_try_gpv map_gpv_conv_map_gpv' map_gpv'_comp o_def)
 
 lemma catch_gpv_map: "catch_gpv (map_gpv f g gpv) = map_gpv (map_option f) g (catch_gpv gpv)"
   by(simp add: map_gpv_conv_map_gpv' catch_gpv_map')
 
 lemma colossless_gpv_catch_gpv [simp]: "colossless_gpv \<I>_full (catch_gpv gpv)"
 by(coinduction arbitrary: gpv) auto
 
 lemma colosless_gpv_catch_gpv_conv_map:
   "colossless_gpv \<I>_full gpv \<Longrightarrow> catch_gpv gpv = map_gpv Some id gpv"
   apply(coinduction arbitrary: gpv)
   apply(frule colossless_gpv_lossless_spmfD)
   apply(auto simp add: spmf_rel_map gpv.map_sel generat.rel_map intro!: rel_spmf_reflI generat.rel_refl_strong rel_funI elim!: colossless_gpv_continuationD generat.set_cases)
   done
 
 lemma catch_gpv_catch_gpv [simp]: "catch_gpv (catch_gpv gpv) = map_gpv Some id (catch_gpv gpv)"
   by(simp add: colosless_gpv_catch_gpv_conv_map)
 
 lemma case_map_resumption: (* Move to Resumption *)
   "case_resumption done pause (map_resumption f g r) = 
    case_resumption (done \<circ> map_option f) (\<lambda>out c. pause (g out) (map_resumption f g \<circ> c)) r" 
 by(cases r) simp_all
 
 lemma catch_gpv_lift_resumption [simp]: "catch_gpv (lift_resumption r) = lift_resumption (map_resumption Some id r)"
   apply(coinduction arbitrary: r)
   apply(auto simp add: lift_resumption.sel case_map_resumption split: resumption.split option.split)
   oops (* TODO: We'd need a catch_resumption for this *)
 
 lemma results_gpv_catch_gpv:
   "results_gpv \<I> (catch_gpv gpv) = Some ` results_gpv \<I> gpv \<union> (if colossless_gpv \<I> gpv then {} else {None})"
   by(simp add: catch_gpv_def)
 
 lemma Some_in_results_gpv_catch_gpv [simp]:
   "Some x \<in> results_gpv \<I> (catch_gpv gpv) \<longleftrightarrow> x \<in> results_gpv \<I> gpv"
   by(auto simp add: results_gpv_catch_gpv)
 
 lemma None_in_results_gpv_catch_gpv [simp]:
   "None \<in> results_gpv \<I> (catch_gpv gpv) \<longleftrightarrow> \<not> colossless_gpv \<I> gpv"
   by(auto simp add: results_gpv_catch_gpv)
 
 lemma results'_gpv_catch_gpv:
   "results'_gpv (catch_gpv gpv) = Some ` results'_gpv gpv \<union> (if colossless_gpv \<I>_full gpv then {} else {None})"
   by(simp add: results_gpv_\<I>_full[symmetric] results_gpv_catch_gpv)
 
 lemma Some_in_results'_gpv_catch_gpv [simp]:
   "Some x \<in> results'_gpv (catch_gpv gpv) \<longleftrightarrow> x \<in> results'_gpv gpv"
   by(simp add: results_gpv_\<I>_full[symmetric])
 
 lemma None_in_results'_gpv_catch_gpv [simp]:
   "None \<in> results'_gpv (catch_gpv gpv) \<longleftrightarrow> \<not> colossless_gpv \<I>_full gpv"
   by(simp add: results_gpv_\<I>_full[symmetric])
 
 lemma results'_gpv_catch_gpvE:
   assumes "x \<in> results'_gpv (catch_gpv gpv)"
   obtains (Some) x'
   where "x = Some x'" "x' \<in> results'_gpv gpv"
   | (colossless) "x = None" "\<not> colossless_gpv \<I>_full gpv"
   using assms by(auto simp add: results'_gpv_catch_gpv split: if_split_asm)
 
 lemma outs'_gpv_catch_gpv [simp]: "outs'_gpv (catch_gpv gpv) = outs'_gpv gpv"
   by(simp add: catch_gpv_def)
 
 lemma pred_gpv_catch_gpv [simp]: "pred_gpv (pred_option P) Q (catch_gpv gpv) = pred_gpv P Q gpv"
   by(simp add: pred_gpv_def results'_gpv_catch_gpv)
 
 abbreviation bind_gpv' :: "('a, 'call, 'ret) gpv \<Rightarrow> ('a option \<Rightarrow> ('b, 'call, 'ret) gpv) \<Rightarrow> ('b, 'call, 'ret) gpv"
 where "bind_gpv' gpv \<equiv> bind_gpv (catch_gpv gpv)"
 
 (* lemma bind_gpv'_sel [simp]:
   "the_gpv (bind_gpv' gpv f) =
    bind_pmf (the_gpv gpv) (\<lambda>x. case x of
      None \<Rightarrow> the_gpv (f None)
    | Some (Pure x) \<Rightarrow> the_gpv (f (Some x))
    | Some (IO out rpv) \<Rightarrow> return_spmf (IO out (\<lambda>input. bind_gpv' (rpv input) f)))"
 by(auto simp add: bind_gpv'_def bind_map_spmf try_spmf_def bind_spmf_pmf_assoc bind_map_pmf gpv.map_sel intro!: bind_pmf_cong[OF refl] split: option.split generat.split)
  *)
   
 lemma bind_gpv'_assoc [simp]: "bind_gpv' (bind_gpv' gpv f) g = bind_gpv' gpv (\<lambda>x. bind_gpv' (f x) g)"
 by(simp add: catch_gpv_bind_gpv bind_map_gpv o_def bind_gpv_assoc)
 
 lemma bind_gpv'_bind_gpv: "bind_gpv' (bind_gpv gpv f) g = bind_gpv' gpv (case_option (g None) (\<lambda>y. bind_gpv' (f y) g))"
   by(clarsimp simp add: catch_gpv_bind_gpv bind_gpv_assoc intro!: bind_gpv_cong[OF refl] split: option.split)
 
 lemma bind_gpv'_cong:
   "\<lbrakk> gpv = gpv'; \<And>x. x \<in> Some ` results'_gpv gpv' \<or> (\<not> colossless_gpv \<I>_full gpv \<and> x = None) \<Longrightarrow> f x = f' x \<rbrakk>
   \<Longrightarrow> bind_gpv' gpv f = bind_gpv' gpv' f'"
 by(auto elim: results'_gpv_catch_gpvE split: if_split_asm intro!: bind_gpv_cong[OF refl])
 
 lemma bind_gpv'_cong2:
   "\<lbrakk> gpv = gpv'; \<And>x. x \<in> results'_gpv gpv' \<Longrightarrow> f (Some x) = f' (Some x); \<not> colossless_gpv \<I>_full gpv \<Longrightarrow> f None = f' None \<rbrakk>
   \<Longrightarrow> bind_gpv' gpv f = bind_gpv' gpv' f'"
 by(rule bind_gpv'_cong) auto
 
 subsection \<open>Inlining\<close>
 
 lemma gpv_coinduct_bind [consumes 1, case_names Eq_gpv]:
   fixes gpv gpv' :: "('a, 'call, 'ret) gpv"
   assumes *: "R gpv gpv'"
   and step: "\<And>gpv gpv'. R gpv gpv' 
     \<Longrightarrow> rel_spmf (rel_generat (=) (=) (rel_fun (=) (\<lambda>gpv gpv'. R gpv gpv' \<or> gpv = gpv' \<or> 
       (\<exists>gpv2 :: ('b, 'call, 'ret) gpv. \<exists>gpv2' :: ('c, 'call, 'ret) gpv. \<exists>f f'. gpv = bind_gpv gpv2 f \<and> gpv' = bind_gpv gpv2' f' \<and> 
         rel_gpv (\<lambda>x y. R (f x) (f' y)) (=) gpv2 gpv2'))))
       (the_gpv gpv) (the_gpv gpv')"
   shows "gpv = gpv'"
 proof -
   fix x y
   define gpv1 :: "('b, 'call, 'ret) gpv"
     and f :: "'b \<Rightarrow> ('a, 'call, 'ret) gpv"
     and gpv1' :: "('c, 'call, 'ret) gpv"
     and f' :: "'c \<Rightarrow> ('a, 'call, 'ret) gpv"
     where "gpv1 = Done x"
       and "f = (\<lambda>_. gpv)"
       and "gpv1' = Done y"
       and "f' = (\<lambda>_. gpv')"
   from * have "rel_gpv (\<lambda>x y. R (f x) (f' y)) (=) gpv1 gpv1'"
     by(simp add: gpv1_def gpv1'_def f_def f'_def)
   then have "gpv1 \<bind> f = gpv1' \<bind> f'"
   proof(coinduction arbitrary: gpv1 gpv1' f f' rule: gpv.coinduct_strong)
     case (Eq_gpv gpv1 gpv1' f f')
     from Eq_gpv[simplified gpv.rel_sel] show ?case unfolding bind_gpv.sel spmf_rel_map
       apply(rule rel_spmf_bindI)
       subgoal for generat generat'
         apply(cases generat generat' rule: generat.exhaust[case_product generat.exhaust]; clarsimp simp add: o_def spmf_rel_map generat.rel_map)
         subgoal premises Pure for x y
           using step[OF \<open>R (f x) (f' y)\<close>] apply -
           apply(assumption | rule rel_spmf_mono rel_generat_mono rel_fun_mono refl)+
           apply(fastforce intro: exI[where x="Done _"])+
           done
         subgoal by(fastforce simp add: rel_fun_def)
         done
       done
   qed
   thus ?thesis by(simp add: gpv1_def gpv1'_def f_def f'_def)
 qed
 
 text \<open>
   Inlining one gpv into another. This may throw out arbitrarily many
   interactions between the two gpvs if the inlined one does not call its callee.
   So we define it as the coiteration of a least-fixpoint search operator.
 \<close>
 
 context
   fixes callee :: "'s \<Rightarrow> 'call \<Rightarrow> ('ret \<times> 's, 'call', 'ret') gpv"
   notes [[function_internals]]
 begin
 
 partial_function (spmf) inline1
   :: "('a, 'call, 'ret) gpv \<Rightarrow> 's
   \<Rightarrow> ('a \<times> 's + 'call' \<times> ('ret \<times> 's, 'call', 'ret') rpv \<times> ('a, 'call, 'ret) rpv) spmf"
 where
   "inline1 gpv s =
    the_gpv gpv \<bind>
    case_generat (\<lambda>x. return_spmf (Inl (x, s)))
      (\<lambda>out rpv. the_gpv (callee s out) \<bind>
          case_generat (\<lambda>(x, y). inline1 (rpv x) y)
           (\<lambda>out rpv'. return_spmf (Inr (out, rpv', rpv))))"
 
 lemma inline1_unfold:
   "inline1 gpv s =
    the_gpv gpv \<bind>
    case_generat (\<lambda>x. return_spmf (Inl (x, s)))
      (\<lambda>out rpv. the_gpv (callee s out) \<bind>
          case_generat (\<lambda>(x, y). inline1 (rpv x) y)
           (\<lambda>out rpv'. return_spmf (Inr (out, rpv', rpv))))"
 by(fact inline1.simps)
 
 lemma inline1_fixp_induct [case_names adm bottom step]:
   assumes "ccpo.admissible (fun_lub lub_spmf) (fun_ord (ord_spmf (=))) (\<lambda>inline1'. P (\<lambda>gpv s. inline1' (gpv, s)))"
   and "P (\<lambda>_ _. return_pmf None)"
   and "\<And>inline1'. P inline1' \<Longrightarrow> P (\<lambda>gpv s. the_gpv gpv \<bind> case_generat (\<lambda>x. return_spmf (Inl (x, s))) (\<lambda>out rpv. the_gpv (callee s out) \<bind> case_generat (\<lambda>(x, y). inline1' (rpv x) y) (\<lambda>out rpv'. return_spmf (Inr (out, rpv', rpv)))))"
   shows "P inline1"
 using assms by(rule inline1.fixp_induct[unfolded curry_conv[abs_def]])
 
 lemma inline1_fixp_induct_strong [case_names adm bottom step]:
   assumes "ccpo.admissible (fun_lub lub_spmf) (fun_ord (ord_spmf (=))) (\<lambda>inline1'. P (\<lambda>gpv s. inline1' (gpv, s)))"
   and "P (\<lambda>_ _. return_pmf None)"
   and "\<And>inline1'. \<lbrakk> \<And>gpv s. ord_spmf (=) (inline1' gpv s) (inline1 gpv s); P inline1' \<rbrakk>
     \<Longrightarrow> P (\<lambda>gpv s. the_gpv gpv \<bind> case_generat (\<lambda>x. return_spmf (Inl (x, s))) (\<lambda>out rpv. the_gpv (callee s out) \<bind> case_generat (\<lambda>(x, y). inline1' (rpv x) y) (\<lambda>out rpv'. return_spmf (Inr (out, rpv', rpv)))))"
   shows "P inline1"
 using assms by(rule spmf.fixp_strong_induct_uc[where P="\<lambda>f. P (curry f)" and U=case_prod and C=curry, OF inline1.mono inline1_def, simplified curry_case_prod, simplified curry_conv[abs_def] fun_ord_def split_paired_All prod.case case_prod_eta, OF refl]) blast+
 
 lemma inline1_fixp_induct_strong2 [case_names adm bottom step]:
   assumes "ccpo.admissible (fun_lub lub_spmf) (fun_ord (ord_spmf (=))) (\<lambda>inline1'. P (\<lambda>gpv s. inline1' (gpv, s)))"
   and "P (\<lambda>_ _. return_pmf None)"
   and "\<And>inline1'. 
     \<lbrakk> \<And>gpv s. ord_spmf (=) (inline1' gpv s) (inline1 gpv s); 
       \<And>gpv s. ord_spmf (=) (inline1' gpv s) (the_gpv gpv \<bind> case_generat (\<lambda>x. return_spmf (Inl (x, s))) (\<lambda>out rpv. the_gpv (callee s out) \<bind> case_generat (\<lambda>(x, y). inline1' (rpv x) y) (\<lambda>out rpv'. return_spmf (Inr (out, rpv', rpv)))));
       P inline1' \<rbrakk>
     \<Longrightarrow> P (\<lambda>gpv s. the_gpv gpv \<bind> case_generat (\<lambda>x. return_spmf (Inl (x, s))) (\<lambda>out rpv. the_gpv (callee s out) \<bind> case_generat (\<lambda>(x, y). inline1' (rpv x) y) (\<lambda>out rpv'. return_spmf (Inr (out, rpv', rpv)))))"
   shows "P inline1"
 using assms
 by(rule spmf.fixp_induct_strong2_uc[where P="\<lambda>f. P (curry f)" and U=case_prod and C=curry, OF inline1.mono inline1_def, simplified curry_case_prod, simplified curry_conv[abs_def] fun_ord_def split_paired_All prod.case case_prod_eta, OF refl]) blast+
 
 text \<open>
   Iterate @{const inline1} over all interactions. We'd like to use @{const bind_gpv} before
   the recursive call, but primcorec does not support this. So we emulate @{const bind_gpv}
   by effectively defining two mutually recursive functions (sum type in the argument)
   where the second is exactly @{const bind_gpv} specialised to call \<open>inline\<close> in the bind.
 \<close>
 
 primcorec inline_aux
   :: "('a, 'call, 'ret) gpv \<times> 's + ('ret \<Rightarrow> ('a, 'call, 'ret) gpv) \<times> ('ret \<times> 's, 'call', 'ret') gpv
   \<Rightarrow> ('a \<times> 's, 'call', 'ret') gpv"
 where
   "\<And>state. the_gpv (inline_aux state) =
   (case state of Inl (c, s) \<Rightarrow> map_spmf (\<lambda>result. 
      case result of Inl (x, s) \<Rightarrow> Pure (x, s)
      | Inr (out, oracle, rpv) \<Rightarrow> IO out (\<lambda>input. inline_aux (Inr (rpv, oracle input)))) (inline1 c s)
   | Inr (rpv, c) \<Rightarrow>  
     map_spmf (\<lambda>result. 
        case result of Inl (Inl (x, s)) \<Rightarrow> Pure (x, s)
        | Inl (Inr (out, oracle, rpv)) \<Rightarrow> IO out (\<lambda>input. inline_aux (Inr (rpv, oracle input)))
        | Inr (out, c) \<Rightarrow> IO out (\<lambda>input. inline_aux (Inr (rpv, c input))))
   (bind_spmf (the_gpv c) (\<lambda>generat. case generat of Pure (x, s') \<Rightarrow> (map_spmf Inl (inline1 (rpv x) s'))
      | IO out c \<Rightarrow> return_spmf (Inr (out, c)))
      ))"
 
 declare inline_aux.simps[simp del]
 
 definition inline :: "('a, 'call, 'ret) gpv \<Rightarrow> 's \<Rightarrow> ('a \<times> 's, 'call', 'ret') gpv"
 where "inline c s = inline_aux (Inl (c, s))"
 
 lemma inline_aux_Inr:
   "inline_aux (Inr (rpv, oracl)) = bind_gpv oracl (\<lambda>(x, s). inline (rpv x) s)"
 unfolding inline_def
 apply(coinduction arbitrary: oracl rule: gpv.coinduct_strong)
 apply(simp add: inline_aux.sel bind_gpv.sel spmf_rel_map del: bind_gpv_sel')
 apply(rule rel_spmf_bindI[where R="(=)"])
 apply(auto simp add: spmf_rel_map inline_aux.sel rel_spmf_reflI generat.rel_map generat.rel_refl rel_fun_def split: generat.split)
 done
 
 lemma inline_sel:
   "the_gpv (inline c s) = 
    map_spmf (\<lambda>result. case result of Inl xs \<Rightarrow> Pure xs
                        | Inr (out, oracle, rpv) \<Rightarrow> IO out (\<lambda>input. bind_gpv (oracle input) (\<lambda>(x, s'). inline (rpv x) s'))) (inline1 c s)"
 by(simp add: inline_def inline_aux.sel inline_aux_Inr cong del: sum.case_cong)
 
 lemma inline1_Fail [simp]: "inline1 Fail s = return_pmf None"
 by(rewrite inline1.simps) simp
 
 lemma inline_Fail [simp]: "inline Fail s = Fail"
 by(rule gpv.expand)(simp add: inline_sel)
 
 lemma inline1_Done [simp]: "inline1 (Done x) s = return_spmf (Inl (x, s))"
 by(rewrite inline1.simps) simp
 
 lemma inline_Done [simp]: "inline (Done x) s = Done (x, s)"
 by(rule gpv.expand)(simp add: inline_sel)
 
 lemma inline1_lift_spmf [simp]: "inline1 (lift_spmf p) s = map_spmf (\<lambda>x. Inl (x, s)) p"
 by(rewrite inline1.simps)(simp add: bind_map_spmf o_def map_spmf_conv_bind_spmf)
 
 lemma inline_lift_spmf [simp]: "inline (lift_spmf p) s = lift_spmf (map_spmf (\<lambda>x. (x, s)) p)"
 by(rule gpv.expand)(simp add: inline_sel spmf.map_comp o_def)
 
 lemma inline1_Pause:
   "inline1 (Pause out c) s = 
   the_gpv (callee s out) \<bind> (\<lambda>react. case react of Pure (x, s') \<Rightarrow> inline1 (c x) s' | IO out' c' \<Rightarrow> return_spmf (Inr (out', c', c)))"
 by(rewrite inline1.simps) simp
 
 lemma inline_Pause [simp]:
   "inline (Pause out c) s = callee s out \<bind> (\<lambda>(x, s'). inline (c x) s')"
 by(rule gpv.expand)(auto simp add: inline_sel inline1_Pause map_spmf_bind_spmf bind_gpv.sel o_def[abs_def] spmf.map_comp generat.map_comp id_def generat.map_id[unfolded id_def] simp del: bind_gpv_sel' intro!: bind_spmf_cong[OF refl] split: generat.split)
 
 lemma inline1_bind_gpv:
   fixes gpv f s
   defines [simp]: "inline11 \<equiv> inline1" and [simp]: "inline12 \<equiv> inline1" and [simp]: "inline13 \<equiv> inline1"
   shows "inline11 (bind_gpv gpv f) s = bind_spmf (inline12 gpv s) 
     (\<lambda>res. case res of Inl (x, s') \<Rightarrow> inline13 (f x) s' | Inr (out, rpv', rpv) \<Rightarrow> return_spmf (Inr (out, rpv', bind_rpv rpv f)))"
   (is "?lhs = ?rhs")
 proof(rule spmf.leq_antisym)
   note [intro!] = ord_spmf_bind_reflI and [split] = generat.split
   show "ord_spmf (=) ?lhs ?rhs" unfolding inline11_def
   proof(induction arbitrary: gpv s f rule: inline1_fixp_induct)
     case adm show ?case by simp
     case bottom show ?case by simp
     case (step inline1')
     show ?case unfolding inline12_def
       apply(rewrite inline1.simps; clarsimp simp add: bind_rpv_def)
       apply(rule conjI; clarsimp)
       subgoal premises Pure for x
         apply(rewrite inline1.simps; clarsimp)
         subgoal for out c ret s' using step.IH[of "Done x" "\<lambda>_. c ret" s'] by simp
         done
       subgoal for out c ret s' using step.IH[of "c ret" f s'] by(simp cong del: sum.case_cong_weak)
       done
   qed
   show "ord_spmf (=) ?rhs ?lhs" unfolding inline12_def
   proof(induction arbitrary: gpv s rule: inline1_fixp_induct)
     case adm show ?case by simp
     case bottom show ?case by simp
     case (step inline1')
     show ?case unfolding inline11_def
       apply(rewrite inline1.simps; clarsimp simp add: bind_rpv_def)
       apply(rule conjI; clarsimp)
       subgoal by(rewrite inline1.simps; simp)
       subgoal for out c ret s' using step.IH[of "c ret" s'] by(simp cong del: sum.case_cong_weak)
       done
   qed
 qed
 
 lemma inline_bind_gpv [simp]:
   "inline (bind_gpv gpv f) s = bind_gpv (inline gpv s) (\<lambda>(x, s'). inline (f x) s')"
 apply(coinduction arbitrary: gpv s rule: gpv_coinduct_bind)
 apply(clarsimp simp add: map_spmf_bind_spmf o_def[abs_def] bind_gpv.sel inline_sel bind_map_spmf inline1_bind_gpv simp del: bind_gpv_sel' intro!: rel_spmf_bind_reflI split: generat.split)
 apply(rule conjI)
  subgoal by(auto split: sum.split_asm simp add: spmf_rel_map spmf.map_comp o_def generat.map_comp generat.map_id[unfolded id_def] spmf.map_id[unfolded id_def] inline_sel intro!: rel_spmf_reflI generat.rel_refl fun.rel_refl)
 by(auto split: sum.split_asm simp add: bind_gpv_assoc split_def intro!: gpv.rel_refl exI disjI2 rel_funI)
 
 end
 
 lemma set_inline1_lift_spmf1: "set_spmf (inline1 (\<lambda>s x. lift_spmf (p s x)) gpv s) \<subseteq> range Inl"
 apply(induction arbitrary: gpv s rule: inline1_fixp_induct)
 subgoal by(rule cont_intro ccpo_class.admissible_leI)+
 apply(auto simp add: o_def bind_UNION split: generat.split_asm)+
 done
 
 lemma in_set_inline1_lift_spmf1: "y \<in> set_spmf (inline1 (\<lambda>s x. lift_spmf (p s x)) gpv s) \<Longrightarrow> \<exists>r s'. y = Inl (r, s')"
 by(drule set_inline1_lift_spmf1[THEN subsetD]) auto
 
 lemma inline_lift_spmf1:
   fixes p defines "callee \<equiv> \<lambda>s c. lift_spmf (p s c)"
   shows "inline callee gpv s = lift_spmf (map_spmf projl (inline1 callee gpv s))"
 by(rule gpv.expand)(auto simp add: inline_sel spmf.map_comp callee_def intro!: map_spmf_cong[OF refl] dest: in_set_inline1_lift_spmf1)
 
 context includes lifting_syntax begin
 lemma inline1_parametric':
   "((S ===> C ===> rel_gpv'' (rel_prod R S) C' R') ===> rel_gpv'' A C R ===> S
    ===> rel_spmf (rel_sum (rel_prod A S) (rel_prod C' (rel_prod (R' ===> rel_gpv'' (rel_prod R S) C' R') (R ===> rel_gpv'' A C R)))))
   inline1 inline1"
   (is "(_ ===> ?R) _ _")
 proof(rule rel_funI)
   note [transfer_rule] = the_gpv_parametric'
   show "?R (inline1 callee) (inline1 callee')" 
     if [transfer_rule]: "(S ===> C ===> rel_gpv'' (rel_prod R S) C' R') callee callee'"
     for callee callee'
     unfolding inline1_def
     by(unfold rel_fun_curry case_prod_curry)(rule fixp_spmf_parametric[OF inline1.mono inline1.mono]; transfer_prover)
 qed
 
 lemma inline1_parametric [transfer_rule]:
   "((S ===> C ===> rel_gpv (rel_prod (=) S) C') ===> rel_gpv A C ===> S
    ===> rel_spmf (rel_sum (rel_prod A S) (rel_prod C' (rel_prod (rel_rpv (rel_prod (=) S) C') (rel_rpv A C)))))
   inline1 inline1"
 unfolding rel_gpv_conv_rel_gpv'' by(rule inline1_parametric')
 
 lemma inline_parametric':
   notes [transfer_rule] = inline1_parametric' the_gpv_parametric' corec_gpv_parametric'
   shows "((S ===> C ===> rel_gpv'' (rel_prod R S) C' R') ===> rel_gpv'' A C R ===> S ===> rel_gpv'' (rel_prod A S) C' R')
   inline inline"
 unfolding inline_def[abs_def] inline_aux_def
 (* apply transfer_prover raises loose bound variable *)
 apply(rule rel_funI)+
 subgoal premises [transfer_rule] by transfer_prover
 done
 
 lemma inline_parametric [transfer_rule]:
   "((S ===> C ===> rel_gpv (rel_prod (=) S) C') ===> rel_gpv A C ===> S ===> rel_gpv (rel_prod A S) C')
   inline inline"
 unfolding rel_gpv_conv_rel_gpv'' by(rule inline_parametric')
 end
 
 
 text \<open>Associativity rule for @{const inline}\<close>
 
 context
   fixes callee1 :: "'s1 \<Rightarrow> 'c1 \<Rightarrow> ('r1 \<times> 's1, 'c, 'r) gpv"
   and callee2 :: "'s2 \<Rightarrow> 'c2 \<Rightarrow> ('r2 \<times> 's2, 'c1, 'r1) gpv"
 begin
 
 partial_function (spmf) inline2 :: "('a, 'c2, 'r2) gpv \<Rightarrow> 's2 \<Rightarrow> 's1
   \<Rightarrow> ('a \<times> ('s2 \<times> 's1) + 'c \<times> ('r1 \<times> 's1, 'c, 'r) rpv \<times> ('r2 \<times> 's2, 'c1, 'r1) rpv \<times> ('a, 'c2, 'r2) rpv) spmf"
 where
   "inline2 gpv s2 s1 =
   bind_spmf (the_gpv gpv)
    (case_generat (\<lambda>x. return_spmf (Inl (x, s2, s1)))
      (\<lambda>out rpv. bind_spmf (inline1 callee1 (callee2 s2 out) s1)
        (case_sum (\<lambda>((r2, s2), s1). inline2 (rpv r2) s2 s1)
          (\<lambda>(x, rpv'', rpv'). return_spmf (Inr (x, rpv'', rpv', rpv))))))"
 
 lemma inline2_fixp_induct [case_names adm bottom step]:
   assumes "ccpo.admissible (fun_lub lub_spmf) (fun_ord (ord_spmf (=))) (\<lambda>inline2. P (\<lambda>gpv s2 s1. inline2 ((gpv, s2), s1)))"
   and "P (\<lambda>_ _ _. return_pmf None)"
   and "\<And>inline2'. P inline2' \<Longrightarrow>
        P (\<lambda>gpv s2 s1. bind_spmf (the_gpv gpv) (\<lambda>generat. case generat of
            Pure x \<Rightarrow> return_spmf (Inl (x, s2, s1))
          | IO out rpv \<Rightarrow> bind_spmf (inline1 callee1 (callee2 s2 out) s1) (\<lambda>lr. case lr of
               Inl ((r2, s2), c) \<Rightarrow> inline2' (rpv r2) s2 c
            | Inr (x, rpv'', rpv') \<Rightarrow> return_spmf (Inr (x, rpv'', rpv', rpv)))))"
   shows "P inline2"
 using assms unfolding split_def by(rule inline2.fixp_induct[unfolded curry_conv[abs_def] split_def])
 
 lemma inline1_inline_conv_inline2:
   fixes gpv' :: "('r2 \<times> 's2, 'c1, 'r1) gpv"
   shows "inline1 callee1 (inline callee2 gpv s2) s1 = 
   map_spmf (map_sum (\<lambda>(x, (s2, s1)). ((x, s2), s1))
     (\<lambda>(x, rpv'', rpv', rpv). (x, rpv'', \<lambda>r1. rpv' r1 \<bind> (\<lambda>(r2, s2). inline callee2 (rpv r2) s2))))
   (inline2 gpv s2 s1)"
   (is "?lhs = ?rhs")
 proof(rule spmf.leq_antisym)
   define inline1_1 :: "('s1 \<Rightarrow> 'c1 \<Rightarrow> ('r1 \<times> 's1, 'c, 'r) gpv) \<Rightarrow> ('r2 \<times> 's2, 'c1, 'r1) gpv \<Rightarrow> 's1 \<Rightarrow> _"
     where "inline1_1 = inline1"
   have "ord_spmf (=) ?lhs ?rhs"
     \<comment> \<open>We need in the inductive step that the approximation behaves well with @{const bind_gpv}
          because of @{thm [source] inline_aux_Inr}. So we have to thread it through the induction
          and do one half of the proof from @{thm [source] inline1_bind_gpv} again. We cannot inline
          @{thm [source] inline1_bind_gpv} in this proof here because the types are too specific.\<close>
     and "ord_spmf (=) (inline1 callee1 (gpv' \<bind> f) s1') 
       (do {
       res \<leftarrow> inline1_1 callee1 gpv' s1';
       case res of Inl (x, s') \<Rightarrow> inline1 callee1 (f x) s'
       | Inr (out, rpv', rpv) \<Rightarrow> return_spmf (Inr (out, rpv', rpv \<bind> f))
     })" for gpv' and f :: "_ \<Rightarrow> ('a \<times> 's2, 'c1, 'r1) gpv" and s1'
   proof(induction arbitrary: gpv s2 s1 gpv' f s1' rule: inline1_fixp_induct_strong2)
     case adm thus ?case
       apply(rule cont_intro)+
       subgoal for a b c d by(cases d; clarsimp)
       done
 
     case (step inline1')
     note step_IH = step.IH[unfolded inline1_1_def] and step_hyps = step.hyps[unfolded inline1_1_def]
     { case 1
       have inline1: "ord_spmf (=)
          (inline1 callee2 gpv s2 \<bind> (\<lambda>lr. case lr of Inl as2 \<Rightarrow> return_spmf (Inl (as2, s1))
             | Inr (out1, rpv', rpv) \<Rightarrow> the_gpv (callee1 s1 out1) \<bind> (\<lambda>generat. case generat of
                 Pure (r1, s1) \<Rightarrow> inline1' (bind_gpv (rpv' r1) (\<lambda>(r2, s2). inline callee2 (rpv r2) s2)) s1
               | IO out rpv'' \<Rightarrow> return_spmf (Inr (out, rpv'', \<lambda>r1. bind_gpv (rpv' r1) (\<lambda>(r2, s2). inline callee2 (rpv r2) s2)) ))))
          (the_gpv gpv \<bind> (\<lambda>generat. case generat of Pure x \<Rightarrow> return_spmf (Inl ((x, s2), s1))
             | IO out2 rpv \<Rightarrow> inline1_1 callee1 (callee2 s2 out2) s1 \<bind> (\<lambda>lr. case lr of
                 Inl ((r2, s2), s1) \<Rightarrow>
                    map_spmf (map_sum (\<lambda>(x, s2, s1). ((x, s2), s1)) (\<lambda>(x, rpv'', rpv', rpv). (x, rpv'', \<lambda>r1. bind_gpv (rpv' r1) (\<lambda>(r2, s2). inline callee2 (rpv r2) s2))))
                      (inline2 (rpv r2) s2 s1)
               | Inr (out, rpv'', rpv') \<Rightarrow>
                    return_spmf (Inr (out, rpv'', \<lambda>r1. bind_gpv (rpv' r1) (\<lambda>(r2, s2). inline callee2 (rpv r2) s2))))))"
       proof(induction arbitrary: gpv s2 s1 rule: inline1_fixp_induct)
         case step2: (step inline1'')
         note step2_IH = step2.IH[unfolded inline1_1_def]
 
         show ?case unfolding inline1_1_def
           apply(rewrite in "ord_spmf _ _ \<hole>" inline1.simps)
           apply(clarsimp intro!: ord_spmf_bind_reflI split: generat.split)
           apply(rule conjI)
           subgoal by(rewrite in "ord_spmf _ _ \<hole>" inline2.simps)(clarsimp simp add: map_spmf_bind_spmf o_def split: generat.split sum.split intro!: ord_spmf_bind_reflI spmf.leq_trans[OF step2_IH])
           subgoal by(clarsimp intro!: ord_spmf_bind_reflI step_IH[THEN spmf.leq_trans] split: generat.split sum.split simp add: bind_rpv_def)
           done
       qed simp_all
       show ?case
         apply(rewrite in "ord_spmf _ \<hole> _" inline_sel)
         apply(rewrite in "ord_spmf _ _ \<hole>" inline2.simps)
         apply(clarsimp simp add: map_spmf_bind_spmf bind_map_spmf o_def intro!: ord_spmf_bind_reflI split: generat.split)
         apply(rule spmf.leq_trans[OF spmf.leq_trans, OF _ inline1])
         apply(auto intro!: ord_spmf_bind_reflI split: sum.split generat.split simp add: inline1_1_def map_spmf_bind_spmf)
         done }
     { case 2
       show ?case unfolding inline1_1_def
         by(rewrite inline1.simps)(auto simp del: bind_gpv_sel' simp add: bind_gpv.sel map_spmf_bind_spmf bind_map_spmf o_def bind_rpv_def intro!: ord_spmf_bind_reflI step_IH(2)[THEN spmf.leq_trans] step_hyps(2) split: generat.split sum.split) }
   qed simp_all
   thus "ord_spmf (=) ?lhs ?rhs" by -
 
   show "ord_spmf (=) ?rhs ?lhs"
   proof(induction arbitrary: gpv s2 s1 rule: inline2_fixp_induct)
     case adm show ?case by simp
     case bottom show ?case by simp
     case (step inline2')
     show ?case
       apply(rewrite in "ord_spmf _ _ \<hole>" inline1.simps)
       apply(rewrite inline_sel)
       apply(rewrite in "ord_spmf _ \<hole> _" inline1.simps)
       apply(rewrite in "ord_spmf _ _ \<hole>" inline1.simps)
       apply(clarsimp simp add: map_spmf_bind_spmf bind_map_spmf intro!: ord_spmf_bind_reflI split: generat.split)
       apply(rule conjI)
       subgoal
          apply clarsimp
          apply(rule step.IH[THEN spmf.leq_trans])
          apply(rewrite in "ord_spmf _ \<hole> _" inline1.simps)
          apply(rewrite inline_sel)
          apply(simp add: bind_map_spmf)
          done
       subgoal by(clarsimp intro!: ord_spmf_bind_reflI split: generat.split sum.split simp add: o_def inline1_bind_gpv bind_rpv_def step.IH)
       done
   qed
 qed
 
 lemma inline1_inline_conv_inline2':
   "inline1 (\<lambda>(s2, s1) c2. map_gpv (\<lambda>((r, s2), s1). (r, s2, s1)) id (inline callee1 (callee2 s2 c2) s1)) gpv (s2, s1) =
    map_spmf (map_sum id (\<lambda>(x, rpv'', rpv', rpv). (x, \<lambda>r. bind_gpv (rpv'' r)
        (\<lambda>(r1, s1). map_gpv (\<lambda>((r2, s2), s1). (r2, s2, s1)) id (inline callee1 (rpv' r1) s1)), rpv)))
      (inline2 gpv s2 s1)"
   (is "?lhs = ?rhs")
 proof(rule spmf.leq_antisym)
   show "ord_spmf (=) ?lhs ?rhs"
   proof(induction arbitrary: gpv s2 s1 rule: inline1_fixp_induct)
     case (step inline1') show ?case
       by(rewrite inline2.simps)(auto simp add: map_spmf_bind_spmf o_def inline_sel gpv.map_sel bind_map_spmf id_def[symmetric] gpv.map_id map_gpv_bind_gpv split_def intro!: ord_spmf_bind_reflI step.IH[THEN spmf.leq_trans] split: generat.split sum.split)
   qed simp_all
   show "ord_spmf (=) ?rhs ?lhs"
   proof(induction arbitrary: gpv s2 s1 rule: inline2_fixp_induct)
    case (step inline2')
    show ?case
      apply(rewrite in "ord_spmf _ _ \<hole>" inline1.simps)
      apply(clarsimp simp add: map_spmf_bind_spmf bind_rpv_def o_def gpv.map_sel bind_map_spmf inline_sel map_gpv_bind_gpv id_def[symmetric] gpv.map_id split_def split: generat.split sum.split intro!: ord_spmf_bind_reflI)
      apply(rule spmf.leq_trans[OF spmf.leq_trans, OF _ step.IH])
      apply(auto simp add: split_def id_def[symmetric] intro!: ord_spmf_reflI)
      done
   qed simp_all
 qed
 
 lemma inline_assoc:
   "inline callee1 (inline callee2 gpv s2) s1 =
    map_gpv (\<lambda>(r, s2, s1). ((r, s2), s1)) id (inline (\<lambda>(s2, s1) c2. map_gpv (\<lambda>((r, s2), s1). (r, s2, s1)) id (inline callee1 (callee2 s2 c2) s1)) gpv (s2, s1))"
 proof(coinduction arbitrary: s2 s1 gpv rule: gpv_coinduct_bind[where ?'b = "('r2 \<times> 's2) \<times> 's1" and ?'c = "('r2 \<times> 's2) \<times> 's1"])
   case (Eq_gpv s2 s1 gpv)
   have "\<exists>gpv2 gpv2' (f :: ('r2 \<times> 's2) \<times> 's1 \<Rightarrow> _) (f' :: ('r2 \<times> 's2) \<times> 's1 \<Rightarrow> _).
           bind_gpv (bind_gpv (rpv'' r) (\<lambda>(r1, s1). inline callee1 (rpv' r1) s1)) (\<lambda>((r2, s2), s1). inline callee1 (inline callee2 (rpv r2) s2) s1) = gpv2 \<bind> f \<and>
           bind_gpv (bind_gpv (rpv'' r) (\<lambda>(r1, s1). inline callee1 (rpv' r1) s1)) (\<lambda>((r2, s2), s1). map_gpv (\<lambda>(r, s2, y). ((r, s2), y)) id (inline (\<lambda>(s2, s1) c2. map_gpv (\<lambda>((r, s2), s1). (r, s2, s1)) id (inline callee1 (callee2 s2 c2) s1)) (rpv r2) (s2, s1))) = gpv2' \<bind> f' \<and>
           rel_gpv (\<lambda>x y. \<exists>s2 s1 gpv. f x = inline callee1 (inline callee2 gpv s2) s1 \<and>
               f' y = map_gpv (\<lambda>(r, s2, y). ((r, s2), y)) id (inline (\<lambda>(s2, s1) c2. map_gpv (\<lambda>((r, s2), s1). (r, s2, s1)) id (inline callee1 (callee2 s2 c2) s1)) gpv (s2, s1)))
             (=) gpv2 gpv2'" 
     for rpv'' :: "('r1 \<times> 's1, 'c, 'r) rpv" and rpv' :: "('r2 \<times> 's2, 'c1, 'r1) rpv" and rpv :: "('a, 'c2, 'r2) rpv" and r :: 'r
     by(auto intro!: exI gpv.rel_refl)
   then show ?case
     apply(subst inline_sel)
     apply(subst gpv.map_sel)
     apply(subst inline_sel)
     apply(subst inline1_inline_conv_inline2)
     apply(subst inline1_inline_conv_inline2')
     apply(unfold spmf.map_comp o_def case_sum_map_sum spmf_rel_map generat.rel_map)
     apply(rule rel_spmf_reflI)
     subgoal for lr by(cases lr)(auto del: disjCI intro!: rel_funI disjI2 simp add: split_def map_gpv_conv_bind[folded id_def] bind_gpv_assoc)
     done
 qed
 
 end
 
 lemma set_inline2_lift_spmf1: "set_spmf (inline2 (\<lambda>s x. lift_spmf (p s x)) callee gpv s s') \<subseteq> range Inl"
 apply(induction arbitrary: gpv s s' rule: inline2_fixp_induct)
 subgoal by(rule cont_intro ccpo_class.admissible_leI)+
 apply(auto simp add: o_def bind_UNION split: generat.split_asm sum.split_asm dest!: in_set_inline1_lift_spmf1)
 apply blast
 done
 
 lemma in_set_inline2_lift_spmf1: "y \<in> set_spmf (inline2 (\<lambda>s x. lift_spmf (p s x)) callee gpv s s') \<Longrightarrow> \<exists>r s s'. y = Inl (r, s, s')"
 by(drule set_inline2_lift_spmf1[THEN subsetD]) auto
 
 context
   fixes consider' :: "'call \<Rightarrow> bool" 
   and "consider" :: "'call' \<Rightarrow> bool" 
   and callee :: "'s \<Rightarrow> 'call \<Rightarrow> ('ret \<times> 's, 'call', 'ret') gpv" 
   notes [[function_internals]]
 begin
 
 private partial_function (spmf) inline1'
   :: "('a, 'call, 'ret) gpv \<Rightarrow> 's
   \<Rightarrow> ('a \<times> 's + 'call \<times> 'call' \<times> ('ret \<times> 's, 'call', 'ret') rpv \<times> ('a, 'call, 'ret) rpv) spmf"
 where
   "inline1' gpv s =
    the_gpv gpv \<bind>
    case_generat (\<lambda>x. return_spmf (Inl (x, s)))
      (\<lambda>out rpv. the_gpv (callee s out) \<bind>
          case_generat (\<lambda>(x, y). inline1' (rpv x) y)
           (\<lambda>out' rpv'. return_spmf (Inr (out, out', rpv', rpv))))"
 
 private lemma inline1'_fixp_induct [case_names adm bottom step]:
   assumes "ccpo.admissible (fun_lub lub_spmf) (fun_ord (ord_spmf (=))) (\<lambda>inline1'. P (\<lambda>gpv s. inline1' (gpv, s)))"
   and "P (\<lambda>_ _. return_pmf None)"
   and "\<And>inline1'. P inline1' \<Longrightarrow> P (\<lambda>gpv s. the_gpv gpv \<bind> case_generat (\<lambda>x. return_spmf (Inl (x, s))) (\<lambda>out rpv. the_gpv (callee s out) \<bind> case_generat (\<lambda>(x, y). inline1' (rpv x) y) (\<lambda>out' rpv'. return_spmf (Inr (out, out', rpv', rpv)))))"
   shows "P inline1'"
 using assms by(rule inline1'.fixp_induct[unfolded curry_conv[abs_def]])
 
 private lemma inline1_conv_inline1': "inline1 callee gpv s = map_spmf (map_sum id snd) (inline1' gpv s)"
 proof(induction arbitrary: gpv s rule: parallel_fixp_induct_2_2[OF partial_function_definitions_spmf partial_function_definitions_spmf inline1.mono inline1'.mono inline1_def inline1'_def, unfolded lub_spmf_empty, case_names adm bottom step])
   case adm show ?case by simp
   case bottom show ?case by simp
   case (step inline1 inline1')
   thus ?case by(clarsimp simp add: map_spmf_bind_spmf o_def intro!: bind_spmf_cong[OF refl] split: generat.split)
 qed
 
 context
   fixes q :: "enat" 
   assumes q: "\<And>s x. consider' x \<Longrightarrow> interaction_bound consider (callee s x) \<le> q"
   and ignore: "\<And>s x. \<not> consider' x \<Longrightarrow> interaction_bound consider (callee s x) = 0"
 begin
 
 private lemma interaction_bound_inline1'_aux:
   "interaction_bound consider' gpv \<le> p
   \<Longrightarrow> set_spmf (inline1' gpv s) \<subseteq> {Inr (out', out, c', rpv) | out' out c' rpv. 
         if consider' out'
         then (\<forall>input. (if consider out then eSuc (interaction_bound consider (c' input)) else interaction_bound consider (c' input)) \<le> q) \<and> 
              (\<forall>x. eSuc (interaction_bound consider' (rpv x)) \<le> p)
         else \<not> consider out \<and> (\<forall>input. interaction_bound consider (c' input) = 0) \<and> (\<forall>x. interaction_bound consider' (rpv x) \<le> p)}
       \<union> range Inl"
 proof(induction arbitrary: gpv s rule: inline1'_fixp_induct)
   { case adm show ?case by(rule cont_intro ccpo_class.admissible_leI)+ }
   { case bottom show ?case by simp }
   case (step inline1')
   have *: "interaction_bound consider' (c input) \<le> p" if "IO out c \<in> set_spmf (the_gpv gpv)" for out c input
     by(cases "consider' out")(auto intro: interaction_bound_IO_consider[OF that, THEN order_trans, THEN order_trans[OF ile_eSuc]] interaction_bound_IO_ignore[OF that, THEN order_trans] step.prems)
   have **: "if consider' out'
     then (\<forall>input. (if consider out then eSuc (interaction_bound consider (c input))  else interaction_bound consider (c input)) \<le> q) \<and>
          (\<forall>x. eSuc (interaction_bound consider' (rpv x)) \<le> p)
     else \<not> consider out \<and> (\<forall>input. interaction_bound consider (c input) = 0) \<and> (\<forall>x. interaction_bound consider' (rpv x) \<le> p)"
     if "IO out' rpv \<in> set_spmf (the_gpv gpv)" "IO out c \<in> set_spmf (the_gpv (callee s out'))"
     for out' rpv out c
   proof(cases "consider' out'")
     case True
     then show ?thesis using that q
       by(auto split del: if_split intro!: interaction_bound_IO[THEN order_trans] interaction_bound_IO_consider[THEN order_trans] step.prems)
   next
     case False
     have "\<not> consider out" "interaction_bound consider (c input) = 0" for input
       using interaction_bound_IO[OF that(2), of "consider" input] ignore[OF False, of s]
       by(auto split: if_split_asm)
     then show ?thesis using False that
       by(auto split del: if_split intro: interaction_bound_IO_ignore[THEN order_trans] step.prems)
   qed
   show ?case
     by(auto 6 4 simp add: bind_UNION del: subsetI intro!: UN_least intro: step.IH * ** split: generat.split split del: if_split)
 qed
 
 lemma interaction_bound_inline1':
   "\<lbrakk> Inr (out', out, c', rpv) \<in> set_spmf (inline1' gpv s); interaction_bound consider' gpv \<le> p \<rbrakk>
   \<Longrightarrow> if consider' out' then
         (if consider out then eSuc (interaction_bound consider (c' input)) else interaction_bound consider (c' input)) \<le> q \<and> 
         eSuc (interaction_bound consider' (rpv x)) \<le> p
       else \<not> consider out \<and> interaction_bound consider (c' input) = 0 \<and> interaction_bound consider' (rpv x) \<le> p"
 using interaction_bound_inline1'_aux[where gpv=gpv and p=p and s=s] by(auto split: if_split_asm)
 
 end
 
 lemma interaction_bounded_by_inline1:
   "\<lbrakk> Inr (out', out, c', rpv) \<in> set_spmf (inline1' gpv s); 
     interaction_bounded_by consider' gpv p;
     \<And>s x. consider' x \<Longrightarrow> interaction_bounded_by consider (callee s x) q; 
     \<And>s x. \<not> consider' x \<Longrightarrow> interaction_bounded_by consider (callee s x) 0 \<rbrakk>
   \<Longrightarrow> if consider' out' then
         (if consider out then q \<noteq> 0 \<and> interaction_bounded_by consider (c' input) (q - 1) else interaction_bounded_by consider (c' input) q) \<and>
         p \<noteq> 0 \<and> interaction_bounded_by consider' (rpv x) (p - 1)
       else \<not> consider out \<and> interaction_bounded_by consider (c' input) 0 \<and> interaction_bounded_by consider' (rpv x) p"
 unfolding interaction_bounded_by_0 unfolding interaction_bounded_by.simps
 apply(drule (1) interaction_bound_inline1'[where input=input and x=x, rotated 2], assumption, assumption)
 apply(cases p q rule: co.enat.exhaust[case_product co.enat.exhaust])
 apply(simp_all add: zero_enat_def[symmetric] eSuc_enat[symmetric] split: if_split_asm)
 done
 
 declare enat_0_iff [simp]
 
 lemma interaction_bounded_by_inline [interaction_bound]:
   assumes p: "interaction_bounded_by consider' gpv p"
   and q: "\<And>s x. consider' x \<Longrightarrow> interaction_bounded_by consider (callee s x) q"
   and ignore: "\<And>s x. \<not> consider' x \<Longrightarrow> interaction_bounded_by consider (callee s x) 0"
   shows "interaction_bounded_by consider (inline callee gpv s) (p * q)"
 proof
   have "interaction_bounded_by consider' gpv p \<Longrightarrow> interaction_bound consider (inline callee gpv s) \<le> p * q"
     and "interaction_bound consider (bind_gpv gpv' f) \<le> interaction_bound consider gpv' + (SUP x\<in>results'_gpv gpv'. interaction_bound consider (f x))"
     for gpv' and f :: "'ret \<times> 's \<Rightarrow> ('a \<times> 's, 'call', 'ret') gpv"
   proof(induction arbitrary: gpv s p gpv' f rule: interaction_bound_fixp_induct)
     case adm show ?case by simp
     case bottom case 1 show ?case by simp
     case (step interaction_bound') case step: 1
     show ?case (is "(SUP generat\<in>?inline. ?lhs generat) \<le> ?rhs")
     proof(rule SUP_least)
       fix generat
       assume "generat \<in> ?inline"
       then consider (Pure) ret s' where "generat = Pure (ret, s')"
           and "Inl (ret, s') \<in> set_spmf (inline1 callee gpv s)"
         | (IO) out c rpv where "generat = IO out (\<lambda>input. bind_gpv (c input) (\<lambda>(ret, s'). inline callee (rpv ret) s'))"
           and "Inr (out, c, rpv) \<in> set_spmf (inline1 callee gpv s)"
         by(clarsimp simp add: inline_sel split: sum.split_asm)
       then show "?lhs generat \<le> ?rhs"
       proof(cases)
         case Pure thus ?thesis by simp
       next
         case IO
         from IO(2) obtain out' where out': "Inr (out', out, c, rpv) \<in> set_spmf (inline1' gpv s)"
           by(auto simp add: inline1_conv_inline1' Inr_eq_map_sum_iff)
         show ?thesis
         proof(cases "consider' out'")
           case True
           with interaction_bounded_by_inline1[OF out' step.prems q ignore]
           have p: "p \<noteq> 0" and rpv: "\<And>x. interaction_bounded_by consider' (rpv x) (p - 1)"
             and c: "\<And>input. if consider out then q \<noteq> 0 \<and> interaction_bounded_by consider (c input) (q - 1) else interaction_bounded_by consider (c input) q"
             by auto
 
           have "?lhs generat \<le> (if consider out then 1 else 0) + (SUP input. interaction_bound' (bind_gpv (c input) (\<lambda>(ret, s'). inline callee (rpv ret) s')))"
             (is "_ \<le> _ + ?sup")
             using IO(1) by(auto simp add: plus_1_eSuc)
           also have "?sup \<le> (SUP input. interaction_bound consider (c input) + (SUP (ret, s') \<in> results'_gpv (c input). interaction_bound' (inline callee (rpv ret) s')))"
             unfolding split_def by(rule SUP_mono)(blast intro: step.IH)
           also have "\<dots> \<le> (SUP input. interaction_bound consider (c input) + (SUP (ret, s') \<in> results'_gpv (c input). (p - 1) * q))"
             using rpv by(auto intro!: SUP_mono rev_bexI add_mono step.IH)
           also have "\<dots> \<le> (SUP input. interaction_bound consider (c input) + (p - 1) * q)"
             apply(auto simp add: SUP_constant bot_enat_def intro!: SUP_mono)
             apply(metis add.right_neutral add_mono i0_lb order_refl)+
             done
           also have "\<dots> \<le> (SUP input :: 'ret'. (if consider out then q - 1 else q) + (p - 1) * q)"
             apply(rule SUP_mono rev_bexI UNIV_I add_mono)+
             using c
             apply(auto simp add: interaction_bounded_by.simps)
             done
           also have "\<dots> = (if consider out then q - 1 else q) + (p - 1) * q"
             by(simp add: SUP_constant)
           finally show ?thesis
             apply(rule order_trans)
             prefer 5
             using p c
             apply(cases p; cases q)
             apply(auto simp add: one_enat_def algebra_simps Suc_leI)
             done
         next
           case False
           with interaction_bounded_by_inline1[OF out' step.prems q ignore]
           have out: "\<not> consider out" and zero: "\<And>input. interaction_bounded_by consider (c input) 0"
             and rpv: "\<And>x. interaction_bounded_by consider' (rpv x) p" by auto
           have "?lhs generat \<le> (SUP input. interaction_bound' (bind_gpv (c input) (\<lambda>(ret, s'). inline callee (rpv ret) s')))"
             using IO(1) out by auto
           also have "\<dots> \<le> (SUP input. interaction_bound consider (c input) + (SUP (ret, s') \<in> results'_gpv (c input). interaction_bound' (inline callee (rpv ret) s')))"
             unfolding split_def by(rule SUP_mono)(blast intro: step.IH)
           also have "\<dots> \<le> (SUP input. (SUP (ret, s') \<in> results'_gpv (c input). p * q))"
             using rpv zero by(auto intro!: SUP_mono rev_bexI add_mono step.IH simp add: interaction_bounded_by_0)
           also have "\<dots> \<le> (SUP input :: 'ret'. p * q)"
             by(rule SUP_mono rev_bexI)+(auto simp add: SUP_constant)
           also have "\<dots> = p * q" by(simp add: SUP_constant)
           finally show ?thesis .
         qed
       qed
     qed
   next
     case bottom case 2 show ?case by simp
     case step case 2 show ?case using step by -(rule interaction_bound_bind_step)
   qed
   then show "interaction_bound consider (inline callee gpv s) \<le> p * q" using p by -
 qed
 
 end
 
 lemma interaction_bounded_by_inline_invariant: (* TODO: augment with types *)
   includes lifting_syntax
   fixes consider' :: "'call \<Rightarrow> bool" 
   and "consider" :: "'call' \<Rightarrow> bool" 
   and callee :: "'s \<Rightarrow> 'call \<Rightarrow> ('ret \<times> 's, 'call', 'ret') gpv" 
   and gpv :: "('a, 'call, 'ret) gpv"
   assumes p: "interaction_bounded_by consider' gpv p"
   and q: "\<And>s x. \<lbrakk> I s; consider' x \<rbrakk> \<Longrightarrow> interaction_bounded_by consider (callee s x) q"
   and ignore: "\<And>s x. \<lbrakk> I s; \<not> consider' x \<rbrakk> \<Longrightarrow> interaction_bounded_by consider (callee s x) 0"
   and I: "I s"
   and invariant: "\<And>s x y s'. \<lbrakk> (y, s') \<in> results'_gpv (callee s x); I s \<rbrakk> \<Longrightarrow> I s'"
   shows "interaction_bounded_by consider (inline callee gpv s) (p * q)"
 proof -
   { assume "\<exists>(Rep :: 's' \<Rightarrow> 's) Abs. type_definition Rep Abs {s. I s}"
     then obtain Rep :: "'s' \<Rightarrow> 's" and Abs where td: "type_definition Rep Abs {s. I s}" by blast
     then interpret td: type_definition Rep Abs "{s. I s}" .
     define cr where "cr x y \<longleftrightarrow> x = Rep y" for x y
     have [transfer_rule]: "bi_unique cr" "right_total cr"
       using td cr_def[abs_def] by(rule typedef_bi_unique typedef_right_total)+
     have [transfer_domain_rule]: "Domainp cr = I"
       using type_definition_Domainp[OF td cr_def[abs_def]] by simp
 
     define callee' where "callee' = (Rep --->  id ---> map_gpv (map_prod id Abs) id) callee"
     have [transfer_rule]: "(cr ===> (=) ===> rel_gpv (rel_prod (=) cr) (=)) callee callee'"
       by(auto simp add: callee'_def rel_fun_def cr_def gpv.rel_map prod.rel_map td.Abs_inverse intro!: gpv.rel_refl_strong intro: td.Rep[simplified] dest: invariant)
 
     define s' where "s' = Abs s"
     have [transfer_rule]: "cr s s'" using I by(simp add: cr_def s'_def td.Abs_inverse)
 
     note p moreover
     have "consider' x \<Longrightarrow> interaction_bounded_by consider (callee' s x) q" for s x
       by(transfer fixing: "consider" consider' q)(clarsimp simp add: q)
     moreover have "\<not> consider' x \<Longrightarrow> interaction_bounded_by consider (callee' s x) 0" for s x
       by(transfer fixing: "consider" consider')(clarsimp simp add: ignore)
     ultimately have "interaction_bounded_by consider (inline callee' gpv s') (p * q)" 
       by(rule interaction_bounded_by_inline)
     then have "interaction_bounded_by consider (inline callee gpv s) (p * q)" by transfer  }
   from this[cancel_type_definition] I show ?thesis by blast
 qed
 
 context
   fixes \<I> :: "('call, 'ret) \<I>"
   and \<I>' :: "('call', 'ret') \<I>"
   and callee :: "'s \<Rightarrow> 'call \<Rightarrow> ('ret \<times> 's, 'call', 'ret') gpv"
   assumes results: "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> results_gpv \<I>' (callee s x) \<subseteq> responses_\<I> \<I> x \<times> UNIV"
 begin
 
 lemma inline1_in_sub_gpvs_callee:
   assumes "Inr (out, callee', rpv') \<in> set_spmf (inline1 callee gpv s)"
   and WT: "\<I> \<turnstile>g gpv \<surd>"
   shows "\<exists>call\<in>outs_\<I> \<I>. \<exists>s. \<forall>x \<in> responses_\<I> \<I>' out. callee' x \<in> sub_gpvs \<I>' (callee s call)"
 proof -
   from WT
   have "set_spmf (inline1 callee gpv s) \<subseteq> {Inr (out, callee', rpv') | out callee' rpv'.
     \<exists>call\<in>outs_\<I> \<I>. \<exists>s. \<forall>x \<in> responses_\<I> \<I>' out. callee' x \<in> sub_gpvs \<I>' (callee s call)} \<union> range Inl"
     (is "?concl (inline1 callee) gpv s")
   proof(induction arbitrary: gpv s rule: inline1_fixp_induct)
     case adm show ?case by(intro cont_intro ccpo_class.admissible_leI)
     case bottom show ?case by simp
     case (step inline1')
     { fix out c
       assume IO: "IO out c \<in> set_spmf (the_gpv gpv)" 
       from step.prems IO have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpvD)
       { fix x s'
         assume Pure: "Pure (x, s') \<in> set_spmf (the_gpv (callee s out))"
         then have "(x, s') \<in> results_gpv \<I>' (callee s out)" by(rule results_gpv.Pure)
         with out have "x \<in> responses_\<I> \<I> out" by(auto dest: results)
         with step.prems IO have "\<I> \<turnstile>g c x \<surd>" by(rule WT_gpvD)
         hence "?concl inline1' (c x) s'" by(rule step.IH)
       } moreover {
         fix out' c'
         assume "IO out' c' \<in> set_spmf (the_gpv (callee s out))"
         hence "\<forall>x\<in>responses_\<I> \<I>' out'. c' x \<in> sub_gpvs \<I>' (callee s out)"
           by(auto intro: sub_gpvs.base)
         then have "\<exists>call\<in>outs_\<I> \<I>. \<exists>s. \<forall>x\<in>responses_\<I> \<I>' out'. c' x \<in> sub_gpvs \<I>' (callee s call)"
           using out by blast
       } moreover note calculation }
     then show ?case using step.prems
       by(auto del: subsetI simp add: bind_UNION intro!: UN_least split: generat.split)
   qed
   thus ?thesis using assms by fastforce
 qed
 
 lemma inline1_in_sub_gpvs:
   assumes "Inr (out, callee', rpv') \<in> set_spmf (inline1 callee gpv s)"
   and "(x, s') \<in> results_gpv \<I>' (callee' input)"
   and "input \<in> responses_\<I> \<I>' out"
   and "\<I> \<turnstile>g gpv \<surd>"
   shows "rpv' x \<in> sub_gpvs \<I> gpv"
 proof -
   from \<open>\<I> \<turnstile>g gpv \<surd>\<close>
   have "set_spmf (inline1 callee gpv s) \<subseteq> {Inr (out, callee', rpv') | out callee' rpv'.
     \<forall>input \<in> responses_\<I> \<I>' out. \<forall>(x, s')\<in>results_gpv \<I>' (callee' input). rpv' x \<in> sub_gpvs \<I> gpv}
     \<union> range Inl" (is "?concl (inline1 callee) gpv s" is "_ \<subseteq> ?rhs gpv s")
   proof(induction arbitrary: gpv s rule: inline1_fixp_induct)
     case adm show ?case by(intro cont_intro ccpo_class.admissible_leI)
     case bottom show ?case by simp
   next
     case (step inline1')
     { fix out c
       assume IO: "IO out c \<in> set_spmf (the_gpv gpv)" 
       from step.prems IO have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpvD)
       { fix x s'
         assume Pure: "Pure (x, s') \<in> set_spmf (the_gpv (callee s out))"
         then have "(x, s') \<in> results_gpv \<I>' (callee s out)" by(rule results_gpv.Pure)
         with out have "x \<in> responses_\<I> \<I> out" by(auto dest: results)
         with step.prems IO have "\<I> \<turnstile>g c x \<surd>" by(rule WT_gpvD)
         hence "?concl inline1' (c x) s'" by(rule step.IH)
         also have "\<dots> \<subseteq> ?rhs gpv s'" using IO Pure
           by(fastforce intro: sub_gpvs.cont dest: WT_gpv_OutD[OF step.prems] results[THEN subsetD, OF _ results_gpv.Pure])
         finally have "set_spmf (inline1' (c x) s') \<subseteq> \<dots>" .
       } moreover {
         fix out' c' input x s'
         assume "IO out' c' \<in> set_spmf (the_gpv (callee s out))"
           and "input \<in> responses_\<I> \<I>' out'" and "(x, s') \<in> results_gpv \<I>' (c' input)"
         then have "c x \<in> sub_gpvs \<I> gpv" using IO
           by(auto intro!: sub_gpvs.base dest: WT_gpv_OutD[OF step.prems] results[THEN subsetD, OF _ results_gpv.IO])
       } moreover note calculation }
     then show ?case
       by(auto simp add: bind_UNION intro!: UN_least split: generat.split del: subsetI)
   qed
   with assms show ?thesis by fastforce
 qed
 
 context
   assumes WT: "\<And>x s. x \<in> outs_\<I> \<I> \<Longrightarrow> \<I>' \<turnstile>g callee s x \<surd>"
 begin
 
 lemma WT_gpv_inline1:
   assumes "Inr (out, rpv, rpv') \<in> set_spmf (inline1 callee gpv s)"
   and "\<I> \<turnstile>g gpv \<surd>"
   shows "out \<in> outs_\<I> \<I>'" (is "?thesis1")
   and "input \<in> responses_\<I> \<I>' out \<Longrightarrow> \<I>' \<turnstile>g rpv input \<surd>" (is "PROP ?thesis2")
   and "\<lbrakk> input \<in> responses_\<I> \<I>' out; (x, s') \<in> results_gpv \<I>' (rpv input) \<rbrakk> \<Longrightarrow> \<I> \<turnstile>g rpv' x \<surd>" (is "PROP ?thesis3")
 proof -
   from \<open>\<I> \<turnstile>g gpv \<surd>\<close>
   have "set_spmf (inline1 callee gpv s) \<subseteq> {Inr (out, rpv, rpv') | out rpv rpv'. out \<in> outs_\<I> \<I>'} \<union> range Inl"
   proof(induction arbitrary: gpv s rule: inline1_fixp_induct)
     { case adm show ?case by(intro cont_intro ccpo_class.admissible_leI) }
     { case bottom show ?case by simp }
     case (step inline1')
     { fix out c
       assume IO: "IO out c \<in> set_spmf (the_gpv gpv)" 
       from step.prems IO have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpvD)
       { fix x s'
         assume Pure: "Pure (x, s') \<in> set_spmf (the_gpv (callee s out))"
         then have "(x, s') \<in> results_gpv \<I>' (callee s out)" by(rule results_gpv.Pure)
         with out have "x \<in> responses_\<I> \<I> out" by(auto dest: results)
         with step.prems IO have "\<I> \<turnstile>g c x \<surd>" by(rule WT_gpvD)
       } moreover {
         fix out' c'
         from out have "\<I>' \<turnstile>g callee s out \<surd>" by(rule WT)
         moreover assume "IO out' c' \<in> set_spmf (the_gpv (callee s out))"
         ultimately have "out' \<in> outs_\<I> \<I>'" by(rule WT_gpvD) 
       } moreover note calculation }
     then show ?case 
       by(auto del: subsetI simp add: bind_UNION intro!: UN_least split: generat.split intro!: step.IH[THEN order_trans])
   qed
   then show ?thesis1 using assms by auto
 
   assume "input \<in> responses_\<I> \<I>' out"
   with inline1_in_sub_gpvs_callee[OF \<open>Inr _ \<in> _\<close>] \<open>\<I> \<turnstile>g gpv \<surd>\<close>
   obtain out' s where "out' \<in> outs_\<I> \<I>" 
     and *: "rpv input \<in> sub_gpvs \<I>' (callee s out')" by auto
   from \<open>out' \<in> _\<close> have "\<I>' \<turnstile>g callee s out' \<surd>" by(rule WT)
   then show "\<I>' \<turnstile>g rpv input \<surd>" using * by(rule WT_sub_gpvsD)
 
   assume "(x, s') \<in> results_gpv \<I>' (rpv input)"
   with \<open>Inr _ \<in> _\<close> have "rpv' x \<in> sub_gpvs \<I> gpv"
     using \<open>input \<in> _\<close> \<open>\<I> \<turnstile>g gpv \<surd>\<close> by(rule inline1_in_sub_gpvs)
   with \<open>\<I> \<turnstile>g gpv \<surd>\<close> show "\<I> \<turnstile>g rpv' x \<surd>" by(rule WT_sub_gpvsD)
 qed
 
 lemma WT_gpv_inline:
   assumes "\<I> \<turnstile>g gpv \<surd>"
   shows "\<I>' \<turnstile>g inline callee gpv s \<surd>"
 using assms
 proof(coinduction arbitrary: gpv s rule: WT_gpv_coinduct_bind)
   case (WT_gpv out c gpv)
   from \<open>IO out c \<in> _\<close> obtain callee' rpv'
     where Inr: "Inr (out, callee', rpv') \<in> set_spmf (inline1 callee gpv s)"
     and c: "c = (\<lambda>input. callee' input \<bind> (\<lambda>(x, s). inline callee (rpv' x) s))"
     by(clarsimp simp add: inline_sel split: sum.split_asm)
   from Inr \<open>\<I> \<turnstile>g gpv \<surd>\<close> have ?out by(rule WT_gpv_inline1)
   moreover have "?cont TYPE('ret \<times> 's)" (is "\<forall>input\<in>_. _ \<or> _ \<or> ?case' input")
   proof(rule ballI disjI2)+
     fix input
     assume "input \<in> responses_\<I> \<I>' out"
     with Inr \<open>\<I> \<turnstile>g gpv \<surd> \<close>have "\<I>' \<turnstile>g callee' input \<surd>"
       and "\<And>x s'. (x, s') \<in> results_gpv \<I>' (callee' input) \<Longrightarrow> \<I> \<turnstile>g rpv' x \<surd>"
       by(blast intro: WT_gpv_inline1)+
     then show "?case' input" by(subst c)(auto 4 4)
   qed
   ultimately show "?case TYPE('ret \<times> 's)" ..
 qed
 
 end
 
 context
   fixes gpv :: "('a, 'call, 'ret) gpv"
   assumes gpv: "lossless_gpv \<I> gpv" "\<I> \<turnstile>g gpv \<surd>"
 begin
 
 lemma lossless_spmf_inline1:
   assumes lossless: "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> lossless_spmf (the_gpv (callee s x))"
   shows "lossless_spmf (inline1 callee gpv s)"
 using gpv
 proof(induction arbitrary: s rule: lossless_WT_gpv_induct)
   case (lossless_gpv p)
   show ?case using \<open>lossless_spmf p\<close>
     apply(subst inline1_unfold)
     apply(auto split: generat.split intro: lossless lossless_gpv.hyps dest: results[THEN subsetD, rotated, OF results_gpv.Pure] intro: lossless_gpv.IH)
     done
 qed
 
 lemma lossless_gpv_inline1:
   assumes *: "Inr (out, rpv, rpv') \<in> set_spmf (inline1 callee gpv s)"
   and **: "input \<in> responses_\<I> \<I>' out"
   and lossless: "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> lossless_gpv \<I>' (callee s x)"
   shows "lossless_gpv \<I>' (rpv input)"
 proof -
   from inline1_in_sub_gpvs_callee[OF * gpv(2)] **
   obtain out' s where "out' \<in> outs_\<I> \<I>" and ***: "rpv input \<in> sub_gpvs \<I>' (callee s out')" by blast
   from \<open>out' \<in> _\<close> have "lossless_gpv \<I>' (callee s out')" by(rule lossless)
   thus ?thesis using *** by(rule lossless_sub_gpvsD)
 qed
 
 lemma lossless_results_inline1:
   assumes "Inr (out, rpv, rpv') \<in> set_spmf (inline1 callee gpv s)"
   and "(x, s') \<in> results_gpv \<I>' (rpv input)"
   and "input \<in> responses_\<I> \<I>' out"
   shows "lossless_gpv \<I> (rpv' x)"
 proof -
   from assms gpv(2) have "rpv' x \<in> sub_gpvs \<I> gpv" by(rule inline1_in_sub_gpvs)
   with gpv(1) show "lossless_gpv \<I> (rpv' x)" by(rule lossless_sub_gpvsD)
 qed
 
 end
 
 lemmas lossless_inline1[rotated 2] = lossless_spmf_inline1 lossless_gpv_inline1 lossless_results_inline1
 
 lemma lossless_inline[rotated]:
   fixes gpv :: "('a, 'call, 'ret) gpv"
   assumes gpv: "lossless_gpv \<I> gpv" "\<I> \<turnstile>g gpv \<surd>"
   and lossless: "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> lossless_gpv \<I>' (callee s x)"
   shows "lossless_gpv \<I>' (inline callee gpv s)"
 using gpv
 proof(induction arbitrary: s rule: lossless_WT_gpv_induct_strong)
   case (lossless_gpv p)
   have lp: "lossless_gpv \<I> (GPV p)" by(rule lossless_sub_gpvsI)(auto intro: lossless_gpv.hyps)
   moreover have wp: "\<I> \<turnstile>g GPV p \<surd>" by(rule WT_sub_gpvsI)(auto intro: lossless_gpv.hyps)
   ultimately have "lossless_spmf (the_gpv (inline callee (GPV p) s))"
     by(auto simp add: inline_sel intro: lossless_spmf_inline1 lossless_gpv_lossless_spmfD[OF lossless])
   moreover {
     fix out c input
     assume IO: "IO out c \<in> set_spmf (the_gpv (inline callee (GPV p) s))"
       and "input \<in> responses_\<I> \<I>' out"
     from IO obtain callee' rpv
       where Inr: "Inr (out, callee', rpv) \<in> set_spmf (inline1 callee (GPV p) s)"
       and c: "c = (\<lambda>input. callee' input \<bind> (\<lambda>(x, y). inline callee (rpv x) y))"
       by(clarsimp simp add: inline_sel split: sum.split_asm)
     from Inr \<open>input \<in> _\<close> lossless lp wp have "lossless_gpv \<I>' (callee' input)" by(rule lossless_inline1)
     moreover {
       fix x s'
       assume "(x, s') \<in> results_gpv \<I>' (callee' input)"
       with Inr have "rpv x \<in> sub_gpvs \<I> (GPV p)" using \<open>input \<in> _\<close> wp by(rule inline1_in_sub_gpvs)
       hence "lossless_gpv \<I>' (inline callee (rpv x) s')" by(rule lossless_gpv.IH)
     } ultimately have "lossless_gpv \<I>' (c input)" unfolding c by clarsimp
   } ultimately show ?case by(rule lossless_gpvI)
 qed
 
 end
 
 definition id_oracle :: "'s \<Rightarrow> 'call \<Rightarrow> ('ret \<times> 's, 'call, 'ret) gpv"
 where "id_oracle s x = Pause x (\<lambda>x. Done (x, s))"
 
 lemma inline1_id_oracle:
   "inline1 id_oracle gpv s =
    map_spmf (\<lambda>generat. case generat of Pure x \<Rightarrow> Inl (x, s) | IO out c \<Rightarrow> Inr (out, \<lambda>x. Done (x, s), c)) (the_gpv gpv)"
 by(subst inline1.simps)(auto simp add: id_oracle_def map_spmf_conv_bind_spmf intro!: bind_spmf_cong split: generat.split)
 
 lemma inline_id_oracle [simp]: "inline id_oracle gpv s = map_gpv (\<lambda>x. (x, s)) id gpv"
 by(coinduction arbitrary: gpv s)(auto 4 3 simp add: inline_sel inline1_id_oracle spmf_rel_map gpv.map_sel o_def generat.rel_map intro!: rel_spmf_reflI rel_funI split: generat.split)
 
+locale raw_converter_invariant =
+  fixes \<I> :: "('call, 'ret) \<I>"
+    and \<I>' :: "('call', 'ret') \<I>"
+    and callee :: "'s \<Rightarrow> 'call \<Rightarrow> ('ret \<times> 's, 'call', 'ret') gpv"
+    and I :: "'s \<Rightarrow> bool"
+  assumes results_callee: "\<And>s x. \<lbrakk> x \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> results_gpv \<I>' (callee s x) \<subseteq> responses_\<I> \<I> x \<times> {s. I s}"
+    and WT_callee: "\<And>x s. \<lbrakk> x \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> \<I>' \<turnstile>g callee s x \<surd>"
+begin
+
+context begin
+private lemma aux:
+  "set_spmf (inline1 callee gpv s) \<subseteq> {Inr (out, callee', rpv') | out callee' rpv'.
+    \<exists>call\<in>outs_\<I> \<I>. \<exists>s. I s \<and> (\<forall>x \<in> responses_\<I> \<I>' out. callee' x \<in> sub_gpvs \<I>' (callee s call))} \<union>
+     {Inl (x, s') | x s'. x \<in> results_gpv \<I> gpv \<and> I s'}"
+  (is "?concl (inline1 callee) gpv s" is "_ \<subseteq> ?rhs1 \<union> ?rhs2 gpv")
+  if "\<I> \<turnstile>g gpv \<surd>" "I s"
+  using that
+proof(induction arbitrary: gpv s rule: inline1_fixp_induct)
+  case adm show ?case by simp
+  case bottom show ?case by simp
+  case (step inline1')
+  { fix out c
+    assume IO: "IO out c \<in> set_spmf (the_gpv gpv)" 
+    from step.prems(1) IO have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpvD)
+    { fix x s'
+      assume Pure: "Pure (x, s') \<in> set_spmf (the_gpv (callee s out))"
+      then have "(x, s') \<in> results_gpv \<I>' (callee s out)" by(rule results_gpv.Pure)
+      with out step.prems(2) have "x \<in> responses_\<I> \<I> out" "I s'" by(auto dest: results_callee)
+      from step.prems(1) IO this(1) have "\<I> \<turnstile>g c x \<surd>" by(rule WT_gpvD)
+      hence "?concl inline1' (c x) s'" using \<open>I s'\<close> by(rule step.IH)
+      also have "\<dots> \<subseteq> ?rhs1 \<union> ?rhs2 gpv" using \<open>x \<in> _\<close> IO by(auto intro: results_gpv.intros)
+      also note calculation
+    } moreover {
+      fix out' c'
+      assume "IO out' c' \<in> set_spmf (the_gpv (callee s out))"
+      hence "\<forall>x\<in>responses_\<I> \<I>' out'. c' x \<in> sub_gpvs \<I>' (callee s out)"
+        by(auto intro: sub_gpvs.base)
+      then have "\<exists>call\<in>outs_\<I> \<I>. \<exists>s. I s \<and> (\<forall>x\<in>responses_\<I> \<I>' out'. c' x \<in> sub_gpvs \<I>' (callee s call))"
+        using out step.prems(2) by blast
+    } moreover note calculation }
+    then show ?case using step.prems
+      by(auto 4 3 del: subsetI simp add: bind_UNION intro!: UN_least split: generat.split intro: results_gpv.intros)
+  qed
+
+lemma inline1_in_sub_gpvs_callee:
+  assumes "Inr (out, callee', rpv') \<in> set_spmf (inline1 callee gpv s)"
+    and WT: "\<I> \<turnstile>g gpv \<surd>"
+    and s: "I s"
+  shows "\<exists>call\<in>outs_\<I> \<I>. \<exists>s. I s \<and> (\<forall>x \<in> responses_\<I> \<I>' out. callee' x \<in> sub_gpvs \<I>' (callee s call))"
+  using aux[OF WT s] assms(1) by fastforce
+
+lemma inline1_Inl_results_gpv:
+  assumes "Inl (x, s') \<in> set_spmf (inline1 callee gpv s)"
+    and WT: "\<I> \<turnstile>g gpv \<surd>"
+    and s: "I s"
+  shows "x \<in> results_gpv \<I> gpv \<and> I s'"
+  using aux[OF WT s] assms(1) by fastforce
+end
+
+lemma inline1_in_sub_gpvs:
+  assumes "Inr (out, callee', rpv') \<in> set_spmf (inline1 callee gpv s)"
+    and "(x, s') \<in> results_gpv \<I>' (callee' input)"
+    and "input \<in> responses_\<I> \<I>' out"
+    and "\<I> \<turnstile>g gpv \<surd>"
+    and "I s"
+  shows "rpv' x \<in> sub_gpvs \<I> gpv \<and> I s'"
+proof -
+  from \<open>\<I> \<turnstile>g gpv \<surd>\<close> \<open>I s\<close>
+  have "set_spmf (inline1 callee gpv s) \<subseteq> {Inr (out, callee', rpv') | out callee' rpv'.
+    \<forall>input \<in> responses_\<I> \<I>' out. \<forall>(x, s')\<in>results_gpv \<I>' (callee' input). I s' \<and> rpv' x \<in> sub_gpvs \<I> gpv}
+    \<union> {Inl (x, s') | x s'. I s'}" (is "?concl (inline1 callee) gpv s" is "_ \<subseteq> ?rhs gpv s")
+  proof(induction arbitrary: gpv s rule: inline1_fixp_induct)
+    case adm show ?case by(intro cont_intro ccpo_class.admissible_leI)
+    case bottom show ?case by simp
+    case (step inline1')
+    { fix out c
+      assume IO: "IO out c \<in> set_spmf (the_gpv gpv)" 
+      from step.prems(1) IO have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpvD)
+      { fix x s'
+        assume Pure: "Pure (x, s') \<in> set_spmf (the_gpv (callee s out))"
+        then have "(x, s') \<in> results_gpv \<I>' (callee s out)" by(rule results_gpv.Pure)
+        with out step.prems(2) have "x \<in> responses_\<I> \<I> out" "I s'" by(auto dest: results_callee)
+        from step.prems(1) IO this(1) have "\<I> \<turnstile>g c x \<surd>" by(rule WT_gpvD)
+        hence "?concl inline1' (c x) s'" using \<open>I s'\<close> by(rule step.IH)
+        also have "\<dots> \<subseteq> ?rhs gpv s'" using IO Pure \<open>I s\<close>
+          by(fastforce intro: sub_gpvs.cont dest: WT_gpv_OutD[OF step.prems(1)] results_callee[THEN subsetD, OF _ _ results_gpv.Pure])
+        finally have "set_spmf (inline1' (c x) s') \<subseteq> \<dots>" .
+      } moreover {
+        fix out' c' input x s'
+        assume "IO out' c' \<in> set_spmf (the_gpv (callee s out))"
+          and "input \<in> responses_\<I> \<I>' out'" and "(x, s') \<in> results_gpv \<I>' (c' input)"
+        then have "c x \<in> sub_gpvs \<I> gpv" "I s'" using IO \<open>I s\<close>
+          by(auto intro!: sub_gpvs.base dest: WT_gpv_OutD[OF step.prems(1)] results_callee[THEN subsetD, OF _ _ results_gpv.IO])
+      } moreover note calculation }
+      then show ?case using step.prems(2)
+        by(auto simp add: bind_UNION intro!: UN_least split: generat.split del: subsetI)
+    qed
+    with assms show ?thesis by fastforce
+  qed
+
+lemma WT_gpv_inline1:
+  assumes "Inr (out, rpv, rpv') \<in> set_spmf (inline1 callee gpv s)"
+    and "\<I> \<turnstile>g gpv \<surd>"
+    and "I s"
+  shows "out \<in> outs_\<I> \<I>'" (is "?thesis1")
+    and "input \<in> responses_\<I> \<I>' out \<Longrightarrow> \<I>' \<turnstile>g rpv input \<surd>" (is "PROP ?thesis2")
+    and "\<lbrakk> input \<in> responses_\<I> \<I>' out; (x, s') \<in> results_gpv \<I>' (rpv input) \<rbrakk> \<Longrightarrow> \<I> \<turnstile>g rpv' x \<surd> \<and> I s'" (is "PROP ?thesis3")
+proof -
+  from \<open>\<I> \<turnstile>g gpv \<surd>\<close> \<open>I s\<close>
+  have "set_spmf (inline1 callee gpv s) \<subseteq> {Inr (out, rpv, rpv') | out rpv rpv'. out \<in> outs_\<I> \<I>'} \<union> {Inl (x, s')| x s'. I s'}"
+  proof(induction arbitrary: gpv s rule: inline1_fixp_induct)
+    { case adm show ?case by(intro cont_intro ccpo_class.admissible_leI) }
+    { case bottom show ?case by simp }
+    case (step inline1')
+    { fix out c
+      assume IO: "IO out c \<in> set_spmf (the_gpv gpv)" 
+      from step.prems(1) IO have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpvD)
+      { fix x s'
+        assume Pure: "Pure (x, s') \<in> set_spmf (the_gpv (callee s out))"
+        then have *: "(x, s') \<in> results_gpv \<I>' (callee s out)" by(rule results_gpv.Pure)
+        with out step.prems(2) have "x \<in> responses_\<I> \<I> out" "I s'" by(auto dest: results_callee)
+        from step.prems(1) IO this(1) have "\<I> \<turnstile>g c x \<surd>" by(rule WT_gpvD)
+        note this \<open>I s'\<close>
+      } moreover {
+        fix out' c'
+        from out step.prems(2) have "\<I>' \<turnstile>g callee s out \<surd>" by(rule WT_callee)
+        moreover assume "IO out' c' \<in> set_spmf (the_gpv (callee s out))"
+        ultimately have "out' \<in> outs_\<I> \<I>'" by(rule WT_gpvD) 
+      } moreover note calculation }
+      then show ?case using step.prems(2)
+        by(auto del: subsetI simp add: bind_UNION intro!: UN_least split: generat.split intro!: step.IH[THEN order_trans])
+    qed
+    then show ?thesis1 using assms by auto
+
+    assume "input \<in> responses_\<I> \<I>' out"
+    with inline1_in_sub_gpvs_callee[OF \<open>Inr _ \<in> _\<close> \<open>\<I> \<turnstile>g gpv \<surd>\<close> \<open>I s\<close>]
+    obtain out' s where "out' \<in> outs_\<I> \<I>" 
+      and *: "rpv input \<in> sub_gpvs \<I>' (callee s out')" and "I s" by blast
+    from \<open>out' \<in> _\<close> \<open>I s\<close> have "\<I>' \<turnstile>g callee s out' \<surd>" by(rule WT_callee)
+    then show "\<I>' \<turnstile>g rpv input \<surd>" using * by(rule WT_sub_gpvsD)
+
+    assume "(x, s') \<in> results_gpv \<I>' (rpv input)"
+    with \<open>Inr _ \<in> _\<close> have "rpv' x \<in> sub_gpvs \<I> gpv \<and> I s'"
+      using \<open>input \<in> _\<close> \<open>\<I> \<turnstile>g gpv \<surd>\<close> assms(3) \<open>I s\<close> by-(rule inline1_in_sub_gpvs)
+    with \<open>\<I> \<turnstile>g gpv \<surd>\<close> show "\<I> \<turnstile>g rpv' x \<surd> \<and> I s'" by(blast intro: WT_sub_gpvsD)
+  qed
+
+lemma WT_gpv_inline_invar:
+  assumes "\<I> \<turnstile>g gpv \<surd>"
+    and "I s"
+  shows "\<I>' \<turnstile>g inline callee gpv s \<surd>"
+  using assms
+proof(coinduction arbitrary: gpv s rule: WT_gpv_coinduct_bind)
+  case (WT_gpv out c gpv)
+  from \<open>IO out c \<in> _\<close> obtain callee' rpv'
+    where Inr: "Inr (out, callee', rpv') \<in> set_spmf (inline1 callee gpv s)"
+      and c: "c = (\<lambda>input. callee' input \<bind> (\<lambda>(x, s). inline callee (rpv' x) s))"
+    by(clarsimp simp add: inline_sel split: sum.split_asm)
+  from Inr \<open>\<I> \<turnstile>g gpv \<surd>\<close> \<open>I s\<close> have ?out by(rule WT_gpv_inline1)
+  moreover have "?cont TYPE('ret \<times> 's)" (is "\<forall>input\<in>_. _ \<or> _ \<or> ?case' input")
+  proof(rule ballI disjI2)+
+    fix input
+    assume "input \<in> responses_\<I> \<I>' out"
+    with Inr \<open>\<I> \<turnstile>g gpv \<surd> \<close> \<open>I s\<close> have "\<I>' \<turnstile>g callee' input \<surd>"
+      and "\<And>x s'. (x, s') \<in> results_gpv \<I>' (callee' input) \<Longrightarrow> \<I> \<turnstile>g rpv' x \<surd> \<and> I s'"
+      by(blast dest: WT_gpv_inline1)+
+    then show "?case' input" by(subst c)(auto 4 5)
+  qed
+  ultimately show "?case TYPE('ret \<times> 's)" ..
+qed
+
+end
+
+lemma WT_gpv_inline':
+  assumes "\<And>s x. x \<in> outs_\<I> \<I> \<Longrightarrow> results_gpv \<I>' (callee s x) \<subseteq> responses_\<I> \<I> x \<times> UNIV"
+    and "\<And>x s. x \<in> outs_\<I> \<I> \<Longrightarrow> \<I>' \<turnstile>g callee s x \<surd>"
+    and "\<I> \<turnstile>g gpv \<surd>"
+  shows "\<I>' \<turnstile>g inline callee gpv s \<surd>"
+proof -
+  interpret raw_converter_invariant \<I> \<I>' callee "\<lambda>_. True" 
+    using assms by(unfold_locales)auto
+  show ?thesis by(rule WT_gpv_inline_invar)(use assms in auto)
+qed
+
+lemma results_gpv_sub_gvps: "gpv' \<in> sub_gpvs \<I> gpv \<Longrightarrow> results_gpv \<I> gpv' \<subseteq> results_gpv \<I> gpv"
+  by(induction rule: sub_gpvs.induct)(auto intro: results_gpv.IO)
+
+lemma in_results_gpv_sub_gvps: "\<lbrakk> x \<in> results_gpv \<I> gpv'; gpv' \<in> sub_gpvs \<I> gpv \<rbrakk> \<Longrightarrow> x \<in> results_gpv \<I> gpv"
+  using results_gpv_sub_gvps[of gpv' \<I> gpv] by blast
+
+context raw_converter_invariant begin
+lemma results_gpv_inline_aux:
+  assumes "(x, s') \<in> results_gpv \<I>' (inline_aux callee y)"
+  shows "\<lbrakk> y = Inl (gpv, s); \<I> \<turnstile>g gpv \<surd>; I s \<rbrakk> \<Longrightarrow> x \<in> results_gpv \<I> gpv \<and> I s'"
+    and "\<lbrakk> y = Inr (rpv, callee'); \<forall>(z, s') \<in> results_gpv \<I>' callee'. \<I> \<turnstile>g rpv z \<surd> \<and> I s' \<rbrakk>
+    \<Longrightarrow> \<exists>(z, s'') \<in> results_gpv \<I>' callee'. x \<in> results_gpv \<I> (rpv z) \<and> I s'' \<and> I s'"
+  using assms
+proof(induction gvp'\<equiv>"inline_aux callee y" arbitrary: y gpv s rpv callee')
+  case Pure case 1
+  with Pure show ?case
+    by(auto simp add: inline_aux.sel split: sum.split_asm dest: inline1_Inl_results_gpv)
+next
+  case Pure case 2
+  with Pure show ?case
+    by(clarsimp simp add: inline_aux.sel split: sum.split_asm)
+      (fastforce split: generat.split_asm dest: inline1_Inl_results_gpv intro: results_gpv.Pure)+
+next
+  case (IO out c input) case 1
+  with IO(1) obtain rpv rpv' where inline1: "Inr (out, rpv, rpv') \<in> set_spmf (inline1 callee gpv s)"
+    and c: "c = (\<lambda>input. inline_aux callee (Inr (rpv', rpv input)))"
+    by(auto simp add: inline_aux.sel split: sum.split_asm)
+  from inline1[THEN inline1_in_sub_gpvs, OF _ \<open>input \<in> responses_\<I> \<I>' out\<close> _ \<open>I s\<close>] \<open>\<I> \<turnstile>g gpv \<surd>\<close>
+  have "\<forall>(z, s')\<in>results_gpv \<I>' (rpv input). \<I> \<turnstile>g rpv' z \<surd> \<and> I s'"
+    by(auto intro: WT_sub_gpvsD)
+  from IO(5)[unfolded c, OF refl refl this] obtain input' s'' 
+    where input': "(input', s'') \<in> results_gpv \<I>' (rpv input)" 
+      and x: "x \<in> results_gpv \<I> (rpv' input')" and s'': "I s''" "I s'"
+    by auto
+  from inline1[THEN inline1_in_sub_gpvs, OF input' \<open>input \<in> responses_\<I> \<I>' out\<close> \<open>\<I> \<turnstile>g gpv \<surd>\<close> \<open>I s\<close>] s'' x
+  show ?case by(auto intro: in_results_gpv_sub_gvps)
+next
+  case (IO out c input) case 2
+  from IO(1) "2"(1) consider (Pure) input' s'' rpv' rpv''
+    where "Pure (input', s'') \<in> set_spmf (the_gpv callee')" "Inr (out, rpv', rpv'') \<in> set_spmf (inline1 callee (rpv input') s'')"
+      "c = (\<lambda>input. inline_aux callee (Inr (rpv'', rpv' input)))"
+    | (Cont) rpv' where "IO out rpv' \<in> set_spmf (the_gpv callee')" "c = (\<lambda>input. inline_aux callee (Inr (rpv, rpv' input)))"
+    by(auto simp add: inline_aux.sel split: sum.split_asm; rename_tac generat; case_tac generat; clarsimp)
+  then show ?case
+  proof cases
+    case Pure
+    have res: "(input', s'') \<in> results_gpv \<I>' callee'" using Pure(1) by(rule results_gpv.Pure)
+    with 2 have WT: "\<I> \<turnstile>g rpv input' \<surd>" "I s''" by auto
+    have "\<forall>(z, s')\<in>results_gpv \<I>' (rpv' input). \<I> \<turnstile>g rpv'' z \<surd> \<and> I s'"
+      using inline1_in_sub_gpvs[OF Pure(2) _ \<open>input \<in> _\<close> WT] WT by(auto intro: WT_sub_gpvsD)
+    from IO(5)[unfolded Pure(3), OF refl refl this] obtain z s'''
+      where z: "(z, s''') \<in> results_gpv \<I>' (rpv' input)"
+        and x: "x \<in> results_gpv \<I> (rpv'' z)" and s': "I s'''" "I s'" by auto
+    have "x \<in> results_gpv \<I> (rpv input')" using x inline1_in_sub_gpvs[OF Pure(2) z \<open>input \<in> _\<close> WT]
+      by(auto intro: in_results_gpv_sub_gvps)
+    then show ?thesis using res WT s' by auto
+  next
+    case Cont
+    have "\<forall>(z, s')\<in>results_gpv \<I>' (rpv' input). \<I> \<turnstile>g rpv z \<surd> \<and> I s'" 
+      using Cont 2 \<open>input \<in> responses_\<I> \<I>' out\<close> by(auto intro: results_gpv.IO)
+    from IO(5)[unfolded Cont, OF refl refl this] obtain z s'' 
+      where "(z, s'') \<in> results_gpv \<I>' (rpv' input)" "x \<in> results_gpv \<I> (rpv z)" "I s''" "I s'" by auto
+    then show ?thesis using Cont(1) \<open>input \<in> _\<close> by(auto intro: results_gpv.IO)
+  qed
+qed
+
+lemma results_gpv_inline: 
+  "\<lbrakk>(x, s') \<in> results_gpv \<I>' (inline callee gpv s); \<I> \<turnstile>g gpv \<surd>; I s\<rbrakk> \<Longrightarrow> x \<in> results_gpv \<I> gpv \<and> I s'"
+  unfolding inline_def by(rule results_gpv_inline_aux(1)[OF _ refl])
+
+end
+
+lemma inline_map_gpv:
+  "inline callee (map_gpv f g gpv) s = map_gpv (apfst f) id (inline (\<lambda>s x. callee s (g x)) gpv s)"
+  unfolding apfst_def
+  by(rule inline_parametric
+      [where S="BNF_Def.Grp UNIV id" and C="BNF_Def.Grp UNIV g" and C'="BNF_Def.Grp UNIV id" and A="BNF_Def.Grp UNIV f",
+        THEN rel_funD, THEN rel_funD, THEN rel_funD,
+        unfolded gpv.rel_Grp prod.rel_Grp, simplified, folded eq_alt, unfolded Grp_def, simplified])
+    (auto simp add: rel_fun_def relator_eq)
+
 subsection \<open>Running GPVs\<close>
 
 type_synonym ('call, 'ret, 's) callee = "'s \<Rightarrow> 'call \<Rightarrow> ('ret \<times> 's) spmf"
 
 context fixes callee :: "('call, 'ret, 's) callee" notes [[function_internals]] begin
 
 partial_function (spmf) exec_gpv :: "('a, 'call, 'ret) gpv \<Rightarrow> 's \<Rightarrow> ('a \<times> 's) spmf"
 where
   "exec_gpv c s =
    the_gpv c \<bind>
      case_generat (\<lambda>x. return_spmf (x, s))
      (\<lambda>out c. callee s out \<bind> (\<lambda>(x, y). exec_gpv (c x) y))"
 
 abbreviation run_gpv :: "('a, 'call, 'ret) gpv \<Rightarrow> 's \<Rightarrow> 'a spmf"
 where "run_gpv gpv s \<equiv> map_spmf fst (exec_gpv gpv s)"
 
 lemma exec_gpv_fixp_induct [case_names adm bottom step]:
   assumes "ccpo.admissible (fun_lub lub_spmf) (fun_ord (ord_spmf (=))) (\<lambda>f. P (\<lambda>c s. f (c, s)))"
   and "P (\<lambda>_ _. return_pmf None)"
   and "\<And>exec_gpv. P exec_gpv \<Longrightarrow> 
      P (\<lambda>c s. the_gpv c \<bind> case_generat (\<lambda>x. return_spmf (x, s)) (\<lambda>out c. callee s out \<bind> (\<lambda>(x, y). exec_gpv (c x) y)))"
   shows "P exec_gpv"
 using assms(1)
 by(rule exec_gpv.fixp_induct[unfolded curry_conv[abs_def]])(simp_all add: assms(2-))
 
 lemma exec_gpv_fixp_induct_strong [case_names adm bottom step]:
   assumes "ccpo.admissible (fun_lub lub_spmf) (fun_ord (ord_spmf (=))) (\<lambda>f. P (\<lambda>c s. f (c, s)))"
   and "P (\<lambda>_ _. return_pmf None)"
   and "\<And>exec_gpv'. \<lbrakk> \<And>c s. ord_spmf (=) (exec_gpv' c s) (exec_gpv c s); P exec_gpv' \<rbrakk>
     \<Longrightarrow> P (\<lambda>c s. the_gpv c \<bind> case_generat (\<lambda>x. return_spmf (x, s)) (\<lambda>out c. callee s out \<bind> (\<lambda>(x, y). exec_gpv' (c x) y)))"
   shows "P exec_gpv"
 using assms
 by(rule spmf.fixp_strong_induct_uc[where P="\<lambda>f. P (curry f)" and U=case_prod and C=curry, OF exec_gpv.mono exec_gpv_def, simplified curry_case_prod, simplified curry_conv[abs_def] fun_ord_def split_paired_All prod.case case_prod_eta, OF refl]) blast
 
 lemma exec_gpv_fixp_induct_strong2 [case_names adm bottom step]:
   assumes "ccpo.admissible (fun_lub lub_spmf) (fun_ord (ord_spmf (=))) (\<lambda>f. P (\<lambda>c s. f (c, s)))"
   and "P (\<lambda>_ _. return_pmf None)"
   and "\<And>exec_gpv'.
     \<lbrakk> \<And>c s. ord_spmf (=) (exec_gpv' c s) (exec_gpv c s); 
       \<And>c s. ord_spmf (=) (exec_gpv' c s) (the_gpv c \<bind> case_generat (\<lambda>x. return_spmf (x, s)) (\<lambda>out c. callee s out \<bind> (\<lambda>(x, y). exec_gpv' (c x) y)));
       P exec_gpv' \<rbrakk>
     \<Longrightarrow> P (\<lambda>c s. the_gpv c \<bind> case_generat (\<lambda>x. return_spmf (x, s)) (\<lambda>out c. callee s out \<bind> (\<lambda>(x, y). exec_gpv' (c x) y)))"
   shows "P exec_gpv"
 using assms
 by(rule spmf.fixp_induct_strong2_uc[where P="\<lambda>f. P (curry f)" and U=case_prod and C=curry, OF exec_gpv.mono exec_gpv_def, simplified curry_case_prod, simplified curry_conv[abs_def] fun_ord_def split_paired_All prod.case case_prod_eta, OF refl]) blast+
 
 end
 
 lemma exec_gpv_conv_inline1:
   "exec_gpv callee gpv s = map_spmf projl (inline1 (\<lambda>s c. lift_spmf (callee s c) :: (_, unit, unit) gpv) gpv s)"
 by(induction arbitrary: gpv s rule: parallel_fixp_induct_2_2[OF partial_function_definitions_spmf partial_function_definitions_spmf exec_gpv.mono inline1.mono exec_gpv_def inline1_def, unfolded lub_spmf_empty, case_names adm bottom step])
   (auto simp add: map_spmf_bind_spmf o_def spmf.map_comp bind_map_spmf split_def intro!: bind_spmf_cong[OF refl] split: generat.split)
 
 lemma exec_gpv_simps:
   "exec_gpv callee gpv s =
    the_gpv gpv \<bind>
      case_generat (\<lambda>x. return_spmf (x, s))
      (\<lambda>out rpv. callee s out \<bind> (\<lambda>(x, y). exec_gpv callee (rpv x) y))"
 by(fact exec_gpv.simps)
 
 lemma exec_gpv_lift_spmf [simp]:
   "exec_gpv callee (lift_spmf p) s = bind_spmf p (\<lambda>x. return_spmf (x, s))"
 by(simp add: exec_gpv_conv_inline1 spmf.map_comp o_def map_spmf_conv_bind_spmf)
 
 lemma exec_gpv_Done [simp]: "exec_gpv callee (Done x) s = return_spmf (x, s)"
 by(simp add: exec_gpv_conv_inline1)
 
 lemma exec_gpv_Fail [simp]: "exec_gpv callee Fail s = return_pmf None"
 by(simp add: exec_gpv_conv_inline1)
 
 lemma if_distrib_exec_gpv [if_distribs]:
   "exec_gpv callee (if b then x else y) s = (if b then exec_gpv callee x s else exec_gpv callee y s)"
 by simp
 
 lemmas exec_gpv_fixp_parallel_induct [case_names adm bottom step] =
   parallel_fixp_induct_2_2[OF partial_function_definitions_spmf partial_function_definitions_spmf exec_gpv.mono exec_gpv.mono exec_gpv_def exec_gpv_def, unfolded lub_spmf_empty]
 
 context includes lifting_syntax begin
 
 lemma exec_gpv_parametric':
   "((S ===> CALL ===> rel_spmf (rel_prod R S)) ===> rel_gpv'' A CALL R ===> S ===> rel_spmf (rel_prod A S))
   exec_gpv exec_gpv"
 apply(rule rel_funI)+
 apply(unfold spmf_rel_map exec_gpv_conv_inline1)
 apply(rule rel_spmf_mono_strong)
  apply(erule inline1_parametric'[THEN rel_funD, THEN rel_funD, THEN rel_funD, rotated])
   prefer 3
   apply(drule in_set_inline1_lift_spmf1)+
   apply fastforce
  subgoal by simp
 subgoal premises [transfer_rule]
   supply lift_spmf_parametric'[transfer_rule] by transfer_prover
 done
 
 lemma exec_gpv_parametric [transfer_rule]:
   "((S ===> CALL ===> rel_spmf (rel_prod ((=) :: 'ret \<Rightarrow> _) S)) ===> rel_gpv A CALL ===> S ===> rel_spmf (rel_prod A S))
   exec_gpv exec_gpv"
 unfolding rel_gpv_conv_rel_gpv'' by(rule exec_gpv_parametric')
 
 end
 
 lemma exec_gpv_bind: "exec_gpv callee (c \<bind> f) s = exec_gpv callee c s \<bind> (\<lambda>(x, s') \<Rightarrow> exec_gpv callee (f x) s')"
 by(auto simp add: exec_gpv_conv_inline1 inline1_bind_gpv map_spmf_bind_spmf o_def bind_map_spmf intro!: bind_spmf_cong[OF refl] dest: in_set_inline1_lift_spmf1)
 
 lemma exec_gpv_map_gpv_id:
   "exec_gpv oracle (map_gpv f id gpv) \<sigma> = map_spmf (apfst f) (exec_gpv oracle gpv \<sigma>)"
 proof(rule sym)
   define gpv' where "gpv' = map_gpv f id gpv"
   have [transfer_rule]: "rel_gpv (\<lambda>x y. y = f x) (=) gpv gpv'"
     unfolding gpv'_def by(simp add: gpv.rel_map gpv.rel_refl)
   have "rel_spmf (rel_prod (\<lambda>x y. y = f x) (=)) (exec_gpv oracle gpv \<sigma>) (exec_gpv oracle gpv' \<sigma>)"
     by transfer_prover
   thus "map_spmf (apfst f) (exec_gpv oracle gpv \<sigma>) = exec_gpv oracle (map_gpv f id gpv) \<sigma>"
     unfolding spmf_rel_eq[symmetric] gpv'_def spmf_rel_map by(rule rel_spmf_mono) clarsimp
 qed
 
 lemma exec_gpv_Pause [simp]:
   "exec_gpv callee (Pause out f) s = callee s out \<bind> (\<lambda>(x, s'). exec_gpv callee (f x) s')"
 by(simp add: inline1_Pause map_spmf_bind_spmf bind_map_spmf o_def exec_gpv_conv_inline1 split_def)
 
 lemma exec_gpv_bind_lift_spmf:
   "exec_gpv callee (bind_gpv (lift_spmf p) f) s = bind_spmf p (\<lambda>x. exec_gpv callee (f x) s)"
 by(simp add: exec_gpv_bind)
 
 lemma exec_gpv_bind_option [simp]:
   "exec_gpv oracle (monad.bind_option Fail x f) s = monad.bind_option (return_pmf None) x (\<lambda>a. exec_gpv oracle (f a) s)"
 by(cases x) simp_all
 
 lemma pred_spmf_exec_gpv:
   \<comment> \<open>We don't get an equivalence here because states are threaded through in @{const exec_gpv}.\<close>
   "\<lbrakk> pred_gpv A C gpv; pred_fun S (pred_fun C (pred_spmf (pred_prod (\<lambda>_. True) S))) callee; S s \<rbrakk>
   \<Longrightarrow> pred_spmf (pred_prod A S) (exec_gpv callee gpv s)"
 using exec_gpv_parametric[of "eq_onp S" "eq_onp C" "eq_onp A", folded eq_onp_True]
 apply(unfold prod.rel_eq_onp option.rel_eq_onp pmf.rel_eq_onp gpv.rel_eq_onp)
 apply(drule rel_funD[where x=callee and y=callee])
  subgoal
    apply(rule rel_fun_mono[where X="eq_onp S"])
      apply(rule rel_fun_eq_onpI)
      apply(unfold eq_onp_same_args)
      apply assumption
     apply simp
    apply(erule rel_fun_eq_onpI)
    done
 apply(auto dest!: rel_funD simp add: eq_onp_def)
 done
 
 lemma exec_gpv_inline:
   fixes callee :: "('c, 'r, 's) callee"
   and gpv :: "'s' \<Rightarrow> 'c' \<Rightarrow> ('r' \<times> 's', 'c, 'r) gpv"
   shows "exec_gpv callee (inline gpv c' s') s =
     map_spmf (\<lambda>(x, s', s). ((x, s'), s)) (exec_gpv (\<lambda>(s', s) y. map_spmf (\<lambda>((x, s'), s). (x, s', s)) (exec_gpv callee (gpv s' y) s)) c' (s', s))"
     (is "?lhs = ?rhs")
 proof -
   have "?lhs = map_spmf projl (map_spmf (map_sum (\<lambda>(x, s2, y). ((x, s2), y))
         (\<lambda>(x, rpv'' :: ('r \<times> 's, unit, unit) rpv, rpv', rpv). (x, rpv'', \<lambda>r1. bind_gpv (rpv' r1) (\<lambda>(r2, y). inline gpv (rpv r2) y))))
       (inline2 (\<lambda>s c. lift_spmf (callee s c)) gpv c' s' s))"
     unfolding exec_gpv_conv_inline1 by(simp add: inline1_inline_conv_inline2)
   also have "\<dots> = map_spmf (\<lambda>(x, s', s). ((x, s'), s)) (map_spmf projl (map_spmf (map_sum id
         (\<lambda>(x, rpv'' :: ('r \<times> 's, unit, unit) rpv, rpv', rpv). (x, \<lambda>r. bind_gpv (rpv'' r) (\<lambda>(r1, s1). map_gpv (\<lambda>((r2, s2), s1). (r2, s2, s1)) id (inline (\<lambda>s c. lift_spmf (callee s c)) (rpv' r1) s1)), rpv)))
       (inline2 (\<lambda>s c. lift_spmf (callee s c)) gpv c' s' s)))"
    unfolding spmf.map_comp by(rule map_spmf_cong[OF refl])(auto dest!: in_set_inline2_lift_spmf1)
   also have "\<dots> = ?rhs" unfolding exec_gpv_conv_inline1
     by(subst inline1_inline_conv_inline2'[symmetric])(simp add: spmf.map_comp split_def inline_lift_spmf1 map_lift_spmf)
   finally show ?thesis .
 qed
 
 lemma ord_spmf_exec_gpv:
   assumes callee: "\<And>s x. ord_spmf (=) (callee1 s x) (callee2 s x)"
   shows "ord_spmf (=) (exec_gpv callee1 gpv s) (exec_gpv callee2 gpv s)"
 proof(induction arbitrary: gpv s rule: exec_gpv_fixp_parallel_induct)
   case adm show ?case by simp
   case bottom show ?case by simp
 next
   case (step exec_gpv1 exec_gpv2)
   show ?case using step.prems
     by(clarsimp intro!: ord_spmf_bind_reflI ord_spmf_bindI[OF assms] step.IH split!: generat.split)
 qed
 
 context fixes callee :: "('call, 'ret, 's) callee" notes [[function_internals]] begin
 
 partial_function (spmf) execp_resumption :: "('a, 'call, 'ret) resumption \<Rightarrow> 's \<Rightarrow> ('a \<times> 's) spmf"
 where
   "execp_resumption r s = (case r of resumption.Done x \<Rightarrow> return_pmf (map_option (\<lambda>a. (a, s)) x)
       | resumption.Pause out c \<Rightarrow> bind_spmf (callee s out) (\<lambda>(input, s'). execp_resumption (c input) s'))"
 
 simps_of_case execp_resumption_simps [simp]: execp_resumption.simps
 
 lemma execp_resumption_ABORT [simp]: "execp_resumption ABORT s = return_pmf None"
 by(simp add: ABORT_def)
 
 lemma execp_resumption_DONE [simp]: "execp_resumption (DONE x) s = return_spmf (x, s)"
 by(simp add: DONE_def)
 
 lemma exec_gpv_lift_resumption: "exec_gpv callee (lift_resumption r) s = execp_resumption r s"
 proof(induction arbitrary: r s rule: parallel_fixp_induct_2_2[OF partial_function_definitions_spmf partial_function_definitions_spmf exec_gpv.mono execp_resumption.mono exec_gpv_def execp_resumption_def, case_names adm bot step])
   case adm show ?case by(simp)
   case bot thus ?case by simp
   case (step exec_gpv' execp_resumption')
   show ?case
     by(auto split: resumption.split option.split simp add: lift_resumption.sel intro: bind_spmf_cong step)
 qed
 
 lemma mcont2mcont_execp_resumption [THEN spmf.mcont2mcont, cont_intro, simp]:
   shows mcont_execp_resumption:
   "mcont resumption_lub resumption_ord lub_spmf (ord_spmf (=)) (\<lambda>r. execp_resumption r s)"
 proof -
   have "mcont (prod_lub resumption_lub the_Sup) (rel_prod resumption_ord (=)) lub_spmf (ord_spmf (=)) (case_prod execp_resumption)"
   proof(rule ccpo.fixp_preserves_mcont2[OF ccpo_spmf execp_resumption.mono execp_resumption_def])
     fix execp_resumption' :: "('b, 'call, 'ret) resumption \<Rightarrow> 's \<Rightarrow> ('b \<times> 's) spmf"
     assume *: "mcont (prod_lub resumption_lub the_Sup) (rel_prod resumption_ord (=)) lub_spmf (ord_spmf (=)) (\<lambda>(r, s). execp_resumption' r s)"
     have [THEN spmf.mcont2mcont, cont_intro, simp]: "mcont resumption_lub resumption_ord lub_spmf (ord_spmf (=)) (\<lambda>r. execp_resumption' r s)" 
       for s using * by simp
     have "mcont resumption_lub resumption_ord lub_spmf (ord_spmf (=))
       (\<lambda>r. case r of resumption.Done x \<Rightarrow> return_pmf (map_option (\<lambda>a. (a, s)) x)
            | resumption.Pause out c \<Rightarrow> bind_spmf (callee s out) (\<lambda>(input, s'). execp_resumption' (c input) s'))"
       for s by(rule mcont_case_resumption)(auto simp add: ccpo_spmf intro!: mcont_bind_spmf)
     thus "mcont (prod_lub resumption_lub the_Sup) (rel_prod resumption_ord (=)) lub_spmf (ord_spmf (=))
           (\<lambda>(r, s). case r of resumption.Done x \<Rightarrow> return_pmf (map_option (\<lambda>a. (a, s)) x)
               | resumption.Pause out c \<Rightarrow> bind_spmf (callee s out) (\<lambda>(input, s'). execp_resumption' (c input) s'))"
       by simp
   qed
   thus ?thesis by auto
 qed
 
 
 lemma execp_resumption_bind [simp]:
   "execp_resumption (r \<bind> f) s = execp_resumption r s \<bind> (\<lambda>(x, s'). execp_resumption (f x) s')"
 by(simp add: exec_gpv_lift_resumption[symmetric] lift_resumption_bind exec_gpv_bind)
 
 lemma pred_spmf_execp_resumption:
   "\<And>A. \<lbrakk> pred_resumption A C r; pred_fun S (pred_fun C (pred_spmf (pred_prod (\<lambda>_. True) S))) callee; S s \<rbrakk>
   \<Longrightarrow> pred_spmf (pred_prod A S) (execp_resumption r s)"
 unfolding exec_gpv_lift_resumption[symmetric]
 by(rule pred_spmf_exec_gpv) simp_all
 
 end
 
 inductive WT_callee :: "('call, 'ret) \<I> \<Rightarrow> ('call \<Rightarrow> ('ret \<times> 's) spmf) \<Rightarrow> bool" ("(_) \<turnstile>c/ (_) \<surd>" [100, 0] 99)
   for \<I> callee
 where
   WT_callee:
   "\<lbrakk> \<And>call ret s. \<lbrakk> call \<in> outs_\<I> \<I>; (ret, s) \<in> set_spmf (callee call) \<rbrakk> \<Longrightarrow> ret \<in> responses_\<I> \<I> call \<rbrakk>
   \<Longrightarrow> \<I> \<turnstile>c callee \<surd>"
 
 lemmas WT_calleeI = WT_callee
 hide_fact WT_callee
 
 lemma WT_calleeD: "\<lbrakk> \<I> \<turnstile>c callee \<surd>; (ret, s) \<in> set_spmf (callee out); out \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> ret \<in> responses_\<I> \<I> out"
 by(rule WT_callee.cases)
 
 lemma WT_callee_full [intro!, simp]: "\<I>_full \<turnstile>c callee \<surd>"
 by(rule WT_calleeI) simp
 
 lemma WT_callee_parametric [transfer_rule]:
   includes lifting_syntax 
   assumes [transfer_rule]: "bi_unique R"
   shows "(rel_\<I> C R ===> (C ===> rel_spmf (rel_prod R S)) ===> (=)) WT_callee WT_callee"
 proof -
   have *: "WT_callee = (\<lambda>\<I> callee. \<forall>call\<in> outs_\<I> \<I>. \<forall>(ret, s) \<in> set_spmf (callee call). ret \<in> responses_\<I> \<I> call)"
     unfolding WT_callee.simps by blast
   show ?thesis unfolding * by transfer_prover
 qed
 
 locale callee_invariant_on_base =
   fixes callee :: "'s \<Rightarrow> 'a \<Rightarrow> ('b \<times> 's) spmf"
   and I :: "'s \<Rightarrow> bool"
   and \<I> :: "('a, 'b) \<I>"
 
 locale callee_invariant_on = callee_invariant_on_base callee I \<I>
   for callee :: "'s \<Rightarrow> 'a \<Rightarrow> ('b \<times> 's) spmf"
   and I :: "'s \<Rightarrow> bool"
   and \<I> :: "('a, 'b) \<I>"
   +
   assumes callee_invariant: "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); I s; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> I s'"
   and WT_callee: "\<And>s. I s \<Longrightarrow> \<I> \<turnstile>c callee s \<surd>"
 begin
 
 lemma callee_invariant': "\<lbrakk> (y, s') \<in> set_spmf (callee s x); I s; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> I s' \<and> y \<in> responses_\<I> \<I> x"
 by(auto dest: WT_calleeD[OF WT_callee] callee_invariant)
 
 lemma exec_gpv_invariant':
   "\<lbrakk> I s; \<I> \<turnstile>g gpv \<surd> \<rbrakk> \<Longrightarrow> set_spmf (exec_gpv callee gpv s) \<subseteq> {(x, s'). I s'}"
 proof(induction arbitrary: gpv s rule: exec_gpv_fixp_induct)
   case adm show ?case by(intro cont_intro ccpo_class.admissible_leI)
   case bottom show ?case by simp
   case step show ?case using step.prems
     by(auto simp add: bind_UNION intro!: UN_least step.IH del: subsetI split: generat.split dest!: callee_invariant' elim: WT_gpvD)
 qed
 
 lemma exec_gpv_invariant:
   "\<lbrakk> (x, s') \<in> set_spmf (exec_gpv callee gpv s); I s; \<I> \<turnstile>g gpv \<surd> \<rbrakk> \<Longrightarrow> I s'"
 by(drule exec_gpv_invariant') blast+
 
 lemma interaction_bounded_by_exec_gpv_count':
   fixes count
   assumes bound: "interaction_bounded_by consider gpv n"
   and count: "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); I s; consider x; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> count s' \<le> eSuc (count s)"
   and ignore: "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); I s; \<not> consider x; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> count s' \<le> count s"
   and WT: "\<I> \<turnstile>g gpv \<surd>"
   and I: "I s"
   shows "set_spmf (exec_gpv callee gpv s) \<subseteq> {(x, s'). count s' \<le> n + count s}"
 using bound I WT
 proof(induction arbitrary: gpv s n rule: exec_gpv_fixp_induct)
   case adm show ?case by(intro cont_intro ccpo_class.admissible_leI)
   case bottom show ?case by simp
   case (step exec_gpv')
   have "set_spmf (exec_gpv' (c input) s') \<subseteq> {(x, s''). count s'' \<le> n + count s}"
     if out: "IO out c \<in> set_spmf (the_gpv gpv)"
     and input: "(input, s') \<in> set_spmf (callee s out)"
     and X: "out \<in> outs_\<I> \<I>"
     for out c input s'
   proof(cases "consider out")
     case True
     with step.prems out have "n > 0"
       and bound': "interaction_bounded_by consider (c input) (n - 1)"
       by(auto dest: interaction_bounded_by_contD)
     note bound'
     moreover from input \<open>I s\<close> X have "I s'" by(rule callee_invariant)
     moreover have "\<I> \<turnstile>g c input \<surd>" using step.prems(3) out WT_calleeD[OF WT_callee input]
       by(rule WT_gpvD)(rule step.prems X)+
     ultimately have "set_spmf (exec_gpv' (c input) s') \<subseteq> {(x, s''). count s'' \<le> n - 1 + count s'}"      
       by(rule step.IH)
     also have "\<dots> \<subseteq> {(x, s''). count s'' \<le> n + count s}" using \<open>n > 0\<close> count[OF input \<open>I s\<close> True X]     
       by(cases n rule: co.enat.exhaust)(auto, metis add_left_mono_trans eSuc_plus iadd_Suc_right)
     finally show ?thesis .
   next
     case False
     from step.prems out this have bound': "interaction_bounded_by consider (c input) n"
       by(auto dest: interaction_bounded_by_contD_ignore)
     from input \<open>I s\<close> X have "I s'" by(rule callee_invariant)
     note bound'
     moreover from input \<open>I s\<close> X have "I s'" by(rule callee_invariant)
     moreover have "\<I> \<turnstile>g c input \<surd>" using step.prems(3) out WT_calleeD[OF WT_callee input]
       by(rule WT_gpvD)(rule step.prems X)+
     ultimately have "set_spmf (exec_gpv' (c input) s') \<subseteq> {(x, s''). count s'' \<le> n + count s'}"
       by(rule step.IH)
     also have "\<dots> \<subseteq> {(x, s''). count s'' \<le> n + count s}"
       using ignore[OF input \<open>I s\<close> False X] by(auto elim: order_trans)
     finally show ?thesis .
   qed
   then show ?case using step.prems(3)
     by(auto 4 3 simp add: bind_UNION del: subsetI intro!: UN_least split: generat.split dest: WT_gpvD)
 qed
 
 lemma interaction_bounded_by_exec_gpv_count:
   fixes count
   assumes bound: "interaction_bounded_by consider gpv n"
   and xs': "(x, s') \<in> set_spmf (exec_gpv callee gpv s)"
   and count: "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); I s; consider x; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> count s' \<le> eSuc (count s)"
   and ignore: "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); I s; \<not> consider x; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> count s' \<le> count s"
   and WT: "\<I> \<turnstile>g gpv \<surd>"
   and I: "I s"
   shows "count s' \<le> n + count s"
 using bound count ignore WT I 
 by(rule interaction_bounded_by_exec_gpv_count'[THEN subsetD, OF _ _ _ _ _ xs', unfolded mem_Collect_eq prod.case])
 
 lemma interaction_bounded_by'_exec_gpv_count:
   fixes count
   assumes bound: "interaction_bounded_by' consider gpv n"
   and xs': "(x, s') \<in> set_spmf (exec_gpv callee gpv s)"
   and count: "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); I s; consider x; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> count s' \<le> Suc (count s)"
   and ignore: "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); I s; \<not> consider x; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> count s' \<le> count s"
   and outs: "\<I> \<turnstile>g gpv \<surd>"
   and I: "I s"
   shows "count s' \<le> n + count s"
 using interaction_bounded_by_exec_gpv_count[OF bound xs', of count] count ignore outs I
 by(simp add: eSuc_enat)
 
 lemma pred_spmf_calleeI: "\<lbrakk> I s; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> pred_spmf (pred_prod (\<lambda>_. True) I) (callee s x)"
 by(auto simp add: pred_spmf_def dest: callee_invariant)
 
 lemma lossless_exec_gpv:
   assumes gpv: "lossless_gpv \<I> gpv"
   and callee: "\<And>s out. \<lbrakk> out \<in> outs_\<I> \<I>; I s \<rbrakk> \<Longrightarrow> lossless_spmf (callee s out)"
   and WT_gpv: "\<I> \<turnstile>g gpv \<surd>"
   and I: "I s"
   shows "lossless_spmf (exec_gpv callee gpv s)"
 using gpv WT_gpv I
 proof(induction arbitrary: s rule: lossless_WT_gpv_induct)
   case (lossless_gpv gpv)
   show ?case using lossless_gpv.hyps lossless_gpv.prems
     by(subst exec_gpv.simps)(fastforce split: generat.split simp add: callee intro!: lossless_gpv.IH intro: WT_calleeD[OF WT_callee] elim!: callee_invariant)
 qed
 
 lemma in_set_spmf_exec_gpv_into_results_gpv:
   assumes *: "(x, s') \<in> set_spmf (exec_gpv callee gpv s)"
   and WT_gpv : "\<I> \<turnstile>g gpv \<surd>"
   and I: "I s"
   shows "x \<in> results_gpv \<I> gpv"
 proof -
   have "set_spmf (exec_gpv callee gpv s) \<subseteq> results_gpv \<I> gpv \<times> UNIV"
     using WT_gpv I
   proof(induction arbitrary: gpv s rule: exec_gpv_fixp_induct)
     { case adm show ?case by(intro cont_intro ccpo_class.admissible_leI) }
     { case bottom show ?case by simp }
     case (step exec_gpv')
     { fix out c ret s'
       assume IO: "IO out c \<in> set_spmf (the_gpv gpv)"
         and ret: "(ret, s') \<in> set_spmf (callee s out)"
       from step.prems(1) IO have "out \<in> outs_\<I> \<I>" by(rule WT_gpvD)
       with WT_callee[OF \<open>I s\<close>] ret have "ret \<in> responses_\<I> \<I> out" by(rule WT_calleeD)
       with step.prems(1) IO have "\<I> \<turnstile>g c ret \<surd>" by(rule WT_gpvD)
       moreover from ret \<open>I s\<close> \<open>out \<in> outs_\<I> \<I>\<close> have "I s'" by(rule callee_invariant)
       ultimately have "set_spmf (exec_gpv' (c ret) s') \<subseteq> results_gpv \<I> (c ret) \<times> UNIV"
         by(rule step.IH)
       also have "\<dots> \<subseteq> results_gpv \<I> gpv \<times> UNIV" using IO \<open>ret \<in> _\<close>
         by(auto intro: results_gpv.IO)
       finally have "set_spmf (exec_gpv' (c ret) s') \<subseteq> results_gpv \<I> gpv \<times> UNIV" . }
     then show ?case using step.prems
       by(auto simp add: bind_UNION intro!: UN_least del: subsetI split: generat.split intro: results_gpv.Pure)
   qed
   thus "x \<in> results_gpv \<I> gpv" using * by blast+
 qed
 
 end
 
 lemma callee_invariant_on_alt_def:
   "callee_invariant_on = (\<lambda>callee I \<I>.
     (\<forall>s \<in> Collect I. \<forall>x \<in> outs_\<I> \<I>. \<forall>(y, s') \<in> set_spmf (callee s x). I s') \<and>
     (\<forall>s \<in> Collect I. \<I> \<turnstile>c callee s \<surd>))"
 unfolding callee_invariant_on_def by blast
 
 lemma callee_invariant_on_parametric [transfer_rule]: includes lifting_syntax
   assumes [transfer_rule]: "bi_unique R" "bi_total S"
   shows "((S ===> C ===> rel_spmf (rel_prod R S)) ===> (S ===> (=)) ===> rel_\<I> C R ===> (=))
     callee_invariant_on callee_invariant_on"
 unfolding callee_invariant_on_alt_def by transfer_prover
 
 lemma callee_invariant_on_cong:
   "\<lbrakk> I = I'; outs_\<I> \<I> = outs_\<I> \<I>'; 
     \<And>s x. \<lbrakk> I' s; x \<in> outs_\<I> \<I>' \<rbrakk> \<Longrightarrow> set_spmf (callee s x) \<subseteq> responses_\<I> \<I> x \<times> Collect I' \<longleftrightarrow> set_spmf (callee' s x) \<subseteq> responses_\<I> \<I>' x \<times> Collect I' \<rbrakk>
   \<Longrightarrow> callee_invariant_on callee I \<I> = callee_invariant_on callee' I' \<I>'"
 unfolding callee_invariant_on_def WT_callee.simps
 by safe((erule meta_allE)+, (erule (1) meta_impE)+, force)+ 
 
 abbreviation callee_invariant :: "('s \<Rightarrow> 'a \<Rightarrow> ('b \<times> 's) spmf) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> bool"
 where "callee_invariant callee I \<equiv> callee_invariant_on callee I \<I>_full"
 
 interpretation oi_True: callee_invariant_on callee "\<lambda>_. True" \<I>_full for callee
 by unfold_locales (simp_all)
 
 lemma callee_invariant_on_return_spmf [simp]:
   "callee_invariant_on (\<lambda>s x. return_spmf (f s x)) I \<I> \<longleftrightarrow> (\<forall>s. \<forall>x\<in>outs_\<I> \<I>. I s \<longrightarrow> I (snd (f s x)) \<and> fst (f s x) \<in> responses_\<I> \<I> x)"
 by(auto simp add: callee_invariant_on_def split_pairs WT_callee.simps)
 
 lemma callee_invariant_return_spmf [simp]:
   "callee_invariant (\<lambda>s x. return_spmf (f s x)) I \<longleftrightarrow> (\<forall>s x. I s \<longrightarrow> I (snd (f s x)))"
 by(auto simp add: callee_invariant_on_def split_pairs)
 
 lemma callee_invariant_restrict_relp:
   includes lifting_syntax
   assumes "(S ===> C ===> rel_spmf (rel_prod R S)) callee1 callee2"
   and "callee_invariant callee1 I1"
   and "callee_invariant callee2 I2"
   shows "((S \<upharpoonleft> I1 \<otimes> I2) ===> C ===> rel_spmf (rel_prod R (S \<upharpoonleft> I1 \<otimes> I2))) callee1 callee2"
 proof -
   interpret ci1: callee_invariant_on callee1 I1 \<I>_full by fact
   interpret ci2: callee_invariant_on callee2 I2 \<I>_full by fact
   show ?thesis using assms(1)
     by(intro rel_funI)(auto simp add: restrict_rel_prod2 intro!: rel_spmf_restrict_relpI intro: ci1.pred_spmf_calleeI ci2.pred_spmf_calleeI dest: rel_funD rel_setD1 rel_setD2)
 qed
 
 lemma callee_invariant_on_True [simp]: "callee_invariant_on callee (\<lambda>_. True) \<I> \<longleftrightarrow> (\<forall>s. \<I> \<turnstile>c callee s \<surd>)"
 by(simp add: callee_invariant_on_def)
 
 lemma lossless_exec_gpv:
   "\<lbrakk> lossless_gpv \<I> gpv;  \<And>s out. out \<in> outs_\<I> \<I> \<Longrightarrow> lossless_spmf (callee s out);
      \<I> \<turnstile>g gpv \<surd>; \<And>s. \<I> \<turnstile>c callee s \<surd> \<rbrakk>
   \<Longrightarrow> lossless_spmf (exec_gpv callee gpv s)"
 by(rule callee_invariant_on.lossless_exec_gpv; simp)
 
 lemma in_set_spmf_exec_gpv_into_results'_gpv:
   assumes *: "(x, s') \<in> set_spmf (exec_gpv callee gpv s)"
   shows "x \<in> results'_gpv gpv"
 using oi_True.in_set_spmf_exec_gpv_into_results_gpv[OF *] by(simp add: results_gpv_\<I>_full)
 
 
 context fixes \<I> :: "('out, 'in) \<I>" begin
 
 primcorec restrict_gpv :: "('a, 'out, 'in) gpv \<Rightarrow> ('a, 'out, 'in) gpv"
 where
   "restrict_gpv gpv = GPV (
   map_pmf (case_option None (case_generat (Some \<circ> Pure) 
        (\<lambda>out c. if out \<in> outs_\<I> \<I> then Some (IO out (\<lambda>input. if input \<in> responses_\<I> \<I> out then restrict_gpv (c input) else Fail))
           else None)))
     (the_gpv gpv))" 
 
 lemma restrict_gpv_Done [simp]: "restrict_gpv (Done x) = Done x"
 by(rule gpv.expand)(simp)
 
 lemma restrict_gpv_Fail [simp]: "restrict_gpv Fail = Fail"
 by(rule gpv.expand)(simp)
 
 lemma restrict_gpv_Pause [simp]: "restrict_gpv (Pause out c) = (if out \<in> outs_\<I> \<I> then Pause out (\<lambda>input. if input \<in> responses_\<I> \<I> out then restrict_gpv (c input) else Fail) else Fail)"
 by(rule gpv.expand)(simp)
 
 lemma restrict_gpv_bind [simp]: "restrict_gpv (bind_gpv gpv f) = bind_gpv (restrict_gpv gpv) (\<lambda>x. restrict_gpv (f x))"
 apply(coinduction arbitrary: gpv rule: gpv.coinduct_strong)
 apply(auto 4 3 simp del: bind_gpv_sel' simp add: bind_gpv.sel bind_spmf_def pmf.rel_map bind_map_pmf rel_fun_def intro!: rel_pmf_bind_reflI rel_pmf_reflI split!: option.split generat.split split: if_split_asm)
 done
 
 lemma WT_restrict_gpv [simp]: "\<I> \<turnstile>g restrict_gpv gpv \<surd>"
 apply(coinduction arbitrary: gpv)
 apply(clarsimp split: option.split_asm)
 apply(split generat.split_asm; auto split: if_split_asm)
 done
 
 lemma exec_gpv_restrict_gpv:
   assumes "\<I> \<turnstile>g gpv \<surd>" and WT_callee: "\<And>s. \<I> \<turnstile>c callee s \<surd>"
   shows "exec_gpv callee (restrict_gpv gpv) s = exec_gpv callee gpv s"
 using assms(1)
 proof(induction arbitrary: gpv s rule: exec_gpv_fixp_induct)
   case adm show ?case by simp
   case bottom show ?case by simp
   case (step exec_gpv') show ?case 
     by(auto 4 3 simp add: bind_spmf_def bind_map_pmf in_set_spmf[symmetric] WT_gpv_OutD[OF step.prems] WT_calleeD[OF WT_callee] intro!: bind_pmf_cong[OF refl] step.IH split!: option.split generat.split intro: WT_gpv_ContD[OF step.prems])
 qed
 
 lemma in_outs'_restrict_gpvD: "x \<in> outs'_gpv (restrict_gpv gpv) \<Longrightarrow> x \<in> outs_\<I> \<I>"
 apply(induction gpv'\<equiv>"restrict_gpv gpv" arbitrary: gpv rule: outs'_gpv_induct)
 apply(clarsimp split: option.split_asm; split generat.split_asm; clarsimp split: if_split_asm)+
 done
 
 lemma outs'_restrict_gpv: "outs'_gpv (restrict_gpv gpv) \<subseteq> outs_\<I> \<I>" by(blast intro: in_outs'_restrict_gpvD)
 
 lemma lossless_restrict_gpvI: "\<lbrakk> lossless_gpv \<I> gpv; \<I> \<turnstile>g gpv \<surd> \<rbrakk> \<Longrightarrow> lossless_gpv \<I> (restrict_gpv gpv)"
 apply(induction rule: lossless_gpv_induct)
 apply(rule lossless_gpvI)
 subgoal by(clarsimp simp add: lossless_map_pmf lossless_iff_set_pmf_None in_set_spmf[symmetric] WT_gpv_OutD split: option.split_asm generat.split_asm if_split_asm)
 subgoal by(clarsimp split: option.split_asm; split generat.split_asm; force simp add: fun_eq_iff in_set_spmf[symmetric] split: if_split_asm intro: WT_gpv_ContD)
 done
 
 lemma lossless_restrict_gpvD: "\<lbrakk> lossless_gpv \<I> (restrict_gpv gpv); \<I> \<turnstile>g gpv \<surd> \<rbrakk> \<Longrightarrow> lossless_gpv \<I> gpv"
 proof(induction gpv'\<equiv>"restrict_gpv gpv" arbitrary: gpv rule: lossless_gpv_induct)
   case (lossless_gpv p)
   from lossless_gpv.hyps(4) have p: "p = the_gpv (restrict_gpv gpv)" by(cases "restrict_gpv gpv") simp
   show ?case
   proof(rule lossless_gpvI) 
     from lossless_gpv.hyps(1) show "lossless_spmf (the_gpv gpv)"
       by(auto simp add: p lossless_iff_set_pmf_None intro: rev_image_eqI)
 
     fix out c input
     assume IO: "IO out c \<in> set_spmf (the_gpv gpv)" and input: "input \<in> responses_\<I> \<I> out"
     from lossless_gpv.prems(1) IO have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpv_OutD)
     hence "IO out (\<lambda>input. if input \<in> responses_\<I> \<I> out then restrict_gpv (c input) else Fail) \<in> set_spmf p" using IO
       by(auto simp add: p in_set_spmf intro: rev_bexI)
     from lossless_gpv.hyps(3)[OF this input, of "c input"] WT_gpvD[OF lossless_gpv.prems IO] input
     show "lossless_gpv \<I> (c input)" by simp
   qed
 qed
   
 lemma colossless_restrict_gpvD:
   "\<lbrakk> colossless_gpv \<I> (restrict_gpv gpv); \<I> \<turnstile>g gpv \<surd> \<rbrakk> \<Longrightarrow> colossless_gpv \<I> gpv"
 proof(coinduction arbitrary: gpv)
   case (colossless_gpv gpv)
   have ?lossless_spmf using colossless_gpv(1)[THEN colossless_gpv_lossless_spmfD]
     by(auto simp add: lossless_iff_set_pmf_None intro: rev_image_eqI)
   moreover have ?continuation
   proof(intro strip disjI1)
     fix out c input
     assume IO: "IO out c \<in> set_spmf (the_gpv gpv)" and input: "input \<in> responses_\<I> \<I> out"
     from colossless_gpv(2) IO have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpv_OutD)
     hence "IO out (\<lambda>input. if input \<in> responses_\<I> \<I> out then restrict_gpv (c input) else Fail) \<in> set_spmf (the_gpv (restrict_gpv gpv))"
       using IO by(auto simp add: in_set_spmf intro: rev_bexI)
     from colossless_gpv_continuationD[OF colossless_gpv(1) this input] input WT_gpv_ContD[OF colossless_gpv(2) IO input]
     show "\<exists>gpv. c input = gpv \<and> colossless_gpv \<I> (restrict_gpv gpv) \<and> \<I> \<turnstile>g gpv \<surd>" by simp
   qed
   ultimately show ?case ..
 qed
 
 lemma colossless_restrict_gpvI:
   "\<lbrakk> colossless_gpv \<I> gpv; \<I> \<turnstile>g gpv \<surd> \<rbrakk> \<Longrightarrow> colossless_gpv \<I> (restrict_gpv gpv)"
 proof(coinduction arbitrary: gpv)
   case (colossless_gpv gpv)
   have ?lossless_spmf using colossless_gpv(1)[THEN colossless_gpv_lossless_spmfD]
     by(auto simp add: lossless_iff_set_pmf_None in_set_spmf[symmetric] split: option.split_asm generat.split_asm if_split_asm dest: WT_gpv_OutD[OF colossless_gpv(2)])
   moreover have ?continuation
   proof(intro strip disjI1)
     fix out c input
     assume IO: "IO out c \<in> set_spmf (the_gpv (restrict_gpv gpv))" and input: "input \<in> responses_\<I> \<I> out"
     then obtain c' where out: "out \<in> outs_\<I> \<I>"
       and c: "c = (\<lambda>input. if input \<in> responses_\<I> \<I> out then restrict_gpv (c' input) else Fail)"
       and IO': "IO out c' \<in> set_spmf (the_gpv gpv)"
       by(clarsimp split: option.split_asm; split generat.split_asm; clarsimp simp add: in_set_spmf split: if_split_asm)
     with input WT_gpv_ContD[OF colossless_gpv(2) IO' input] colossless_gpv_continuationD[OF colossless_gpv(1) IO' input]
     show "\<exists>gpv. c input = restrict_gpv gpv \<and> colossless_gpv \<I> gpv \<and> \<I> \<turnstile>g gpv \<surd>" by(auto)
   qed
   ultimately show ?case ..
 qed
 
 lemma gen_colossless_restrict_gpv [simp]:
   "\<I> \<turnstile>g gpv \<surd> \<Longrightarrow> gen_lossless_gpv b \<I> (restrict_gpv gpv) \<longleftrightarrow> gen_lossless_gpv b \<I> gpv"
 by(cases b)(auto intro: lossless_restrict_gpvI lossless_restrict_gpvD colossless_restrict_gpvI colossless_restrict_gpvD)
 
 lemma interaction_bound_restrict_gpv:
   "interaction_bound consider (restrict_gpv gpv) \<le> interaction_bound consider gpv"
 proof(induction arbitrary: gpv rule: interaction_bound_fixp_induct)
   case adm show ?case by simp
   case bottom show ?case by simp
   case (step interaction_bound')
   show ?case using step.hyps(1)[of Fail]
     by(fastforce simp add: SUP_UNION set_spmf_def bind_UNION intro: SUP_mono rev_bexI step.IH split: option.split generat.split)
 qed
 
 lemma interaction_bounded_by_restrict_gpvI [interaction_bound, simp]:
   "interaction_bounded_by consider gpv n \<Longrightarrow> interaction_bounded_by consider (restrict_gpv gpv) n"
 using interaction_bound_restrict_gpv[of "consider" gpv] by(simp add: interaction_bounded_by.simps)
 
 end
 
 lemma restrict_gpv_parametric':
   includes lifting_syntax
   notes [transfer_rule] = the_gpv_parametric' Fail_parametric' corec_gpv_parametric'
   assumes [transfer_rule]: "bi_unique C" "bi_unique R"
   shows "(rel_\<I> C R ===> rel_gpv'' A C R ===> rel_gpv'' A C R) restrict_gpv restrict_gpv"
 unfolding restrict_gpv_def by transfer_prover
 
 lemma restrict_gpv_parametric [transfer_rule]: includes lifting_syntax shows 
   "bi_unique C \<Longrightarrow> (rel_\<I> C (=) ===> rel_gpv A C ===> rel_gpv A C) restrict_gpv restrict_gpv"
 using restrict_gpv_parametric'[of C "(=)" A]
 by(simp add: bi_unique_eq rel_gpv_conv_rel_gpv'')
 
 lemma map_restrict_gpv: "map_gpv f id (restrict_gpv \<I> gpv) = restrict_gpv \<I> (map_gpv f id gpv)"
   for gpv :: "('a, 'out, 'ret) gpv"
 using restrict_gpv_parametric[of "BNF_Def.Grp UNIV (id :: 'out \<Rightarrow> 'out)" "BNF_Def.Grp UNIV f", where ?'c='ret]
 unfolding gpv.rel_Grp by(simp add: eq_alt[symmetric] rel_\<I>_eq rel_fun_def bi_unique_eq)(simp add: Grp_def)
 
 lemma (in callee_invariant_on) exec_gpv_restrict_gpv_invariant:
   assumes "\<I> \<turnstile>g gpv \<surd>" and "I s"
   shows "exec_gpv callee (restrict_gpv \<I> gpv) s = exec_gpv callee gpv s"
 using assms
 proof(induction arbitrary: gpv s rule: exec_gpv_fixp_induct)
   case adm show ?case by simp
   case bottom show ?case by simp
   case (step exec_gpv') show ?case using step.prems(2)
     by(auto 4 3 simp add: bind_spmf_def bind_map_pmf in_set_spmf[symmetric] WT_gpv_OutD[OF step.prems(1)] WT_calleeD[OF WT_callee[OF step.prems(2)]] intro!: bind_pmf_cong[OF refl] step.IH split!: option.split generat.split intro: WT_gpv_ContD[OF step.prems(1)] callee_invariant)
 qed
 
+lemma in_results_gpv_restrict_gpvD:
+  assumes "x \<in> results_gpv \<I> (restrict_gpv \<I>' gpv)"
+  shows "x \<in> results_gpv \<I> gpv"
+  using assms
+  apply(induction gpv'\<equiv>"restrict_gpv \<I>' gpv" arbitrary: gpv)
+   apply(clarsimp split: option.split_asm simp add: in_set_spmf[symmetric])
+  subgoal for \<dots> y by(cases y)(auto intro: results_gpv.intros split: if_split_asm)
+  apply(clarsimp split: option.split_asm simp add: in_set_spmf[symmetric])
+  subgoal for \<dots> y by(cases y)(auto intro: results_gpv.intros split: if_split_asm)
+  done
+
+lemma results_gpv_restrict_gpv:
+  "results_gpv \<I> (restrict_gpv \<I>' gpv) \<subseteq> results_gpv \<I> gpv"
+  by(blast intro: in_results_gpv_restrict_gpvD)
+
+lemma in_results'_gpv_restrict_gpvD:
+  "x \<in> results'_gpv (restrict_gpv \<I>' gpv) \<Longrightarrow> x \<in> results'_gpv gpv"
+  by(rule in_results_gpv_restrict_gpvD[where \<I> = "\<I>_full", unfolded results_gpv_\<I>_full])
+
+primcorec enforce_\<I>_gpv :: "('out, 'in) \<I> \<Rightarrow> ('a, 'out, 'in) gpv \<Rightarrow> ('a, 'out, 'in) gpv" where
+  "enforce_\<I>_gpv \<I> gpv = GPV 
+    (map_spmf (map_generat id id ((\<circ>) (enforce_\<I>_gpv \<I>))) 
+     (map_spmf (\<lambda>generat. case generat of Pure x \<Rightarrow> Pure x | IO out rpv \<Rightarrow> IO out (\<lambda>input. if input \<in> responses_\<I> \<I> out then rpv input else Fail))
+        (enforce_spmf (pred_generat \<top> (\<lambda>x. x \<in> outs_\<I> \<I>) \<top>) (the_gpv gpv))))"
+
+lemma enforce_\<I>_gpv_Done [simp]: "enforce_\<I>_gpv \<I> (Done x) = Done x"
+  by(rule gpv.expand) simp
+
+lemma enforce_\<I>_gpv_Fail [simp]: "enforce_\<I>_gpv \<I> Fail = Fail"
+  by(rule gpv.expand) simp
+
+lemma enforce_\<I>_gpv_Pause [simp]:
+  "enforce_\<I>_gpv \<I> (Pause out rpv) =
+   (if out \<in> outs_\<I> \<I> then Pause out (\<lambda>input. if input \<in> responses_\<I> \<I> out then enforce_\<I>_gpv \<I> (rpv input) else Fail) else Fail)"
+  by(rule gpv.expand)(simp add: fun_eq_iff)
+
+lemma enforce_\<I>_gpv_lift_spmf [simp]: "enforce_\<I>_gpv \<I> (lift_spmf p) = lift_spmf p"
+  by(rule gpv.expand)(simp add: enforce_map_spmf spmf.map_comp o_def)
+
+lemma enforce_\<I>_gpv_bind_gpv [simp]:
+  "enforce_\<I>_gpv \<I> (bind_gpv gpv f) = bind_gpv (enforce_\<I>_gpv \<I> gpv) (enforce_\<I>_gpv \<I> \<circ> f)"
+  by(coinduction arbitrary: gpv rule: gpv.coinduct_strong)
+    (auto 4 3 simp add: bind_gpv.sel spmf_rel_map bind_map_spmf o_def pred_generat_def elim!: generat.set_cases intro!: generat.rel_refl_strong rel_spmf_bind_reflI rel_spmf_reflI rel_funI split!: if_splits generat.split_asm)
+
+lemma enforce_\<I>_gpv_parametric':
+  includes lifting_syntax 
+  notes [transfer_rule] = corec_gpv_parametric' the_gpv_parametric' Fail_parametric'
+  assumes [transfer_rule]: "bi_unique C" "bi_unique R"
+  shows "(rel_\<I> C R ===> rel_gpv'' A C R ===> rel_gpv'' A C R) enforce_\<I>_gpv enforce_\<I>_gpv"
+  unfolding enforce_\<I>_gpv_def top_fun_def by(transfer_prover)
+
+lemma enforce_\<I>_gpv_parametric [transfer_rule]: includes lifting_syntax shows
+  "bi_unique C \<Longrightarrow> (rel_\<I> C (=) ===> rel_gpv A C ===> rel_gpv A C) enforce_\<I>_gpv enforce_\<I>_gpv"
+  unfolding rel_gpv_conv_rel_gpv'' by(rule enforce_\<I>_gpv_parametric'[OF _ bi_unique_eq])
+
+lemma WT_enforce_\<I>_gpv [simp]: "\<I> \<turnstile>g enforce_\<I>_gpv \<I> gpv \<surd>"
+  by(coinduction arbitrary: gpv)(auto split: generat.split_asm)
+
 context fixes \<I> :: "('out, 'in) \<I>" begin
 
 inductive finite_gpv :: "('a, 'out, 'in) gpv \<Rightarrow> bool"
 where
   finite_gpvI: 
   "(\<And>out c input. \<lbrakk> IO out c \<in> set_spmf (the_gpv gpv); input \<in> responses_\<I> \<I> out \<rbrakk> \<Longrightarrow> finite_gpv (c input)) \<Longrightarrow> finite_gpv gpv"
 
 lemmas finite_gpv_induct[consumes 1, case_names finite_gpv, induct pred] = finite_gpv.induct
 
 lemma finite_gpvD: "\<lbrakk> finite_gpv gpv; IO out c \<in> set_spmf (the_gpv gpv); input \<in> responses_\<I> \<I> out \<rbrakk> \<Longrightarrow> finite_gpv (c input)"
 by(auto elim: finite_gpv.cases)
 
 lemma finite_gpv_Fail [simp]: "finite_gpv Fail"
 by(auto intro: finite_gpvI)
 
 lemma finite_gpv_Done [simp]: "finite_gpv (Done x)"
 by(auto intro: finite_gpvI)
 
 lemma finite_gpv_Pause [simp]: "finite_gpv (Pause x c) \<longleftrightarrow> (\<forall>input \<in> responses_\<I> \<I> x. finite_gpv (c input))"
 by(auto dest: finite_gpvD intro: finite_gpvI)
 
 lemma finite_gpv_lift_spmf [simp]: "finite_gpv (lift_spmf p)"
 by(auto intro: finite_gpvI)
 
 lemma finite_gpv_bind [simp]:
   "finite_gpv (gpv \<bind> f) \<longleftrightarrow> finite_gpv gpv \<and> (\<forall>x\<in>results_gpv \<I> gpv. finite_gpv (f x))"
   (is "?lhs = ?rhs")
 proof(intro iffI conjI ballI; (elim conjE)?)
   show "finite_gpv gpv" if "?lhs" using that
   proof(induction gpv'\<equiv>"gpv \<bind> f" arbitrary: gpv)
     case finite_gpv
     show ?case
     proof(rule finite_gpvI)
       fix out c input
       assume IO: "IO out c \<in> set_spmf (the_gpv gpv)"
         and input: "input \<in> responses_\<I> \<I> out"
       have "IO out (\<lambda>input. c input \<bind> f) \<in> set_spmf (the_gpv (gpv \<bind> f))"
         using IO by(auto intro: rev_bexI)
       thus "finite_gpv (c input)" using input by(rule finite_gpv.hyps) simp
     qed
   qed
   show "finite_gpv (f x)" if "x \<in> results_gpv \<I> gpv" ?lhs for x using that
   proof(induction)
     case (Pure gpv)
     show ?case
     proof
       fix out c input
       assume "IO out c \<in> set_spmf (the_gpv (f x))" "input \<in> responses_\<I> \<I> out"
       with Pure have "IO out c \<in> set_spmf (the_gpv (gpv \<bind> f))" by(auto intro: rev_bexI)
       with Pure.prems show "finite_gpv (c input)" by(rule finite_gpvD) fact
     qed
   next
     case (IO out c gpv input)
     with IO.hyps have "IO out (\<lambda>input. c input \<bind> f) \<in> set_spmf (the_gpv (gpv \<bind> f))"
       by(auto intro: rev_bexI)
     with IO.prems have "finite_gpv (c input \<bind> f)" using IO.hyps(2) by(rule finite_gpvD)
     thus ?case by(rule IO.IH)
   qed
   show ?lhs if "finite_gpv gpv" "\<forall>x\<in>results_gpv \<I> gpv. finite_gpv (f x)" using that
   proof induction
     case (finite_gpv gpv)
     show ?case
     proof(rule finite_gpvI)
       fix out c input
       assume IO: "IO out c \<in> set_spmf (the_gpv (gpv \<bind> f))" and input: "input \<in> responses_\<I> \<I> out"
       then obtain generat where generat: "generat \<in> set_spmf (the_gpv gpv)"
         and IO: "IO out c \<in> set_spmf (if is_Pure generat then the_gpv (f (result generat)) else
                    return_spmf (IO (output generat) (\<lambda>input. continuation generat input \<bind> f)))"
         by(auto)
       show "finite_gpv (c input)"
       proof(cases generat)
         case (Pure x)
         with generat IO have "x \<in> results_gpv \<I> gpv" "IO out c \<in> set_spmf (the_gpv (f x))"
           by(auto intro: results_gpv.Pure)
         thus ?thesis using finite_gpv.prems input by(auto dest: finite_gpvD)
       next
         case *: (IO out' c')
         with IO generat finite_gpv.prems input show ?thesis
           by(auto 4 4 intro: finite_gpv.IH results_gpv.IO)
       qed
     qed
   qed
 qed
 
 end
 
 context includes lifting_syntax begin
 
 lemma finite_gpv_rel''D1:
   assumes "rel_gpv'' A C R gpv gpv'" and "finite_gpv \<I> gpv" and \<I>: "rel_\<I> C R \<I> \<I>'"
   shows "finite_gpv \<I>' gpv'"
 using assms(2,1)
 proof(induction arbitrary: gpv')
   case (finite_gpv gpv)
   note finite_gpv.prems[transfer_rule]
   show ?case
   proof(rule finite_gpvI)
     fix out' c' input'
     assume IO: "IO out' c' \<in> set_spmf (the_gpv gpv')" and input': "input' \<in> responses_\<I> \<I>' out'"
     have "rel_set (rel_generat A C (R ===> (rel_gpv'' A C R))) (set_spmf (the_gpv gpv)) (set_spmf (the_gpv gpv'))"
       supply the_gpv_parametric'[transfer_rule] by transfer_prover
     with IO input' responses_\<I>_parametric[THEN rel_funD, OF \<I>] obtain out c input
       where "IO out c \<in> set_spmf (the_gpv gpv)" "input \<in> responses_\<I> \<I> out" "rel_gpv'' A C R (c input) (c' input')"
       by(auto 4 3 dest!: rel_setD2 elim!: generat.rel_cases dest: rel_funD)
     then show "finite_gpv \<I>' (c' input')" by(rule finite_gpv.IH)
   qed
 qed
 
 lemma finite_gpv_relD1: "\<lbrakk> rel_gpv A C gpv gpv'; finite_gpv \<I> gpv; rel_\<I> C (=) \<I> \<I> \<rbrakk> \<Longrightarrow> finite_gpv \<I> gpv'"
 using finite_gpv_rel''D1[of A C "(=)" gpv gpv' \<I> \<I>] by(simp add: rel_gpv_conv_rel_gpv'')
 
 lemma finite_gpv_rel''D2: "\<lbrakk> rel_gpv'' A C R gpv gpv'; finite_gpv \<I> gpv'; rel_\<I> C R \<I>' \<I> \<rbrakk> \<Longrightarrow> finite_gpv \<I>' gpv"
 using finite_gpv_rel''D1[of "A\<inverse>\<inverse>" "C\<inverse>\<inverse>" "R\<inverse>\<inverse>" gpv' gpv \<I> \<I>'] by(simp add: rel_gpv''_conversep)
 
 lemma finite_gpv_relD2: "\<lbrakk> rel_gpv A C gpv gpv'; finite_gpv \<I> gpv'; rel_\<I> C (=) \<I> \<I> \<rbrakk> \<Longrightarrow> finite_gpv \<I> gpv"
 using finite_gpv_rel''D2[of A C "(=)" gpv gpv' \<I> \<I>] by(simp add: rel_gpv_conv_rel_gpv'')
 
 lemma finite_gpv_parametric': "(rel_\<I> C R ===> rel_gpv'' A C R ===> (=)) finite_gpv finite_gpv"
 by(blast dest: finite_gpv_rel''D2 finite_gpv_rel''D1)
 
 lemma finite_gpv_parametric [transfer_rule]: "(rel_\<I> C (=) ===> rel_gpv A C ===> (=)) finite_gpv finite_gpv"
 using finite_gpv_parametric'[of C "(=)" A] by(simp add: rel_gpv_conv_rel_gpv'')
 
 end
 
 lemma finite_gpv_map [simp]: "finite_gpv \<I> (map_gpv f id gpv) = finite_gpv \<I> gpv"
 using finite_gpv_parametric[of "BNF_Def.Grp UNIV id" "BNF_Def.Grp UNIV f"]
 unfolding gpv.rel_Grp by(auto simp add: rel_fun_def BNF_Def.Grp_def eq_commute rel_\<I>_eq)
 
 lemma finite_gpv_assert [simp]: "finite_gpv \<I> (assert_gpv b)"
 by(cases b) simp_all
 
 lemma finite_gpv_try [simp]:
   "finite_gpv \<I> (TRY gpv ELSE gpv') \<longleftrightarrow> finite_gpv \<I> gpv \<and> (colossless_gpv \<I> gpv \<or> finite_gpv \<I> gpv')"
   (is "?lhs = _")
 proof(intro iffI conjI; (elim conjE disjE)?)
   show 1: "finite_gpv \<I> gpv" if ?lhs using that
   proof(induction gpv''\<equiv>"TRY gpv ELSE gpv'" arbitrary: gpv)
     case (finite_gpv gpv)
     show ?case
     proof(rule finite_gpvI)
       fix out c input
       assume IO: "IO out c \<in> set_spmf (the_gpv gpv)" and input: "input \<in> responses_\<I> \<I> out"
       from IO have "IO out (\<lambda>input. TRY c input ELSE gpv') \<in> set_spmf (the_gpv (TRY gpv ELSE gpv'))"
         by(auto simp add: image_image generat.map_comp o_def intro: rev_image_eqI)
       thus "finite_gpv \<I> (c input)" using input by(rule finite_gpv.hyps) simp
     qed
   qed
   have "finite_gpv \<I> gpv'" if "?lhs" "\<not> colossless_gpv \<I> gpv" using that
   proof(induction gpv''\<equiv>"TRY gpv ELSE gpv'" arbitrary: gpv)
     case (finite_gpv gpv)
     show ?case
     proof(cases "lossless_spmf (the_gpv gpv)")
       case True
       have "\<exists>out c input. IO out c \<in> set_spmf (the_gpv gpv) \<and> input \<in> responses_\<I> \<I> out \<and> \<not> colossless_gpv \<I> (c input)"
         using finite_gpv.prems by(rule contrapos_np)(auto intro: colossless_gpvI simp add: True)
       then obtain out c input where IO: "IO out c \<in> set_spmf (the_gpv gpv)"
         and co': "\<not> colossless_gpv \<I> (c input)" 
         and input: "input \<in> responses_\<I> \<I> out" by blast
       from IO have "IO out (\<lambda>input. TRY c input ELSE gpv') \<in> set_spmf (the_gpv (TRY gpv ELSE gpv'))"
         by(auto simp add: image_image generat.map_comp o_def intro: rev_image_eqI)
       with co' show ?thesis using input by(blast intro: finite_gpv.hyps(2))
     next
       case False
       show ?thesis
       proof(rule finite_gpvI)
         fix out c input
         assume IO: "IO out c \<in> set_spmf (the_gpv gpv')" and input: "input \<in> responses_\<I> \<I> out"
         from IO False have "IO out c \<in> set_spmf (the_gpv (TRY gpv ELSE gpv'))" by(auto intro: rev_image_eqI)
         then show "finite_gpv \<I> (c input)" using input by(rule finite_gpv.hyps)
       qed
     qed
   qed
   then show "colossless_gpv \<I> gpv \<or> finite_gpv \<I> gpv'" if ?lhs using that by blast
   
   show ?lhs if "finite_gpv \<I> gpv" "finite_gpv \<I> gpv'" using that(1)
   proof induction
     case (finite_gpv gpv)
     show ?case
     proof
       fix out c input
       assume IO: "IO out c \<in> set_spmf (the_gpv (TRY gpv ELSE gpv'))"
         and input: "input \<in> responses_\<I> \<I> out"
       then consider (gpv) c' where "IO out c' \<in> set_spmf (the_gpv gpv)" "c = (\<lambda>input. TRY c' input ELSE gpv')"
         | (gpv') "IO out c \<in> set_spmf (the_gpv gpv')" by(auto split: if_split_asm)
       then show "finite_gpv \<I> (c input)" using input
         by cases(auto intro: finite_gpv.IH finite_gpvD[OF that(2)])
     qed
   qed
   show ?lhs if "finite_gpv \<I> gpv" "colossless_gpv \<I> gpv" using that
   proof induction
     case (finite_gpv gpv)
     show ?case
       by(rule finite_gpvI)(use finite_gpv.prems in \<open>fastforce split: if_split_asm dest: colossless_gpvD intro: finite_gpv.IH\<close>)
   qed
 qed
 
 lemma lossless_gpv_conv_finite:
   "lossless_gpv \<I> gpv \<longleftrightarrow> finite_gpv \<I> gpv \<and> colossless_gpv \<I> gpv"
   (is "?loss \<longleftrightarrow> ?fin \<and> ?co")
 proof(intro iffI conjI; (elim conjE)?)
   show ?fin if ?loss using that by induction(auto intro: finite_gpvI)
   show ?co if ?loss using that by induction(auto intro: colossless_gpvI)
   show ?loss if ?fin ?co using that
   proof induction
     case (finite_gpv gpv)
     from finite_gpv.prems finite_gpv.IH show ?case
       by cases(auto intro: lossless_gpvI)
   qed
 qed
 
 lemma colossless_gpv_try [simp]:
   "colossless_gpv \<I> (TRY gpv ELSE gpv') \<longleftrightarrow> colossless_gpv \<I> gpv \<or> colossless_gpv \<I> gpv'"
   (is "?lhs \<longleftrightarrow> ?gpv \<or> ?gpv'")
 proof(intro iffI disjCI; (elim disjE)?)
   show "?gpv" if ?lhs "\<not> ?gpv'" using that(1)
   proof(coinduction arbitrary: gpv)
     case (colossless_gpv gpv)
     have ?lossless_spmf
     proof(rule ccontr)
       assume loss: "\<not> ?lossless_spmf"
       with colossless_gpv_lossless_spmfD[OF colossless_gpv(1)]
       have gpv': "lossless_spmf (the_gpv gpv')" by auto
       have "\<exists>out c input. IO out c \<in> set_spmf (the_gpv gpv') \<and> input \<in> responses_\<I> \<I> out \<and> \<not> colossless_gpv \<I> (c input)"
         using that(2) by(rule contrapos_np)(auto intro: colossless_gpvI gpv')
       then obtain out c input
         where IO: "IO out c \<in> set_spmf (the_gpv gpv')"
         and co': "\<not> colossless_gpv \<I> (c input)" 
         and input: "input \<in> responses_\<I> \<I> out" by blast
       from IO loss have "IO out c \<in> set_spmf (the_gpv (TRY gpv ELSE gpv'))"
         by(auto intro: rev_image_eqI)
       with colossless_gpv(1) have "colossless_gpv \<I> (c input)" using input
         by(rule colossless_gpv_continuationD)
       with co' show False by contradiction
     qed
     moreover have ?continuation
     proof(intro strip disjI1; simp)
       fix out c input
       assume IO: "IO out c \<in> set_spmf (the_gpv gpv)" and input: "input \<in> responses_\<I> \<I> out"
       hence "IO out (\<lambda>input. TRY c input ELSE gpv') \<in> set_spmf (the_gpv (TRY gpv ELSE gpv'))"
         by(auto intro: rev_image_eqI)
       with colossless_gpv show "colossless_gpv \<I> (TRY c input ELSE gpv')"
         by(rule colossless_gpv_continuationD)(simp add: input)
     qed
     ultimately show ?case ..
   qed
   show ?lhs if ?gpv'
   proof(coinduction arbitrary: gpv)
     case colossless_gpv
     show ?case using colossless_gpvD[OF that] by(auto 4 3)
   qed
   show ?lhs if ?gpv using that
   proof(coinduction arbitrary: gpv)
     case colossless_gpv
     show ?case using colossless_gpvD[OF colossless_gpv] by(auto 4 3)
   qed
 qed
 
 lemma lossless_gpv_try [simp]:
   "lossless_gpv \<I> (TRY gpv ELSE gpv') \<longleftrightarrow> 
    finite_gpv \<I> gpv \<and> (lossless_gpv \<I> gpv \<or> lossless_gpv \<I> gpv')"
 by(auto simp add: lossless_gpv_conv_finite)
 
 lemma interaction_any_bounded_by_imp_finite:
   assumes "interaction_any_bounded_by gpv (enat n)"
   shows "finite_gpv \<I>_full gpv"
 using assms 
 proof(induction n arbitrary: gpv)
   case 0
   then show ?case by(auto intro: finite_gpv.intros dest: interaction_bounded_by_contD simp add: zero_enat_def[symmetric])
 next
   case (Suc n)
   from Suc.prems show ?case unfolding eSuc_enat[symmetric]
     by(auto 4 4 intro: finite_gpv.intros Suc.IH dest: interaction_bounded_by_contD)
 qed
 
 lemma finite_restrict_gpvI [simp]: "finite_gpv \<I>' gpv \<Longrightarrow> finite_gpv \<I>' (restrict_gpv \<I> gpv)"
 by(induction rule: finite_gpv_induct)(rule finite_gpvI; clarsimp split: option.split_asm; split generat.split_asm; clarsimp split: if_split_asm simp add: in_set_spmf)
 
 lemma interaction_bounded_by_exec_gpv_bad_count:
   fixes count and bad and n :: enat and k :: real
   assumes bound: "interaction_bounded_by consider gpv n"
   and good: "\<not> bad s"
   and count: "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); consider x; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> count s' \<le> Suc (count s)"
   and ignore: "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); \<not> consider x; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> count s' \<le> count s"
   and bad: "\<And>s' x. \<lbrakk> \<not> bad s'; count s' < n + count s; consider x; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> spmf (map_spmf (bad \<circ> snd) (callee s' x)) True \<le> k"
   and "consider": "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); \<not> bad s; bad s'; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> consider x"
   and k_nonneg: "k \<ge> 0"
   and WT_gpv: "\<I> \<turnstile>g gpv \<surd>"
   and WT_callee: "\<And>s. \<I> \<turnstile>c callee s \<surd>"
   shows "spmf (map_spmf (bad \<circ> snd) (exec_gpv callee gpv s)) True \<le> ennreal k * n"
 using bound good bad WT_gpv
 proof(induction arbitrary: gpv s n rule: exec_gpv_fixp_induct)
   case adm show ?case by(rule cont_intro ccpo_class.admissible_leI)+
   case bottom show ?case using k_nonneg by(simp add: zero_ereal_def[symmetric])
 next
   case (step exec_gpv')
   let ?M = "restrict_space (measure_spmf (the_gpv gpv)) {IO out c|out c. True}"
   have "ennreal (spmf (map_spmf (bad \<circ> snd) (bind_spmf (the_gpv gpv) (case_generat (\<lambda>x. return_spmf (x, s)) (\<lambda>out c. bind_spmf (callee s out) (\<lambda>(x, y). exec_gpv' (c x) y))))) True) =
     ennreal (spmf (bind_spmf (the_gpv gpv) (\<lambda>generat. case generat of Pure x \<Rightarrow> return_spmf (bad s) |
        IO out rpv \<Rightarrow> bind_spmf (callee s out) (\<lambda>(x, s'). map_spmf (bad \<circ> snd) (exec_gpv' (rpv x) s')))) True)"
     (is "_ = ennreal (spmf (bind_spmf _ (case_generat _ ?io)) _)")
     by(simp add: map_spmf_bind_spmf o_def generat.case_distrib[where h="map_spmf _"] split_def cong del: generat.case_cong_weak)
   also have "\<dots> = \<integral>\<^sup>+ generat. \<integral>\<^sup>+ (x, s'). spmf (map_spmf (bad \<circ> snd) (exec_gpv' (continuation generat x) s')) True \<partial>measure_spmf (callee s (output generat)) \<partial>?M"
     using step.prems(2) by(auto simp add: ennreal_spmf_bind nn_integral_restrict_space intro!: nn_integral_cong split: generat.split)
   also have "\<dots> \<le> \<integral>\<^sup>+ generat. \<integral>\<^sup>+ (x, s'). (if bad s' then 1 else ennreal k * (if consider (output generat) then n - 1 else n)) \<partial>measure_spmf (callee s (output generat)) \<partial>?M"
   proof(clarsimp intro!: nn_integral_mono_AE simp add: AE_restrict_space_iff split del: if_split cong del: if_cong)
     show "ennreal (spmf (map_spmf (bad \<circ> snd) (exec_gpv' (rpv ret) s')) True)
           \<le> (if bad s' then 1 else ennreal k * ennreal_of_enat (if consider out then n - 1 else n))"
       if IO: "IO out rpv \<in> set_spmf (the_gpv gpv)"
       and call: "(ret, s') \<in> set_spmf (callee s out)"
       for out rpv ret s'
     proof(cases "bad s'")
       case True
       then show ?thesis by(simp add: pmf_le_1)
     next
       case False
       let ?n' = "if consider out then n - 1 else n"
       have out: "out \<in> outs_\<I> \<I>" using IO step.prems(4) by(simp add: WT_gpv_OutD)
       have bound': "interaction_bounded_by consider (rpv ret) ?n'"
         using interaction_bounded_by_contD[OF step.prems(1) IO]
               interaction_bounded_by_contD_ignore[OF step.prems(1) IO] by(auto)
       have "ret \<in> responses_\<I> \<I> out" using WT_callee call out by(rule WT_calleeD)
       with step.prems(4) IO have WT': "\<I> \<turnstile>g rpv ret \<surd>" by(rule WT_gpv_ContD)
       have bad':  "spmf (map_pmf (map_option (bad \<circ> snd)) (callee s'' x)) True \<le> k"
         if "\<not> bad s''" and count': "count s'' < ?n' + count s'" and "consider x" and "x \<in> outs_\<I> \<I>"
         for s'' x using \<open>\<not> bad s''\<close> _ \<open>consider x\<close> \<open>x \<in> outs_\<I> \<I>\<close>
       proof(rule step.prems)
         show "count s'' < n + count s"
         proof(cases "consider out")
           case True
           with count[OF call True out] count' interaction_bounded_by_contD[OF step.prems(1) IO, of undefined]
           show ?thesis by(cases n)(auto simp add: one_enat_def)
         next
           case False
           with ignore[OF call _ out] count' show ?thesis by(cases n)auto
         qed
       qed
       from step.IH[OF bound' False this] False WT' show ?thesis by(auto simp add: o_def)
     qed
   qed
   also have "\<dots> = \<integral>\<^sup>+ generat. \<integral>\<^sup>+ b. indicator {True} b + ennreal k * (if consider (output generat) then n - 1 else n) * indicator {False} b \<partial>measure_spmf (map_spmf (bad \<circ> snd) (callee s (output generat))) \<partial>?M"
     (is "_ = \<integral>\<^sup>+ generat. \<integral>\<^sup>+ _. _ \<partial>?O' generat \<partial>_")
     by(auto intro!: nn_integral_cong)
   also have "\<dots> = \<integral>\<^sup>+ generat. (\<integral>\<^sup>+ b. indicator {True} b \<partial>?O' generat) + ennreal k * (if consider (output generat) then n - 1 else n) * \<integral>\<^sup>+ b. indicator {False} b \<partial>?O' generat \<partial>?M"
     by(subst nn_integral_add)(simp_all add: k_nonneg nn_integral_cmult o_def)
   also have "\<dots> = \<integral>\<^sup>+ generat. ennreal (spmf (map_spmf (bad \<circ> snd) (callee s (output generat))) True) + ennreal k * (if consider (output generat) then n - 1 else n) * spmf (map_spmf (bad \<circ> snd) (callee s (output generat))) False \<partial>?M"
     by(simp del: nn_integral_map_spmf add: emeasure_spmf_single ereal_of_enat_mult)
   also have "\<dots> \<le> \<integral>\<^sup>+ generat. ennreal k * n \<partial>?M"
   proof(intro nn_integral_mono_AE, clarsimp intro!: nn_integral_mono_AE simp add: AE_restrict_space_iff not_is_Pure_conv split del: if_split)
     fix out c
     assume IO: "IO out c \<in> set_spmf (the_gpv gpv)"
     with step.prems(4) have out: "out \<in> outs_\<I> \<I>" by(rule WT_gpv_OutD)
     show "spmf (map_spmf (bad \<circ> snd) (callee s out)) True +
            ennreal k * (if consider out then n - 1 else n) * spmf (map_spmf (bad \<circ> snd) (callee s out)) False
           \<le> ennreal k * n"
     proof(cases "consider out")
       case True
       with IO have "n > 0" using interaction_bounded_by_contD[OF step.prems(1)] by(blast dest: interaction_bounded_by_contD)
       have "spmf (map_spmf (bad \<circ> snd) (callee s out)) True \<le> k" (is "?o True \<le> _")
         using \<open>\<not> bad s\<close> True \<open>n > 0\<close> out by(intro step.prems)(simp)
       hence "ennreal (?o True) \<le> k" using k_nonneg by(simp del: o_apply)
       hence "?o True + ennreal k * (n - 1) * ?o False \<le> ennreal k + ennreal k * (n - 1) * ennreal 1"
         by(rule add_mono)(rule mult_left_mono, simp_all add: pmf_le_1 k_nonneg)
       also have "\<dots> \<le> ennreal k * n" using \<open>n > 0\<close>
         by(cases n)(auto simp add: zero_enat_def ennreal_top_mult gr0_conv_Suc eSuc_enat[symmetric] field_simps)
       finally show ?thesis using True by(simp del: o_apply add: ereal_of_enat_mult)
     next
       case False
       hence "spmf (map_spmf (bad \<circ> snd) (callee s out)) True = 0" using \<open>\<not> bad s\<close> out
         unfolding spmf_eq_0_set_spmf by(auto dest: "consider")
       with False k_nonneg pmf_le_1[of "map_spmf (bad \<circ> snd) (callee s out)" "Some False"]
       show ?thesis by(simp add: mult_left_mono[THEN order_trans, where ?b1=1])
     qed
   qed
   also have "\<dots> \<le> ennreal k * n"
     by(simp add: k_nonneg emeasure_restrict_space measure_spmf.emeasure_eq_measure space_restrict_space measure_spmf.subprob_measure_le_1 mult_left_mono[THEN order_trans, where ?b1=1])
   finally show ?case by(simp del: o_apply)
 qed
 
 context callee_invariant_on begin
 
 lemma interaction_bounded_by_exec_gpv_bad_count:
   includes lifting_syntax
   fixes count and bad and n :: enat
   assumes bound: "interaction_bounded_by consider gpv n"
   and I: "I s"
   and good: "\<not> bad s"
   and count: "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); I s; consider x; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> count s' \<le> Suc (count s)"
   and ignore: "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); I s; \<not> consider x; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> count s' \<le> count s"
   and bad: "\<And>s' x. \<lbrakk> I s'; \<not> bad s'; count s' < n + count s; consider x; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> spmf (map_spmf (bad \<circ> snd) (callee s' x)) True \<le> k"
   and "consider": "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); I s; \<not> bad s; bad s'; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> consider x"
   and k_nonneg: "k \<ge> 0"
   and WT_gpv: "\<I> \<turnstile>g gpv \<surd>"
   shows "spmf (map_spmf (bad \<circ> snd) (exec_gpv callee gpv s)) True \<le> ennreal k * n"
 proof -
   { assume "\<exists>(Rep :: 's' \<Rightarrow> 's) Abs. type_definition Rep Abs {s. I s}"
     then obtain Rep :: "'s' \<Rightarrow> 's" and Abs where td: "type_definition Rep Abs {s. I s}" by blast
     then interpret td: type_definition Rep Abs "{s. I s}" .
     define cr where "cr \<equiv> \<lambda>x y. x = Rep y"
     have [transfer_rule]: "bi_unique cr" "right_total cr" using td cr_def by(rule typedef_bi_unique typedef_right_total)+
     have [transfer_domain_rule]: "Domainp cr = I" using type_definition_Domainp[OF td cr_def] by simp
     
     let ?C = "eq_onp (\<lambda>x. x \<in> outs_\<I> \<I>)"
 
     define callee' where "callee' \<equiv> (Rep ---> id ---> map_spmf (map_prod id Abs)) callee"
     have [transfer_rule]: "(cr ===> ?C ===> rel_spmf (rel_prod (=) cr)) callee callee'"
       by(auto simp add: callee'_def rel_fun_def cr_def spmf_rel_map prod.rel_map td.Abs_inverse eq_onp_def intro!: rel_spmf_reflI intro: td.Rep[simplified] dest: callee_invariant)
     define s' where "s' \<equiv> Abs s"
     have [transfer_rule]: "cr s s'" using I by(simp add: cr_def s'_def td.Abs_inverse)
     define bad' where "bad' \<equiv> (Rep ---> id) bad"
     have [transfer_rule]: "(cr ===> (=)) bad bad'" by(simp add: rel_fun_def bad'_def cr_def)
     define count' where "count' \<equiv> (Rep ---> id) count"
     have [transfer_rule]: "(cr ===> (=)) count count'" by(simp add: rel_fun_def count'_def cr_def)
 
     have [transfer_rule]: "(?C ===> (=)) consider consider" by(simp add: eq_onp_def rel_fun_def)
     have [transfer_rule]: "rel_\<I> ?C (=) \<I> \<I>"
       by(rule rel_\<I>I)(auto simp add: rel_set_eq set_relator_eq_onp eq_onp_same_args dest: eq_onp_to_eq)
     note [transfer_rule] = bi_unique_eq_onp bi_unique_eq
 
     define gpv' where "gpv' \<equiv> restrict_gpv \<I> gpv"
     have [transfer_rule]: "rel_gpv (=) ?C gpv' gpv'"
       by(fold eq_onp_top_eq_eq)(auto simp add: gpv.rel_eq_onp eq_onp_same_args pred_gpv_def gpv'_def dest: in_outs'_restrict_gpvD)
 
     have "interaction_bounded_by consider gpv' n" using bound by(simp add: gpv'_def)
     moreover have "\<not> bad' s'" using good by transfer
     moreover have [rule_format, rotated]:
       "\<And>s y s'. \<forall>x \<in> outs_\<I> \<I>. (y, s') \<in> set_spmf (callee' s x) \<longrightarrow> consider x \<longrightarrow> count' s' \<le> Suc (count' s)"
       by(transfer fixing: "consider")(blast intro: count)
     moreover have [rule_format, rotated]:
       "\<And>s y s'. \<forall>x \<in> outs_\<I> \<I>. (y, s') \<in> set_spmf (callee' s x) \<longrightarrow> \<not> consider x \<longrightarrow> count' s' \<le> count' s"
       by(transfer fixing: "consider")(blast intro: ignore)
     moreover have [rule_format, rotated]: 
       "\<And>s''. \<forall>x \<in> outs_\<I> \<I>. \<not> bad' s'' \<longrightarrow> count' s'' < n + count' s' \<longrightarrow> consider x \<longrightarrow> spmf (map_spmf (bad' \<circ> snd) (callee' s'' x)) True \<le> k"
       by(transfer fixing: "consider" k n)(blast intro: bad)
     moreover have [rule_format, rotated]: 
       "\<And>s y s'. \<forall>x \<in> outs_\<I> \<I>. (y, s') \<in> set_spmf (callee' s x) \<longrightarrow> \<not> bad' s \<longrightarrow> bad' s' \<longrightarrow> consider x"
       by(transfer fixing: "consider")(blast intro: "consider")
     moreover note k_nonneg
     moreover have "\<I> \<turnstile>g gpv' \<surd>" by(simp add: gpv'_def)
     moreover have "\<And>s. \<I> \<turnstile>c callee' s \<surd>" by transfer(rule WT_callee)
     ultimately have **: "spmf (map_spmf (bad' \<circ> snd) (exec_gpv callee' gpv' s')) True \<le> ennreal k * n"
       by(rule interaction_bounded_by_exec_gpv_bad_count)
     have [transfer_rule]: "((=) ===> ?C ===> rel_spmf (rel_prod (=) (=))) callee callee"
       by(simp add: rel_fun_def eq_onp_def prod.rel_eq)
     have "spmf (map_spmf (bad \<circ> snd) (exec_gpv callee gpv' s)) True \<le> ennreal k * n" using **
       by(transfer)
     also have "exec_gpv callee gpv' s = exec_gpv callee gpv s"
       unfolding gpv'_def using WT_gpv I by(rule exec_gpv_restrict_gpv_invariant)
     finally have ?thesis . }
   from this[cancel_type_definition] I show ?thesis by blast
 qed
 
 lemma interaction_bounded_by'_exec_gpv_bad_count:
   fixes count and bad and n :: nat
   assumes bound: "interaction_bounded_by' consider gpv n"
   and I: "I s"
   and good: "\<not> bad s"
   and count: "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); I s; consider x; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> count s' \<le> Suc (count s)"
   and ignore: "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); I s; \<not> consider x; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> count s' \<le> count s"
   and bad: "\<And>s' x. \<lbrakk> I s'; \<not> bad s'; count s' < n + count s; consider x; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> spmf (map_spmf (bad \<circ> snd) (callee s' x)) True \<le> k"
   and "consider": "\<And>s x y s'. \<lbrakk> (y, s') \<in> set_spmf (callee s x); I s; \<not> bad s; bad s'; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> consider x"
   and k_nonneg: "k \<ge> 0"
   and WT_gpv: "\<I> \<turnstile>g gpv \<surd>"
   shows "spmf (map_spmf (bad \<circ> snd) (exec_gpv callee gpv s)) True \<le> k * n"
 apply(subst ennreal_le_iff[symmetric], simp_all add: k_nonneg ennreal_mult ennreal_real_conv_ennreal_of_enat del: ennreal_of_enat_enat ennreal_le_iff)
 apply(rule interaction_bounded_by_exec_gpv_bad_count[OF bound I _ count ignore bad "consider" k_nonneg WT_gpv, OF good])
 apply simp_all
 done
 
 lemma interaction_bounded_by_exec_gpv_bad:
   assumes "interaction_any_bounded_by gpv n"
   and "I s" "\<not> bad s"
   and bad: "\<And>s x. \<lbrakk> I s; \<not> bad s; x \<in> outs_\<I> \<I> \<rbrakk> \<Longrightarrow> spmf (map_spmf (bad \<circ> snd) (callee s x)) True \<le> k"
   and k_nonneg: "0 \<le> k"
   and WT_gpv: "\<I> \<turnstile>g gpv \<surd>"
   shows "spmf (map_spmf (bad \<circ> snd) (exec_gpv callee gpv s)) True \<le> k * n"
 using interaction_bounded_by_exec_gpv_bad_count[where bad=bad, OF assms(1) assms(2-3), where ?count = "\<lambda>_. 0", OF _ _ bad _ k_nonneg] k_nonneg WT_gpv
 by(simp add: ennreal_real_conv_ennreal_of_enat[symmetric] ennreal_mult[symmetric] del: ennreal_of_enat_enat)
 
 end
 
 end
diff --git a/thys/CryptHOL/Misc_CryptHOL.thy b/thys/CryptHOL/Misc_CryptHOL.thy
--- a/thys/CryptHOL/Misc_CryptHOL.thy
+++ b/thys/CryptHOL/Misc_CryptHOL.thy
@@ -1,1920 +1,2521 @@
 (* Title: Misc_CryptHOL.thy
   Author: Andreas Lochbihler, ETH Zurich *)
 
 section \<open>Miscellaneous library additions\<close>
 
 theory Misc_CryptHOL imports 
   Probabilistic_While.While_SPMF
   "HOL-Library.Rewrite"
   "HOL-Library.Simps_Case_Conv"
   "HOL-Library.Type_Length"
   "HOL-Eisbach.Eisbach"
   Coinductive.TLList
   Monad_Normalisation.Monad_Normalisation
   Monomorphic_Monad.Monomorphic_Monad
+  Applicative_Lifting.Applicative
 begin
 
 hide_const (open) Henstock_Kurzweil_Integration.negligible
 
+declare eq_on_def [simp del]
+
 subsection \<open>HOL\<close>
 
 lemma asm_rl_conv: "(PROP P \<Longrightarrow> PROP P) \<equiv> Trueprop True"
 by(rule equal_intr_rule) iprover+
 
 named_theorems if_distribs "Distributivity theorems for If"
 
 lemma if_mono_cong: "\<lbrakk>b \<Longrightarrow> x \<le> x'; \<not> b \<Longrightarrow> y \<le> y' \<rbrakk> \<Longrightarrow> If b x y \<le> If b x' y'"
 by simp
 
 lemma if_cong_then: "\<lbrakk> b = b'; b' \<Longrightarrow> t = t'; e = e' \<rbrakk> \<Longrightarrow> If b t e = If b' t' e'"
 by simp
 
 lemma if_False_eq: "\<lbrakk> b \<Longrightarrow> False; e = e' \<rbrakk> \<Longrightarrow> If b t e = e'"
 by auto
 
 lemma imp_OO_imp [simp]: "(\<longrightarrow>) OO (\<longrightarrow>) = (\<longrightarrow>)"
 by auto
 
 lemma inj_on_fun_updD: "\<lbrakk> inj_on (f(x := y)) A; x \<notin> A \<rbrakk> \<Longrightarrow> inj_on f A"
 by(auto simp add: inj_on_def split: if_split_asm)
 
 lemma disjoint_notin1: "\<lbrakk> A \<inter> B = {}; x \<in> B \<rbrakk> \<Longrightarrow> x \<notin> A" by auto
 
 lemma Least_le_Least:
   fixes x :: "'a :: wellorder"
   assumes "Q x"
   and Q: "\<And>x. Q x \<Longrightarrow> \<exists>y\<le>x. P y"
   shows "Least P \<le> Least Q"
 proof -
   obtain f :: "'a \<Rightarrow> 'a" where "\<forall>a. \<not> Q a \<or> f a \<le> a \<and> P (f a)" using Q by moura
   moreover have "Q (Least Q)" using \<open>Q x\<close> by(rule LeastI)
   ultimately show ?thesis by (metis (full_types) le_cases le_less less_le_trans not_less_Least)
 qed
 
+lemma is_empty_image [simp]: "Set.is_empty (f ` A) = Set.is_empty A"
+  by(auto simp add: Set.is_empty_def)
+
 subsection \<open>Relations\<close>
 
 inductive Imagep :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> bool"
   for R P
 where ImagepI: "\<lbrakk> P x; R x y \<rbrakk> \<Longrightarrow> Imagep R P y"
 
 lemma r_r_into_tranclp: "\<lbrakk> r x y; r y z \<rbrakk> \<Longrightarrow> r^++ x z"
 by(rule tranclp.trancl_into_trancl)(rule tranclp.r_into_trancl)
 
 lemma transp_tranclp_id:
   assumes "transp R"
   shows "tranclp R = R"
 proof(intro ext iffI)
   fix x y
   assume "R^++ x y"
   thus "R x y" by induction(blast dest: transpD[OF assms])+
 qed simp
 
 lemma transp_inv_image: "transp r \<Longrightarrow> transp (\<lambda>x y. r (f x) (f y))"
 using trans_inv_image[where r="{(x, y). r x y}" and f = f]
 by(simp add: transp_trans inv_image_def)
 
 lemma Domainp_conversep: "Domainp R\<inverse>\<inverse> = Rangep R"
 by(auto)
 
 lemma bi_unique_rel_set_bij_betw:
   assumes unique: "bi_unique R"
   and rel: "rel_set R A B"
   shows "\<exists>f. bij_betw f A B \<and> (\<forall>x\<in>A. R x (f x))"
 proof -
   from assms obtain f where f: "\<And>x. x \<in> A \<Longrightarrow> R x (f x)" and B: "\<And>x. x \<in> A \<Longrightarrow> f x \<in> B"
     apply(atomize_elim)
     apply(fold all_conj_distrib)
     apply(subst choice_iff[symmetric])
     apply(auto dest: rel_setD1)
     done
   have "inj_on f A" by(rule inj_onI)(auto dest!: f dest: bi_uniqueDl[OF unique])
   moreover have "f ` A = B" using rel
     by(auto 4 3 intro: B dest: rel_setD2 f bi_uniqueDr[OF unique])
   ultimately have "bij_betw f A B" unfolding bij_betw_def ..
   thus ?thesis using f by blast
 qed
 
 definition restrict_relp :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
   ("_ \<upharpoonleft> (_ \<otimes> _)" [53, 54, 54] 53)
 where "restrict_relp R P Q = (\<lambda>x y. R x y \<and> P x \<and> Q y)"
 
 lemma restrict_relp_apply [simp]: "(R \<upharpoonleft> P \<otimes> Q) x y \<longleftrightarrow> R x y \<and> P x \<and> Q y"
 by(simp add: restrict_relp_def)
 
 lemma restrict_relpI [intro?]: "\<lbrakk> R x y; P x; Q y \<rbrakk> \<Longrightarrow> (R \<upharpoonleft> P \<otimes> Q) x y"
 by(simp add: restrict_relp_def)
 
 lemma restrict_relpE [elim?, cases pred]:
   assumes "(R \<upharpoonleft> P \<otimes> Q) x y"
   obtains (restrict_relp) "R x y" "P x" "Q y"
 using assms by(simp add: restrict_relp_def)
 
 lemma conversep_restrict_relp [simp]: "(R \<upharpoonleft> P \<otimes> Q)\<inverse>\<inverse> = R\<inverse>\<inverse> \<upharpoonleft> Q \<otimes> P"
 by(auto simp add: fun_eq_iff)
 
 lemma restrict_relp_restrict_relp [simp]: "R \<upharpoonleft> P \<otimes> Q \<upharpoonleft> P' \<otimes> Q' = R \<upharpoonleft> inf P P' \<otimes> inf Q Q'"
 by(auto simp add: fun_eq_iff)
 
 lemma restrict_relp_cong:
   "\<lbrakk> P = P'; Q = Q'; \<And>x y. \<lbrakk> P x; Q y \<rbrakk> \<Longrightarrow> R x y = R' x y \<rbrakk> \<Longrightarrow> R \<upharpoonleft> P \<otimes> Q = R' \<upharpoonleft> P' \<otimes> Q'"
 by(auto simp add: fun_eq_iff)
 
 lemma restrict_relp_cong_simp:
   "\<lbrakk> P = P'; Q = Q'; \<And>x y. P x =simp=> Q y =simp=> R x y = R' x y \<rbrakk> \<Longrightarrow> R \<upharpoonleft> P \<otimes> Q = R' \<upharpoonleft> P' \<otimes> Q'"
 by(rule restrict_relp_cong; simp add: simp_implies_def)
 
 lemma restrict_relp_parametric [transfer_rule]:
   includes lifting_syntax shows
   "((A ===> B ===> (=)) ===> (A ===> (=)) ===> (B ===> (=)) ===> A ===> B ===> (=)) restrict_relp restrict_relp"
 unfolding restrict_relp_def[abs_def] by transfer_prover
 
 lemma restrict_relp_mono: "\<lbrakk> R \<le> R'; P \<le> P'; Q \<le> Q' \<rbrakk> \<Longrightarrow> R \<upharpoonleft> P \<otimes> Q \<le> R' \<upharpoonleft> P' \<otimes> Q'"
 by(simp add: le_fun_def)
 
 lemma restrict_relp_mono': 
   "\<lbrakk> (R \<upharpoonleft> P \<otimes> Q) x y; \<lbrakk> R x y; P x; Q y \<rbrakk> \<Longrightarrow> R' x y &&& P' x &&& Q' y \<rbrakk>
   \<Longrightarrow> (R' \<upharpoonleft> P' \<otimes> Q') x y"
 by(auto dest: conjunctionD1 conjunctionD2)
 
 lemma restrict_relp_DomainpD: "Domainp (R \<upharpoonleft> P \<otimes> Q) x \<Longrightarrow> Domainp R x \<and> P x"
 by(auto simp add: Domainp.simps)
 
 lemma restrict_relp_True: "R \<upharpoonleft> (\<lambda>_. True) \<otimes> (\<lambda>_. True) = R"
 by(simp add: fun_eq_iff)
 
 lemma restrict_relp_False1: "R \<upharpoonleft> (\<lambda>_. False) \<otimes> Q = bot"
 by(simp add: fun_eq_iff)
 
 lemma restrict_relp_False2: "R \<upharpoonleft> P \<otimes> (\<lambda>_. False) = bot"
 by(simp add: fun_eq_iff)
 
 definition rel_prod2 :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> ('c \<times> 'b) \<Rightarrow> bool"
 where "rel_prod2 R a = (\<lambda>(c, b). R a b)"
 
 lemma rel_prod2_simps [simp]: "rel_prod2 R a (c, b) \<longleftrightarrow> R a b"
 by(simp add: rel_prod2_def)
 
 lemma restrict_rel_prod:
   "rel_prod (R \<upharpoonleft> I1 \<otimes> I2) (S \<upharpoonleft> I1' \<otimes> I2') = rel_prod R S \<upharpoonleft> pred_prod I1 I1' \<otimes> pred_prod I2 I2'"
 by(auto simp add: fun_eq_iff)
 
 lemma restrict_rel_prod1:
   "rel_prod (R \<upharpoonleft> I1 \<otimes> I2) S = rel_prod R S \<upharpoonleft> pred_prod I1 (\<lambda>_. True) \<otimes> pred_prod I2 (\<lambda>_. True)"
 by(simp add: restrict_rel_prod[symmetric] restrict_relp_True)
 
 lemma restrict_rel_prod2:
   "rel_prod R (S \<upharpoonleft> I1 \<otimes> I2) = rel_prod R S \<upharpoonleft> pred_prod (\<lambda>_. True) I1 \<otimes> pred_prod (\<lambda>_. True) I2"
 by(simp add: restrict_rel_prod[symmetric] restrict_relp_True)
 
+consts relcompp_witness :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'c \<Rightarrow> 'b"
+specification (relcompp_witness)
+  relcompp_witness1: "(A OO B) (fst xy) (snd xy) \<Longrightarrow> A (fst xy) (relcompp_witness A B xy)"
+  relcompp_witness2: "(A OO B) (fst xy) (snd xy) \<Longrightarrow> B (relcompp_witness A B xy) (snd xy)"
+  apply(fold all_conj_distrib)
+  apply(rule choice allI)+
+  by(auto intro: choice allI)
+
+lemmas relcompp_witness[of _ _ "(x, y)" for x y, simplified] = relcompp_witness1 relcompp_witness2
+
+hide_fact (open) relcompp_witness1 relcompp_witness2
+
+lemma relcompp_witness_eq [simp]: "relcompp_witness (=) (=) (x, x) = x"
+  using relcompp_witness(1)[of "(=)" "(=)" x x] by(simp add: eq_OO)
+
 subsection \<open>Pairs\<close>
 
 lemma split_apfst [simp]: "case_prod h (apfst f xy) = case_prod (h \<circ> f) xy"
 by(cases xy) simp
 
 definition corec_prod :: "('s \<Rightarrow> 'a) \<Rightarrow> ('s \<Rightarrow> 'b) \<Rightarrow> 's \<Rightarrow> 'a \<times> 'b"
 where "corec_prod f g = (\<lambda>s. (f s, g s))"
 
 lemma corec_prod_apply: "corec_prod f g s = (f s, g s)"
 by(simp add: corec_prod_def)
 
 lemma corec_prod_sel [simp]:
   shows fst_corec_prod: "fst (corec_prod f g s) = f s"
   and snd_corec_prod: "snd (corec_prod f g s) = g s"
 by(simp_all add: corec_prod_apply)
 
 lemma apfst_corec_prod [simp]: "apfst h (corec_prod f g s) = corec_prod (h \<circ> f) g s"
 by(simp add: corec_prod_apply)
 
 lemma apsnd_corec_prod [simp]: "apsnd h (corec_prod f g s) = corec_prod f (h \<circ> g) s"
 by(simp add: corec_prod_apply)
 
 lemma map_corec_prod [simp]: "map_prod f g (corec_prod h k s) = corec_prod (f \<circ> h) (g \<circ> k) s"
 by(simp add: corec_prod_apply)
 
 lemma split_corec_prod [simp]: "case_prod h (corec_prod f g s) = h (f s) (g s)"
 by(simp add: corec_prod_apply)
 
+lemma Pair_fst_Unity: "(fst x, ()) = x"
+  by(cases x) simp
+
+definition rprodl :: "('a \<times> 'b) \<times> 'c \<Rightarrow> 'a \<times> ('b \<times> 'c)" where "rprodl = (\<lambda>((a, b), c). (a, (b, c)))"
+
+lemma rprodl_simps [simp]: "rprodl ((a, b), c) = (a, (b, c))"
+  by(simp add: rprodl_def)
+
+lemma rprodl_parametric [transfer_rule]: includes lifting_syntax shows
+  "(rel_prod (rel_prod A B) C ===> rel_prod A (rel_prod B C)) rprodl rprodl"
+  unfolding rprodl_def by transfer_prover
+
+definition lprodr :: "'a \<times> ('b \<times> 'c) \<Rightarrow> ('a \<times> 'b) \<times> 'c" where "lprodr = (\<lambda>(a, b, c). ((a, b), c))"
+
+lemma lprodr_simps [simp]: "lprodr (a, b, c) = ((a, b), c)"
+  by(simp add: lprodr_def)
+
+lemma lprodr_parametric [transfer_rule]: includes lifting_syntax shows
+  "(rel_prod A (rel_prod B C) ===> rel_prod (rel_prod A B) C) lprodr lprodr"
+  unfolding lprodr_def by transfer_prover
+
+lemma lprodr_inverse [simp]: "rprodl (lprodr x) = x"
+  by(cases x) auto
+
+lemma rprodl_inverse [simp]: "lprodr (rprodl x) = x"
+  by(cases x) auto
+
+lemma pred_prod_mono' [mono]:
+  "pred_prod A B xy \<longrightarrow> pred_prod A' B' xy"
+  if "\<And>x. A x \<longrightarrow> A' x" "\<And>y. B y \<longrightarrow> B' y"
+  using that by(cases xy) auto
+
+fun rel_witness_prod :: "('a \<times> 'b) \<times> ('c \<times> 'd) \<Rightarrow> (('a \<times> 'c) \<times> ('b \<times> 'd))" where
+  "rel_witness_prod ((a, b), (c, d)) = ((a, c), (b, d))"
+
 subsection \<open>Sums\<close>
 
 lemma islE:
   assumes "isl x"
   obtains l where "x = Inl l"
 using assms by(cases x) auto
 
 lemma Inl_in_Plus [simp]: "Inl x \<in> A <+> B \<longleftrightarrow> x \<in> A"
 by auto
 
 lemma Inr_in_Plus [simp]: "Inr x \<in> A <+> B \<longleftrightarrow> x \<in> B"
 by auto
 
 lemma Inl_eq_map_sum_iff: "Inl x = map_sum f g y \<longleftrightarrow> (\<exists>z. y = Inl z \<and> x = f z)"
 by(cases y) auto
 
 lemma Inr_eq_map_sum_iff: "Inr x = map_sum f g y \<longleftrightarrow> (\<exists>z. y = Inr z \<and> x = g z)"
 by(cases y) auto
 
+lemma inj_on_map_sum [simp]:
+  "\<lbrakk> inj_on f A; inj_on g B \<rbrakk> \<Longrightarrow> inj_on (map_sum f g) (A <+> B)"
+proof(rule inj_onI, goal_cases)
+  case (1 x y)
+  then show ?case by(cases x; cases y; auto simp add: inj_on_def)
+qed
+
+lemma inv_into_map_sum:
+  "inv_into (A <+> B) (map_sum f g) x = map_sum (inv_into A f) (inv_into B g) x"
+  if "x \<in> f ` A <+> g ` B" "inj_on f A" "inj_on g B"
+  using that by(cases rule: PlusE[consumes 1])(auto simp add: inv_into_f_eq f_inv_into_f)
+
+fun rsuml :: "('a + 'b) + 'c \<Rightarrow> 'a + ('b + 'c)" where
+  "rsuml (Inl (Inl a)) = Inl a"
+| "rsuml (Inl (Inr b)) = Inr (Inl b)"
+| "rsuml (Inr c) = Inr (Inr c)"
+
+fun lsumr :: "'a + ('b + 'c) \<Rightarrow> ('a + 'b) + 'c" where
+  "lsumr (Inl a) = Inl (Inl a)"
+| "lsumr (Inr (Inl b)) = Inl (Inr b)"
+| "lsumr (Inr (Inr c)) = Inr c"
+
+lemma rsuml_lsumr [simp]: "rsuml (lsumr x) = x"
+  by(cases x rule: lsumr.cases) simp_all
+
+lemma lsumr_rsuml [simp]: "lsumr (rsuml x) = x"
+  by(cases x rule: rsuml.cases) simp_all
+
 subsection \<open>Option\<close>
 
 declare is_none_bind [simp]
 
 lemma case_option_collapse: "case_option x (\<lambda>_. x) y = x"
 by(simp split: option.split)
 
 lemma indicator_single_Some: "indicator {Some x} (Some y) = indicator {x} y"
 by(simp split: split_indicator)
 
 subsubsection \<open>Predicator and relator\<close>
 
 lemma option_pred_mono_strong:
   "\<lbrakk> pred_option P x; \<And>a. \<lbrakk> a \<in> set_option x; P a \<rbrakk> \<Longrightarrow> P' a \<rbrakk> \<Longrightarrow> pred_option P' x"
 by(fact option.pred_mono_strong)
 
 lemma option_pred_map [simp]: "pred_option P (map_option f x) = pred_option (P \<circ> f) x"
 by(fact option.pred_map)
 
 lemma option_pred_o_map [simp]: "pred_option P \<circ> map_option f = pred_option (P \<circ> f)"
 by(simp add: fun_eq_iff)
 
 lemma option_pred_bind [simp]: "pred_option P (Option.bind x f) = pred_option (pred_option P \<circ> f) x"
 by(simp add: pred_option_def)
 
 lemma pred_option_conj [simp]:
   "pred_option (\<lambda>x. P x \<and> Q x) = (\<lambda>x. pred_option P x \<and> pred_option Q x)"
 by(auto simp add: pred_option_def)
 
 lemma pred_option_top [simp]:
   "pred_option (\<lambda>_. True) = (\<lambda>_. True)"
 by(fact option.pred_True)
 
 lemma rel_option_restrict_relpI [intro?]:
   "\<lbrakk> rel_option R x y; pred_option P x; pred_option Q y \<rbrakk> \<Longrightarrow> rel_option (R \<upharpoonleft> P \<otimes> Q) x y"
 by(erule option.rel_mono_strong) simp
 
 lemma rel_option_restrict_relpE [elim?]:
   assumes "rel_option (R \<upharpoonleft> P \<otimes> Q) x y"
   obtains "rel_option R x y" "pred_option P x" "pred_option Q y"
 proof
   show "rel_option R x y" using assms by(auto elim!: option.rel_mono_strong)
   have "pred_option (Domainp (R \<upharpoonleft> P \<otimes> Q)) x" using assms by(fold option.Domainp_rel) blast
   then show "pred_option P x" by(rule option_pred_mono_strong)(blast dest!: restrict_relp_DomainpD)
   have "pred_option (Domainp (R \<upharpoonleft> P \<otimes> Q)\<inverse>\<inverse>) y" using assms
     by(fold option.Domainp_rel)(auto simp only: option.rel_conversep Domainp_conversep)
   then show "pred_option Q y" by(rule option_pred_mono_strong)(auto dest!: restrict_relp_DomainpD)
 qed
 
 lemma rel_option_restrict_relp_iff:
   "rel_option (R \<upharpoonleft> P \<otimes> Q) x y \<longleftrightarrow> rel_option R x y \<and> pred_option P x \<and> pred_option Q y"
 by(blast intro: rel_option_restrict_relpI elim: rel_option_restrict_relpE)
 
 lemma option_rel_map_restrict_relp:
   shows option_rel_map_restrict_relp1:
   "rel_option (R \<upharpoonleft> P \<otimes> Q) (map_option f x) = rel_option (R \<circ> f \<upharpoonleft> P \<circ> f \<otimes> Q) x"
   and option_rel_map_restrict_relp2:
   "rel_option (R \<upharpoonleft> P \<otimes> Q) x (map_option g y) = rel_option ((\<lambda>x. R x \<circ> g) \<upharpoonleft> P \<otimes> Q \<circ> g) x y"
 by(simp_all add: option.rel_map restrict_relp_def fun_eq_iff)
 
+fun rel_witness_option :: "'a option \<times> 'b option \<Rightarrow> ('a \<times> 'b) option" where
+  "rel_witness_option (Some x, Some y) = Some (x, y)"
+| "rel_witness_option (None, None) = None"
+| "rel_witness_option _ = None" \<comment> \<open>Just to make the definition complete\<close>
+
+lemma rel_witness_option:
+  shows set_rel_witness_option: "\<lbrakk> rel_option A x y; (a, b) \<in> set_option (rel_witness_option (x, y)) \<rbrakk> \<Longrightarrow> A a b"
+    and map1_rel_witness_option: "rel_option A x y \<Longrightarrow> map_option fst (rel_witness_option (x, y)) = x"
+    and map2_rel_witness_option: "rel_option A x y \<Longrightarrow> map_option snd (rel_witness_option (x, y)) = y"
+  by(cases "(x, y)" rule: rel_witness_option.cases; simp; fail)+
+
+lemma rel_witness_option1:
+  assumes "rel_option A x y"
+  shows "rel_option (\<lambda>a (a', b). a = a' \<and> A a' b) x (rel_witness_option (x, y))"
+  using map1_rel_witness_option[OF assms, symmetric]
+  unfolding option.rel_eq[symmetric] option.rel_map
+  by(rule option.rel_mono_strong)(auto intro: set_rel_witness_option[OF assms])
+
+lemma rel_witness_option2:
+  assumes "rel_option A x y"
+  shows "rel_option (\<lambda>(a, b') b. b = b' \<and> A a b') (rel_witness_option (x, y)) y"
+  using map2_rel_witness_option[OF assms]
+  unfolding option.rel_eq[symmetric] option.rel_map
+  by(rule option.rel_mono_strong)(auto intro: set_rel_witness_option[OF assms])
+
 subsubsection \<open>Orders on option\<close>
 
 abbreviation le_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool"
 where "le_option \<equiv> ord_option (=)"
 
 lemma le_option_bind_mono:
   "\<lbrakk> le_option x y; \<And>a. a \<in> set_option x \<Longrightarrow> le_option (f a) (g a) \<rbrakk>
   \<Longrightarrow> le_option (Option.bind x f) (Option.bind y g)"
 by(cases x) simp_all
 
 lemma le_option_refl [simp]: "le_option x x"
 by(cases x) simp_all
 
 
 lemma le_option_conv_option_ord: "le_option = option_ord"
 by(auto simp add: fun_eq_iff flat_ord_def elim: ord_option.cases)
 
 definition pcr_Some :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b option \<Rightarrow> bool"
 where "pcr_Some R x y \<longleftrightarrow> (\<exists>z. y = Some z \<and> R x z)"
 
 lemma pcr_Some_simps [simp]: "pcr_Some R x (Some y) \<longleftrightarrow> R x y"
 by(simp add: pcr_Some_def)
 
 lemma pcr_SomeE [cases pred]:
   assumes "pcr_Some R x y"
   obtains (pcr_Some) z where "y = Some z" "R x z"
 using assms by(auto simp add: pcr_Some_def)
 
 subsubsection \<open>Filter for option\<close>
 
 fun filter_option :: "('a \<Rightarrow> bool) \<Rightarrow> 'a option \<Rightarrow> 'a option"
 where
   "filter_option P None = None"
 | "filter_option P (Some x) = (if P x then Some x else None)"
 
 lemma set_filter_option [simp]: "set_option (filter_option P x) = {y \<in> set_option x. P y}"
 by(cases x) auto
 
 lemma filter_map_option: "filter_option P (map_option f x) = map_option f (filter_option (P \<circ> f) x)"
 by(cases x) simp_all
 
 lemma is_none_filter_option [simp]: "Option.is_none (filter_option P x) \<longleftrightarrow> Option.is_none x \<or> \<not> P (the x)"
 by(cases x) simp_all
 
 lemma filter_option_eq_Some_iff [simp]: "filter_option P x = Some y \<longleftrightarrow> x = Some y \<and> P y"
 by(cases x) auto
 
 lemma Some_eq_filter_option_iff [simp]: "Some y = filter_option P x \<longleftrightarrow> x = Some y \<and> P y"
 by(cases x) auto
 
 lemma filter_conv_bind_option: "filter_option P x = Option.bind x (\<lambda>y. if P y then Some y else None)"
 by(cases x) simp_all
 
 subsubsection \<open>Assert for option\<close>
 
 primrec assert_option :: "bool \<Rightarrow> unit option" where
   "assert_option True = Some ()"
 | "assert_option False = None"
 
 lemma set_assert_option_conv: "set_option (assert_option b) = (if b then {()} else {})"
 by(simp)
 
 lemma in_set_assert_option [simp]: "x \<in> set_option (assert_option b) \<longleftrightarrow> b"
 by(cases b) simp_all
 
 
 subsubsection \<open>Join on options\<close>
 
 definition join_option :: "'a option option \<Rightarrow> 'a option"
 where "join_option x = (case x of Some y \<Rightarrow> y | None \<Rightarrow> None)"
 
 simps_of_case join_simps [simp, code]: join_option_def
 
 lemma set_join_option [simp]: "set_option (join_option x) = \<Union>(set_option ` set_option x)"
 by(cases x)(simp_all)
 
 lemma in_set_join_option: "x \<in> set_option (join_option (Some (Some x)))"
 by simp
 
 lemma map_join_option: "map_option f (join_option x) = join_option (map_option (map_option f) x)"
 by(cases x) simp_all
 
 lemma bind_conv_join_option: "Option.bind x f = join_option (map_option f x)"
 by(cases x) simp_all
 
 lemma join_conv_bind_option: "join_option x = Option.bind x id"
 by(cases x) simp_all
 
 lemma join_option_parametric [transfer_rule]:
   includes lifting_syntax shows
   "(rel_option (rel_option R) ===> rel_option R) join_option join_option"
 unfolding join_conv_bind_option[abs_def] by transfer_prover
 
 lemma join_option_eq_Some [simp]: "join_option x = Some y \<longleftrightarrow> x = Some (Some y)"
 by(cases x) simp_all
 
 lemma Some_eq_join_option [simp]: "Some y = join_option x \<longleftrightarrow> x = Some (Some y)"
 by(cases x) auto
 
 lemma join_option_eq_None: "join_option x = None \<longleftrightarrow> x = None \<or> x = Some None"
 by(cases x) simp_all
 
 lemma None_eq_join_option: "None = join_option x \<longleftrightarrow> x = None \<or> x = Some None"
 by(cases x) auto
 
 subsubsection \<open>Zip on options\<close>
 
 function zip_option :: "'a option \<Rightarrow> 'b option \<Rightarrow> ('a \<times> 'b) option"
 where
   "zip_option (Some x) (Some y) = Some (x, y)"
 | "zip_option _ None = None"
 | "zip_option None _ = None"
 by pat_completeness auto
 termination by lexicographic_order
 
 lemma zip_option_eq_Some_iff [iff]:
   "zip_option x y = Some (a, b) \<longleftrightarrow> x = Some a \<and> y = Some b"
 by(cases "(x, y)" rule: zip_option.cases) simp_all
 
 lemma set_zip_option [simp]:
   "set_option (zip_option x y) = set_option x \<times> set_option y"
 by auto
 
 lemma zip_map_option1: "zip_option (map_option f x) y = map_option (apfst f) (zip_option x y)"
 by(cases "(x, y)" rule: zip_option.cases) simp_all
 
 lemma zip_map_option2: "zip_option x (map_option g y) = map_option (apsnd g) (zip_option x y)"
 by(cases "(x, y)" rule: zip_option.cases) simp_all
 
 lemma map_zip_option:
   "map_option (map_prod f g) (zip_option x y) = zip_option (map_option f x) (map_option g y)"
 by(simp add: zip_map_option1 zip_map_option2 option.map_comp apfst_def apsnd_def o_def prod.map_comp)
 
 lemma zip_conv_bind_option:
   "zip_option x y = Option.bind x (\<lambda>x. Option.bind y (\<lambda>y. Some (x, y)))"
 by(cases "(x, y)" rule: zip_option.cases) simp_all
 
 lemma zip_option_parametric [transfer_rule]:
   includes lifting_syntax shows
   "(rel_option R ===> rel_option Q ===> rel_option (rel_prod R Q)) zip_option zip_option"
 unfolding zip_conv_bind_option[abs_def] by transfer_prover
 
 lemma rel_option_eqI [simp]: "rel_option (=) x x"
 by(simp add: option.rel_eq)
 
 subsubsection \<open>Binary supremum on @{typ "'a option"}\<close>
 
 primrec sup_option :: "'a option \<Rightarrow> 'a option \<Rightarrow> 'a option"
 where
   "sup_option x None = x"
 | "sup_option x (Some y) = (Some y)"
 
 lemma sup_option_idem [simp]: "sup_option x x = x"
 by(cases x) simp_all
 
 lemma sup_option_assoc: "sup_option (sup_option x y) z = sup_option x (sup_option y z)"
 by(cases z) simp_all
 
 lemma sup_option_left_idem: "sup_option x (sup_option x y) = sup_option x y"
 by(rewrite sup_option_assoc[symmetric])(simp)
 
 lemmas sup_option_ai = sup_option_assoc sup_option_left_idem
 
 lemma sup_option_None [simp]: "sup_option None y = y"
 by(cases y) simp_all
 
+subsubsection \<open>Restriction on @{typ "'a option"}\<close>
+
+primrec (transfer) enforce_option :: "('a \<Rightarrow> bool) \<Rightarrow> 'a option \<Rightarrow> 'a option" where
+  "enforce_option P (Some x) = (if P x then Some x else None)"
+| "enforce_option P None = None"
+
+lemma set_enforce_option [simp]: "set_option (enforce_option P x) = {a \<in> set_option x. P a}"
+  by(cases x) auto
+
+lemma enforce_map_option: "enforce_option P (map_option f x) = map_option f (enforce_option (P \<circ> f) x)"
+  by(cases x) auto
+
+lemma enforce_bind_option [simp]:
+  "enforce_option P (Option.bind x f) = Option.bind x (enforce_option P \<circ> f)"
+  by(cases x) auto
+
+lemma enforce_option_alt_def:
+  "enforce_option P x = Option.bind x (\<lambda>a. Option.bind (assert_option (P a)) (\<lambda>_ :: unit. Some a))"
+  by(cases x) simp_all
+
+lemma enforce_option_eq_None_iff [simp]:
+  "enforce_option P x = None \<longleftrightarrow> (\<forall>a. x = Some a \<longrightarrow> \<not> P a)"
+  by(cases x) auto
+
+lemma enforce_option_eq_Some_iff [simp]:
+  "enforce_option P x = Some y \<longleftrightarrow> x = Some y \<and> P y"
+  by(cases x) auto
+
+lemma Some_eq_enforce_option_iff [simp]:
+  "Some y = enforce_option P x \<longleftrightarrow> x = Some y \<and> P y"
+  by(cases x) auto
+
+lemma enforce_option_top [simp]: "enforce_option \<top> = id"
+  by(rule ext; rename_tac x; case_tac x; simp)
+
+lemma enforce_option_K_True [simp]: "enforce_option (\<lambda>_. True) x = x"
+  by(cases x) simp_all
+
+lemma enforce_option_bot [simp]: "enforce_option \<bottom> = (\<lambda>_. None)"
+  by(simp add: fun_eq_iff)
+
+lemma enforce_option_K_False [simp]: "enforce_option (\<lambda>_. False) x = None"
+  by simp
+
+lemma enforce_pred_id_option: "pred_option P x \<Longrightarrow> enforce_option P x = x"
+  by(cases x) auto
+
 subsubsection \<open>Maps\<close>
 
 lemma map_add_apply: "(m1 ++ m2) x = sup_option (m1 x) (m2 x)"
 by(simp add: map_add_def split: option.split)
 
 lemma map_le_map_upd2: "\<lbrakk> f \<subseteq>\<^sub>m g; \<And>y'. f x = Some y' \<Longrightarrow> y' = y \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>m g(x \<mapsto> y)"
 by(cases "x \<in> dom f")(auto simp add: map_le_def Ball_def)
 
 lemma eq_None_iff_not_dom: "f x = None \<longleftrightarrow> x \<notin> dom f"
 by auto
 
 lemma card_ran_le_dom: "finite (dom m) \<Longrightarrow> card (ran m) \<le> card (dom m)"
 by(simp add: ran_alt_def card_image_le)
 
 lemma dom_subset_ran_iff:
   assumes "finite (ran m)"
   shows "dom m \<subseteq> ran m \<longleftrightarrow> dom m = ran m"
 proof
   assume le: "dom m \<subseteq> ran m"
   then have "card (dom m) \<le> card (ran m)" by(simp add: card_mono assms)
   moreover have "card (ran m) \<le> card (dom m)" by(simp add: finite_subset[OF le assms] card_ran_le_dom)
   ultimately show "dom m = ran m" using card_subset_eq[OF assms le] by simp
 qed simp
 
 text \<open>
   We need a polymorphic constant for the empty map such that \<open>transfer_prover\<close>
   can use a custom transfer rule for @{const Map.empty}
 \<close>
 definition Map_empty where [simp]: "Map_empty \<equiv> Map.empty"
 
 lemma map_le_Some1D: "\<lbrakk> m \<subseteq>\<^sub>m m'; m x = Some y \<rbrakk> \<Longrightarrow> m' x = Some y"
 by(auto simp add: map_le_def Ball_def)
 
 lemma map_le_fun_upd2: "\<lbrakk> f \<subseteq>\<^sub>m g; x \<notin> dom f \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>m g(x := y)"
 by(auto simp add: map_le_def)
 
 lemma map_eqI: "\<forall>x\<in>dom m \<union> dom m'. m x = m' x \<Longrightarrow> m = m'"
 by(auto simp add: fun_eq_iff domIff intro: option.expand)
 
 
 subsection \<open>Countable\<close>
 
 lemma countable_lfp:
   assumes step: "\<And>Y. countable Y \<Longrightarrow> countable (F Y)"
   and cont: "Order_Continuity.sup_continuous F"
   shows "countable (lfp F)"
 by(subst sup_continuous_lfp[OF cont])(simp add: countable_funpow[OF step])
 
 lemma countable_lfp_apply:
   assumes step: "\<And>Y x. (\<And>x. countable (Y x)) \<Longrightarrow> countable (F Y x)"
   and cont: "Order_Continuity.sup_continuous F"
   shows "countable (lfp F x)"
 proof -
   { fix n
     have "\<And>x. countable ((F ^^ n) bot x)"
       by(induct n)(auto intro: step) }
   thus ?thesis using cont by(simp add: sup_continuous_lfp)
 qed
 
 
 subsection \<open> Extended naturals \<close>
 
 lemma idiff_enat_eq_enat_iff: "x - enat n = enat m \<longleftrightarrow> (\<exists>k. x = enat k \<and> k - n = m)"
   by (cases x) simp_all
 
 lemma eSuc_SUP: "A \<noteq> {} \<Longrightarrow> eSuc (\<Squnion> (f ` A)) = (\<Squnion>x\<in>A. eSuc (f x))"
   by (subst eSuc_Sup) (simp_all add: image_comp)
 
 lemma ereal_of_enat_1: "ereal_of_enat 1 = ereal 1"
   by (simp add: one_enat_def)
 
 lemma ennreal_real_conv_ennreal_of_enat: "ennreal (real n) = ennreal_of_enat n"
   by (simp add: ennreal_of_nat_eq_real_of_nat)
 
 lemma enat_add_sub_same2: "b \<noteq> \<infinity> \<Longrightarrow> a + b - b = (a :: enat)"
   by (cases a; cases b) simp_all
 
 lemma enat_sub_add: "y \<le> x \<Longrightarrow> x - y + z = x + z - (y :: enat)"
   by (cases x; cases y; cases z) simp_all
 
 lemma SUP_enat_eq_0_iff [simp]: "\<Squnion> (f ` A) = (0 :: enat) \<longleftrightarrow> (\<forall>x\<in>A. f x = 0)"
   by (simp add: bot_enat_def [symmetric])
 
 lemma SUP_enat_add_left:
   assumes "I \<noteq> {}"
   shows "(SUP i\<in>I. f i + c :: enat) = (SUP i\<in>I. f i) + c" (is "?lhs = ?rhs")
 proof(cases "c", rule antisym)
   case (enat n)
   show "?lhs \<le> ?rhs" by(auto 4 3 intro: SUP_upper intro: SUP_least)
   have "(SUP i\<in>I. f i) \<le> ?lhs - c" using enat 
     by(auto simp add: enat_add_sub_same2 intro!: SUP_least order_trans[OF _ SUP_upper[THEN enat_minus_mono1]])
   note add_right_mono[OF this, of c]
   also have "\<dots> + c \<le> ?lhs" using assms
     by(subst enat_sub_add)(auto intro: SUP_upper2 simp add: enat_add_sub_same2 enat)
   finally show "?rhs \<le> ?lhs" .
 qed(simp add: assms SUP_constant)
 
 lemma SUP_enat_add_right:
   assumes "I \<noteq> {}"
   shows "(SUP i\<in>I. c + f i :: enat) = c + (SUP i\<in>I. f i)"
 using SUP_enat_add_left[OF assms, of f c]
 by(simp add: add.commute)
 
 lemma iadd_SUP_le_iff: "n + (SUP x\<in>A. f x :: enat) \<le> y \<longleftrightarrow> (if A = {} then n \<le> y else \<forall>x\<in>A. n + f x \<le> y)"
 by(simp add: bot_enat_def SUP_enat_add_right[symmetric] SUP_le_iff)
 
 lemma SUP_iadd_le_iff: "(SUP x\<in>A. f x :: enat) + n \<le> y \<longleftrightarrow> (if A = {} then n \<le> y else \<forall>x\<in>A. f x + n \<le> y)"
 using iadd_SUP_le_iff[of n f A y] by(simp add: add.commute)
 
 
 subsection \<open>Extended non-negative reals\<close>
 
 lemma (in finite_measure) nn_integral_indicator_neq_infty: 
   "f -` A \<in> sets M \<Longrightarrow> (\<integral>\<^sup>+ x. indicator A (f x) \<partial>M) \<noteq> \<infinity>"
 unfolding ennreal_indicator[symmetric]
 apply(rule integrableD)
 apply(rule integrable_const_bound[where B=1])
 apply(simp_all add: indicator_vimage[symmetric])
 done
 
 lemma (in finite_measure) nn_integral_indicator_neq_top: 
   "f -` A \<in> sets M \<Longrightarrow> (\<integral>\<^sup>+ x. indicator A (f x) \<partial>M) \<noteq> \<top>"
 by(drule nn_integral_indicator_neq_infty) simp
 
 lemma nn_integral_indicator_map:
   assumes [measurable]: "f \<in> measurable M N" "{x\<in>space N. P x} \<in> sets N"
   shows "(\<integral>\<^sup>+x. indicator {x\<in>space N. P x} (f x) \<partial>M) = emeasure M {x\<in>space M. P (f x)}"
   using assms(1)[THEN measurable_space] 
   by (subst nn_integral_indicator[symmetric])
      (auto intro!: nn_integral_cong split: split_indicator simp del: nn_integral_indicator)
 
 
 subsection \<open>BNF material\<close>
 
 lemma transp_rel_fun: "\<lbrakk> is_equality Q; transp R \<rbrakk> \<Longrightarrow> transp (rel_fun Q R)"
 by(rule transpI)(auto dest: transpD rel_funD simp add: is_equality_def)
 
 lemma rel_fun_inf: "inf (rel_fun Q R) (rel_fun Q R') = rel_fun Q (inf R R')"
 by(rule antisym)(auto elim: rel_fun_mono dest: rel_funD)
 
 lemma reflp_fun1: includes lifting_syntax shows "\<lbrakk> is_equality A; reflp B \<rbrakk> \<Longrightarrow> reflp (A ===> B)"
 by(simp add: reflp_def rel_fun_def is_equality_def)
 
 lemma type_copy_id': "type_definition (\<lambda>x. x) (\<lambda>x. x) UNIV"
 by unfold_locales simp_all
 
 lemma type_copy_id: "type_definition id id UNIV"
 by(simp add: id_def type_copy_id')
 
 lemma GrpE [cases pred]:
   assumes "BNF_Def.Grp A f x y"
   obtains (Grp) "y = f x" "x \<in> A"
 using assms
 by(simp add: Grp_def)
 
 lemma rel_fun_Grp_copy_Abs:
   includes lifting_syntax
   assumes "type_definition Rep Abs A"
   shows "rel_fun (BNF_Def.Grp A Abs) (BNF_Def.Grp B g) = BNF_Def.Grp {f. f ` A \<subseteq> B} (Rep ---> g)"
 proof -
   interpret type_definition Rep Abs A by fact
   show ?thesis
     by(auto simp add: rel_fun_def Grp_def fun_eq_iff Abs_inverse Rep_inverse intro!: Rep)
 qed
 
 lemma rel_set_Grp:
   "rel_set (BNF_Def.Grp A f) = BNF_Def.Grp {B. B \<subseteq> A} (image f)"
 by(auto simp add: rel_set_def BNF_Def.Grp_def fun_eq_iff)
 
 lemma rel_set_comp_Grp:
   "rel_set R = (BNF_Def.Grp {x. x \<subseteq> {(x, y). R x y}} ((`) fst))\<inverse>\<inverse> OO BNF_Def.Grp {x. x \<subseteq> {(x, y). R x y}} ((`) snd)"
 apply(auto 4 4 del: ext intro!: ext simp add: BNF_Def.Grp_def intro!: rel_setI intro: rev_bexI)
 apply(simp add: relcompp_apply)
 subgoal for A B
   apply(rule exI[where x="A \<times> B \<inter> {(x, y). R x y}"])
   apply(auto 4 3 dest: rel_setD1 rel_setD2 intro: rev_image_eqI)
   done
 done
 
 lemma Domainp_Grp: "Domainp (BNF_Def.Grp A f) = (\<lambda>x. x \<in> A)"
 by(auto simp add: fun_eq_iff Grp_def)
 
 lemma pred_prod_conj [simp]:
   shows pred_prod_conj1: "\<And>P Q R. pred_prod (\<lambda>x. P x \<and> Q x) R = (\<lambda>x. pred_prod P R x \<and> pred_prod Q R x)"
   and pred_prod_conj2: "\<And>P Q R. pred_prod P (\<lambda>x. Q x \<and> R x) = (\<lambda>x. pred_prod P Q x \<and> pred_prod P R x)"
 by(auto simp add: pred_prod.simps)
 
 lemma pred_sum_conj [simp]:
   shows pred_sum_conj1: "\<And>P Q R. pred_sum (\<lambda>x. P x \<and> Q x) R = (\<lambda>x. pred_sum P R x \<and> pred_sum Q R x)"
   and pred_sum_conj2: "\<And>P Q R. pred_sum P (\<lambda>x. Q x \<and> R x) = (\<lambda>x. pred_sum P Q x \<and> pred_sum P R x)"
 by(auto simp add: pred_sum.simps fun_eq_iff)
 
 lemma pred_list_conj [simp]: "list_all (\<lambda>x. P x \<and> Q x) = (\<lambda>x. list_all P x \<and> list_all Q x)"
 by(auto simp add: list_all_def)
 
 lemma pred_prod_top [simp]:
   "pred_prod (\<lambda>_. True) (\<lambda>_. True) = (\<lambda>_. True)"
 by(simp add: pred_prod.simps fun_eq_iff)
 
 lemma rel_fun_conversep: includes lifting_syntax shows
   "(A^--1 ===> B^--1) = (A ===> B)^--1"
 by(auto simp add: rel_fun_def fun_eq_iff)
 
 lemma left_unique_Grp [iff]:
   "left_unique (BNF_Def.Grp A f) \<longleftrightarrow> inj_on f A"
 unfolding Grp_def left_unique_def by(auto simp add: inj_on_def)
 
 lemma right_unique_Grp [simp, intro!]: "right_unique (BNF_Def.Grp A f)"
 by(simp add: Grp_def right_unique_def)
 
 lemma bi_unique_Grp [iff]:
   "bi_unique (BNF_Def.Grp A f) \<longleftrightarrow> inj_on f A"
 by(simp add: bi_unique_alt_def)
 
 lemma left_total_Grp [iff]:
   "left_total (BNF_Def.Grp A f) \<longleftrightarrow> A = UNIV"
 by(auto simp add: left_total_def Grp_def)
 
 lemma right_total_Grp [iff]:
   "right_total (BNF_Def.Grp A f) \<longleftrightarrow> f ` A = UNIV"
 by(auto simp add: right_total_def BNF_Def.Grp_def image_def)
 
 lemma bi_total_Grp [iff]:
   "bi_total (BNF_Def.Grp A f) \<longleftrightarrow> A = UNIV \<and> surj f"
 by(auto simp add: bi_total_alt_def)
 
 lemma left_unique_vimage2p [simp]:
   "\<lbrakk> left_unique P; inj f \<rbrakk> \<Longrightarrow> left_unique (BNF_Def.vimage2p f g P)"
 unfolding vimage2p_Grp by(intro left_unique_OO) simp_all
 
 lemma right_unique_vimage2p [simp]:
   "\<lbrakk> right_unique P; inj g \<rbrakk> \<Longrightarrow> right_unique (BNF_Def.vimage2p f g P)"
 unfolding vimage2p_Grp by(intro right_unique_OO) simp_all
 
 lemma bi_unique_vimage2p [simp]:
   "\<lbrakk> bi_unique P; inj f; inj g \<rbrakk> \<Longrightarrow> bi_unique (BNF_Def.vimage2p f g P)"
 unfolding bi_unique_alt_def by simp
 
 lemma left_total_vimage2p [simp]:
   "\<lbrakk> left_total P; surj g \<rbrakk> \<Longrightarrow> left_total (BNF_Def.vimage2p f g P)"
 unfolding vimage2p_Grp by(intro left_total_OO) simp_all
 
 lemma right_total_vimage2p [simp]:
   "\<lbrakk> right_total P; surj f \<rbrakk> \<Longrightarrow> right_total (BNF_Def.vimage2p f g P)"
 unfolding vimage2p_Grp by(intro right_total_OO) simp_all
 
 lemma bi_total_vimage2p [simp]:
   "\<lbrakk> bi_total P; surj f; surj g \<rbrakk> \<Longrightarrow> bi_total (BNF_Def.vimage2p f g P)"
 unfolding bi_total_alt_def by simp
 
 lemma vimage2p_eq [simp]:
   "inj f \<Longrightarrow> BNF_Def.vimage2p f f (=) = (=)"
 by(auto simp add: vimage2p_def fun_eq_iff inj_on_def)
 
 lemma vimage2p_conversep: "BNF_Def.vimage2p f g R^--1 = (BNF_Def.vimage2p g f R)^--1"
 by(simp add: vimage2p_def fun_eq_iff)
 
+lemma rel_fun_refl: "\<lbrakk> A \<le> (=); (=) \<le> B \<rbrakk> \<Longrightarrow> (=) \<le> rel_fun A B"
+  by(subst fun.rel_eq[symmetric])(rule fun_mono)
+
+lemma rel_fun_mono_strong:
+  "\<lbrakk> rel_fun A B f g; A' \<le> A; \<And>x y. \<lbrakk> x \<in> f ` {x. Domainp A' x}; y \<in> g ` {x. Rangep A' x}; B x y \<rbrakk> \<Longrightarrow> B' x y \<rbrakk> \<Longrightarrow> rel_fun A' B' f g"
+  by(auto simp add: rel_fun_def) fastforce
+
+lemma rel_fun_refl_strong: 
+  assumes "A \<le> (=)" "\<And>x. x \<in> f ` {x. Domainp A x} \<Longrightarrow> B x x"
+  shows "rel_fun A B f f"
+proof -
+  have "rel_fun (=) (=) f f" by(simp add: rel_fun_eq)
+  then show ?thesis using assms(1)
+    by(rule rel_fun_mono_strong) (auto intro: assms(2))
+qed
+
+lemma Grp_iff: "BNF_Def.Grp B g x y \<longleftrightarrow> y = g x \<and> x \<in> B" by(simp add: Grp_def)
+
+lemma Rangep_Grp: "Rangep (BNF_Def.Grp A f) = (\<lambda>x. x \<in> f ` A)"
+  by(auto simp add: fun_eq_iff Grp_iff)
+
+lemma rel_fun_Grp:
+  "rel_fun (BNF_Def.Grp UNIV h)\<inverse>\<inverse> (BNF_Def.Grp A g) = BNF_Def.Grp {f. f ` range h \<subseteq> A} (map_fun h g)"
+  by(auto simp add: rel_fun_def fun_eq_iff Grp_iff)
+
 subsection \<open>Transfer and lifting material\<close>
 
 context includes lifting_syntax begin
 
 lemma monotone_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_total A"
   shows "((A ===> A ===> (=)) ===> (B ===> B ===> (=)) ===> (A ===> B) ===> (=)) monotone monotone"
 unfolding monotone_def[abs_def] by transfer_prover
 
 lemma fun_ord_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_total C"
   shows "((A ===> B ===> (=)) ===> (C ===> A) ===> (C ===> B) ===> (=)) fun_ord fun_ord"
 unfolding fun_ord_def[abs_def] by transfer_prover
 
 lemma Plus_parametric [transfer_rule]:
   "(rel_set A ===> rel_set B ===> rel_set (rel_sum A B)) (<+>) (<+>)"
 unfolding Plus_def[abs_def] by transfer_prover
 
 lemma pred_fun_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_total A"
   shows "((A ===> (=)) ===> (B ===> (=)) ===> (A ===> B) ===> (=)) pred_fun pred_fun"
 unfolding pred_fun_def by(transfer_prover)
 
 lemma rel_fun_eq_OO: "((=) ===> A) OO ((=) ===> B) = ((=) ===> A OO B)"
 by(clarsimp simp add: rel_fun_def fun_eq_iff relcompp.simps) metis
 
 end
 
 lemma Quotient_set_rel_eq:
   includes lifting_syntax
   assumes "Quotient R Abs Rep T"
   shows "(rel_set T ===> rel_set T ===> (=)) (rel_set R) (=)"
 proof(rule rel_funI iffI)+
   fix A B C D
   assume AB: "rel_set T A B" and CD: "rel_set T C D"
   have *: "\<And>x y. R x y = (T x (Abs x) \<and> T y (Abs y) \<and> Abs x = Abs y)"
     "\<And>a b. T a b \<Longrightarrow> Abs a = b"
     using assms unfolding Quotient_alt_def by simp_all
 
   { assume [simp]: "B = D"
     thus "rel_set R A C"
       by(auto 4 4 intro!: rel_setI dest: rel_setD1[OF AB, simplified] rel_setD2[OF AB, simplified] rel_setD2[OF CD] rel_setD1[OF CD] simp add: * elim!: rev_bexI)
   next
     assume AC: "rel_set R A C"
     show "B = D"
       apply safe
        apply(drule rel_setD2[OF AB], erule bexE)
        apply(drule rel_setD1[OF AC], erule bexE)
        apply(drule rel_setD1[OF CD], erule bexE)
        apply(simp add: *)
       apply(drule rel_setD2[OF CD], erule bexE)
       apply(drule rel_setD2[OF AC], erule bexE)
       apply(drule rel_setD1[OF AB], erule bexE)
       apply(simp add: *)
       done
   }
 qed
 
 lemma Domainp_eq: "Domainp (=) = (\<lambda>_. True)"
 by(simp add: Domainp.simps fun_eq_iff)
 
 lemma rel_fun_eq_onpI: "eq_onp (pred_fun P Q) f g \<Longrightarrow> rel_fun (eq_onp P) (eq_onp Q) f g"
 by(auto simp add: eq_onp_def rel_fun_def)
 
 lemma bi_unique_eq_onp: "bi_unique (eq_onp P)"
 by(simp add: bi_unique_def eq_onp_def)
 
 lemma rel_fun_eq_conversep: includes lifting_syntax shows "(A\<inverse>\<inverse> ===> (=)) = (A ===> (=))\<inverse>\<inverse>"
 by(auto simp add: fun_eq_iff rel_fun_def)
 
+lemma rel_fun_comp:
+  "\<And>f g h. rel_fun A B (f \<circ> g) h = rel_fun A (\<lambda>x. B (f x)) g h"
+  "\<And>f g h. rel_fun A B f (g \<circ> h) = rel_fun A (\<lambda>x y. B x (g y)) f h"
+  by(auto simp add: rel_fun_def)
+
+lemma rel_fun_map_fun1: "rel_fun (BNF_Def.Grp UNIV h)\<inverse>\<inverse> A f g \<Longrightarrow> rel_fun (=) A (map_fun h id f) g"
+  by(auto simp add: rel_fun_def Grp_def)
+
+lemma map_fun2_id: "map_fun f g x = g \<circ> map_fun f id x"
+  by(simp add: map_fun_def o_assoc)
+
+lemma map_fun_id2_in: "map_fun g h f = map_fun g id (h \<circ> f)"
+  by(simp add: map_fun_def)
+
+lemma Domainp_rel_fun_le: "Domainp (rel_fun A B) \<le> pred_fun (Domainp A) (Domainp B)"
+  by(auto dest: rel_funD)
+
+definition rel_witness_fun :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'd) \<times> ('c \<Rightarrow> 'e) \<Rightarrow> ('b \<Rightarrow> 'd \<times> 'e)" where
+  "rel_witness_fun A A' = (\<lambda>(f, g) b. (f (THE a. A a b), g (THE c. A' b c)))"
+
+lemma
+  assumes fg: "rel_fun (A OO A') B f g"
+    and A: "left_unique A" "right_total A"
+    and A': "right_unique A'" "left_total A'"
+  shows rel_witness_fun1: "rel_fun A (\<lambda>x (x', y). x = x' \<and> B x' y) f (rel_witness_fun A A' (f, g))"
+    and rel_witness_fun2: "rel_fun A' (\<lambda>(x, y') y. y = y' \<and> B x y') (rel_witness_fun A A' (f, g)) g"
+proof (goal_cases)
+  case 1
+  have "A x y \<Longrightarrow> f x = f (THE a. A a y) \<and> B (f (THE a. A a y)) (g (The (A' y)))" for x y 
+    by(rule left_totalE[OF A'(2)]; erule meta_allE[of _ y]; erule exE; frule (1) fg[THEN rel_funD, OF relcomppI])
+      (auto intro!: arg_cong[where f=f] arg_cong[where f=g] rel_funI the_equality the_equality[symmetric] dest: left_uniqueD[OF A(1)] right_uniqueD[OF A'(1)] elim!: arg_cong2[where f=B, THEN iffD2, rotated -1])
+
+  with 1 show ?case by(clarsimp simp add: rel_fun_def rel_witness_fun_def)
+next
+  case 2
+  have "A' x y \<Longrightarrow> g y = g (The (A' x)) \<and> B (f (THE a. A a x)) (g (The (A' x)))" for x y
+    by(rule right_totalE[OF A(2), of x]; frule (1) fg[THEN rel_funD, OF relcomppI])
+      (auto intro!: arg_cong[where f=f] arg_cong[where f=g] rel_funI the_equality the_equality[symmetric] dest: left_uniqueD[OF A(1)] right_uniqueD[OF A'(1)] elim!: arg_cong2[where f=B, THEN iffD2, rotated -1])
+
+  with 2 show ?case by(clarsimp simp add: rel_fun_def rel_witness_fun_def)    
+qed
+
+lemma rel_witness_fun_eq [simp]: "rel_witness_fun (=) (=) (f, g) = (\<lambda>x. (f x, g x))"
+  by(simp add: rel_witness_fun_def)
 
 subsection \<open>Arithmetic\<close>
 
 lemma abs_diff_triangle_ineq2: "\<bar>a - b :: _ :: ordered_ab_group_add_abs\<bar> \<le> \<bar>a - c\<bar> + \<bar>c - b\<bar>"
 by(rule order_trans[OF _ abs_diff_triangle_ineq]) simp
 
 lemma (in ordered_ab_semigroup_add) add_left_mono_trans:
   "\<lbrakk> x \<le> a + b; b \<le> c \<rbrakk> \<Longrightarrow> x \<le> a + c"
 by(erule order_trans)(rule add_left_mono)
 
 lemma of_nat_le_one_cancel_iff [simp]:
   fixes n :: nat shows "real n \<le> 1 \<longleftrightarrow> n \<le> 1"
 by linarith
 
 lemma (in linordered_semidom) mult_right_le: "c \<le> 1 \<Longrightarrow> 0 \<le> a \<Longrightarrow> c * a \<le> a"
 by(subst mult.commute)(rule mult_left_le)
 
 subsection \<open>Chain-complete partial orders and \<open>partial_function\<close>\<close>
 
 lemma fun_ordD: "fun_ord ord f g \<Longrightarrow> ord (f x) (g x)"
 by(simp add: fun_ord_def)
 
 lemma parallel_fixp_induct_strong:
   assumes ccpo1: "class.ccpo luba orda (mk_less orda)"
   and ccpo2: "class.ccpo lubb ordb (mk_less ordb)"
   and adm: "ccpo.admissible (prod_lub luba lubb) (rel_prod orda ordb) (\<lambda>x. P (fst x) (snd x))"
   and f: "monotone orda orda f"
   and g: "monotone ordb ordb g"
   and bot: "P (luba {}) (lubb {})"
   and step: "\<And>x y. \<lbrakk> orda x (ccpo.fixp luba orda f); ordb y (ccpo.fixp lubb ordb g); P x y \<rbrakk> \<Longrightarrow> P (f x) (g y)"
   shows "P (ccpo.fixp luba orda f) (ccpo.fixp lubb ordb g)"
 proof -
   let ?P="\<lambda>x y. orda x (ccpo.fixp luba orda f) \<and> ordb y (ccpo.fixp lubb ordb g) \<and> P x y"
   show ?thesis using ccpo1 ccpo2 _ f g
   proof(rule parallel_fixp_induct[where P="?P", THEN conjunct2, THEN conjunct2])
     note [cont_intro] = 
       admissible_leI[OF ccpo1] ccpo.mcont_const[OF ccpo1]
       admissible_leI[OF ccpo2] ccpo.mcont_const[OF ccpo2]
     show "ccpo.admissible (prod_lub luba lubb) (rel_prod orda ordb) (\<lambda>xy. ?P (fst xy) (snd xy))"
       using adm by simp
     show "?P (luba {}) (lubb {})" using bot by(auto intro: ccpo.ccpo_Sup_least ccpo1 ccpo2 chain_empty)
     show "?P (f x) (g y)" if "?P x y" for x y using that
       apply(subst ccpo.fixp_unfold[OF ccpo1 f])
       apply(subst ccpo.fixp_unfold[OF ccpo2 g])
       apply(auto intro: step monotoneD[OF f] monotoneD[OF g])
       done
   qed
 qed
 
 lemma parallel_fixp_induct_strong_uc:
   assumes a: "partial_function_definitions orda luba"
   and b: "partial_function_definitions ordb lubb"
   and F: "\<And>x. monotone (fun_ord orda) orda (\<lambda>f. U1 (F (C1 f)) x)"
   and G: "\<And>y. monotone (fun_ord ordb) ordb (\<lambda>g. U2 (G (C2 g)) y)"
   and eq1: "f \<equiv> C1 (ccpo.fixp (fun_lub luba) (fun_ord orda) (\<lambda>f. U1 (F (C1 f))))"
   and eq2: "g \<equiv> C2 (ccpo.fixp (fun_lub lubb) (fun_ord ordb) (\<lambda>g. U2 (G (C2 g))))"
   and inverse: "\<And>f. U1 (C1 f) = f"
   and inverse2: "\<And>g. U2 (C2 g) = g"
   and adm: "ccpo.admissible (prod_lub (fun_lub luba) (fun_lub lubb)) (rel_prod (fun_ord orda) (fun_ord ordb)) (\<lambda>x. P (fst x) (snd x))"
   and bot: "P (\<lambda>_. luba {}) (\<lambda>_. lubb {})"
   and step: "\<And>f' g'. \<lbrakk> \<And>x. orda (U1 f' x) (U1 f x); \<And>y. ordb (U2 g' y) (U2 g y); P (U1 f') (U2 g') \<rbrakk> \<Longrightarrow> P (U1 (F f')) (U2 (G g'))"
   shows "P (U1 f) (U2 g)"
 apply(unfold eq1 eq2 inverse inverse2)
 apply(rule parallel_fixp_induct_strong[OF partial_function_definitions.ccpo[OF a] partial_function_definitions.ccpo[OF b] adm])
 using F apply(simp add: monotone_def fun_ord_def)
 using G apply(simp add: monotone_def fun_ord_def)
 apply(simp add: fun_lub_def bot)
 apply(rule step; simp add: inverse inverse2 eq1 eq2 fun_ordD)
 done
 
 lemmas parallel_fixp_induct_strong_1_1 = parallel_fixp_induct_strong_uc[
   of _ _ _ _ "\<lambda>x. x" _ "\<lambda>x. x" "\<lambda>x. x" _ "\<lambda>x. x",
   OF _ _ _ _ _ _ refl refl]
 
 lemmas parallel_fixp_induct_strong_2_2 = parallel_fixp_induct_strong_uc[
   of _ _ _ _ "case_prod" _ "curry" "case_prod" _ "curry",
   where P="\<lambda>f g. P (curry f) (curry g)",
   unfolded case_prod_curry curry_case_prod curry_K,
   OF _ _ _ _ _ _ refl refl,
   split_format (complete), unfolded prod.case]
   for P
 
 lemma fixp_induct_option': \<comment> \<open>Stronger induction rule\<close>
   fixes F :: "'c \<Rightarrow> 'c" and
     U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a option" and
     C :: "('b \<Rightarrow> 'a option) \<Rightarrow> 'c" and
     P :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
   assumes mono: "\<And>x. mono_option (\<lambda>f. U (F (C f)) x)"
   assumes eq: "f \<equiv> C (ccpo.fixp (fun_lub (flat_lub None)) (fun_ord option_ord) (\<lambda>f. U (F (C f))))"
   assumes inverse2: "\<And>f. U (C f) = f"
   assumes step: "\<And>g x y. \<lbrakk> \<And>x y. U g x = Some y \<Longrightarrow> P x y; U (F g) x = Some y; \<And>x. option_ord (U g x) (U f x) \<rbrakk> \<Longrightarrow> P x y"
   assumes defined: "U f x = Some y"
   shows "P x y"
 using step defined option.fixp_strong_induct_uc[of U F C, OF mono eq inverse2 option_admissible, of P]
 unfolding fun_lub_def flat_lub_def fun_ord_def
 by(simp (no_asm_use)) blast
 
 declaration \<open>Partial_Function.init "option'" @{term option.fixp_fun}
   @{term option.mono_body} @{thm option.fixp_rule_uc} @{thm option.fixp_induct_uc}
   (SOME @{thm fixp_induct_option'})\<close>
 
 lemma bot_fun_least [simp]: "(\<lambda>_. bot :: 'a :: order_bot) \<le> x"
 by(fold bot_fun_def) simp
 
 lemma fun_ord_conv_rel_fun: "fun_ord = rel_fun (=)"
 by(simp add: fun_ord_def fun_eq_iff rel_fun_def)
 
 inductive finite_chains :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   for ord
 where finite_chainsI: "(\<And>Y. Complete_Partial_Order.chain ord Y \<Longrightarrow> finite Y) \<Longrightarrow> finite_chains ord"
 
 lemma finite_chainsD: "\<lbrakk> finite_chains ord; Complete_Partial_Order.chain ord Y \<rbrakk> \<Longrightarrow> finite Y"
 by(rule finite_chains.cases)
 
 lemma finite_chains_flat_ord [simp, intro!]: "finite_chains (flat_ord x)"
 proof
   fix Y
   assume chain: "Complete_Partial_Order.chain (flat_ord x) Y"
   show "finite Y"
   proof(cases "\<exists>y \<in> Y. y \<noteq> x")
     case True
     then obtain y where y: "y \<in> Y" and yx: "y \<noteq> x" by blast
     hence "Y \<subseteq> {x, y}" by(auto dest: chainD[OF chain] simp add: flat_ord_def)
     thus ?thesis by(rule finite_subset) simp
   next
     case False
     hence "Y \<subseteq> {x}" by auto
     thus ?thesis by(rule finite_subset) simp
   qed
 qed    
 
 lemma mcont_finite_chains:
   assumes finite: "finite_chains ord"
   and mono: "monotone ord ord' f"
   and ccpo: "class.ccpo lub ord (mk_less ord)"
   and ccpo': "class.ccpo lub' ord' (mk_less ord')"
   shows "mcont lub ord lub' ord' f"
 proof(intro mcontI contI)
   fix Y
   assume chain: "Complete_Partial_Order.chain ord Y" and Y: "Y \<noteq> {}"
   from finite chain have fin: "finite Y" by(rule finite_chainsD)
   from ccpo chain fin Y have lub: "lub Y \<in> Y" by(rule ccpo.in_chain_finite)
 
   interpret ccpo': ccpo lub' ord' "mk_less ord'" by(rule ccpo')
 
   have chain': "Complete_Partial_Order.chain ord' (f ` Y)" using chain
     by(rule chain_imageI)(rule monotoneD[OF mono])
 
   have "ord' (f (lub Y)) (lub' (f ` Y))" using chain'
     by(rule ccpo'.ccpo_Sup_upper)(simp add: lub)
   moreover
   have "ord' (lub' (f ` Y)) (f (lub Y))" using chain'
     by(rule ccpo'.ccpo_Sup_least)(blast intro: monotoneD[OF mono] ccpo.ccpo_Sup_upper[OF ccpo chain])
   ultimately show "f (lub Y) = lub' (f ` Y)" by(rule ccpo'.antisym)
 qed(fact mono)  
 
 lemma rel_fun_curry: includes lifting_syntax shows
   "(A ===> B ===> C) f g \<longleftrightarrow> (rel_prod A B ===> C) (case_prod f) (case_prod g)"
 by(auto simp add: rel_fun_def)
 
 lemma (in ccpo) Sup_image_mono:
   assumes ccpo: "class.ccpo luba orda lessa"
   and mono: "monotone orda (\<le>) f"
   and chain: "Complete_Partial_Order.chain orda A"
   and "A \<noteq> {}"
   shows "Sup (f ` A) \<le> (f (luba A))"
 proof(rule ccpo_Sup_least)
   from chain show "Complete_Partial_Order.chain (\<le>) (f ` A)"
     by(rule chain_imageI)(rule monotoneD[OF mono])
   fix x
   assume "x \<in> f ` A"
   then obtain y where "x = f y" "y \<in> A" by blast
   from \<open>y \<in> A\<close> have "orda y (luba A)" by(rule ccpo.ccpo_Sup_upper[OF ccpo chain])
   hence "f y \<le> f (luba A)" by(rule monotoneD[OF mono])
   thus "x \<le> f (luba A)" using \<open>x = f y\<close> by simp
 qed
 
 lemma (in ccpo) admissible_le_mono:
   assumes "monotone (\<le>) (\<le>) f"
   shows "ccpo.admissible Sup (\<le>) (\<lambda>x. x \<le> f x)"
 proof(rule ccpo.admissibleI)
   fix Y
   assume chain: "Complete_Partial_Order.chain (\<le>) Y"
     and Y: "Y \<noteq> {}"
     and le [rule_format]: "\<forall>x\<in>Y. x \<le> f x"
   have "\<Squnion>Y \<le> \<Squnion>(f ` Y)" using chain
     by(rule ccpo_Sup_least)(rule order_trans[OF le]; blast intro!: ccpo_Sup_upper chain_imageI[OF chain] intro: monotoneD[OF assms])
   also have "\<dots> \<le> f (\<Squnion>Y)"
     by(rule Sup_image_mono[OF _ assms chain Y, where lessa="(<)"]) unfold_locales
   finally show "\<Squnion>Y \<le> \<dots>" .
 qed
 
 lemma (in ccpo) fixp_induct_strong2:
   assumes adm: "ccpo.admissible Sup (\<le>) P"
   and mono: "monotone (\<le>) (\<le>) f"
   and bot: "P (\<Squnion>{})"
   and step: "\<And>x. \<lbrakk> x \<le> ccpo_class.fixp f; x \<le> f x; P x \<rbrakk> \<Longrightarrow> P (f x)"
   shows "P (ccpo_class.fixp f)"
 proof(rule fixp_strong_induct[where P="\<lambda>x. x \<le> f x \<and> P x", THEN conjunct2])
   show "ccpo.admissible Sup (\<le>) (\<lambda>x. x \<le> f x \<and> P x)"
     using admissible_le_mono adm by(rule admissible_conj)(rule mono)
 next
   show "\<Squnion>{} \<le> f (\<Squnion>{}) \<and> P (\<Squnion>{})"
     by(auto simp add: bot chain_empty intro: ccpo_Sup_least)
 next
   fix x
   assume "x \<le> ccpo_class.fixp f" "x \<le> f x \<and> P x"
   thus "f x \<le> f (f x) \<and> P (f x)"
     by(auto dest: monotoneD[OF mono] intro: step)
 qed(rule mono)
 
 context partial_function_definitions begin
 
 lemma fixp_induct_strong2_uc:
   fixes F :: "'c \<Rightarrow> 'c"
     and U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a"
     and C :: "('b \<Rightarrow> 'a) \<Rightarrow> 'c"
     and P :: "('b \<Rightarrow> 'a) \<Rightarrow> bool"
   assumes mono: "\<And>x. mono_body (\<lambda>f. U (F (C f)) x)"
     and eq: "f \<equiv> C (fixp_fun (\<lambda>f. U (F (C f))))"
     and inverse: "\<And>f. U (C f) = f"
     and adm: "ccpo.admissible lub_fun le_fun P"
     and bot: "P (\<lambda>_. lub {})"
     and step: "\<And>f'. \<lbrakk> le_fun (U f') (U f); le_fun (U f') (U (F f')); P (U f') \<rbrakk> \<Longrightarrow> P (U (F f'))"
   shows "P (U f)"
 unfolding eq inverse
 apply (rule ccpo.fixp_induct_strong2[OF ccpo adm])
 apply (insert mono, auto simp: monotone_def fun_ord_def bot fun_lub_def)[2]
 apply (rule_tac f'5="C x" in step)
 apply (simp_all add: inverse eq)
 done
 
 end
 
 lemmas parallel_fixp_induct_2_4 = parallel_fixp_induct_uc[
   of _ _ _ _ "case_prod" _ "curry" "\<lambda>f. case_prod (case_prod (case_prod f))" _ "\<lambda>f. curry (curry (curry f))",
   where P="\<lambda>f g. P (curry f) (curry (curry (curry g)))",
   unfolded case_prod_curry curry_case_prod curry_K,
   OF _ _ _ _ _ _ refl refl]
   for P
   
 lemma (in ccpo) fixp_greatest:
   assumes f: "monotone (\<le>) (\<le>) f"
     and ge: "\<And>y. f y \<le> y \<Longrightarrow> x \<le> y"
   shows "x \<le> ccpo.fixp Sup (\<le>) f"
   by(rule ge)(simp add: fixp_unfold[OF f, symmetric])
 
 lemma fixp_rolling:
   assumes "class.ccpo lub1 leq1 (mk_less leq1)"
     and "class.ccpo lub2 leq2 (mk_less leq2)"
     and f: "monotone leq1 leq2 f"
     and g: "monotone leq2 leq1 g"
   shows "ccpo.fixp lub1 leq1 (\<lambda>x. g (f x)) = g (ccpo.fixp lub2 leq2 (\<lambda>x. f (g x)))"
 proof -
   interpret c1: ccpo lub1 leq1 "mk_less leq1" by fact
   interpret c2: ccpo lub2 leq2 "mk_less leq2" by fact
   show ?thesis
   proof(rule c1.antisym)
     have fg: "monotone leq2 leq2 (\<lambda>x. f (g x))" using f g by(rule monotone2monotone) simp_all
     have gf: "monotone leq1 leq1 (\<lambda>x. g (f x))" using g f by(rule monotone2monotone) simp_all
     show "leq1 (c1.fixp (\<lambda>x. g (f x))) (g (c2.fixp (\<lambda>x. f (g x))))" using gf
       by(rule c1.fixp_lowerbound)(subst (2) c2.fixp_unfold[OF fg], simp)
     show "leq1 (g (c2.fixp (\<lambda>x. f (g x)))) (c1.fixp (\<lambda>x. g (f x)))" using gf
     proof(rule c1.fixp_greatest)
       fix u
       assume u: "leq1 (g (f u)) u"
       have "leq1 (g (c2.fixp (\<lambda>x. f (g x)))) (g (f u))"
         by(intro monotoneD[OF g] c2.fixp_lowerbound[OF fg] monotoneD[OF f u])
       then show "leq1 (g (c2.fixp (\<lambda>x. f (g x)))) u" using u by(rule c1.order_trans)
     qed
   qed
 qed
 
 lemma fixp_lfp_parametric_eq:
   includes lifting_syntax
   assumes f: "\<And>x. lfp.mono_body (\<lambda>f. F f x)"
   and g: "\<And>x. lfp.mono_body (\<lambda>f. G f x)"
   and param: "((A ===> (=)) ===> A ===> (=)) F G"
   shows "(A ===> (=)) (lfp.fixp_fun F) (lfp.fixp_fun G)"
 using f g
 proof(rule parallel_fixp_induct_1_1[OF complete_lattice_partial_function_definitions complete_lattice_partial_function_definitions _ _ reflexive reflexive, where P="(A ===> (=))"])
   show "ccpo.admissible (prod_lub lfp.lub_fun lfp.lub_fun) (rel_prod lfp.le_fun lfp.le_fun) (\<lambda>x. (A ===> (=)) (fst x) (snd x))"
     unfolding rel_fun_def by simp
   show "(A ===> (=)) (\<lambda>_. \<Squnion>{}) (\<lambda>_. \<Squnion>{})" by auto
   show "(A ===> (=)) (F f) (G g)" if "(A ===> (=)) f g" for f g
     using that by(rule rel_funD[OF param])
 qed
 
 lemma mono2mono_map_option[THEN option.mono2mono, simp, cont_intro]:
   shows monotone_map_option: "monotone option_ord option_ord (map_option f)"
 by(rule monotoneI)(auto simp add: flat_ord_def)
 
 lemma mcont2mcont_map_option[THEN option.mcont2mcont, simp, cont_intro]:
   shows mcont_map_option: "mcont (flat_lub None) option_ord (flat_lub None) option_ord (map_option f)"
 by(rule mcont_finite_chains[OF _ _ flat_interpretation[THEN ccpo] flat_interpretation[THEN ccpo]]) simp_all
 
 lemma mono2mono_set_option [THEN lfp.mono2mono]:
   shows monotone_set_option: "monotone option_ord (\<subseteq>) set_option"
 by(auto intro!: monotoneI simp add: option_ord_Some1_iff)
 
 lemma mcont2mcont_set_option [THEN lfp.mcont2mcont, cont_intro, simp]:
   shows mcont_set_option: "mcont (flat_lub None) option_ord Union (\<subseteq>) set_option"
 by(rule mcont_finite_chains)(simp_all add: monotone_set_option ccpo option.partial_function_definitions_axioms)
 
 lemma eadd_gfp_partial_function_mono [partial_function_mono]:
   "\<lbrakk> monotone (fun_ord (\<ge>)) (\<ge>) f; monotone (fun_ord (\<ge>)) (\<ge>) g \<rbrakk>
   \<Longrightarrow> monotone (fun_ord (\<ge>)) (\<ge>) (\<lambda>x. f x + g x :: enat)"
 by(rule mono2mono_gfp_eadd)
 
 lemma map_option_mono [partial_function_mono]:
   "mono_option B \<Longrightarrow> mono_option (\<lambda>f. map_option g (B f))"
 unfolding map_conv_bind_option by(rule bind_mono) simp_all
 
 
 subsection \<open>Folding over finite sets\<close>
 
 lemma (in comp_fun_commute) fold_invariant_remove [consumes 1, case_names start step]:
   assumes fin: "finite A"
   and start: "I A s"
   and step: "\<And>x s A'. \<lbrakk> x \<in> A'; I A' s; A' \<subseteq> A \<rbrakk> \<Longrightarrow> I (A' - {x}) (f x s)"
   shows "I {} (Finite_Set.fold f s A)"
 proof -
   define A' where "A' == A"
   with fin start have "finite A'" "A' \<subseteq> A" "I A' s" by simp_all
   thus "I {} (Finite_Set.fold f s A')"
   proof(induction arbitrary: s)
     case empty thus ?case by simp
   next
     case (insert x A')
     let ?A' = "insert x A'"
     have "x \<in> ?A'" "I ?A' s" "?A' \<subseteq> A" using insert by auto
     hence "I (?A' - {x}) (f x s)" by(rule step)
     with insert have "A' \<subseteq> A" "I A' (f x s)" by auto
     hence "I {} (Finite_Set.fold f (f x s) A')" by(rule insert.IH)
     thus ?case using insert by(simp add: fold_insert2 del: fold_insert)
   qed
 qed
 
 lemma (in comp_fun_commute) fold_invariant_insert [consumes 1, case_names start step]:
   assumes fin: "finite A"
   and start: "I {} s"
   and step: "\<And>x s A'. \<lbrakk> I A' s; x \<notin> A'; x \<in> A; A' \<subseteq> A \<rbrakk> \<Longrightarrow> I (insert x A') (f x s)"
   shows "I A (Finite_Set.fold f s A)"
 using fin start
 proof(rule fold_invariant_remove[where I="\<lambda>A'. I (A - A')" and A=A and s=s, simplified])
   fix x s A'
   assume *: "x \<in> A'" "I (A - A') s" "A' \<subseteq> A"
   hence "x \<notin> A - A'" "x \<in> A" "A - A' \<subseteq> A" by auto
   with \<open>I (A - A') s\<close> have "I (insert x (A - A')) (f x s)" by(rule step)
   also have "insert x (A - A') = A - (A' - {x})" using * by auto
   finally show "I \<dots> (f x s)" .
 qed
 
 lemma (in comp_fun_idem) fold_set_union:
   assumes "finite A" "finite B"
   shows "Finite_Set.fold f z (A \<union> B) = Finite_Set.fold f (Finite_Set.fold f z A) B"
 using assms(2,1) by induction simp_all
 
 
 subsection \<open>Parametrisation of transfer rules\<close>
 
 attribute_setup transfer_parametric = \<open> 
   Attrib.thm >> (fn parametricity =>
     Thm.rule_attribute [] (fn context => fn transfer_rule =>
       let
         val ctxt = Context.proof_of context;
         val thm' = Lifting_Term.parametrize_transfer_rule ctxt transfer_rule
       in Lifting_Def.generate_parametric_transfer_rule ctxt thm' parametricity
       end
       handle Lifting_Term.MERGE_TRANSFER_REL msg => error (Pretty.string_of msg)
       ))
 \<close> "combine transfer rule with parametricity theorem"
 
 subsection \<open>Lists\<close>
 
 lemma nth_eq_tlI: "xs ! n = z \<Longrightarrow> (x # xs) ! Suc n = z"
 by simp
 
 lemma list_all2_append':
   "length us = length vs \<Longrightarrow> list_all2 P (xs @ us) (ys @ vs) \<longleftrightarrow> list_all2 P xs ys \<and> list_all2 P us vs"
 by(auto simp add: list_all2_append1 list_all2_append2 dest: list_all2_lengthD)
 
 definition disjointp :: "('a \<Rightarrow> bool) list \<Rightarrow> bool"
 where "disjointp xs = disjoint_family_on (\<lambda>n. {x. (xs ! n) x}) {0..<length xs}"
 
 lemma disjointpD:
   "\<lbrakk> disjointp xs; (xs ! n) x; (xs ! m) x; n < length xs; m < length xs \<rbrakk> \<Longrightarrow> n = m"
 by(auto 4 3 simp add: disjointp_def disjoint_family_on_def)
 
 lemma disjointpD':
   "\<lbrakk> disjointp xs; P x; Q x; xs ! n = P; xs ! m = Q; n < length xs; m < length xs \<rbrakk> \<Longrightarrow> n = m"
 by(auto 4 3 simp add: disjointp_def disjoint_family_on_def)
 
+lemma wf_strict_prefix: "wfP strict_prefix"
+proof -
+  from wf have "wf (inv_image {(x, y). x < y} length)" by(rule wf_inv_image)
+  moreover have "{(x, y). strict_prefix x y} \<subseteq> inv_image {(x, y). x < y} length" by(auto intro: prefix_length_less)
+  ultimately show ?thesis unfolding wfP_def by(rule wf_subset)
+qed
+
+lemma strict_prefix_setD:
+  "strict_prefix xs ys \<Longrightarrow> set xs \<subseteq> set ys"
+  by(auto simp add: strict_prefix_def prefix_def)
+
 subsubsection \<open>List of a given length\<close>
 
 inductive_set nlists :: "'a set \<Rightarrow> nat \<Rightarrow> 'a list set" for A n
 where nlists: "\<lbrakk> set xs \<subseteq> A; length xs = n \<rbrakk> \<Longrightarrow> xs \<in> nlists A n"
 hide_fact (open) nlists
 
 lemma nlists_alt_def: "nlists A n = {xs. set xs \<subseteq> A \<and> length xs = n}"
 by(auto simp add: nlists.simps)
 
 lemma nlists_empty: "nlists {} n = (if n = 0 then {[]} else {})"
 by(auto simp add: nlists_alt_def)
 
 lemma nlists_empty_gt0 [simp]: "n > 0 \<Longrightarrow> nlists {} n = {}"
 by(simp add: nlists_empty)
 
 lemma nlists_0 [simp]: "nlists A 0 = {[]}"
 by(auto simp add: nlists_alt_def)
 
 lemma Cons_in_nlists_Suc [simp]: "x # xs \<in> nlists A (Suc n) \<longleftrightarrow> x \<in> A \<and> xs \<in> nlists A n"
 by(simp add: nlists_alt_def)
 
 lemma Nil_in_nlists [simp]: "[] \<in> nlists A n \<longleftrightarrow> n = 0"
 by(auto simp add: nlists_alt_def)
 
 lemma Cons_in_nlists_iff: "x # xs \<in> nlists A n \<longleftrightarrow> (\<exists>n'. n = Suc n' \<and> x \<in> A \<and> xs \<in> nlists A n')"
 by(cases n) simp_all
 
 lemma in_nlists_Suc_iff: "xs \<in> nlists A (Suc n) \<longleftrightarrow> (\<exists>x xs'. xs = x # xs' \<and> x \<in> A \<and> xs' \<in> nlists A n)"
 by(cases xs) simp_all
 
 lemma nlists_Suc: "nlists A (Suc n) = (\<Union>x\<in>A. (#) x ` nlists A n)"
 by(auto 4 3 simp add: in_nlists_Suc_iff intro: rev_image_eqI)
 
 lemma replicate_in_nlists [simp, intro]: "x \<in> A \<Longrightarrow> replicate n x \<in> nlists A n"
 by(simp add: nlists_alt_def set_replicate_conv_if)
 
 lemma nlists_eq_empty_iff [simp]: "nlists A n = {} \<longleftrightarrow> n > 0 \<and> A = {}"
 using replicate_in_nlists by(cases n)(auto)
 
 lemma finite_nlists [simp]: "finite A \<Longrightarrow> finite (nlists A n)"
 by(induction n)(simp_all add: nlists_Suc)
 
 lemma finite_nlistsD: 
   assumes "finite (nlists A n)"
   shows "finite A \<or> n = 0"
 proof(rule disjCI)
   assume "n \<noteq> 0"
   then obtain n' where n: "n = Suc n'" by(cases n)auto
   then have "A = hd ` nlists A n" by(auto 4 4 simp add: nlists_Suc intro: rev_image_eqI rev_bexI)
   also have "finite \<dots>" using assms ..
   finally show "finite A" .
 qed
 
 lemma finite_nlists_iff: "finite (nlists A n) \<longleftrightarrow> finite A \<or> n = 0"
 by(auto dest: finite_nlistsD)
 
 lemma card_nlists: "card (nlists A n) = card A ^ n"
 proof(induction n)
   case (Suc n)
   have "card (\<Union>x\<in>A. (#) x ` nlists A n) = card A * card (nlists A n)"
   proof(cases "finite A")
     case True
     then show ?thesis by(subst card_UN_disjoint)(auto simp add: card_image inj_on_def)
   next
     case False
     hence "\<not> finite (\<Union>x\<in>A. (#) x ` nlists A n)"
       unfolding nlists_Suc[symmetric] by(auto dest: finite_nlistsD)
     then show ?thesis using False by simp
   qed
   then show ?case using Suc.IH by(simp add: nlists_Suc)
 qed simp
 
 lemma in_nlists_UNIV: "xs \<in> nlists UNIV n \<longleftrightarrow> length xs = n"
 by(simp add: nlists_alt_def)
 
 subsubsection \<open> The type of lists of a given length \<close>
 
 typedef (overloaded) ('a, 'b :: len0) nlist = "nlists (UNIV :: 'a set) (LENGTH('b))"
 proof
   show "replicate LENGTH('b) undefined \<in> ?nlist" by simp
 qed
 
 setup_lifting type_definition_nlist
 
 subsection \<open>Streams and infinite lists\<close>
 
 primrec sprefix :: "'a list \<Rightarrow> 'a stream \<Rightarrow> bool" where
   sprefix_Nil: "sprefix [] ys = True"
 | sprefix_Cons: "sprefix (x # xs) ys \<longleftrightarrow> x = shd ys \<and> sprefix xs (stl ys)"
 
 lemma sprefix_append: "sprefix (xs @ ys) zs \<longleftrightarrow> sprefix xs zs \<and> sprefix ys (sdrop (length xs) zs)"
 by(induct xs arbitrary: zs) simp_all
 
 lemma sprefix_stake_same [simp]: "sprefix (stake n xs) xs"
 by(induct n arbitrary: xs) simp_all
 
 lemma sprefix_same_imp_eq:
   assumes "sprefix xs ys" "sprefix xs' ys"
   and "length xs = length xs'"
   shows "xs = xs'"
 using assms(3,1,2) by(induct arbitrary: ys rule: list_induct2) auto
 
 lemma sprefix_shift_same [simp]:
   "sprefix xs (xs @- ys)"
 by(induct xs) simp_all
 
 lemma sprefix_shift [simp]:
   "length xs \<le> length ys \<Longrightarrow> sprefix xs (ys @- zs) \<longleftrightarrow> prefix xs ys"
 by(induct xs arbitrary: ys)(simp, case_tac ys, auto)
 
 lemma prefixeq_stake2 [simp]: "prefix xs (stake n ys) \<longleftrightarrow> length xs \<le> n \<and> sprefix xs ys"
 proof(induct xs arbitrary: n ys)
   case (Cons x xs)
   thus ?case by(cases ys n rule: stream.exhaust[case_product nat.exhaust]) auto
 qed simp
 
 lemma tlength_eq_infinity_iff: "tlength xs = \<infinity> \<longleftrightarrow> \<not> tfinite xs"
 including tllist.lifting by transfer(simp add: llength_eq_infty_conv_lfinite)
 
 subsection \<open>Monomorphic monads\<close>
 
 context includes lifting_syntax begin
 local_setup \<open>Local_Theory.map_background_naming (Name_Space.mandatory_path "monad")\<close>
 
 definition bind_option :: "'m fail \<Rightarrow> 'a option \<Rightarrow> ('a \<Rightarrow> 'm) \<Rightarrow> 'm"
 where "bind_option fail x f = (case x of None \<Rightarrow> fail | Some x' \<Rightarrow> f x')" for fail
 
 simps_of_case bind_option_simps [simp]: bind_option_def
 
 lemma bind_option_parametric [transfer_rule]:
   "(M ===> rel_option B ===> (B ===> M) ===> M) bind_option bind_option"
 unfolding bind_option_def by transfer_prover
 
 lemma bind_option_K:
   "\<And>monad. (x = None \<Longrightarrow> m = fail) \<Longrightarrow> bind_option fail x (\<lambda>_. m) = m"
 by(cases x) simp_all
 
 end
 
 lemma bind_option_option [simp]: "monad.bind_option None = Option.bind"
 by(simp add: monad.bind_option_def fun_eq_iff split: option.split)
 
 context monad_fail_hom begin
 
 lemma hom_bind_option: "h (monad.bind_option fail1 x f) = monad.bind_option fail2 x (h \<circ> f)"
 by(cases x)(simp_all)
 
 end
 
 lemma bind_option_set [simp]: "monad.bind_option fail_set = (\<lambda>x f. \<Union> (f ` set_option x))"
 by(simp add: monad.bind_option_def fun_eq_iff split: option.split)
 
 lemma run_bind_option_stateT [simp]:
   "\<And>more. run_state (monad.bind_option (fail_state fail) x f) s = 
   monad.bind_option fail x (\<lambda>y. run_state (f y) s)"
 by(cases x) simp_all
 
 lemma run_bind_option_envT [simp]:
   "\<And>more. run_env (monad.bind_option (fail_env fail) x f) s = 
   monad.bind_option fail x (\<lambda>y. run_env (f y) s)"
 by(cases x) simp_all
 
 
 subsection \<open>Measures\<close>
 
 declare sets_restrict_space_count_space [measurable_cong]
 
 lemma (in sigma_algebra) sets_Collect_countable_Ex1:
   "(\<And>i :: 'i :: countable. {x \<in> \<Omega>. P i x} \<in> M) \<Longrightarrow> {x \<in> \<Omega>. \<exists>!i. P i x} \<in> M"
 using sets_Collect_countable_Ex1'[of "UNIV :: 'i set"] by simp
 
 lemma pred_countable_Ex1 [measurable]:
   "(\<And>i :: _ :: countable. Measurable.pred M (\<lambda>x. P i x))
   \<Longrightarrow> Measurable.pred M (\<lambda>x. \<exists>!i. P i x)"
 unfolding pred_def by(rule sets.sets_Collect_countable_Ex1)
 
 lemma measurable_snd_count_space [measurable]: 
   "A \<subseteq> B \<Longrightarrow> snd \<in> measurable (M1 \<Otimes>\<^sub>M count_space A) (count_space B)"
 by(auto simp add: measurable_def space_pair_measure snd_vimage_eq_Times Times_Int_Times)
 
+lemma integrable_scale_measure [simp]:
+  "\<lbrakk> integrable M f; r < \<top> \<rbrakk> \<Longrightarrow> integrable (scale_measure r M) f" 
+  for f :: "'a \<Rightarrow> 'b::{banach, second_countable_topology}"
+  by(auto simp add: integrable_iff_bounded nn_integral_scale_measure ennreal_mult_less_top)
+
+lemma integral_scale_measure:
+  assumes "integrable M f" "r < \<top>"
+  shows "integral\<^sup>L (scale_measure r M) f = enn2real r * integral\<^sup>L M f"
+  using assms
+  apply(subst (1 2) real_lebesgue_integral_def)
+    apply(simp_all add: nn_integral_scale_measure ennreal_enn2real_if)
+  by(auto simp add: ennreal_mult_less_top ennreal_less_top_iff ennreal_mult_eq_top_iff enn2real_mult right_diff_distrib elim!: integrableE)
+
 subsection \<open>Sequence space\<close>
 
 lemma (in sequence_space) nn_integral_split:
   assumes f[measurable]: "f \<in> borel_measurable S"
   shows "(\<integral>\<^sup>+\<omega>. f \<omega> \<partial>S) = (\<integral>\<^sup>+\<omega>. (\<integral>\<^sup>+\<omega>'. f (comb_seq i \<omega> \<omega>') \<partial>S) \<partial>S)"
 by (subst PiM_comb_seq[symmetric, where i=i])
    (simp add: nn_integral_distr P.nn_integral_fst[symmetric])
 
 lemma (in sequence_space) prob_Collect_split:
   assumes f[measurable]: "{x\<in>space S. P x} \<in> sets S"
   shows "\<P>(x in S. P x) = (\<integral>\<^sup>+x. \<P>(x' in S. P (comb_seq i x x')) \<partial>S)"
 proof -
   have "\<P>(x in S. P x) = (\<integral>\<^sup>+x. (\<integral>\<^sup>+x'. indicator {x\<in>space S. P x} (comb_seq i x x') \<partial>S) \<partial>S)"
     using nn_integral_split[of "indicator {x\<in>space S. P x}"] by (auto simp: emeasure_eq_measure)
   also have "\<dots> = (\<integral>\<^sup>+x. \<P>(x' in S. P (comb_seq i x x')) \<partial>S)"
     by (intro nn_integral_cong) (auto simp: emeasure_eq_measure nn_integral_indicator_map)
   finally show ?thesis .
 qed
 
 subsection \<open>Probability mass functions\<close>
 
 lemma measure_map_pmf_conv_distr:
   "measure_pmf (map_pmf f p) = distr (measure_pmf p) (count_space UNIV) f"
 by(fact map_pmf_rep_eq)
 
 abbreviation coin_pmf :: "bool pmf" where "coin_pmf \<equiv> pmf_of_set UNIV"
 
 text \<open>The rule @{thm [source] rel_pmf_bindI} is not complete as a program logic.\<close>
 notepad begin
   define x where "x = pmf_of_set {True, False}"
   define y where "y = pmf_of_set {True, False}"
   define f where "f x = pmf_of_set {True, False}" for x :: bool
   define g :: "bool \<Rightarrow> bool pmf" where "g = return_pmf"
   define P :: "bool \<Rightarrow> bool \<Rightarrow> bool" where "P = (=)"
   have "rel_pmf P (bind_pmf x f) (bind_pmf y g)"
     by(simp add: P_def f_def[abs_def] g_def y_def bind_return_pmf' pmf.rel_eq)
   have "\<not> R x y" if "\<And>x y. R x y \<Longrightarrow> rel_pmf P (f x) (g y)" for R x y
     \<comment> \<open>Only the empty relation satisfies @{thm [source] rel_pmf_bindI}'s second premise.\<close>
   proof
     assume "R x y"
     hence "rel_pmf P (f x) (g y)" by(rule that)
     thus False by(auto simp add: P_def f_def g_def rel_pmf_return_pmf2)
   qed
   define R where "R x y = False" for x y :: bool
   have "\<not> rel_pmf R x y" by(simp add: R_def[abs_def])
 end
 
 lemma pred_rel_pmf:
   "\<lbrakk> pred_pmf P p; rel_pmf R p q \<rbrakk> \<Longrightarrow> pred_pmf (Imagep R P) q"
 unfolding pred_pmf_def
 apply(rule ballI)
 apply(unfold rel_pmf.simps)
 apply(erule exE conjE)+
 apply hypsubst
 apply(unfold pmf.set_map)
 apply(erule imageE, hypsubst)
 apply(drule bspec)
  apply(erule rev_image_eqI)
  apply(rule refl)
 apply(erule Imagep.intros)
 apply(erule allE)+
  apply(erule mp)
 apply(unfold prod.collapse)
 apply assumption
 done
 
 lemma pmf_rel_mono': "\<lbrakk> rel_pmf P x y; P \<le> Q \<rbrakk> \<Longrightarrow> rel_pmf Q x y"
 by(drule pmf.rel_mono) (auto)
 
 lemma rel_pmf_eqI [simp]: "rel_pmf (=) x x"
 by(simp add: pmf.rel_eq)
 
 lemma rel_pmf_bind_reflI:
   "(\<And>x. x \<in> set_pmf p \<Longrightarrow> rel_pmf R (f x) (g x))
   \<Longrightarrow> rel_pmf R (bind_pmf p f) (bind_pmf p g)"
 by(rule rel_pmf_bindI[where R="\<lambda>x y. x = y \<and> x \<in> set_pmf p"])(auto intro: rel_pmf_reflI)
 
 lemma pmf_pred_mono_strong:
   "\<lbrakk> pred_pmf P p; \<And>a. \<lbrakk> a \<in> set_pmf p; P a \<rbrakk> \<Longrightarrow> P' a \<rbrakk> \<Longrightarrow> pred_pmf P' p"
 by(simp add: pred_pmf_def)
 
 lemma rel_pmf_restrict_relpI [intro?]:
   "\<lbrakk> rel_pmf R x y; pred_pmf P x; pred_pmf Q y \<rbrakk> \<Longrightarrow> rel_pmf (R \<upharpoonleft> P \<otimes> Q) x y"
 by(erule pmf.rel_mono_strong)(simp add: pred_pmf_def)
 
 lemma rel_pmf_restrict_relpE [elim?]:
   assumes "rel_pmf (R \<upharpoonleft> P \<otimes> Q) x y"
   obtains "rel_pmf R x y" "pred_pmf P x" "pred_pmf Q y"
 proof
   show "rel_pmf R x y" using assms by(auto elim!: pmf.rel_mono_strong)
   have "pred_pmf (Domainp (R \<upharpoonleft> P \<otimes> Q)) x" using assms by(fold pmf.Domainp_rel) blast
   then show "pred_pmf P x" by(rule pmf_pred_mono_strong)(blast dest!: restrict_relp_DomainpD)
   have "pred_pmf (Domainp (R \<upharpoonleft> P \<otimes> Q)\<inverse>\<inverse>) y" using assms
     by(fold pmf.Domainp_rel)(auto simp only: pmf.rel_conversep Domainp_conversep)
   then show "pred_pmf Q y" by(rule pmf_pred_mono_strong)(auto dest!: restrict_relp_DomainpD)
 qed
 
 lemma rel_pmf_restrict_relp_iff:
   "rel_pmf (R \<upharpoonleft> P \<otimes> Q) x y \<longleftrightarrow> rel_pmf R x y \<and> pred_pmf P x \<and> pred_pmf Q y"
 by(blast intro: rel_pmf_restrict_relpI elim: rel_pmf_restrict_relpE)
 
 lemma rel_pmf_OO_trans [trans]:
   "\<lbrakk> rel_pmf R p q; rel_pmf S q r \<rbrakk> \<Longrightarrow> rel_pmf (R OO S) p r"
 unfolding pmf.rel_compp by blast
 
 lemma pmf_pred_map [simp]: "pred_pmf P (map_pmf f p) = pred_pmf (P \<circ> f) p"
 by(simp add: pred_pmf_def)
 
 lemma pred_pmf_bind [simp]: "pred_pmf P (bind_pmf p f) = pred_pmf (pred_pmf P \<circ> f) p"
 by(simp add: pred_pmf_def)
 
 lemma pred_pmf_return [simp]: "pred_pmf P (return_pmf x) = P x"
 by(simp add: pred_pmf_def)
 
 lemma pred_pmf_of_set [simp]: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> pred_pmf P (pmf_of_set A) = Ball A P"
 by(simp add: pred_pmf_def)
 
 lemma pred_pmf_of_multiset [simp]: "M \<noteq> {#} \<Longrightarrow> pred_pmf P (pmf_of_multiset M) = Ball (set_mset M) P"
 by(simp add: pred_pmf_def)
 
 lemma pred_pmf_cond [simp]:
   "set_pmf p \<inter> A \<noteq> {} \<Longrightarrow> pred_pmf P (cond_pmf p A) = pred_pmf (\<lambda>x. x \<in> A \<longrightarrow> P x) p"
 by(auto simp add: pred_pmf_def)
 
 lemma pred_pmf_pair [simp]:
   "pred_pmf P (pair_pmf p q) = pred_pmf (\<lambda>x. pred_pmf (P \<circ> Pair x) q) p"
 by(simp add: pred_pmf_def)
 
 lemma pred_pmf_join [simp]: "pred_pmf P (join_pmf p) = pred_pmf (pred_pmf P) p"
 by(simp add: pred_pmf_def)
 
 lemma pred_pmf_bernoulli [simp]: "\<lbrakk> 0 < p; p < 1 \<rbrakk> \<Longrightarrow> pred_pmf P (bernoulli_pmf p) = All P"
 by(simp add: pred_pmf_def)
 
 lemma pred_pmf_geometric [simp]: "\<lbrakk> 0 < p; p < 1 \<rbrakk> \<Longrightarrow> pred_pmf P (geometric_pmf p) = All P"
 by(simp add: pred_pmf_def set_pmf_geometric)
 
 lemma pred_pmf_poisson [simp]: "0 < rate \<Longrightarrow> pred_pmf P (poisson_pmf rate) = All P"
 by(simp add: pred_pmf_def)
 
 lemma pmf_rel_map_restrict_relp: 
   shows pmf_rel_map_restrict_relp1: "rel_pmf (R \<upharpoonleft> P \<otimes> Q) (map_pmf f p) = rel_pmf (R \<circ> f \<upharpoonleft> P \<circ> f \<otimes> Q) p"
   and pmf_rel_map_restrict_relp2: "rel_pmf (R \<upharpoonleft> P \<otimes> Q) p (map_pmf g q) = rel_pmf ((\<lambda>x. R x \<circ> g) \<upharpoonleft> P \<otimes> Q \<circ> g) p q"
 by(simp_all add: pmf.rel_map restrict_relp_def fun_eq_iff)
 
 lemma pred_pmf_conj [simp]: "pred_pmf (\<lambda>x. P x \<and> Q x) = (\<lambda>x. pred_pmf P x \<and> pred_pmf Q x)"
 by(auto simp add: pred_pmf_def)
 
 lemma pred_pmf_top [simp]:
   "pred_pmf (\<lambda>_. True) = (\<lambda>_. True)"
 by(simp add: pred_pmf_def)
 
 lemma rel_pmf_of_setI:
   assumes A: "A \<noteq> {}" "finite A"
   and B: "B \<noteq> {}" "finite B"
   and card: "\<And>X. X \<subseteq> A \<Longrightarrow> card B * card X \<le> card A * card {y\<in>B. \<exists>x\<in>X. R x y}"
   shows "rel_pmf R (pmf_of_set A) (pmf_of_set B)"
 apply(rule rel_pmf_measureI)
 using assms
 apply(clarsimp simp add: measure_pmf_of_set card_gt_0_iff field_simps of_nat_mult[symmetric] simp del: of_nat_mult)
 apply(subst mult.commute)
 apply(erule meta_allE)
 apply(erule meta_impE)
  prefer 2
  apply(erule order_trans)
 apply(auto simp add: card_gt_0_iff intro: card_mono)
 done
 
+consts rel_witness_pmf :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a pmf \<times> 'b pmf \<Rightarrow> ('a \<times> 'b) pmf"
+specification (rel_witness_pmf)
+  set_rel_witness_pmf': "rel_pmf A (fst xy) (snd xy) \<Longrightarrow> set_pmf (rel_witness_pmf A xy) \<subseteq> {(a, b). A a b}"
+  map1_rel_witness_pmf': "rel_pmf A (fst xy) (snd xy) \<Longrightarrow> map_pmf fst (rel_witness_pmf A xy) = fst xy"
+  map2_rel_witness_pmf': "rel_pmf A (fst xy) (snd xy) \<Longrightarrow> map_pmf snd (rel_witness_pmf A xy) = snd xy"
+  apply(fold all_conj_distrib imp_conjR)
+  apply(rule choice allI)+
+  apply(unfold pmf.in_rel)
+  by blast
+
+lemmas set_rel_witness_pmf = set_rel_witness_pmf'[of _ "(x, y)" for x y, simplified]
+lemmas map1_rel_witness_pmf = map1_rel_witness_pmf'[of _ "(x, y)" for x y, simplified]
+lemmas map2_rel_witness_pmf = map2_rel_witness_pmf'[of _ "(x, y)" for x y, simplified]
+lemmas rel_witness_pmf = set_rel_witness_pmf map1_rel_witness_pmf map2_rel_witness_pmf
+
+lemma rel_witness_pmf1:
+  assumes "rel_pmf A p q" 
+  shows "rel_pmf (\<lambda>a (a', b). a = a' \<and> A a' b) p (rel_witness_pmf A (p, q))"
+  using map1_rel_witness_pmf[OF assms, symmetric]
+  unfolding pmf.rel_eq[symmetric] pmf.rel_map
+  by(rule pmf.rel_mono_strong)(auto dest: set_rel_witness_pmf[OF assms, THEN subsetD])
+
+lemma rel_witness_pmf2:
+  assumes "rel_pmf A p q" 
+  shows "rel_pmf (\<lambda>(a, b') b. b = b' \<and> A a b') (rel_witness_pmf A (p, q)) q"
+  using map2_rel_witness_pmf[OF assms]
+  unfolding pmf.rel_eq[symmetric] pmf.rel_map
+  by(rule pmf.rel_mono_strong)(auto dest: set_rel_witness_pmf[OF assms, THEN subsetD])
+
+lemma cond_pmf_of_set:
+  assumes fin: "finite A" and nonempty: "A \<inter> B \<noteq> {}"
+  shows "cond_pmf (pmf_of_set A) B = pmf_of_set (A \<inter> B)" (is "?lhs = ?rhs")
+proof(rule pmf_eqI)
+  from nonempty have A: "A \<noteq> {}" by auto
+  show "pmf ?lhs x = pmf ?rhs x" for x
+    by(subst pmf_cond; clarsimp simp add: fin A nonempty measure_pmf_of_set split: split_indicator)
+qed
+
+lemma pair_pmf_of_set:
+  assumes A: "finite A" "A \<noteq> {}"
+    and B: "finite B" "B \<noteq> {}"
+  shows "pair_pmf (pmf_of_set A) (pmf_of_set B) = pmf_of_set (A \<times> B)"
+  by(rule pmf_eqI)(clarsimp simp add: pmf_pair assms split: split_indicator)
+
+lemma emeasure_cond_pmf:
+  fixes p A
+  defines "q \<equiv> cond_pmf p A"
+  assumes "set_pmf p \<inter> A \<noteq> {}"
+  shows "emeasure (measure_pmf q) B = emeasure (measure_pmf p) (A \<inter> B) / emeasure (measure_pmf p) A"
+proof -
+  note [transfer_rule] = cond_pmf.transfer[OF assms(2), folded q_def]
+  interpret pmf_as_measure .
+  show ?thesis by transfer simp
+qed
+
+lemma measure_cond_pmf:
+  "measure (measure_pmf (cond_pmf p A)) B = measure (measure_pmf p) (A \<inter> B) / measure (measure_pmf p) A"
+  if "set_pmf p \<inter> A \<noteq> {}"
+  using emeasure_cond_pmf[OF that, of B] that 
+  by(auto simp add: measure_pmf.emeasure_eq_measure measure_pmf_posI divide_ennreal)
+
+lemma emeasure_measure_pmf_zero_iff: "emeasure (measure_pmf p) s = 0 \<longleftrightarrow> set_pmf p \<inter> s = {}" (is "?lhs = ?rhs")
+proof -
+  have "?lhs \<longleftrightarrow> (AE x in measure_pmf p. x \<notin> s)"
+    by(subst AE_iff_measurable)(auto)
+  also have "\<dots> = ?rhs" by(auto simp add: AE_measure_pmf_iff)
+  finally show ?thesis .
+qed
+
 subsection \<open>Subprobability mass functions\<close>
 
 lemma ord_spmf_return_spmf1: "ord_spmf R (return_spmf x) p \<longleftrightarrow> lossless_spmf p \<and> (\<forall>y\<in>set_spmf p. R x y)"
 by(auto simp add: rel_pmf_return_pmf1 ord_option.simps in_set_spmf lossless_iff_set_pmf_None Ball_def) (metis option.exhaust)
 
 lemma ord_spmf_conv:
   "ord_spmf R = rel_spmf R OO ord_spmf (=)"
 apply(subst pmf.rel_compp[symmetric])
 apply(rule arg_cong[where f="rel_pmf"])  
 apply(rule ext)+
 apply(auto elim!: ord_option.cases option.rel_cases intro: option.rel_intros)
 done
 
 lemma ord_spmf_expand:
   "NO_MATCH (=) R \<Longrightarrow> ord_spmf R = rel_spmf R OO ord_spmf (=)"
 by(rule ord_spmf_conv)
 
 lemma ord_spmf_eqD_measure: "ord_spmf (=) p q \<Longrightarrow> measure (measure_spmf p) A \<le> measure (measure_spmf q) A"
 by(drule ord_spmf_eqD_measure_spmf)(simp add: le_measure measure_spmf.emeasure_eq_measure)
 
 lemma ord_spmf_measureD:
   assumes "ord_spmf R p q"
   shows "measure (measure_spmf p) A \<le> measure (measure_spmf q) {y. \<exists>x\<in>A. R x y}"
     (is "?lhs \<le> ?rhs")
 proof -
   from assms obtain p' where *: "rel_spmf R p p'" and **: "ord_spmf (=) p' q"
     by(auto simp add: ord_spmf_expand)
   have "?lhs \<le> measure (measure_spmf p') {y. \<exists>x\<in>A. R x y}" using * by(rule rel_spmf_measureD)
   also have "\<dots> \<le> ?rhs" using ** by(rule ord_spmf_eqD_measure)
   finally show ?thesis .
 qed
 
 lemma ord_spmf_bind_pmfI1:
   "(\<And>x. x \<in> set_pmf p \<Longrightarrow> ord_spmf R (f x) q) \<Longrightarrow> ord_spmf R (bind_pmf p f) q"
   apply(rewrite at "ord_spmf _ _ \<hole>" bind_return_pmf[symmetric, where f="\<lambda>_ :: unit. q"])
   apply(rule rel_pmf_bindI[where R="\<lambda>x y. x \<in> set_pmf p"])
   apply(simp_all add: rel_pmf_return_pmf2)
   done
   
 lemma ord_spmf_bind_spmfI1:
   "(\<And>x. x \<in> set_spmf p \<Longrightarrow> ord_spmf R (f x) q) \<Longrightarrow> ord_spmf R (bind_spmf p f) q"
 unfolding bind_spmf_def by(rule ord_spmf_bind_pmfI1)(auto split: option.split simp add: in_set_spmf)
 
 lemma spmf_of_set_empty: "spmf_of_set {} = return_pmf None"
 by(simp add: spmf_of_set_def)
 
 lemma rel_spmf_of_setI:
   assumes card: "\<And>X. X \<subseteq> A \<Longrightarrow> card B * card X \<le> card A * card {y\<in>B. \<exists>x\<in>X. R x y}"
   and eq: "(finite A \<and> A \<noteq> {}) \<longleftrightarrow> (finite B \<and> B \<noteq> {})"
   shows "rel_spmf R (spmf_of_set A) (spmf_of_set B)"
 using eq by(clarsimp simp add: spmf_of_set_def card rel_pmf_of_setI simp del: spmf_of_pmf_pmf_of_set cong: conj_cong)
 
 lemmas map_bind_spmf = map_spmf_bind_spmf
 
 lemma nn_integral_measure_spmf_conv_measure_pmf:
   assumes [measurable]: "f \<in> borel_measurable (count_space UNIV)"
   shows "nn_integral (measure_spmf p) f = nn_integral (restrict_space (measure_pmf p) (range Some)) (f \<circ> the)"
 by(simp add: measure_spmf_def nn_integral_distr o_def)
 
 lemma nn_integral_spmf_neq_infinity: "(\<integral>\<^sup>+ x. spmf p x \<partial>count_space UNIV) \<noteq> \<infinity>"
 using nn_integral_measure_spmf[where f="\<lambda>_. 1", of p, symmetric] by simp
 
 lemma return_pmf_bind_option:
   "return_pmf (Option.bind x f) = bind_spmf (return_pmf x) (return_pmf \<circ> f)"
 by(cases x) simp_all
 
 lemma rel_spmf_pos_distr: "rel_spmf A OO rel_spmf B \<le> rel_spmf (A OO B)"
 unfolding option.rel_compp pmf.rel_compp ..
 
 lemma rel_spmf_OO_trans [trans]:
   "\<lbrakk> rel_spmf R p q; rel_spmf S q r \<rbrakk> \<Longrightarrow> rel_spmf (R OO S) p r"
 by(rule rel_spmf_pos_distr[THEN predicate2D]) auto
 
 lemma map_spmf_eq_map_spmf_iff: "map_spmf f p = map_spmf g q \<longleftrightarrow> rel_spmf (\<lambda>x y. f x = g y) p q"
 by(simp add: spmf_rel_eq[symmetric] spmf_rel_map)
 
 lemma map_spmf_eq_map_spmfI: "rel_spmf (\<lambda>x y. f x = g y) p q \<Longrightarrow> map_spmf f p = map_spmf g q"
 by(simp add: map_spmf_eq_map_spmf_iff)
 
 lemma spmf_rel_mono_strong:
   "\<lbrakk>rel_spmf A f g; \<And>x y. \<lbrakk> x \<in> set_spmf f; y \<in> set_spmf g; A x y \<rbrakk> \<Longrightarrow> B x y \<rbrakk> \<Longrightarrow> rel_spmf B f g"
 apply(erule pmf.rel_mono_strong)
 apply(erule option.rel_mono_strong)
 by(clarsimp simp add: in_set_spmf)
 
 lemma set_spmf_eq_empty: "set_spmf p = {} \<longleftrightarrow> p = return_pmf None"
 by auto (metis restrict_spmf_empty restrict_spmf_trivial)
 
 
 lemma measure_pair_spmf_times:
   "measure (measure_spmf (pair_spmf p q)) (A \<times> B) = measure (measure_spmf p) A * measure (measure_spmf q) B"
 proof -
   have "emeasure (measure_spmf (pair_spmf p q)) (A \<times> B) = (\<integral>\<^sup>+ x. ennreal (spmf (pair_spmf p q) x) * indicator (A \<times> B) x \<partial>count_space UNIV)"
     by(simp add: nn_integral_spmf[symmetric] nn_integral_count_space_indicator)
   also have "\<dots> = (\<integral>\<^sup>+ x. (\<integral>\<^sup>+ y. (ennreal (spmf p x) * indicator A x) * (ennreal (spmf q y) * indicator B y) \<partial>count_space UNIV) \<partial>count_space UNIV)"
     by(subst nn_integral_fst_count_space[symmetric])(auto intro!: nn_integral_cong split: split_indicator simp add: ennreal_mult)
   also have "\<dots> = (\<integral>\<^sup>+ x. ennreal (spmf p x) * indicator A x * emeasure (measure_spmf q) B \<partial>count_space UNIV)"
     by(simp add: nn_integral_cmult nn_integral_spmf[symmetric] nn_integral_count_space_indicator)
   also have "\<dots> = emeasure (measure_spmf p) A * emeasure (measure_spmf q) B"
     by(simp add: nn_integral_multc)(simp add: nn_integral_spmf[symmetric] nn_integral_count_space_indicator)
   finally show ?thesis by(simp add: measure_spmf.emeasure_eq_measure ennreal_mult[symmetric])
 qed
 
 lemma lossless_spmfD_set_spmf_nonempty: "lossless_spmf p \<Longrightarrow> set_spmf p \<noteq> {}"
 using set_pmf_not_empty[of p] by(auto simp add: set_spmf_def bind_UNION lossless_iff_set_pmf_None)
 
 lemma set_spmf_return_pmf: "set_spmf (return_pmf x) = set_option x"
 by(cases x) simp_all
 
 lemma bind_spmf_pmf_assoc: "bind_spmf (bind_pmf p f) g = bind_pmf p (\<lambda>x. bind_spmf (f x) g)"
 by(simp add: bind_spmf_def bind_assoc_pmf)
 
 lemma bind_spmf_of_set:  "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> bind_spmf (spmf_of_set A) f = bind_pmf (pmf_of_set A) f"
 by(simp add: spmf_of_set_def del: spmf_of_pmf_pmf_of_set)
 
 lemma bind_spmf_map_pmf:
   "bind_spmf (map_pmf f p) g = bind_pmf p (\<lambda>x. bind_spmf (return_pmf (f x)) g)"
 by(simp add: map_pmf_def bind_spmf_def bind_assoc_pmf)
 
 lemma rel_spmf_eqI [simp]: "rel_spmf (=) x x"
 by(simp add: option.rel_eq)
 
 lemma set_spmf_map_pmf: "set_spmf (map_pmf f p) = (\<Union>x\<in>set_pmf p. set_option (f x))" (* Move up *)
 by(simp add: set_spmf_def bind_UNION)
 
 lemma ord_spmf_return_spmf [simp]: "ord_spmf (=) (return_spmf x) p \<longleftrightarrow> p = return_spmf x"
 proof -
   have "p = return_spmf x \<Longrightarrow> ord_spmf (=) (return_spmf x) p" by simp
   thus ?thesis
     by (metis (no_types) ord_option_eq_simps(2) rel_pmf_return_pmf1 rel_pmf_return_pmf2 spmf.leq_antisym)
 qed
 
 declare
   set_bind_spmf [simp]
   set_spmf_return_pmf [simp]
 
 lemma bind_spmf_pmf_commute:
   "bind_spmf p (\<lambda>x. bind_pmf q (f x)) = bind_pmf q (\<lambda>y. bind_spmf p (\<lambda>x. f x y))"
 unfolding bind_spmf_def 
 by(subst bind_commute_pmf)(auto intro: bind_pmf_cong[OF refl] split: option.split)
 
 lemma return_pmf_map_option_conv_bind:
   "return_pmf (map_option f x) = bind_spmf (return_pmf x) (return_spmf \<circ> f)"
 by(cases x) simp_all
 
 lemma lossless_return_pmf_iff [simp]: "lossless_spmf (return_pmf x) \<longleftrightarrow> x \<noteq> None"
 by(cases x) simp_all
 
 lemma lossless_map_pmf: "lossless_spmf (map_pmf f p) \<longleftrightarrow> (\<forall>x \<in> set_pmf p. f x \<noteq> None)"
 using image_iff by(fastforce simp add: lossless_iff_set_pmf_None)
 
 lemma bind_pmf_spmf_assoc:
   "g None = return_pmf None
   \<Longrightarrow> bind_pmf (bind_spmf p f) g = bind_spmf p (\<lambda>x. bind_pmf (f x) g)"
 by(auto simp add: bind_spmf_def bind_assoc_pmf bind_return_pmf fun_eq_iff intro!: arg_cong2[where f=bind_pmf] split: option.split)
 
 abbreviation pred_spmf :: "('a \<Rightarrow> bool) \<Rightarrow> 'a spmf \<Rightarrow> bool"
 where "pred_spmf P \<equiv> pred_pmf (pred_option P)"
 
 lemma pred_spmf_def: "pred_spmf P p \<longleftrightarrow> (\<forall>x\<in>set_spmf p. P x)"
 by(auto simp add: pred_pmf_def pred_option_def set_spmf_def)
 
 lemma spmf_pred_mono_strong:
   "\<lbrakk> pred_spmf P p; \<And>a. \<lbrakk> a \<in> set_spmf p; P a \<rbrakk> \<Longrightarrow> P' a \<rbrakk> \<Longrightarrow> pred_spmf P' p"
 by(simp add: pred_spmf_def)
 
 lemma spmf_Domainp_rel: "Domainp (rel_spmf R) = pred_spmf (Domainp R)"
 by(simp add: pmf.Domainp_rel option.Domainp_rel)
 
 lemma rel_spmf_restrict_relpI [intro?]:
   "\<lbrakk> rel_spmf R p q; pred_spmf P p; pred_spmf Q q \<rbrakk> \<Longrightarrow> rel_spmf (R \<upharpoonleft> P \<otimes> Q) p q"
 by(erule spmf_rel_mono_strong)(simp add: pred_spmf_def)
 
 lemma rel_spmf_restrict_relpE [elim?]:
   assumes "rel_spmf (R \<upharpoonleft> P \<otimes> Q) x y"
   obtains "rel_spmf R x y" "pred_spmf P x" "pred_spmf Q y"
 proof
   show "rel_spmf R x y" using assms by(auto elim!: spmf_rel_mono_strong)
   have "pred_spmf (Domainp (R \<upharpoonleft> P \<otimes> Q)) x" using assms by(fold spmf_Domainp_rel) blast
   then show "pred_spmf P x" by(rule spmf_pred_mono_strong)(blast dest!: restrict_relp_DomainpD)
   have "pred_spmf (Domainp (R \<upharpoonleft> P \<otimes> Q)\<inverse>\<inverse>) y" using assms
     by(fold spmf_Domainp_rel)(auto simp only: spmf_rel_conversep Domainp_conversep)
   then show "pred_spmf Q y" by(rule spmf_pred_mono_strong)(auto dest!: restrict_relp_DomainpD)
 qed
 
 lemma rel_spmf_restrict_relp_iff:
   "rel_spmf (R \<upharpoonleft> P \<otimes> Q) x y \<longleftrightarrow> rel_spmf R x y \<and> pred_spmf P x \<and> pred_spmf Q y"
 by(blast intro: rel_spmf_restrict_relpI elim: rel_spmf_restrict_relpE)
 
 lemma spmf_pred_map: "pred_spmf P (map_spmf f p) = pred_spmf (P \<circ> f) p"
 by(simp)
 
 lemma pred_spmf_bind [simp]: "pred_spmf P (bind_spmf p f) = pred_spmf (pred_spmf P \<circ> f) p"
 by(simp add: pred_spmf_def bind_UNION)
 
 lemma pred_spmf_return: "pred_spmf P (return_spmf x) = P x"
 by simp
 
 lemma pred_spmf_return_pmf_None: "pred_spmf P (return_pmf None)"
 by simp
 
 lemma pred_spmf_spmf_of_pmf [simp]: "pred_spmf P (spmf_of_pmf p) = pred_pmf P p"
 unfolding pred_spmf_def by(simp add: pred_pmf_def)
 
 lemma pred_spmf_of_set [simp]: "pred_spmf P (spmf_of_set A) = (finite A \<longrightarrow> Ball A P)"
 by(auto simp add: pred_spmf_def set_spmf_of_set)
 
 lemma pred_spmf_assert_spmf [simp]: "pred_spmf P (assert_spmf b) = (b \<longrightarrow> P ())"
 by(cases b) simp_all
 
 lemma pred_spmf_pair [simp]:
   "pred_spmf P (pair_spmf p q) = pred_spmf (\<lambda>x. pred_spmf (P \<circ> Pair x) q) p"
 by(simp add: pred_spmf_def)
 
 lemma set_spmf_try [simp]:
   "set_spmf (try_spmf p q) = set_spmf p \<union> (if lossless_spmf p then {} else set_spmf q)"
 by(auto simp add: try_spmf_def set_spmf_bind_pmf in_set_spmf lossless_iff_set_pmf_None split: option.splits)(metis option.collapse)
 
 lemma try_spmf_bind_out1:
   "(\<And>x. lossless_spmf (f x)) \<Longrightarrow> bind_spmf (TRY p ELSE q) f = TRY (bind_spmf p f) ELSE (bind_spmf q f)"
   apply(clarsimp simp add: bind_spmf_def try_spmf_def bind_assoc_pmf bind_return_pmf intro!: bind_pmf_cong[OF refl] split: option.split)
   apply(rewrite in "\<hole> = _" bind_return_pmf'[symmetric])
   apply(rule bind_pmf_cong[OF refl])
   apply(clarsimp split: option.split simp add: lossless_iff_set_pmf_None)
   done
 
 lemma pred_spmf_try [simp]:
   "pred_spmf P (try_spmf p q) = (pred_spmf P p \<and> (\<not> lossless_spmf p \<longrightarrow> pred_spmf P q))"
 by(auto simp add: pred_spmf_def)
 
 lemma pred_spmf_cond [simp]:
   "pred_spmf P (cond_spmf p A) = pred_spmf (\<lambda>x. x \<in> A \<longrightarrow> P x) p"
 by(auto simp add: pred_spmf_def)
 
 lemma spmf_rel_map_restrict_relp: 
   shows spmf_rel_map_restrict_relp1: "rel_spmf (R \<upharpoonleft> P \<otimes> Q) (map_spmf f p) = rel_spmf (R \<circ> f \<upharpoonleft> P \<circ> f \<otimes> Q) p"
   and spmf_rel_map_restrict_relp2: "rel_spmf (R \<upharpoonleft> P \<otimes> Q) p (map_spmf g q) = rel_spmf ((\<lambda>x. R x \<circ> g) \<upharpoonleft> P \<otimes> Q \<circ> g) p q"
 by(simp_all add: spmf_rel_map restrict_relp_def)
 
 lemma pred_spmf_conj: "pred_spmf (\<lambda>x. P x \<and> Q x) = (\<lambda>x. pred_spmf P x \<and> pred_spmf Q x)"
 by simp
 
-
 lemma spmf_of_pmf_parametric [transfer_rule]: 
   includes lifting_syntax shows
   "(rel_pmf A ===> rel_spmf A) spmf_of_pmf spmf_of_pmf"
 unfolding spmf_of_pmf_def[abs_def] by transfer_prover
 
 lemma mono2mono_return_pmf[THEN spmf.mono2mono, simp, cont_intro]: (* Move to SPMF *)
   shows monotone_return_pmf: "monotone option_ord (ord_spmf (=)) return_pmf"
 by(rule monotoneI)(auto simp add: flat_ord_def)
 
 lemma mcont2mcont_return_pmf[THEN spmf.mcont2mcont, simp, cont_intro]:  (* Move to SPMF *)
   shows mcont_return_pmf: "mcont (flat_lub None) option_ord lub_spmf (ord_spmf (=)) return_pmf"
 by(rule mcont_finite_chains[OF _ _ flat_interpretation[THEN ccpo] ccpo_spmf]) simp_all
 
 lemma pred_spmf_top: (* Move up *)
   "pred_spmf (\<lambda>_. True) = (\<lambda>_. True)"
 by(simp)
 
 lemma rel_spmf_restrict_relpI' [intro?]:
   "\<lbrakk> rel_spmf (\<lambda>x y. P x \<longrightarrow> Q y \<longrightarrow> R x y) p q; pred_spmf P p; pred_spmf Q q \<rbrakk> \<Longrightarrow> rel_spmf (R \<upharpoonleft> P \<otimes> Q) p q"
 by(erule spmf_rel_mono_strong)(simp add: pred_spmf_def)
 
 lemma set_spmf_map_pmf_MATCH [simp]:
   assumes "NO_MATCH (map_option g) f"
   shows "set_spmf (map_pmf f p) = (\<Union>x\<in>set_pmf p. set_option (f x))"
 by(rule set_spmf_map_pmf)
 
 lemma rel_spmf_bindI':
   "\<lbrakk> rel_spmf A p q; \<And>x y. \<lbrakk> A x y; x \<in> set_spmf p; y \<in> set_spmf q \<rbrakk> \<Longrightarrow> rel_spmf B (f x) (g y) \<rbrakk>
   \<Longrightarrow> rel_spmf B (p \<bind> f) (q \<bind> g)"
 apply(rule rel_spmf_bindI[where R="\<lambda>x y. A x y \<and> x \<in> set_spmf p \<and> y \<in> set_spmf q"])
  apply(erule spmf_rel_mono_strong; simp)
 apply simp
 done
 
+definition rel_witness_spmf :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a spmf \<times> 'b spmf \<Rightarrow> ('a \<times> 'b) spmf" where
+  "rel_witness_spmf A = map_pmf rel_witness_option \<circ> rel_witness_pmf (rel_option A)"
+
+lemma assumes "rel_spmf A p q"
+  shows rel_witness_spmf1: "rel_spmf (\<lambda>a (a', b). a = a' \<and> A a' b) p (rel_witness_spmf A (p, q))"
+    and rel_witness_spmf2: "rel_spmf (\<lambda>(a, b') b. b = b' \<and> A a b') (rel_witness_spmf A (p, q)) q"
+  by(auto simp add: pmf.rel_map rel_witness_spmf_def intro: pmf.rel_mono_strong[OF rel_witness_pmf1[OF assms]] rel_witness_option1 pmf.rel_mono_strong[OF rel_witness_pmf2[OF assms]] rel_witness_option2)
+
+lemma weight_assert_spmf [simp]: "weight_spmf (assert_spmf b) = indicator {True} b"
+  by(simp split: split_indicator)
+
+definition enforce_spmf :: "('a \<Rightarrow> bool) \<Rightarrow> 'a spmf \<Rightarrow> 'a spmf" where
+  "enforce_spmf P = map_pmf (enforce_option P)"
+
+lemma enforce_spmf_parametric [transfer_rule]: includes lifting_syntax shows
+  "((A ===> (=)) ===> rel_spmf A ===> rel_spmf A) enforce_spmf enforce_spmf"
+  unfolding enforce_spmf_def by transfer_prover
+
+lemma enforce_return_spmf [simp]:
+  "enforce_spmf P (return_spmf x) = (if P x then return_spmf x else return_pmf None)"
+  by(simp add: enforce_spmf_def)
+
+lemma enforce_return_pmf_None [simp]:
+  "enforce_spmf P (return_pmf None) = return_pmf None"
+  by(simp add: enforce_spmf_def)
+
+lemma enforce_map_spmf:
+  "enforce_spmf P (map_spmf f p) = map_spmf f (enforce_spmf (P \<circ> f) p)"
+  by(simp add: enforce_spmf_def pmf.map_comp o_def enforce_map_option)
+
+lemma enforce_bind_spmf [simp]:
+  "enforce_spmf P (bind_spmf p f) = bind_spmf p (enforce_spmf P \<circ> f)"
+  by(auto simp add: enforce_spmf_def bind_spmf_def map_bind_pmf intro!: bind_pmf_cong split: option.split)
+
+lemma set_enforce_spmf [simp]: "set_spmf (enforce_spmf P p) = {a \<in> set_spmf p. P a}"
+  by(auto simp add: enforce_spmf_def in_set_spmf)
+
+lemma enforce_spmf_alt_def:
+  "enforce_spmf P p = bind_spmf p (\<lambda>a. bind_spmf (assert_spmf (P a)) (\<lambda>_ :: unit. return_spmf a))"
+  by(auto simp add: enforce_spmf_def assert_spmf_def map_pmf_def bind_spmf_def bind_return_pmf intro!: bind_pmf_cong split: option.split)
+
+lemma bind_enforce_spmf [simp]:
+  "bind_spmf (enforce_spmf P p) f = bind_spmf p (\<lambda>x. if P x then f x else return_pmf None)"
+  by(auto simp add: enforce_spmf_alt_def assert_spmf_def intro!: bind_spmf_cong)
+
+lemma weight_enforce_spmf:
+  "weight_spmf (enforce_spmf P p) = weight_spmf p - measure (measure_spmf p) {x. \<not> P x}" (is "?lhs = ?rhs")
+proof -
+  have "?lhs = LINT x|measure_spmf p. indicator {x. P x} x"
+    by(auto simp add: enforce_spmf_alt_def weight_bind_spmf o_def simp del: Bochner_Integration.integral_indicator intro!: Bochner_Integration.integral_cong split: split_indicator)
+  also have "\<dots> = ?rhs"
+    by(subst measure_spmf.finite_measure_Diff[symmetric])(auto simp add: space_measure_spmf intro!: arg_cong2[where f=measure])
+  finally show ?thesis .
+qed
+
+lemma lossless_enforce_spmf [simp]:
+  "lossless_spmf (enforce_spmf P p) \<longleftrightarrow> lossless_spmf p \<and> set_spmf p \<subseteq> {x. P x}"
+  by(auto simp add: enforce_spmf_alt_def)
+
+lemma enforce_spmf_top [simp]: "enforce_spmf \<top> = id"
+  by(simp add: enforce_spmf_def)
+
+lemma enforce_spmf_K_True [simp]: "enforce_spmf (\<lambda>_. True) p = p"
+  using enforce_spmf_top[THEN fun_cong, of p] by(simp add: top_fun_def)
+
+lemma enforce_spmf_bot [simp]: "enforce_spmf \<bottom> = (\<lambda>_. return_pmf None)"
+  by(simp add: enforce_spmf_def fun_eq_iff)
+
+lemma enforce_spmf_K_False [simp]: "enforce_spmf (\<lambda>_. False) p = return_pmf None"
+  using enforce_spmf_bot[THEN fun_cong, of p] by(simp add: bot_fun_def)
+
+lemma enforce_pred_id_spmf: "enforce_spmf P p = p" if "pred_spmf P p"
+proof -
+  have "enforce_spmf P p = map_pmf id p" using that
+    by(auto simp add: enforce_spmf_def enforce_pred_id_option simp del: map_pmf_id intro!: pmf.map_cong_pred[OF refl] elim!: pmf_pred_mono_strong)
+  then show ?thesis by simp
+qed
+
+lemma map_the_spmf_of_pmf [simp]: "map_pmf the (spmf_of_pmf p) = p"
+  by(simp add: spmf_of_pmf_def pmf.map_comp o_def)
+
+lemma bind_bind_conv_pair_spmf:
+  "bind_spmf p (\<lambda>x. bind_spmf q (f x)) = bind_spmf (pair_spmf p q) (\<lambda>(x, y). f x y)"
+  by(simp add: pair_spmf_alt_def)
+
+lemma cond_spmf_spmf_of_set:
+  "cond_spmf (spmf_of_set A) B = spmf_of_set (A \<inter> B)" if "finite A"
+  by(rule spmf_eqI)(auto simp add: spmf_of_set measure_spmf_of_set that split: split_indicator)
+
+lemma pair_spmf_of_set:
+  "pair_spmf (spmf_of_set A) (spmf_of_set B) = spmf_of_set (A \<times> B)"
+  by(rule spmf_eqI)(clarsimp simp add: spmf_of_set card_cartesian_product split: split_indicator)
+
+lemma emeasure_cond_spmf:
+  "emeasure (measure_spmf (cond_spmf p A)) B = emeasure (measure_spmf p) (A \<inter> B) / emeasure (measure_spmf p) A"
+  apply(clarsimp simp add: cond_spmf_def emeasure_measure_spmf_conv_measure_pmf emeasure_measure_pmf_zero_iff set_pmf_Int_Some split!: if_split)
+   apply blast
+  apply(subst (asm) emeasure_cond_pmf)
+  by(auto simp add: set_pmf_Int_Some image_Int)
+
+lemma measure_cond_spmf:
+  "measure (measure_spmf (cond_spmf p A)) B = measure (measure_spmf p) (A \<inter> B) / measure (measure_spmf p) A"
+  apply(clarsimp simp add: cond_spmf_def measure_measure_spmf_conv_measure_pmf measure_pmf_zero_iff set_pmf_Int_Some split!: if_split)
+  apply(subst (asm) measure_cond_pmf)
+  by(auto simp add: image_Int set_pmf_Int_Some)
+
+
+lemma lossless_cond_spmf [simp]: "lossless_spmf (cond_spmf p A) \<longleftrightarrow> set_spmf p \<inter> A \<noteq> {}"
+  by(clarsimp simp add: cond_spmf_def lossless_iff_set_pmf_None set_pmf_Int_Some)
+
+lemma measure_spmf_eq_density: "measure_spmf p = density (count_space UNIV) (spmf p)"
+  by(rule measure_eqI)(simp_all add: emeasure_density nn_integral_spmf[symmetric] nn_integral_count_space_indicator)
+
+lemma integral_measure_spmf:
+  fixes f :: "'a \<Rightarrow> 'b::{banach, second_countable_topology}"
+  assumes A: "finite A"
+  shows "(\<And>a. a \<in> set_spmf M \<Longrightarrow> f a \<noteq> 0 \<Longrightarrow> a \<in> A) \<Longrightarrow> (LINT x|measure_spmf M. f x) = (\<Sum>a\<in>A. spmf M a *\<^sub>R f a)"
+  unfolding measure_spmf_eq_density
+  apply (simp add: integral_density)
+  apply (subst lebesgue_integral_count_space_finite_support)
+  by (auto intro!: finite_subset[OF _ \<open>finite A\<close>] sum.mono_neutral_left simp: spmf_eq_0_set_spmf)
+
+
+lemma image_set_spmf_eq:
+  "f ` set_spmf p = g ` set_spmf q" if "ASSUMPTION (map_spmf f p = map_spmf g q)"
+  using that[unfolded ASSUMPTION_def, THEN arg_cong[where f=set_spmf]] by simp
+
+lemma map_spmf_const: "map_spmf (\<lambda>_. x) p = scale_spmf (weight_spmf p) (return_spmf x)"
+  by(simp add: map_spmf_conv_bind_spmf bind_spmf_const)
+
+lemma cond_return_pmf [simp]: "cond_pmf (return_pmf x) A = return_pmf x" if "x \<in> A"
+  using that by(intro pmf_eqI)(auto simp add: pmf_cond split: split_indicator)
+
+lemma cond_return_spmf [simp]: "cond_spmf (return_spmf x) A = (if x \<in> A then return_spmf x else return_pmf None)"
+  by(simp add: cond_spmf_def)
+
+lemma measure_range_Some_eq_weight:
+  "measure (measure_pmf p) (range Some) = weight_spmf p"
+  by (simp add: measure_measure_spmf_conv_measure_pmf space_measure_spmf)
+
+lemma restrict_spmf_eq_return_pmf_None [simp]:
+  "restrict_spmf p A = return_pmf None \<longleftrightarrow> set_spmf p \<inter> A = {}"
+  by(auto 4 3 simp add: restrict_spmf_def map_pmf_eq_return_pmf_iff bind_UNION in_set_spmf bind_eq_None_conv option.the_def dest: bspec split: if_split_asm option.split_asm)
+
+definition mk_lossless :: "'a spmf \<Rightarrow> 'a spmf" where
+  "mk_lossless p = scale_spmf (inverse (weight_spmf p)) p"
+
+lemma mk_lossless_idem [simp]: "mk_lossless (mk_lossless p) = mk_lossless p"
+  by(simp add: mk_lossless_def weight_scale_spmf min_def max_def inverse_eq_divide) 
+
+lemma mk_lossless_return [simp]: "mk_lossless (return_pmf x) = return_pmf x"
+  by(cases x)(simp_all add: mk_lossless_def)
+
+lemma mk_lossless_map [simp]: "mk_lossless (map_spmf f p) = map_spmf f (mk_lossless p)"
+  by(simp add: mk_lossless_def map_scale_spmf)
+
+lemma spmf_mk_lossless [simp]: "spmf (mk_lossless p) x = spmf p x / weight_spmf p"
+  by(simp add: mk_lossless_def spmf_scale_spmf inverse_eq_divide max_def)
+
+lemma set_spmf_mk_lossless [simp]: "set_spmf (mk_lossless p) = set_spmf p"
+  by(simp add: mk_lossless_def set_scale_spmf measure_spmf_zero_iff zero_less_measure_iff)
+
+lemma mk_lossless_lossless [simp]: "lossless_spmf p \<Longrightarrow> mk_lossless p = p"
+  by(simp add: mk_lossless_def lossless_weight_spmfD)
+
+lemma mk_lossless_eq_return_pmf_None [simp]: "mk_lossless p = return_pmf None \<longleftrightarrow> p = return_pmf None"
+proof -
+  have aux: "weight_spmf p = 0 \<Longrightarrow> spmf p i = 0" for i
+    by(rule antisym, rule order_trans[OF spmf_le_weight]) (auto intro!: order_trans[OF spmf_le_weight])
+
+  have[simp]: " spmf (scale_spmf (inverse (weight_spmf p)) p) = spmf (return_pmf None) \<Longrightarrow> spmf p i = 0" for i
+    by(drule fun_cong[where x=i]) (auto simp add: aux spmf_scale_spmf max_def)
+
+  show ?thesis by(auto simp add: mk_lossless_def intro: spmf_eqI)
+qed
+
+lemma return_pmf_None_eq_mk_lossless [simp]: "return_pmf None = mk_lossless p \<longleftrightarrow> p = return_pmf None"
+  by(metis mk_lossless_eq_return_pmf_None)
+
+lemma mk_lossless_spmf_of_set [simp]: "mk_lossless (spmf_of_set A) = spmf_of_set A"
+  by(simp add: spmf_of_set_def del: spmf_of_pmf_pmf_of_set)
+
+lemma weight_mk_lossless: "weight_spmf (mk_lossless p) = (if p = return_pmf None then 0 else 1)"
+  by(simp add: mk_lossless_def weight_scale_spmf min_def max_def inverse_eq_divide weight_spmf_eq_0)
+
+lemma mk_lossless_parametric [transfer_rule]: includes lifting_syntax shows
+  "(rel_spmf A ===> rel_spmf A) mk_lossless mk_lossless"
+  by(simp add: mk_lossless_def rel_fun_def rel_spmf_weightD rel_spmf_scaleI)
+
+lemma rel_spmf_mk_losslessI:
+  "rel_spmf A p q \<Longrightarrow> rel_spmf A (mk_lossless p) (mk_lossless q)"
+  by(rule mk_lossless_parametric[THEN rel_funD])
+
+lemma rel_spmf_restrict_spmfI:
+  "rel_spmf (\<lambda>x y. (x \<in> A \<and> y \<in> B \<and> R x y) \<or> x \<notin> A \<and> y \<notin> B) p q
+   \<Longrightarrow> rel_spmf R (restrict_spmf p A) (restrict_spmf q B)"
+  by(auto simp add: restrict_spmf_def pmf.rel_map elim!: option.rel_cases pmf.rel_mono_strong)
+
+lemma cond_spmf_alt: "cond_spmf p A = mk_lossless (restrict_spmf p A)"
+proof(cases "set_spmf p \<inter> A = {}")
+  case True
+  then show ?thesis by(simp add: cond_spmf_def measure_spmf_zero_iff)
+next
+  case False
+  show ?thesis
+    by(rule spmf_eqI)(simp add: False cond_spmf_def pmf_cond set_pmf_Int_Some image_iff measure_measure_spmf_conv_measure_pmf[symmetric] spmf_scale_spmf max_def inverse_eq_divide)
+qed
+
+lemma cond_spmf_bind:
+  "cond_spmf (bind_spmf p f) A = mk_lossless (p \<bind> (\<lambda>x. f x \<upharpoonleft> A))"
+  by(simp add: cond_spmf_alt restrict_bind_spmf scale_bind_spmf)
+
+lemma cond_spmf_UNIV [simp]: "cond_spmf p UNIV = mk_lossless p"
+  by(clarsimp simp add: cond_spmf_alt)
+
+lemma cond_pmf_singleton:
+  "cond_pmf p A = return_pmf x" if "set_pmf p \<inter> A = {x}"
+proof -
+  have[simp]: "set_pmf p \<inter> A = {x} \<Longrightarrow> x \<in> A \<Longrightarrow> measure_pmf.prob p A = pmf p x"
+    by(auto simp add: measure_pmf_single[symmetric] AE_measure_pmf_iff intro!: measure_pmf.finite_measure_eq_AE)
+
+  have "pmf (cond_pmf p A) i = pmf (return_pmf x) i" for i
+    using that by(auto simp add: pmf_cond measure_pmf_zero_iff pmf_eq_0_set_pmf split: split_indicator)
+
+  then show ?thesis by(rule pmf_eqI)
+qed
+
+
+definition cond_spmf_fst :: "('a \<times> 'b) spmf \<Rightarrow> 'a \<Rightarrow> 'b spmf" where
+  "cond_spmf_fst p a = map_spmf snd (cond_spmf p ({a} \<times> UNIV))"
+
+lemma cond_spmf_fst_return_spmf [simp]:
+  "cond_spmf_fst (return_spmf (x, y)) x = return_spmf y"
+  by(simp add: cond_spmf_fst_def)
+
+lemma cond_spmf_fst_map_Pair [simp]: "cond_spmf_fst (map_spmf (Pair x) p) x = mk_lossless p"
+  by(clarsimp simp add: cond_spmf_fst_def spmf.map_comp o_def)
+
+lemma cond_spmf_fst_map_Pair' [simp]: "cond_spmf_fst (map_spmf (\<lambda>y. (x, f y)) p) x = map_spmf f (mk_lossless p)"
+  by(subst spmf.map_comp[where f="Pair x", symmetric, unfolded o_def]) simp
+
+lemma cond_spmf_fst_eq_return_None [simp]: "cond_spmf_fst p x = return_pmf None \<longleftrightarrow> x \<notin> fst ` set_spmf p"
+  by(auto 4 4 simp add: cond_spmf_fst_def map_pmf_eq_return_pmf_iff in_set_spmf[symmetric] dest: bspec[where x="Some _"] intro: ccontr rev_image_eqI)
+
+lemma cond_spmf_fst_map_Pair1:
+  "cond_spmf_fst (map_spmf (\<lambda>x. (f x, g x)) p) (f x) = return_spmf (g (inv_into (set_spmf p) f (f x)))"
+  if "x \<in> set_spmf p" "inj_on f (set_spmf p)"
+proof -
+  let ?foo="\<lambda>y. map_option (\<lambda>x. (f x, g x)) -` Some ` ({f y} \<times> UNIV)"
+  have[simp]: "y \<in> set_spmf p \<Longrightarrow> f x = f y \<Longrightarrow> set_pmf p \<inter> (?foo y) \<noteq> {}" for y
+    by(auto simp add: vimage_def image_def in_set_spmf)
+
+  have[simp]: "y \<in> set_spmf p \<Longrightarrow> f x = f y \<Longrightarrow>  map_spmf snd (map_spmf (\<lambda>x. (f x, g x)) (cond_pmf p (?foo y))) = return_spmf (g x)" for y
+    using that by(subst cond_pmf_singleton[where x="Some x"]) (auto simp add: in_set_spmf elim: inj_onD)
+
+  show ?thesis
+    using that
+    by(auto simp add: cond_spmf_fst_def cond_spmf_def)
+      (erule notE, subst cond_map_pmf, simp_all)
+qed
+
+lemma lossless_cond_spmf_fst [simp]: "lossless_spmf (cond_spmf_fst p x) \<longleftrightarrow> x \<in> fst ` set_spmf p"
+  by(auto simp add: cond_spmf_fst_def intro: rev_image_eqI)
+
+lemma cond_spmf_fst_inverse:
+  "bind_spmf (map_spmf fst p) (\<lambda>x. map_spmf (Pair x) (cond_spmf_fst p x)) = p"
+  (is "?lhs = ?rhs")
+proof(rule spmf_eqI)
+  fix i :: "'a \<times> 'b"
+  have *: "({x} \<times> UNIV \<inter> (Pair x \<circ> snd) -` {i}) = (if x = fst i then {i} else {})" for x by(cases i)auto
+  have "spmf ?lhs i = LINT x|measure_spmf (map_spmf fst p). spmf (map_spmf (Pair x \<circ> snd) (cond_spmf p ({x} \<times> UNIV))) i"
+    by(auto simp add: spmf_bind spmf.map_comp[symmetric] cond_spmf_fst_def intro!: integral_cong_AE)
+  also have "\<dots> = LINT x|measure_spmf (map_spmf fst p). measure (measure_spmf (cond_spmf p ({x} \<times> UNIV))) ((Pair x \<circ> snd) -` {i})"
+    by(rule integral_cong_AE)(auto simp add: spmf_map)
+  also have "\<dots> = LINT x|measure_spmf (map_spmf fst p). measure (measure_spmf p) ({x} \<times> UNIV \<inter> (Pair x \<circ> snd) -` {i}) /
+       measure (measure_spmf p) ({x} \<times> UNIV)"
+    by(rule integral_cong_AE; clarsimp simp add: measure_cond_spmf)
+  also have "\<dots> = spmf (map_spmf fst p) (fst i) * spmf p i / measure (measure_spmf p) ({fst i} \<times> UNIV)"
+    by(simp add: * if_distrib[where f="measure (measure_spmf _)"] cong: if_cong)
+      (subst integral_measure_spmf[where A="{fst i}"]; auto split: if_split_asm simp add: spmf_conv_measure_spmf)
+  also have "\<dots> = spmf p i"
+    by(clarsimp simp add: spmf_map vimage_fst)(metis (no_types, lifting) Int_insert_left_if1 in_set_spmf_iff_spmf insertI1 insert_UNIV insert_absorb insert_not_empty measure_spmf_zero_iff mem_Sigma_iff prod.collapse)
+  finally show "spmf ?lhs i = spmf ?rhs i" .
+qed
 
 subsubsection \<open>Embedding of @{typ "'a option"} into @{typ "'a spmf"}\<close>
 
 text \<open>This theoretically follows from the embedding between @{typ "_ id"} into @{typ "_ prob"} and the isomorphism
   between @{typ "(_, _ prob) optionT"} and @{typ "_ spmf"}, but we would only get the monomorphic
   version via this connection. So we do it directly.
 \<close>
 
 lemma bind_option_spmf_monad [simp]: "monad.bind_option (return_pmf None) x = bind_spmf (return_pmf x)"
 by(cases x)(simp_all add: fun_eq_iff)
 
 locale option_to_spmf begin
 
 text \<open>
   We have to get the embedding into the lifting package such that we can use the parametrisation of transfer rules.
 \<close>
 
 definition the_pmf :: "'a pmf \<Rightarrow> 'a" where "the_pmf p = (THE x. p = return_pmf x)"
 
 lemma the_pmf_return [simp]: "the_pmf (return_pmf x) = x"
 by(simp add: the_pmf_def)
 
 lemma type_definition_option_spmf: "type_definition return_pmf the_pmf {x. \<exists>y :: 'a option. x = return_pmf y}"
 by unfold_locales(auto)
 
 context begin
 private setup_lifting type_definition_option_spmf
 abbreviation cr_spmf_option where "cr_spmf_option \<equiv> cr_option"
 abbreviation pcr_spmf_option where "pcr_spmf_option \<equiv> pcr_option"
 lemmas Quotient_spmf_option = Quotient_option
   and cr_spmf_option_def = cr_option_def
   and pcr_spmf_option_bi_unique = option.bi_unique
   and Domainp_pcr_spmf_option = option.domain
   and Domainp_pcr_spmf_option_eq = option.domain_eq
   and Domainp_pcr_spmf_option_par = option.domain_par
   and Domainp_pcr_spmf_option_left_total = option.domain_par_left_total
   and pcr_spmf_option_left_unique = option.left_unique
   and pcr_spmf_option_cr_eq = option.pcr_cr_eq
   and pcr_spmf_option_return_pmf_transfer = option.rep_transfer
   and pcr_spmf_option_right_total = option.right_total
   and pcr_spmf_option_right_unique = option.right_unique
   and pcr_spmf_option_def = pcr_option_def
 bundle spmf_option_lifting = [[Lifting.lifting_restore_internal "Misc_CryptHOL.option.lifting"]]
 end
 
 
 context includes lifting_syntax begin
 
 lemma return_option_spmf_transfer [transfer_parametric return_spmf_parametric, transfer_rule]:
   "((=) ===> cr_spmf_option) return_spmf Some"
 by(rule rel_funI)(simp add: cr_spmf_option_def)
 
 lemma map_option_spmf_transfer [transfer_parametric map_spmf_parametric, transfer_rule]:
   "(((=) ===> (=)) ===> cr_spmf_option ===> cr_spmf_option) map_spmf map_option"
 unfolding rel_fun_eq by(auto simp add: rel_fun_def cr_spmf_option_def)
 
 lemma fail_option_spmf_transfer [transfer_parametric return_spmf_None_parametric, transfer_rule]:
   "cr_spmf_option (return_pmf None) None"
 by(simp add: cr_spmf_option_def)
 
 lemma bind_option_spmf_transfer [transfer_parametric bind_spmf_parametric, transfer_rule]:
   "(cr_spmf_option ===> ((=) ===> cr_spmf_option) ===> cr_spmf_option) bind_spmf Option.bind"
 apply(clarsimp simp add: rel_fun_def cr_spmf_option_def)
 subgoal for x f g by(cases x; simp)
 done
 
 lemma set_option_spmf_transfer [transfer_parametric set_spmf_parametric, transfer_rule]:
   "(cr_spmf_option ===> rel_set (=)) set_spmf set_option"
 by(clarsimp simp add: rel_fun_def cr_spmf_option_def rel_set_eq)
 
 lemma rel_option_spmf_transfer [transfer_parametric rel_spmf_parametric, transfer_rule]:
   "(((=) ===> (=) ===> (=)) ===> cr_spmf_option ===> cr_spmf_option ===> (=)) rel_spmf rel_option"
 unfolding rel_fun_eq by(simp add: rel_fun_def cr_spmf_option_def)
 
 end
 
 end
 
 locale option_le_spmf begin
 
 text \<open>
   Embedding where only successful computations in the option monad are related to Dirac spmf.
 \<close>
 
 definition cr_option_le_spmf :: "'a option \<Rightarrow> 'a spmf \<Rightarrow> bool"
 where "cr_option_le_spmf x p \<longleftrightarrow> ord_spmf (=) (return_pmf x) p"
 
 context includes lifting_syntax begin
 
 lemma return_option_le_spmf_transfer [transfer_rule]:
   "((=) ===> cr_option_le_spmf) (\<lambda>x. x) return_pmf"
 by(rule rel_funI)(simp add: cr_option_le_spmf_def ord_option_reflI)
 
 lemma map_option_le_spmf_transfer [transfer_rule]:
   "(((=) ===> (=)) ===> cr_option_le_spmf ===> cr_option_le_spmf) map_option map_spmf"
 unfolding rel_fun_eq
 apply(clarsimp simp add: rel_fun_def cr_option_le_spmf_def rel_pmf_return_pmf1 ord_option_map1 ord_option_map2)
 subgoal for f x p y by(cases x; simp add: ord_option_reflI)
 done
 
 lemma bind_option_le_spmf_transfer [transfer_rule]:
   "(cr_option_le_spmf ===> ((=) ===> cr_option_le_spmf) ===> cr_option_le_spmf) Option.bind bind_spmf"
 apply(clarsimp simp add: rel_fun_def cr_option_le_spmf_def)
 subgoal for x p f g by(cases x; auto 4 3 simp add: rel_pmf_return_pmf1 set_pmf_bind_spmf)
 done
 
 end
 
 end
 
 interpretation rel_spmf_characterisation by unfold_locales(rule rel_pmf_measureI)
 
 lemma if_distrib_bind_spmf1 [if_distribs]:
   "bind_spmf (if b then x else y) f = (if b then bind_spmf x f else bind_spmf y f)"
 by simp
 
 lemma if_distrib_bind_spmf2 [if_distribs]:
   "bind_spmf x (\<lambda>y. if b then f y else g y) = (if b then bind_spmf x f else bind_spmf x g)"
 by simp
 
 lemma rel_spmf_if_distrib [if_distribs]:
   "rel_spmf R (if b then x else y) (if b then x' else y') \<longleftrightarrow>
   (b \<longrightarrow> rel_spmf R x x') \<and> (\<not> b \<longrightarrow> rel_spmf R y y')"
 by(simp)
 
 lemma if_distrib_map_spmf [if_distribs]:
   "map_spmf f (if b then p else q) = (if b then map_spmf f p else map_spmf f q)"
 by simp
 
 lemma if_distrib_restrict_spmf1 [if_distribs]:
   "restrict_spmf (if b then p else q) A = (if b then restrict_spmf p A else restrict_spmf q A)"
 by simp
 
 end
diff --git a/thys/CryptHOL/SPMF_Applicative.thy b/thys/CryptHOL/SPMF_Applicative.thy
--- a/thys/CryptHOL/SPMF_Applicative.thy
+++ b/thys/CryptHOL/SPMF_Applicative.thy
@@ -1,60 +1,62 @@
 theory SPMF_Applicative imports
   Applicative_Lifting.Applicative_PMF
   Set_Applicative
   "HOL-Probability.SPMF"
 begin
 
+declare eq_on_def [simp del]
+
 subsection \<open>Applicative instance for @{typ "'a spmf"}\<close>
 
 abbreviation (input) pure_spmf :: "'a \<Rightarrow> 'a spmf"
 where "pure_spmf \<equiv> return_spmf"
 
 definition ap_spmf :: "('a \<Rightarrow> 'b) spmf \<Rightarrow> 'a spmf \<Rightarrow> 'b spmf"
 where "ap_spmf f x = map_spmf (\<lambda>(f, x). f x) (pair_spmf f x)"
 
 lemma ap_spmf_conv_bind: "ap_spmf f x = bind_spmf f (\<lambda>f. bind_spmf x (\<lambda>x. return_spmf (f x)))"
 by(simp add: ap_spmf_def map_spmf_conv_bind_spmf pair_spmf_alt_def)
 
 adhoc_overloading Applicative.ap ap_spmf
 
 context includes applicative_syntax begin
 
 lemma ap_spmf_id: "pure_spmf (\<lambda>x. x) \<diamondop> x = x"
 by(simp add: ap_spmf_def pair_spmf_return_spmf1 spmf.map_comp o_def)
 
 lemma ap_spmf_comp: "pure_spmf (\<circ>) \<diamondop> u \<diamondop> v \<diamondop> w = u \<diamondop> (v \<diamondop> w)"
 by(simp add: ap_spmf_def pair_spmf_return_spmf1 pair_map_spmf1 pair_map_spmf2 spmf.map_comp o_def split_def pair_pair_spmf)
 
 lemma ap_spmf_homo: "pure_spmf f \<diamondop> pure_spmf x = pure_spmf (f x)"
 by(simp add: ap_spmf_def pair_spmf_return_spmf1)
 
 lemma ap_spmf_interchange: "u \<diamondop> pure_spmf x = pure_spmf (\<lambda>f. f x) \<diamondop> u"
 by(simp add: ap_spmf_def pair_spmf_return_spmf1 pair_spmf_return_spmf2 spmf.map_comp o_def)
 
 lemma ap_spmf_C: "return_spmf (\<lambda>f x y. f y x) \<diamondop> f \<diamondop> x \<diamondop> y = f \<diamondop> y \<diamondop> x"
 apply(simp add: ap_spmf_def pair_map_spmf1 spmf.map_comp pair_spmf_return_spmf1 pair_pair_spmf o_def split_def)
 apply(subst (2) pair_commute_spmf)
 apply(simp add: pair_map_spmf2 spmf.map_comp o_def split_def)
 done
 
 applicative spmf (C)
 for
   pure: pure_spmf
   ap: ap_spmf
 by(rule ap_spmf_id ap_spmf_comp[unfolded o_def[abs_def]] ap_spmf_homo ap_spmf_interchange ap_spmf_C)+
 
 lemma set_ap_spmf [simp]: "set_spmf (p \<diamondop> q) = set_spmf p \<diamondop> set_spmf q"
 by(auto simp add: ap_spmf_def ap_set_def)
 
 lemma bind_ap_spmf: "bind_spmf (p \<diamondop> x) f = bind_spmf p (\<lambda>p. x \<bind> (\<lambda>x. f (p x)))"
 by(simp add: ap_spmf_conv_bind)
 
 lemma bind_pmf_ap_return_spmf [simp]: "bind_pmf (ap_spmf (return_spmf f) p) g = bind_pmf p (g \<circ> map_option f)"
 by(auto simp add: ap_spmf_conv_bind bind_spmf_def bind_return_pmf bind_assoc_pmf intro: bind_pmf_cong split: option.split)
 
 lemma map_spmf_conv_ap [applicative_unfold]: "map_spmf f p = return_spmf f \<diamondop> p"
 by(simp add: map_spmf_conv_bind_spmf ap_spmf_conv_bind)
 
 end
 
 end