section \<open>Basic Definitions\<close>
theory Sepref_Basic
imports
  "HOL-Eisbach.Eisbach"
  Separation_Logic_Imperative_HOL.Sep_Main
  Refine_Monadic.Refine_Monadic
  "Lib/Sepref_Misc"
  "Lib/Structured_Apply"
  Sepref_Id_Op
begin
no_notation i_ANNOT (infixr ":::\<^sub>i" 10)
no_notation CONST_INTF (infixr "::\<^sub>i" 10)

text \<open>
  In this theory, we define the basic concept of refinement
  from a nondeterministic program specified in the
  Isabelle Refinement Framework to an imperative deterministic one
  specified in Imperative/HOL.
\<close>

subsection \<open>Values on Heap\<close>
text \<open>We tag every refinement assertion with the tag \<open>hn_ctxt\<close>, to
  avoid higher-order unification problems when the refinement assertion
  is schematic.\<close>
definition hn_ctxt :: "('a\<Rightarrow>'c\<Rightarrow>assn) \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> assn"
  \<comment> \<open>Tag for refinement assertion\<close>
  where
  "hn_ctxt P a c \<equiv> P a c"

definition pure :: "('b \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> assn"
  \<comment> \<open>Pure binding, not involving the heap\<close>
  where "pure R \<equiv> (\<lambda>a c. \<up>((c,a)\<in>R))"

lemma pure_app_eq: "pure R a c = \<up>((c,a)\<in>R)" by (auto simp: pure_def)

lemma pure_eq_conv[simp]: "pure R = pure R' \<longleftrightarrow> R=R'"
  unfolding pure_def
  apply (rule iffI)
  apply safe
  apply (meson pure_assn_eq_conv)
  apply (meson pure_assn_eq_conv)
  done

lemma pure_rel_eq_false_iff: "pure R x y = false \<longleftrightarrow> (y,x)\<notin>R"
  by (auto simp: pure_def)

definition "is_pure P \<equiv> \<exists>P'. \<forall>x x'. P x x'=\<up>(P' x x')"
lemma is_pureI[intro?]:
  assumes "\<And>x x'. P x x' = \<up>(P' x x')"
  shows "is_pure P"
  using assms unfolding is_pure_def by blast

lemma is_pureE:
  assumes "is_pure P"
  obtains P' where "\<And>x x'. P x x' = \<up>(P' x x')"
  using assms unfolding is_pure_def by blast

lemma pure_pure[simp]: "is_pure (pure P)"
  unfolding pure_def by rule blast
lemma pure_hn_ctxt[intro!]: "is_pure P \<Longrightarrow> is_pure (hn_ctxt P)"
  unfolding hn_ctxt_def[abs_def] .

definition "the_pure P \<equiv> THE P'. \<forall>x x'. P x x'=\<up>((x',x)\<in>P')"

lemma the_pure_pure[simp]: "the_pure (pure R) = R"
  unfolding pure_def the_pure_def
  by (rule theI2[where a=R]) auto

lemma is_pure_alt_def: "is_pure R \<longleftrightarrow> (\<exists>Ri. \<forall>x y. R x y = \<up>((y,x)\<in>Ri))"
  unfolding is_pure_def
  apply auto
  apply (rename_tac P')
  apply (rule_tac x="{(x,y). P' y x}" in exI)
  apply auto
  done

lemma pure_the_pure[simp]: "is_pure R \<Longrightarrow> pure (the_pure R) = R"
  unfolding is_pure_alt_def pure_def the_pure_def
  apply (intro ext)
  apply clarsimp
  apply (rename_tac a c Ri)
  apply (rule_tac a=Ri in theI2)
  apply auto
  done

lemma is_pure_conv: "is_pure R \<longleftrightarrow> (\<exists>R'. R = pure R')"
  unfolding pure_def is_pure_alt_def by force

lemma is_pure_the_pure_id_eq[simp]: "is_pure R \<Longrightarrow> the_pure R = Id \<longleftrightarrow> R=pure Id"
  by (auto simp: is_pure_conv)

lemma is_pure_iff_pure_assn: "is_pure P = (\<forall>x x'. is_pure_assn (P x x'))"
  unfolding is_pure_def is_pure_assn_def by metis

abbreviation "hn_val R \<equiv> hn_ctxt (pure R)"

lemma hn_val_unfold: "hn_val R a b = \<up>((b,a)\<in>R)"
  by (simp add: hn_ctxt_def pure_def)

definition "invalid_assn R x y \<equiv> \<up>(\<exists>h. h\<Turnstile>R x y) * true"

abbreviation "hn_invalid R \<equiv> hn_ctxt (invalid_assn R)"

lemma invalidate_clone: "R x y \<Longrightarrow>\<^sub>A invalid_assn R x y * R x y"
  apply (rule entailsI)
  unfolding invalid_assn_def
  apply (auto simp: models_in_range mod_star_trueI)
  done

lemma invalidate_clone': "R x y \<Longrightarrow>\<^sub>A invalid_assn R x y * R x y * true"
  apply (rule entailsI)
  unfolding invalid_assn_def
  apply (auto simp: models_in_range mod_star_trueI)
  done

lemma invalidate: "R x y \<Longrightarrow>\<^sub>A invalid_assn R x y"
  apply (rule entailsI)
  unfolding invalid_assn_def
  apply (auto simp: models_in_range mod_star_trueI)
  done

lemma invalid_pure_recover: "invalid_assn (pure R) x y = pure R x y * true"
  apply (rule ent_iffI)
  subgoal
    apply (rule entailsI)
    unfolding invalid_assn_def
    by (auto simp: pure_def)
  subgoal
    unfolding invalid_assn_def
    by (auto simp: pure_def)
  done

lemma hn_invalidI: "h\<Turnstile>hn_ctxt P x y \<Longrightarrow> hn_invalid P x y = true"
  apply (cases h)
  apply (rule ent_iffI)
  apply (auto simp: invalid_assn_def hn_ctxt_def)
  done

lemma invalid_assn_cong[cong]:
  assumes "x\<equiv>x'"
  assumes "y\<equiv>y'"
  assumes "R x' y' \<equiv> R' x' y'"
  shows "invalid_assn R x y = invalid_assn R' x' y'"
  using assms unfolding invalid_assn_def
  by simp

subsection \<open>Constraints in Refinement Relations\<close>

lemma mod_pure_conv[simp]: "(h,as)\<Turnstile>pure R a b \<longleftrightarrow> (as={} \<and> (b,a)\<in>R)"
  by (auto simp: pure_def)

definition rdomp :: "('a \<Rightarrow> 'c \<Rightarrow> assn) \<Rightarrow> 'a \<Rightarrow> bool" where
  "rdomp R a \<equiv> \<exists>h c. h \<Turnstile> R a c"

abbreviation "rdom R \<equiv> Collect (rdomp R)"

lemma rdomp_ctxt[simp]: "rdomp (hn_ctxt R) = rdomp R"
  by (simp add: hn_ctxt_def[abs_def])

lemma rdomp_pure[simp]: "rdomp (pure R) a \<longleftrightarrow> a\<in>Range R"
  unfolding rdomp_def pure_def by auto

lemma Range_of_constraint_conv[simp]: "Range (A\<inter>UNIV\<times>C) = Range A \<inter> C"
  by auto

subsection \<open>Heap-Nres Refinement Calculus\<close>

text \<open>Predicate that expresses refinement. Given a heap
  \<open>\<Gamma>\<close>, program \<open>c\<close> produces a heap \<open>\<Gamma>'\<close> and
  a concrete result that is related with predicate \<open>R\<close> to some
  abstract result from \<open>m\<close>\<close>
definition "hn_refine \<Gamma> c \<Gamma>' R m \<equiv> nofail m \<longrightarrow>
  <\<Gamma>> c <\<lambda>r. \<Gamma>' * (\<exists>\<^sub>Ax. R x r * \<up>(RETURN x \<le> m)) >\<^sub>t"

(* TODO: Can we change the patterns of assn_simproc to add this pattern? *)
simproc_setup assn_simproc_hnr ("hn_refine \<Gamma> c \<Gamma>'")
  = \<open>K Seplogic_Auto.assn_simproc_fun\<close>

lemma hn_refineI[intro?]:
  assumes "nofail m
    \<Longrightarrow> <\<Gamma>> c <\<lambda>r. \<Gamma>' * (\<exists>\<^sub>Ax. R x r * \<up>(RETURN x \<le> m)) >\<^sub>t"
  shows "hn_refine \<Gamma> c \<Gamma>' R m"
  using assms unfolding hn_refine_def by blast

lemma hn_refineD:
  assumes "hn_refine \<Gamma> c \<Gamma>' R m"
  assumes "nofail m"
  shows "<\<Gamma>> c <\<lambda>r. \<Gamma>' * (\<exists>\<^sub>Ax. R x r * \<up>(RETURN x \<le> m)) >\<^sub>t"
  using assms unfolding hn_refine_def by blast

lemma hn_refine_preI:
  assumes "\<And>h. h\<Turnstile>\<Gamma> \<Longrightarrow> hn_refine \<Gamma> c \<Gamma>' R a"
  shows "hn_refine \<Gamma> c \<Gamma>' R a"
  using assms unfolding hn_refine_def
  by (auto intro: hoare_triple_preI)

lemma hn_refine_nofailI:
  assumes "nofail a \<Longrightarrow> hn_refine \<Gamma> c \<Gamma>' R a"
  shows "hn_refine \<Gamma> c \<Gamma>' R a"
  using assms by (auto simp: hn_refine_def)

lemma hn_refine_false[simp]: "hn_refine false c \<Gamma>' R m"
  by rule auto

lemma hn_refine_fail[simp]: "hn_refine \<Gamma> c \<Gamma>' R FAIL"
  by rule auto

lemma hn_refine_frame:
  assumes "hn_refine P' c Q' R m"
  assumes "P \<Longrightarrow>\<^sub>t F * P'"
  shows "hn_refine P c (F * Q') R m"
  using assms
  unfolding hn_refine_def entailst_def
  apply clarsimp
  apply (erule cons_pre_rule)
  apply (rule cons_post_rule)
  apply (erule fi_rule, frame_inference)
  apply (simp only: star_aci)
  apply simp
  done

lemma hn_refine_cons:
  assumes I: "P\<Longrightarrow>\<^sub>tP'"
  assumes R: "hn_refine P' c Q R m"
  assumes I': "Q\<Longrightarrow>\<^sub>tQ'"
  assumes R': "\<And>x y. R x y \<Longrightarrow>\<^sub>t R' x y"
  shows "hn_refine P c Q' R' m"
  using R unfolding hn_refine_def
  apply clarify
  apply (rule cons_pre_rulet[OF I])
  apply (rule cons_post_rulet)
  apply assumption
  apply (sep_auto simp: entailst_def)
  apply (rule enttD)
  apply (intro entt_star_mono I' R')
  done

(*lemma hn_refine_cons:
  assumes I: "P\<Longrightarrow>\<^sub>AP'"
  assumes R: "hn_refine P' c Q R m"
  assumes I': "Q\<Longrightarrow>\<^sub>AQ'"
  assumes R': "\<And>x y. R x y \<Longrightarrow>\<^sub>A R' x y"
  shows "hn_refine P c Q' R' m"
  using R unfolding hn_refine_def
  apply clarsimp
  apply (rule cons_pre_rule[OF I])
  apply (erule cons_post_rule)
  apply (rule ent_star_mono ent_refl I' R' ent_ex_preI ent_ex_postI)+
  done
*)
lemma hn_refine_cons_pre:
  assumes I: "P\<Longrightarrow>\<^sub>tP'"
  assumes R: "hn_refine P' c Q R m"
  shows "hn_refine P c Q R m"
  by (rule hn_refine_cons[OF I R]) sep_auto+

lemma hn_refine_cons_post:
  assumes R: "hn_refine P c Q R m"
  assumes I: "Q\<Longrightarrow>\<^sub>tQ'"
  shows "hn_refine P c Q' R m"
  using assms
  by (rule hn_refine_cons[OF entt_refl _ _ entt_refl])

lemma hn_refine_cons_res:
  "\<lbrakk> hn_refine \<Gamma> f \<Gamma>' R g; \<And>a c. R a c \<Longrightarrow>\<^sub>t R' a c \<rbrakk> \<Longrightarrow> hn_refine \<Gamma> f \<Gamma>' R' g"
  by (erule hn_refine_cons[OF entt_refl]) sep_auto+

lemma hn_refine_ref:
  assumes LE: "m\<le>m'"
  assumes R: "hn_refine P c Q R m"
  shows "hn_refine P c Q R m'"
  apply rule
  apply (rule cons_post_rule)
  apply (rule hn_refineD[OF R])
  using LE apply (simp add: pw_le_iff)
  apply (sep_auto intro: order_trans[OF _ LE])
  done

lemma hn_refine_cons_complete:
  assumes I: "P\<Longrightarrow>\<^sub>tP'"
  assumes R: "hn_refine P' c Q R m"
  assumes I': "Q\<Longrightarrow>\<^sub>tQ'"
  assumes R': "\<And>x y. R x y \<Longrightarrow>\<^sub>t R' x y"
  assumes LE: "m\<le>m'"
  shows "hn_refine P c Q' R' m'"
  apply (rule hn_refine_ref[OF LE])
  apply (rule hn_refine_cons[OF I R I' R'])
  done

lemma hn_refine_augment_res:
  assumes A: "hn_refine \<Gamma> f \<Gamma>' R g"
  assumes B: "g \<le>\<^sub>n SPEC \<Phi>"
  shows "hn_refine \<Gamma> f \<Gamma>' (\<lambda>a c. R a c * \<up>(\<Phi> a)) g"
  apply (rule hn_refineI)
  apply (rule cons_post_rule)
  apply (erule A[THEN hn_refineD])
  using B
  apply (sep_auto simp: pw_le_iff pw_leof_iff)
  done

subsection \<open>Product Types\<close>
text \<open>Some notion for product types is already defined here, as it is used
  for currying and uncurrying, which is fundamental for the sepref tool\<close>
definition prod_assn :: "('a1\<Rightarrow>'c1\<Rightarrow>assn) \<Rightarrow> ('a2\<Rightarrow>'c2\<Rightarrow>assn)
  \<Rightarrow> 'a1*'a2 \<Rightarrow> 'c1*'c2 \<Rightarrow> assn" where
  "prod_assn P1 P2 a c \<equiv> case (a,c) of ((a1,a2),(c1,c2)) \<Rightarrow>
  P1 a1 c1 * P2 a2 c2"

notation prod_assn (infixr "\<times>\<^sub>a" 70)

lemma prod_assn_pure_conv[simp]: "prod_assn (pure R1) (pure R2) = pure (R1 \<times>\<^sub>r R2)"
  by (auto simp: pure_def prod_assn_def intro!: ext)

lemma prod_assn_pair_conv[simp]:
  "prod_assn A B (a1,b1) (a2,b2) = A a1 a2 * B b1 b2"
  unfolding prod_assn_def by auto

lemma prod_assn_true[simp]: "prod_assn (\<lambda>_ _. true) (\<lambda>_ _. true) = (\<lambda>_ _. true)"
  by (auto intro!: ext simp: hn_ctxt_def prod_assn_def)

subsection "Convenience Lemmas"

lemma hn_refine_guessI:
  assumes "hn_refine P f P' R f'"
  assumes "f=f_conc"
  shows "hn_refine P f_conc P' R f'"
  \<comment> \<open>To prove a refinement, first synthesize one, and then prove equality\<close>
  using assms by simp

lemma imp_correctI:
  assumes R: "hn_refine \<Gamma> c \<Gamma>' R a"
  assumes C: "a \<le> SPEC \<Phi>"
  shows "<\<Gamma>> c <\<lambda>r'. \<exists>\<^sub>Ar. \<Gamma>' * R r r' * \<up>(\<Phi> r)>\<^sub>t"
  apply (rule cons_post_rule)
  apply (rule hn_refineD[OF R])
  apply (rule le_RES_nofailI[OF C])
  apply (sep_auto dest: order_trans[OF _ C])
  done

lemma hnr_pre_ex_conv:
  shows "hn_refine (\<exists>\<^sub>Ax. \<Gamma> x) c \<Gamma>' R a \<longleftrightarrow> (\<forall>x. hn_refine (\<Gamma> x) c \<Gamma>' R a)"
  unfolding hn_refine_def
  apply safe
  apply (erule cons_pre_rule[rotated])
  apply (rule ent_ex_postI)
  apply (rule ent_refl)
  apply sep_auto
  done

lemma hnr_pre_pure_conv:
  shows "hn_refine (\<Gamma> * \<up>P) c \<Gamma>' R a \<longleftrightarrow> (P \<longrightarrow> hn_refine \<Gamma> c \<Gamma>' R a)"
  unfolding hn_refine_def
  by auto

lemma hn_refine_split_post:
  assumes "hn_refine \<Gamma> c \<Gamma>' R a"
  shows "hn_refine \<Gamma> c (\<Gamma>' \<or>\<^sub>A \<Gamma>'') R a"
  apply (rule hn_refine_cons_post[OF assms])
  by (rule entt_disjI1_direct)

lemma hn_refine_post_other:
  assumes "hn_refine \<Gamma> c \<Gamma>'' R a"
  shows "hn_refine \<Gamma> c (\<Gamma>' \<or>\<^sub>A \<Gamma>'') R a"
  apply (rule hn_refine_cons_post[OF assms])
  by (rule entt_disjI2_direct)

subsubsection \<open>Return\<close>

lemma hnr_RETURN_pass:
  "hn_refine (hn_ctxt R x p) (return p) (hn_invalid R x p) R (RETURN x)"
  \<comment> \<open>Pass on a value from the heap as return value\<close>
  apply rule
  apply (sep_auto simp: hn_ctxt_def eintros: invalidate_clone')
  done

lemma hnr_RETURN_pure:
  assumes "(c,a)\<in>R"
  shows "hn_refine emp (return c) emp (pure R) (RETURN a)"
  \<comment> \<open>Return pure value\<close>
  unfolding hn_refine_def using assms
  by (sep_auto simp: pure_def)

subsubsection \<open>Assertion\<close>
lemma hnr_FAIL[simp, intro!]: "hn_refine \<Gamma> c \<Gamma>' R FAIL"
  unfolding hn_refine_def
  by simp

lemma hnr_ASSERT:
  assumes "\<Phi> \<Longrightarrow> hn_refine \<Gamma> c \<Gamma>' R c'"
  shows "hn_refine \<Gamma> c \<Gamma>' R (do { ASSERT \<Phi>; c'})"
  using assms
  apply (cases \<Phi>)
  by auto

subsubsection \<open>Bind\<close>
lemma bind_det_aux: "\<lbrakk> RETURN x \<le> m; RETURN y \<le> f x \<rbrakk> \<Longrightarrow> RETURN y \<le> m \<bind> f"
  apply (rule order_trans[rotated])
  apply (rule Refine_Basic.bind_mono)
  apply assumption
  apply (rule order_refl)
  apply simp
  done

lemma hnr_bind:
  assumes D1: "hn_refine \<Gamma> m' \<Gamma>1 Rh m"
  assumes D2:
    "\<And>x x'. RETURN x \<le> m \<Longrightarrow> hn_refine (\<Gamma>1 * hn_ctxt Rh x x') (f' x') (\<Gamma>2 x x') R (f x)"
  assumes IMP: "\<And>x x'. \<Gamma>2 x x' \<Longrightarrow>\<^sub>t \<Gamma>' * hn_ctxt Rx x x'"
  shows "hn_refine \<Gamma> (m'\<bind>f') \<Gamma>' R (m\<bind>f)"
  using assms
  unfolding hn_refine_def
  apply (clarsimp simp add: pw_bind_nofail)
  apply (rule Hoare_Triple.bind_rule)
  apply assumption
  apply (clarsimp intro!: normalize_rules simp: hn_ctxt_def)
proof -
  fix x' x
  assume 1: "RETURN x \<le> m"
    and "nofail m" "\<forall>x. inres m x \<longrightarrow> nofail (f x)"
  hence "nofail (f x)" by (auto simp: pw_le_iff)
  moreover assume "\<And>x x'. RETURN x \<le> m \<Longrightarrow>
           nofail (f x) \<longrightarrow> <\<Gamma>1 * Rh x x'> f' x'
           <\<lambda>r'. \<exists>\<^sub>Ar. \<Gamma>2 x x' * R r r' * true * \<up> (RETURN r \<le> f x)>"
  ultimately have "\<And>x'. <\<Gamma>1 * Rh x x'> f' x'
           <\<lambda>r'. \<exists>\<^sub>Ar. \<Gamma>2 x x' * R r r' * true * \<up> (RETURN r \<le> f x)>"
    using 1 by simp
  also have "\<And>r'. \<exists>\<^sub>Ar. \<Gamma>2 x x' * R r r' * true * \<up> (RETURN r \<le> f x) \<Longrightarrow>\<^sub>A
    \<exists>\<^sub>Ar. \<Gamma>' * R r r' * true * \<up> (RETURN r \<le> f x)"
    apply (sep_auto)
    apply (rule ent_frame_fwd[OF IMP[THEN enttD]])
    apply frame_inference
    apply (solve_entails)
    done
  finally (cons_post_rule) have
    R: "<\<Gamma>1 * Rh x x'> f' x'
        <\<lambda>r'. \<exists>\<^sub>Ar. \<Gamma>' * R r r' * true * \<up>(RETURN r \<le> f x)>"
    .
  show "<\<Gamma>1 * Rh x x' * true> f' x'
          <\<lambda>r'. \<exists>\<^sub>Ar. \<Gamma>' * R r r' * true * \<up> (RETURN r \<le> m \<bind> f)>"
    by (sep_auto heap: R intro: bind_det_aux[OF 1])
qed

subsubsection \<open>Recursion\<close>

definition "hn_rel P m \<equiv> \<lambda>r. \<exists>\<^sub>Ax. P x r * \<up>(RETURN x \<le> m)"

lemma hn_refine_alt: "hn_refine Fpre c Fpost P m \<equiv> nofail m \<longrightarrow>
  <Fpre> c <\<lambda>r. hn_rel P m r * Fpost>\<^sub>t"
  apply (rule eq_reflection)
  unfolding hn_refine_def hn_rel_def
  apply (simp add: hn_ctxt_def)
  apply (simp only: star_aci)
  done

lemma wit_swap_forall:
  assumes W: "<P> c <\<lambda>_. true>"
  assumes T: "(\<forall>x. A x \<longrightarrow> <P> c <Q x>)"
  shows "<P> c <\<lambda>r. \<not>\<^sub>A (\<exists>\<^sub>Ax. \<up>(A x) * \<not>\<^sub>A Q x r)>"
  unfolding hoare_triple_def Let_def
  apply (intro conjI impI allI)
  subgoal by (elim conjE) (rule hoare_tripleD[OF W], assumption+) []

  subgoal
    apply (clarsimp, intro conjI allI)
    apply1 (rule models_in_range)
    applyS (rule hoare_tripleD[OF W]; assumption; fail)
    apply1 (simp only: disj_not2, intro impI)
    apply1 (drule spec[OF T, THEN mp])
    apply1 (drule (2) hoare_tripleD(2))
    by assumption

  subgoal by (elim conjE) (rule hoare_tripleD[OF W], assumption+)

  subgoal by (elim conjE) (rule hoare_tripleD[OF W], assumption+)
  done

lemma hn_admissible:
  assumes PREC: "precise Ry"
  assumes E: "\<forall>f\<in>A. nofail (f x) \<longrightarrow> <P> c <\<lambda>r. hn_rel Ry (f x) r * F>"
  assumes NF: "nofail (INF f\<in>A. f x)"
  shows "<P> c <\<lambda>r. hn_rel Ry (INF f\<in>A. f x) r * F>"
proof -
  from NF obtain f where "f\<in>A" and "nofail (f x)"
    by (simp only: refine_pw_simps) blast

  with E have "<P> c <\<lambda>r. hn_rel Ry (f x) r * F>" by blast
  hence W: "<P> c <\<lambda>_. true>" by (rule cons_post_rule, simp)

  from E have
    E': "\<forall>f. f\<in>A \<and> nofail (f x) \<longrightarrow> <P> c <\<lambda>r. hn_rel Ry (f x) r * F>"
    by blast
  from wit_swap_forall[OF W E'] have
    E'': "<P> c
     <\<lambda>r. \<not>\<^sub>A (\<exists>\<^sub>Axa. \<up> (xa \<in> A \<and> nofail (xa x)) *
                \<not>\<^sub>A (hn_rel Ry (xa x) r * F))>" .

  thus ?thesis
    apply (rule cons_post_rule)
    unfolding entails_def hn_rel_def
    apply clarsimp
  proof -
    fix h as p
    assume A: "\<forall>f. f\<in>A \<longrightarrow> (\<exists>a.
      ((h, as) \<Turnstile> Ry a p * F \<and> RETURN a \<le> f x)) \<or> \<not> nofail (f x)"
    with \<open>f\<in>A\<close> and \<open>nofail (f x)\<close> obtain a where
      1: "(h, as) \<Turnstile> Ry a p * F" and "RETURN a \<le> f x"
      by blast
    have
      "\<forall>f\<in>A. nofail (f x) \<longrightarrow> (h, as) \<Turnstile> Ry a p * F \<and> RETURN a \<le> f x"
    proof clarsimp
      fix f'
      assume "f'\<in>A" and "nofail (f' x)"
      with A obtain a' where
        2: "(h, as) \<Turnstile> Ry a' p * F" and "RETURN a' \<le> f' x"
        by blast

      moreover note preciseD'[OF PREC 1 2]
      ultimately show "(h, as) \<Turnstile> Ry a p * F \<and> RETURN a \<le> f' x" by simp
    qed
    hence "RETURN a \<le> (INF f\<in>A. f x)"
      by (metis (mono_tags) le_INF_iff le_nofailI)
    with 1 show "\<exists>a. (h, as) \<Turnstile> Ry a p * F \<and> RETURN a \<le> (INF f\<in>A. f x)"
      by blast
  qed
qed

lemma hnr_RECT_old:
  assumes S: "\<And>cf af ax px. \<lbrakk>
    \<And>ax px. hn_refine (hn_ctxt Rx ax px * F) (cf px) (F' ax px) Ry (af ax)\<rbrakk>
    \<Longrightarrow> hn_refine (hn_ctxt Rx ax px * F) (cB cf px) (F' ax px) Ry (aB af ax)"
  assumes M: "(\<And>x. mono_Heap (\<lambda>f. cB f x))"
  assumes PREC: "precise Ry"
  shows "hn_refine
    (hn_ctxt Rx ax px * F) (heap.fixp_fun cB px) (F' ax px) Ry (RECT aB ax)"
  unfolding RECT_gfp_def
proof (simp, intro conjI impI)
  assume "trimono aB"
  hence "mono aB" by (simp add: trimonoD)
  have "\<forall>ax px.
    hn_refine (hn_ctxt Rx ax px * F) (heap.fixp_fun cB px) (F' ax px) Ry
      (gfp aB ax)"
    apply (rule gfp_cadm_induct[OF _ _ \<open>mono aB\<close>])

    apply rule
    apply (auto simp: hn_refine_alt intro: hn_admissible'[OF PREC]) []

    apply (auto simp: hn_refine_alt) []

    apply clarsimp
    apply (subst heap.mono_body_fixp[of cB, OF M])
    apply (rule S)
    apply blast
    done
  thus "hn_refine (hn_ctxt Rx ax px * F)
     (ccpo.fixp (fun_lub Heap_lub) (fun_ord Heap_ord) cB px) (F' ax px) Ry
     (gfp aB ax)" by simp
qed

lemma hnr_RECT:
  assumes S: "\<And>cf af ax px. \<lbrakk>
    \<And>ax px. hn_refine (hn_ctxt Rx ax px * F) (cf px) (F' ax px) Ry (af ax)\<rbrakk>
    \<Longrightarrow> hn_refine (hn_ctxt Rx ax px * F) (cB cf px) (F' ax px) Ry (aB af ax)"
  assumes M: "(\<And>x. mono_Heap (\<lambda>f. cB f x))"
  shows "hn_refine
    (hn_ctxt Rx ax px * F) (heap.fixp_fun cB px) (F' ax px) Ry (RECT aB ax)"
  unfolding RECT_def
proof (simp, intro conjI impI)
  assume "trimono aB"
  hence "flatf_mono_ge aB" by (simp add: trimonoD)
  have "\<forall>ax px.
    hn_refine (hn_ctxt Rx ax px * F) (heap.fixp_fun cB px) (F' ax px) Ry
      (flatf_gfp aB ax)"

    apply (rule flatf_ord.fixp_induct[OF _ \<open>flatf_mono_ge aB\<close>])

    apply (rule flatf_admissible_pointwise)
    apply simp

    apply (auto simp: hn_refine_alt) []

    apply clarsimp
    apply (subst heap.mono_body_fixp[of cB, OF M])
    apply (rule S)
    apply blast
    done
  thus "hn_refine (hn_ctxt Rx ax px * F)
     (ccpo.fixp (fun_lub Heap_lub) (fun_ord Heap_ord) cB px) (F' ax px) Ry
     (flatf_gfp aB ax)" by simp
qed

lemma hnr_If:
  assumes P: "\<Gamma> \<Longrightarrow>\<^sub>t \<Gamma>1 * hn_val bool_rel a a'"
  assumes RT: "a \<Longrightarrow> hn_refine (\<Gamma>1 * hn_val bool_rel a a') b' \<Gamma>2b R b"
  assumes RE: "\<not>a \<Longrightarrow> hn_refine (\<Gamma>1 * hn_val bool_rel a a') c' \<Gamma>2c R c"
  assumes IMP: "\<Gamma>2b \<or>\<^sub>A \<Gamma>2c \<Longrightarrow>\<^sub>t \<Gamma>'"
  shows "hn_refine \<Gamma> (if a' then b' else c') \<Gamma>' R (if a then b else c)"
  apply (rule hn_refine_cons[OF P])
  apply1 (rule hn_refine_preI)
  applyF (cases a; simp add: hn_ctxt_def pure_def)
    focus
      apply1 (rule hn_refine_split_post)
      applyF (rule hn_refine_cons_pre[OF _ RT])
        applyS (simp add: hn_ctxt_def pure_def)
        applyS simp
      solved
    solved
    apply1 (rule hn_refine_post_other)
    applyF (rule hn_refine_cons_pre[OF _ RE])
      applyS (simp add: hn_ctxt_def pure_def)
      applyS simp
    solved
  solved
  applyS (rule IMP)
  applyS (rule entt_refl)
  done

subsection \<open>ML-Level Utilities\<close>
ML \<open>
  signature SEPREF_BASIC = sig
    (* Destroy lambda term, return function to reconstruct. Bound var is replaced by free. *)
    val dest_lambda_rc: Proof.context -> term -> ((term * (term -> term)) * Proof.context)
    (* Apply function under lambda. Bound var is replaced by free. *)
    val apply_under_lambda: (Proof.context -> term -> term) -> Proof.context -> term -> term

    (* 'a nres type *)
    val is_nresT: typ -> bool
    val mk_nresT: typ -> typ
    val dest_nresT: typ -> typ

    (* Make certified == *)
    val mk_cequals: cterm * cterm -> cterm
    (* Make \<Longrightarrow>\<^sub>A *)
    val mk_entails: term * term -> term

    (* Operations on pre-terms *)
    val constrain_type_pre: typ -> term -> term (* t::T *)

    val mk_pair_in_pre: term -> term -> term -> term (* (c,a) \<in> R *)

    val mk_compN_pre: int -> term -> term -> term  (* f o...o g*)

    val mk_curry0_pre: term -> term                (* curry0 f *)
    val mk_curry_pre: term -> term                 (* curry f *)
    val mk_curryN_pre: int -> term -> term         (* curry (...(curry f)...) *)

    val mk_uncurry0_pre: term -> term              (* uncurry0 f *)
    val mk_uncurry_pre: term -> term               (* uncurry f *)
    val mk_uncurryN_pre: int -> term -> term       (* uncurry (...(uncurry f)...) *)

    (* Conversion for hn_refine - term*)
    val hn_refine_conv: conv -> conv -> conv -> conv -> conv -> conv

    (* Conversion on abstract value (last argument) of hn_refine - term *)
    val hn_refine_conv_a: conv -> conv

    (* Conversion on abstract value of hn_refine term in conclusion of theorem *)
    val hn_refine_concl_conv_a: (Proof.context -> conv) -> Proof.context -> conv

    (* Destruct hn_refine term *)
    val dest_hn_refine: term -> term * term * term * term * term
    (* Make hn_refine term *)
    val mk_hn_refine: term * term * term * term * term -> term
    (* Check if given term is Trueprop (hn_refine ...). Use with CONCL_COND'. *)
    val is_hn_refine_concl: term -> bool

    (* Destruct abs-fun, returns RETURN-flag, (f, args) *)
    val dest_hnr_absfun: term -> bool * (term * term list)
    (* Make abs-fun. *)
    val mk_hnr_absfun: bool * (term * term list) -> term
    (* Make abs-fun. Guess RETURN-flag from type. *)
    val mk_hnr_absfun': (term * term list) -> term

    (* Prove permutation of *. To be used with f_tac_conv. *)
    val star_permute_tac: Proof.context -> tactic

    (* Make separation conjunction *)
    val mk_star: term * term -> term
    (* Make separation conjunction from list. "[]" yields "emp". *)
    val list_star: term list -> term
    (* Decompose separation conjunction. "emp" yields "[]". *)
    val strip_star: term -> term list

    (* Check if true-assertion *)
    val is_true: term -> bool

    (* Check if term is hn_ctxt-assertion *)
    val is_hn_ctxt: term -> bool
    (* Decompose hn_ctxt-assertion *)
    val dest_hn_ctxt: term -> term * term * term
    (* Decompose hn_ctxt-assertion, NONE if term has wrong format *)
    val dest_hn_ctxt_opt: term -> (term * term * term) option

    type phases_ctrl = {
      trace: bool,            (* Trace phases *)
      int_res: bool,          (* Stop with intermediate result *)
      start: string option,   (* Start with this phase. NONE: First phase *)
      stop: string option     (* Stop after this phase. NONE: Last phase *)
    }

    (* No tracing or intermediate result, all phases *)
    val dflt_phases_ctrl: phases_ctrl
    (* Tracing, intermediate result, all phases *)
    val dbg_phases_ctrl: phases_ctrl
    val flag_phases_ctrl: bool -> phases_ctrl

    (* Name, tactic, expected number of created goals (may be negative for solved goals) *)
    type phase = string * (Proof.context -> tactic') * int

    (* Perform sequence of tactics (tac,n), each expected to create n new goals,
       or solve goals if n is negative.
       Debug-flag: Stop with intermediate state after tactic
       fails or produces less/more goals as expected. *)
    val PHASES': phase list -> phases_ctrl -> Proof.context -> tactic'

  end

  structure Sepref_Basic: SEPREF_BASIC = struct

    fun is_nresT (Type (@{type_name nres},[_])) = true | is_nresT _ = false
    fun mk_nresT T = Type(@{type_name nres},[T])
    fun dest_nresT (Type (@{type_name nres},[T])) = T | dest_nresT T = raise TYPE("dest_nresT",[T],[])

    fun dest_lambda_rc ctxt (Abs (x,T,t)) = let
        val (u,ctxt) = yield_singleton Variable.variant_fixes x ctxt
        val u = Free (u,T)
        val t = subst_bound (u,t)
        val reconstruct = Term.lambda_name (x,u)
      in
        ((t,reconstruct),ctxt)
      end
    | dest_lambda_rc _ t = raise TERM("dest_lambda_rc",[t])

    fun apply_under_lambda f ctxt t = let
      val ((t,rc),ctxt) = dest_lambda_rc ctxt t
      val t = f ctxt t
    in
      rc t
    end

    (* Functions on pre-terms *)
    fun mk_pair_in_pre x y r = Const (@{const_name Set.member}, dummyT) $
      (Const (@{const_name Product_Type.Pair}, dummyT) $ x $ y) $ r

    fun mk_uncurry_pre t = Const(@{const_name uncurry}, dummyT)$t
    fun mk_uncurry0_pre t = Const(@{const_name uncurry0}, dummyT)$t
    fun mk_uncurryN_pre 0 = mk_uncurry0_pre
      | mk_uncurryN_pre 1 = I
      | mk_uncurryN_pre n = mk_uncurry_pre o mk_uncurryN_pre (n-1)

    fun mk_curry_pre t = Const(@{const_name curry}, dummyT)$t
    fun mk_curry0_pre t = Const(@{const_name curry0}, dummyT)$t
    fun mk_curryN_pre 0 = mk_curry0_pre
      | mk_curryN_pre 1 = I
      | mk_curryN_pre n = mk_curry_pre o mk_curryN_pre (n-1)

    fun mk_compN_pre 0 f g = f $ g
      | mk_compN_pre n f g = let
          val g = fold (fn i => fn t => t$Bound i) (n-2 downto 0) g
          val t = Const(@{const_name "Fun.comp"},dummyT) $ f $ g

          val t = fold (fn i => fn t => Abs ("x"^string_of_int i,dummyT,t)) (n-1 downto 1) t
        in
          t
        end

    fun constrain_type_pre T t = Const(@{syntax_const "_type_constraint_"},T-->T) $ t

    local open Conv in
      fun hn_refine_conv c1 c2 c3 c4 c5 ct = case Thm.term_of ct of
        @{mpat "hn_refine _ _ _ _ _"} => let
          val cc = combination_conv
        in
          cc (cc (cc (cc (cc all_conv c1) c2) c3) c4) c5 ct
        end
      | _ => raise CTERM ("hn_refine_conv",[ct])

      val hn_refine_conv_a = hn_refine_conv all_conv all_conv all_conv all_conv

      fun hn_refine_concl_conv_a conv ctxt = Refine_Util.HOL_concl_conv
        (fn ctxt => hn_refine_conv_a (conv ctxt)) ctxt

    end

    (* FIXME: Strange dependency! *)
    val mk_cequals = uncurry SMT_Util.mk_cequals

    val mk_entails = HOLogic.mk_binrel @{const_name "entails"}

    val mk_star = HOLogic.mk_binop @{const_name "Groups.times_class.times"}

    fun list_star [] = @{term "emp::assn"}
      | list_star [a] = a
      | list_star (a::l) = mk_star (list_star l,a)

    fun strip_star @{mpat "?a*?b"} = strip_star a @ strip_star b
      | strip_star @{mpat "emp"} = []
      | strip_star t = [t]

    fun is_true @{mpat "true"} = true | is_true _ = false

    fun is_hn_ctxt @{mpat "hn_ctxt _ _ _"} = true | is_hn_ctxt _ = false
    fun dest_hn_ctxt @{mpat "hn_ctxt ?R ?a ?p"} = (R,a,p)
      | dest_hn_ctxt t = raise TERM("dest_hn_ctxt",[t])

    fun dest_hn_ctxt_opt @{mpat "hn_ctxt ?R ?a ?p"} = SOME (R,a,p)
      | dest_hn_ctxt_opt _ = NONE

    fun strip_abs_args (t as @{mpat "PR_CONST _"}) = (t,[])
      | strip_abs_args @{mpat "?f$?a"} = (case strip_abs_args f of (f,args) => (f,args@[a]))
      | strip_abs_args t = (t,[])

    fun dest_hnr_absfun @{mpat "RETURN$?a"} = (true, strip_abs_args a)
      | dest_hnr_absfun f = (false, strip_abs_args f)

    fun mk_hnr_absfun (true,fa) = Autoref_Tagging.list_APP fa |> (fn a => @{mk_term "RETURN$?a"})
      | mk_hnr_absfun (false,fa) = Autoref_Tagging.list_APP fa

    fun mk_hnr_absfun' fa = let
      val t = Autoref_Tagging.list_APP fa
      val T = fastype_of t
    in
      case T of
        Type (@{type_name nres},_) => t
      | _ => @{mk_term "RETURN$?t"}

    end

    fun dest_hn_refine @{mpat "hn_refine ?P ?c ?Q ?R ?a"} = (P,c,Q,R,a)
      | dest_hn_refine t = raise TERM("dest_hn_refine",[t])

    fun mk_hn_refine (P,c,Q,R,a) = @{mk_term "hn_refine ?P ?c ?Q ?R ?a"}

    val is_hn_refine_concl = can (HOLogic.dest_Trueprop #> dest_hn_refine)

    fun star_permute_tac ctxt = ALLGOALS (simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms star_aci}))

    type phases_ctrl = {
      trace: bool,
      int_res: bool,
      start: string option,
      stop: string option
    }

    val dflt_phases_ctrl = {trace=false,int_res=false,start=NONE,stop=NONE}
    val dbg_phases_ctrl = {trace=true,int_res=true,start=NONE,stop=NONE}
    fun flag_phases_ctrl dbg = if dbg then dbg_phases_ctrl else dflt_phases_ctrl

    type phase = string * (Proof.context -> tactic') * int

    local
      fun ph_range phases start stop = let
        fun find_phase name = let
          val i = find_index (fn (n,_,_) => n=name) phases
          val _ = if i<0 then error ("No such phase: " ^ name) else ()
        in
          i
        end

        val i = case start of NONE => 0 | SOME n => find_phase n
        val j = case stop of NONE => length phases - 1 | SOME n => find_phase n

        val phases = take (j+1) phases |> drop i

        val _ = case phases of [] => error "No phases selected, range is empty" | _ => ()
      in
        phases
      end
    in

      fun PHASES' phases ctrl ctxt = let
        val phases = ph_range phases (#start ctrl) (#stop ctrl)
        val phases = map (fn (n,tac,d) => (n,tac ctxt,d)) phases

        fun r [] _ st = Seq.single st
          | r ((name,tac,d)::tacs) i st = let
              val n = Thm.nprems_of st
              val bailout_tac = if #int_res ctrl then all_tac else no_tac
              fun trace_tac msg st = (if #trace ctrl then tracing msg else (); Seq.single st)
              val trace_start_tac = trace_tac ("Phase " ^ name)
            in
              K trace_start_tac THEN' IF_EXGOAL (tac)
              THEN_ELSE' (
                fn i => fn st =>
                  (* Bail out if a phase does not solve/create exactly the expected subgoals *)
                  if Thm.nprems_of st = n+d then
                    ((trace_tac "  Done" THEN r tacs i) st)
                  else
                    (trace_tac "*** Wrong number of produced goals" THEN bailout_tac) st
              ,
                K (trace_tac "*** Phase tactic failed" THEN bailout_tac))
            end i st

      in
        r phases
      end

    end

(*    (* Perform sequence of tactics (tac,n), each expected to create n new goals,
       or solve goals if n is negative.
       Debug-flag: Stop with intermediate state after tactic
       fails or produces less/more goals as expected. *)
    val PHASES': phase list -> phases_ctrl -> Proof.context -> tactic'
*)

(*

    fun xPHASES' dbg tacs ctxt = let
      val tacs = map (fn (tac,d) => (tac ctxt,d)) tacs

      fun r [] _ st = Seq.single st
        | r ((tac,d)::tacs) i st = let
            val n = Thm.nprems_of st
            val bailout_tac = if dbg then all_tac else no_tac
          in
            IF_EXGOAL (tac)
            THEN_ELSE' (
              fn i => fn st =>
                (* Bail out if a phase does not solve/create exactly the expected subgoals *)
                if Thm.nprems_of st = n+d then
                  (r tacs i st)
                else
                  bailout_tac st
            ,
              K bailout_tac)
          end i st

    in
      r tacs
    end
*)
  end

  signature SEPREF_DEBUGGING = sig
    (*************************)
    (* Debugging *)
    (* Centralized debugging mode flag *)
    val cfg_debug_all: bool Config.T

    val is_debug: bool Config.T -> Proof.context -> bool
    val is_debug': Proof.context -> bool

    (* Conversion, trace errors if custom or central debugging flag is activated *)
    val DBG_CONVERSION: bool Config.T -> Proof.context -> conv -> tactic'

    (* Conversion, trace errors if central debugging flag is activated *)
    val DBG_CONVERSION': Proof.context -> conv -> tactic'

    (* Tracing message and current subgoal *)
    val tracing_tac': string -> Proof.context -> tactic'
    (* Warning message and current subgoal *)
    val warning_tac': string -> Proof.context -> tactic'
    (* Error message and current subgoal *)
    val error_tac': string -> Proof.context -> tactic'

    (* Trace debug message *)
    val dbg_trace_msg: bool Config.T -> Proof.context -> string -> unit
    val dbg_trace_msg': Proof.context -> string -> unit

    val dbg_msg_tac: bool Config.T -> (Proof.context -> int -> thm -> string) -> Proof.context -> tactic'
    val dbg_msg_tac': (Proof.context -> int -> thm -> string) -> Proof.context -> tactic'

    val msg_text: string -> Proof.context -> int -> thm -> string
    val msg_subgoal: string -> Proof.context -> int -> thm -> string
    val msg_from_subgoal: string -> (term -> Proof.context -> string) -> Proof.context -> int -> thm -> string
    val msg_allgoals: string -> Proof.context -> int -> thm -> string

  end

  structure Sepref_Debugging: SEPREF_DEBUGGING = struct

    val cfg_debug_all =
      Attrib.setup_config_bool @{binding sepref_debug_all} (K false)

    fun is_debug cfg ctxt = Config.get ctxt cfg orelse Config.get ctxt cfg_debug_all
    fun is_debug' ctxt = Config.get ctxt cfg_debug_all

    fun dbg_trace cfg ctxt obj =
      if is_debug cfg ctxt then
        tracing (@{make_string} obj)
      else ()

    fun dbg_trace' ctxt obj =
      if is_debug' ctxt then
        tracing (@{make_string} obj)
      else ()

    fun dbg_trace_msg cfg ctxt msg =
      if is_debug cfg ctxt then
        tracing msg
      else ()
    fun dbg_trace_msg' ctxt msg =
      if is_debug' ctxt then
        tracing msg
      else ()

    fun DBG_CONVERSION cfg ctxt cv i st =
      Seq.single (Conv.gconv_rule cv i st)
      handle e as THM _ => (dbg_trace cfg ctxt e; Seq.empty)
           | e as CTERM _ => (dbg_trace cfg ctxt e; Seq.empty)
           | e as TERM _ => (dbg_trace cfg ctxt e; Seq.empty)
           | e as TYPE _ => (dbg_trace cfg ctxt e; Seq.empty);

    fun DBG_CONVERSION' ctxt cv i st =
      Seq.single (Conv.gconv_rule cv i st)
      handle e as THM _ => (dbg_trace' ctxt e; Seq.empty)
           | e as CTERM _ => (dbg_trace' ctxt e; Seq.empty)
           | e as TERM _ => (dbg_trace' ctxt e; Seq.empty)
           | e as TYPE _ => (dbg_trace' ctxt e; Seq.empty);

    local
      fun gen_subgoal_msg_tac do_msg msg ctxt = IF_EXGOAL (fn i => fn st => let
        val t = nth (Thm.prems_of st) (i-1)
        val _ = Pretty.block [Pretty.str msg, Pretty.fbrk, Syntax.pretty_term ctxt t]
          |> Pretty.string_of |> do_msg

      in
        Seq.single st
      end)
    in
      val tracing_tac' = gen_subgoal_msg_tac tracing
      val warning_tac' = gen_subgoal_msg_tac warning
      val error_tac' = gen_subgoal_msg_tac error
    end

    fun dbg_msg_tac cfg msg ctxt =
      if is_debug cfg ctxt then (fn i => fn st => (tracing (msg ctxt i st); Seq.single st))
      else K all_tac
    fun dbg_msg_tac' msg ctxt =
      if is_debug' ctxt then (fn i => fn st => (tracing (msg ctxt i st); Seq.single st))
      else K all_tac

    fun msg_text msg _ _ _ = msg

    fun msg_from_subgoal msg sgmsg ctxt i st =
      case try (nth (Thm.prems_of st)) (i-1) of
        NONE => msg ^ "\n" ^ "Subgoal out of range"
      | SOME t => msg ^ "\n" ^ sgmsg t ctxt

    fun msg_subgoal msg = msg_from_subgoal msg (fn t => fn ctxt =>
      Syntax.pretty_term ctxt t |> Pretty.string_of
    )

    fun msg_allgoals msg ctxt _ st =
      msg ^ "\n" ^ Pretty.string_of (Pretty.chunks (Goal_Display.pretty_goals ctxt st))

  end
\<close>

ML \<open>
  (* Tactics for produced subgoals *)
  infix 1 THEN_NEXT THEN_ALL_NEW_LIST THEN_ALL_NEW_LIST'
  signature STACTICAL = sig
    (* Apply first tactic on this subgoal, and then second tactic on next subgoal *)
    val THEN_NEXT: tactic' * tactic' -> tactic'
    (* Apply tactics to the current and following subgoals *)
    val APPLY_LIST: tactic' list -> tactic'
    (* Apply list of tactics on subgoals emerging from tactic.
      Requires exactly one tactic per emerging subgoal.*)
    val THEN_ALL_NEW_LIST: tactic' * tactic' list -> tactic'
    (* Apply list of tactics to subgoals emerging from tactic, use fallback for additional subgoals. *)
    val THEN_ALL_NEW_LIST': tactic' * (tactic' list * tactic') -> tactic'

  end

  structure STactical : STACTICAL = struct
    infix 1 THEN_WITH_GOALDIFF
    fun (tac1 THEN_WITH_GOALDIFF tac2) st = let
      val n1 = Thm.nprems_of st
    in
      st |> (tac1 THEN (fn st => tac2 (Thm.nprems_of st - n1) st ))
    end

    fun (tac1 THEN_NEXT tac2) i =
      tac1 i THEN_WITH_GOALDIFF (fn d => (
        if d < ~1 then
          (error "THEN_NEXT: Tactic solved more than one goal"; no_tac)
        else
          tac2 (i+1+d)
      ))

    fun APPLY_LIST [] = K all_tac
      | APPLY_LIST (tac::tacs) = tac THEN_NEXT APPLY_LIST tacs

    fun (tac1 THEN_ALL_NEW_LIST tacs) i =
      tac1 i
      THEN_WITH_GOALDIFF (fn d =>
        if d+1 <> length tacs then (
          error "THEN_ALL_NEW_LIST: Tactic produced wrong number of goals"; no_tac
        ) else APPLY_LIST tacs i
      )

    fun (tac1 THEN_ALL_NEW_LIST' (tacs,rtac)) i =
      tac1 i
      THEN_WITH_GOALDIFF (fn d => let
        val _ = if d+1 < length tacs then error "THEN_ALL_NEW_LIST': Tactic produced too few goals" else ();
        val tacs' = tacs @ replicate (d + 1 - length tacs) rtac
      in
        APPLY_LIST tacs' i
      end)

  end

  open STactical
\<close>

end


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

section \<open>Stream fusion for coinductive lists\<close>

theory Stream_Fusion_LList imports
  Stream_Fusion_List
  Coinductive.Coinductive_List
begin

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

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

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

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

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

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

text \<open>A type of generators that eventually will yield something else than a skip.\<close>

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

setup_lifting type_definition_lgenerator'

subsection \<open>Conversions to @{typ "'a llist"}\<close>

subsubsection \<open>Infinitely many consecutive @{term Skip}s\<close>

context fixes g :: "('a, 's) lgenerator"
  notes [[function_internals]]
begin

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

declare lunstream.simps[code]

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

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

end

subsubsection \<open>Finitely many consecutive @{term Skip}s\<close>

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

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

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

setup \<open>Context.theory_map (fold
  Stream_Fusion.add_unstream [@{const_name lunstream}, @{const_name lunstream'}])\<close>

subsection \<open>Producers\<close>

subsubsection \<open>Conversion to streams\<close>

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

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

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

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

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

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

subsubsection \<open>@{const iterates}\<close>

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

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

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

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

subsubsection \<open>@{const unfold_llist}\<close>

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

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

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

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

subsubsection \<open>@{const inf_llist}\<close>

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

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

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

subsection \<open>Consumers\<close>

subsubsection \<open>@{const lhd}\<close>

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

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

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

end

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

subsubsection \<open>@{const llength}\<close>

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

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

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

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

end

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

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

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

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

end

subsubsection \<open>@{const lnull}\<close>

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

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

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

end

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

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

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

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

end

subsubsection \<open>@{const llist_all2}\<close>

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

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

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

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

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

end

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

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

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

subsubsection \<open>@{const lnth}\<close>

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

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

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

end

subsubsection \<open>@{const lprefix}\<close>

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

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

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

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

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

end

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

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

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

subsection \<open>Transformers\<close>

subsubsection \<open>@{const lmap}\<close>

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

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

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

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

subsubsection \<open>@{const ltake}\<close>

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

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

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

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

subsubsection \<open>@{const ldropn}\<close>

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

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

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

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

subsubsection \<open>@{const ldrop}\<close>

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

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

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

subsubsection \<open>@{const ltakeWhile}\<close>

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

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

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

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

subsubsection \<open>@{const ldropWhile}\<close>

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

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

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

subsubsection \<open>@{const lzip}\<close>

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

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

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

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

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

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

subsubsection \<open>@{const lappend}\<close>

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

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

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

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

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

subsubsection \<open>@{const lfilter}\<close>

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

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

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

subsubsection \<open>@{const llist_of}\<close>

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

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

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

end


(*  Title:      HOL/BNF_Fixpoint_Base.thy
    Author:     Lorenz Panny, TU Muenchen
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Author:     Martin Desharnais, TU Muenchen
    Copyright   2012, 2013, 2014

Shared fixpoint operations on bounded natural functors.
*)

section \<open>Shared Fixpoint Operations on Bounded Natural Functors\<close>

theory BNF_Fixpoint_Base
imports BNF_Composition Basic_BNFs
begin

lemma conj_imp_eq_imp_imp: "(P \<and> Q \<Longrightarrow> PROP R) \<equiv> (P \<Longrightarrow> Q \<Longrightarrow> PROP R)"
  by standard simp_all

lemma predicate2D_conj: "P \<le> Q \<and> R \<Longrightarrow> R \<and> (P x y \<longrightarrow> Q x y)"
  by blast

lemma eq_sym_Unity_conv: "(x = (() = ())) = x"
  by blast

lemma case_unit_Unity: "(case u of () \<Rightarrow> f) = f"
  by (cases u) (hypsubst, rule unit.case)

lemma case_prod_Pair_iden: "(case p of (x, y) \<Rightarrow> (x, y)) = p"
  by simp

lemma unit_all_impI: "(P () \<Longrightarrow> Q ()) \<Longrightarrow> \<forall>x. P x \<longrightarrow> Q x"
  by simp

lemma pointfree_idE: "f \<circ> g = id \<Longrightarrow> f (g x) = x"
  unfolding comp_def fun_eq_iff by simp

lemma o_bij:
  assumes gf: "g \<circ> f = id" and fg: "f \<circ> g = id"
  shows "bij f"
unfolding bij_def inj_on_def surj_def proof safe
  fix a1 a2 assume "f a1 = f a2"
  hence "g ( f a1) = g (f a2)" by simp
  thus "a1 = a2" using gf unfolding fun_eq_iff by simp
next
  fix b
  have "b = f (g b)"
  using fg unfolding fun_eq_iff by simp
  thus "\<exists>a. b = f a" by blast
qed

lemma case_sum_step:
  "case_sum (case_sum f' g') g (Inl p) = case_sum f' g' p"
  "case_sum f (case_sum f' g') (Inr p) = case_sum f' g' p"
  by auto

lemma obj_one_pointE: "\<forall>x. s = x \<longrightarrow> P \<Longrightarrow> P"
  by blast

lemma type_copy_obj_one_point_absE:
  assumes "type_definition Rep Abs UNIV" "\<forall>x. s = Abs x \<longrightarrow> P" shows P
  using type_definition.Rep_inverse[OF assms(1)]
  by (intro mp[OF spec[OF assms(2), of "Rep s"]]) simp

lemma obj_sumE_f:
  assumes "\<forall>x. s = f (Inl x) \<longrightarrow> P" "\<forall>x. s = f (Inr x) \<longrightarrow> P"
  shows "\<forall>x. s = f x \<longrightarrow> P"
proof
  fix x from assms show "s = f x \<longrightarrow> P" by (cases x) auto
qed

lemma case_sum_if:
  "case_sum f g (if p then Inl x else Inr y) = (if p then f x else g y)"
  by simp

lemma prod_set_simps[simp]:
  "fsts (x, y) = {x}"
  "snds (x, y) = {y}"
  unfolding prod_set_defs by simp+

lemma sum_set_simps[simp]:
  "setl (Inl x) = {x}"
  "setl (Inr x) = {}"
  "setr (Inl x) = {}"
  "setr (Inr x) = {x}"
  unfolding sum_set_defs by simp+

lemma Inl_Inr_False: "(Inl x = Inr y) = False"
  by simp

lemma Inr_Inl_False: "(Inr x = Inl y) = False"
  by simp

lemma spec2: "\<forall>x y. P x y \<Longrightarrow> P x y"
  by blast

lemma rewriteR_comp_comp: "\<lbrakk>g \<circ> h = r\<rbrakk> \<Longrightarrow> f \<circ> g \<circ> h = f \<circ> r"
  unfolding comp_def fun_eq_iff by auto

lemma rewriteR_comp_comp2: "\<lbrakk>g \<circ> h = r1 \<circ> r2; f \<circ> r1 = l\<rbrakk> \<Longrightarrow> f \<circ> g \<circ> h = l \<circ> r2"
  unfolding comp_def fun_eq_iff by auto

lemma rewriteL_comp_comp: "\<lbrakk>f \<circ> g = l\<rbrakk> \<Longrightarrow> f \<circ> (g \<circ> h) = l \<circ> h"
  unfolding comp_def fun_eq_iff by auto

lemma rewriteL_comp_comp2: "\<lbrakk>f \<circ> g = l1 \<circ> l2; l2 \<circ> h = r\<rbrakk> \<Longrightarrow> f \<circ> (g \<circ> h) = l1 \<circ> r"
  unfolding comp_def fun_eq_iff by auto

lemma convol_o: "\<langle>f, g\<rangle> \<circ> h = \<langle>f \<circ> h, g \<circ> h\<rangle>"
  unfolding convol_def by auto

lemma map_prod_o_convol: "map_prod h1 h2 \<circ> \<langle>f, g\<rangle> = \<langle>h1 \<circ> f, h2 \<circ> g\<rangle>"
  unfolding convol_def by auto

lemma map_prod_o_convol_id: "(map_prod f id \<circ> \<langle>id, g\<rangle>) x = \<langle>id \<circ> f, g\<rangle> x"
  unfolding map_prod_o_convol id_comp comp_id ..

lemma o_case_sum: "h \<circ> case_sum f g = case_sum (h \<circ> f) (h \<circ> g)"
  unfolding comp_def by (auto split: sum.splits)

lemma case_sum_o_map_sum: "case_sum f g \<circ> map_sum h1 h2 = case_sum (f \<circ> h1) (g \<circ> h2)"
  unfolding comp_def by (auto split: sum.splits)

lemma case_sum_o_map_sum_id: "(case_sum id g \<circ> map_sum f id) x = case_sum (f \<circ> id) g x"
  unfolding case_sum_o_map_sum id_comp comp_id ..

lemma rel_fun_def_butlast:
  "rel_fun R (rel_fun S T) f g = (\<forall>x y. R x y \<longrightarrow> (rel_fun S T) (f x) (g y))"
  unfolding rel_fun_def ..

lemma subst_eq_imp: "(\<forall>a b. a = b \<longrightarrow> P a b) \<equiv> (\<forall>a. P a a)"
  by auto

lemma eq_subset: "(=) \<le> (\<lambda>a b. P a b \<or> a = b)"
  by auto

lemma eq_le_Grp_id_iff: "((=) \<le> Grp (Collect R) id) = (All R)"
  unfolding Grp_def id_apply by blast

lemma Grp_id_mono_subst: "(\<And>x y. Grp P id x y \<Longrightarrow> Grp Q id (f x) (f y)) \<equiv>
   (\<And>x. x \<in> P \<Longrightarrow> f x \<in> Q)"
  unfolding Grp_def by rule auto

lemma vimage2p_mono: "vimage2p f g R x y \<Longrightarrow> R \<le> S \<Longrightarrow> vimage2p f g S x y"
  unfolding vimage2p_def by blast

lemma vimage2p_refl: "(\<And>x. R x x) \<Longrightarrow> vimage2p f f R x x"
  unfolding vimage2p_def by auto

lemma
  assumes "type_definition Rep Abs UNIV"
  shows type_copy_Rep_o_Abs: "Rep \<circ> Abs = id" and type_copy_Abs_o_Rep: "Abs \<circ> Rep = id"
  unfolding fun_eq_iff comp_apply id_apply
    type_definition.Abs_inverse[OF assms UNIV_I] type_definition.Rep_inverse[OF assms] by simp_all

lemma type_copy_map_comp0_undo:
  assumes "type_definition Rep Abs UNIV"
          "type_definition Rep' Abs' UNIV"
          "type_definition Rep'' Abs'' UNIV"
  shows "Abs' \<circ> M \<circ> Rep'' = (Abs' \<circ> M1 \<circ> Rep) \<circ> (Abs \<circ> M2 \<circ> Rep'') \<Longrightarrow> M1 \<circ> M2 = M"
  by (rule sym) (auto simp: fun_eq_iff type_definition.Abs_inject[OF assms(2) UNIV_I UNIV_I]
    type_definition.Abs_inverse[OF assms(1) UNIV_I]
    type_definition.Abs_inverse[OF assms(3) UNIV_I] dest: spec[of _ "Abs'' x" for x])

lemma vimage2p_id: "vimage2p id id R = R"
  unfolding vimage2p_def by auto

lemma vimage2p_comp: "vimage2p (f1 \<circ> f2) (g1 \<circ> g2) = vimage2p f2 g2 \<circ> vimage2p f1 g1"
  unfolding fun_eq_iff vimage2p_def o_apply by simp

lemma vimage2p_rel_fun: "rel_fun (vimage2p f g R) R f g"
  unfolding rel_fun_def vimage2p_def by auto

lemma fun_cong_unused_0: "f = (\<lambda>x. g) \<Longrightarrow> f (\<lambda>x. 0) = g"
  by (erule arg_cong)

lemma inj_on_convol_ident: "inj_on (\<lambda>x. (x, f x)) X"
  unfolding inj_on_def by simp

lemma map_sum_if_distrib_then:
  "\<And>f g e x y. map_sum f g (if e then Inl x else y) = (if e then Inl (f x) else map_sum f g y)"
  "\<And>f g e x y. map_sum f g (if e then Inr x else y) = (if e then Inr (g x) else map_sum f g y)"
  by simp_all

lemma map_sum_if_distrib_else:
  "\<And>f g e x y. map_sum f g (if e then x else Inl y) = (if e then map_sum f g x else Inl (f y))"
  "\<And>f g e x y. map_sum f g (if e then x else Inr y) = (if e then map_sum f g x else Inr (g y))"
  by simp_all

lemma case_prod_app: "case_prod f x y = case_prod (\<lambda>l r. f l r y) x"
  by (cases x) simp

lemma case_sum_map_sum: "case_sum l r (map_sum f g x) = case_sum (l \<circ> f) (r \<circ> g) x"
  by (cases x) simp_all

lemma case_sum_transfer:
  "rel_fun (rel_fun R T) (rel_fun (rel_fun S T) (rel_fun (rel_sum R S) T)) case_sum case_sum"
  unfolding rel_fun_def by (auto split: sum.splits)

lemma case_prod_map_prod: "case_prod h (map_prod f g x) = case_prod (\<lambda>l r. h (f l) (g r)) x"
  by (cases x) simp_all

lemma case_prod_o_map_prod: "case_prod f \<circ> map_prod g1 g2 = case_prod (\<lambda>l r. f (g1 l) (g2 r))"
  unfolding comp_def by auto

lemma case_prod_transfer:
  "(rel_fun (rel_fun A (rel_fun B C)) (rel_fun (rel_prod A B) C)) case_prod case_prod"
  unfolding rel_fun_def by simp

lemma eq_ifI: "(P \<longrightarrow> t = u1) \<Longrightarrow> (\<not> P \<longrightarrow> t = u2) \<Longrightarrow> t = (if P then u1 else u2)"
  by simp

lemma comp_transfer:
  "rel_fun (rel_fun B C) (rel_fun (rel_fun A B) (rel_fun A C)) (\<circ>) (\<circ>)"
  unfolding rel_fun_def by simp

lemma If_transfer: "rel_fun (=) (rel_fun A (rel_fun A A)) If If"
  unfolding rel_fun_def by simp

lemma Abs_transfer:
  assumes type_copy1: "type_definition Rep1 Abs1 UNIV"
  assumes type_copy2: "type_definition Rep2 Abs2 UNIV"
  shows "rel_fun R (vimage2p Rep1 Rep2 R) Abs1 Abs2"
  unfolding vimage2p_def rel_fun_def
    type_definition.Abs_inverse[OF type_copy1 UNIV_I]
    type_definition.Abs_inverse[OF type_copy2 UNIV_I] by simp

lemma Inl_transfer:
  "rel_fun S (rel_sum S T) Inl Inl"
  by auto

lemma Inr_transfer:
  "rel_fun T (rel_sum S T) Inr Inr"
  by auto

lemma Pair_transfer: "rel_fun A (rel_fun B (rel_prod A B)) Pair Pair"
  unfolding rel_fun_def by simp

lemma eq_onp_live_step: "x = y \<Longrightarrow> eq_onp P a a \<and> x \<longleftrightarrow> P a \<and> y"
  by (simp only: eq_onp_same_args)

lemma top_conj: "top x \<and> P \<longleftrightarrow> P" "P \<and> top x \<longleftrightarrow> P"
  by blast+

lemma fst_convol': "fst (\<langle>f, g\<rangle> x) = f x"
  using fst_convol unfolding convol_def by simp

lemma snd_convol': "snd (\<langle>f, g\<rangle> x) = g x"
  using snd_convol unfolding convol_def by simp

lemma convol_expand_snd: "fst \<circ> f = g \<Longrightarrow> \<langle>g, snd \<circ> f\<rangle> = f"
  unfolding convol_def by auto

lemma convol_expand_snd':
  assumes "(fst \<circ> f = g)"
  shows "h = snd \<circ> f \<longleftrightarrow> \<langle>g, h\<rangle> = f"
proof -
  from assms have *: "\<langle>g, snd \<circ> f\<rangle> = f" by (rule convol_expand_snd)
  then have "h = snd \<circ> f \<longleftrightarrow> h = snd \<circ> \<langle>g, snd \<circ> f\<rangle>" by simp
  moreover have "\<dots> \<longleftrightarrow> h = snd \<circ> f" by (simp add: snd_convol)
  moreover have "\<dots> \<longleftrightarrow> \<langle>g, h\<rangle> = f" by (subst (2) *[symmetric]) (auto simp: convol_def fun_eq_iff)
  ultimately show ?thesis by simp
qed

lemma case_sum_expand_Inr_pointfree: "f \<circ> Inl = g \<Longrightarrow> case_sum g (f \<circ> Inr) = f"
  by (auto split: sum.splits)

lemma case_sum_expand_Inr': "f \<circ> Inl = g \<Longrightarrow> h = f \<circ> Inr \<longleftrightarrow> case_sum g h = f"
  by (rule iffI) (auto simp add: fun_eq_iff split: sum.splits)

lemma case_sum_expand_Inr: "f \<circ> Inl = g \<Longrightarrow> f x = case_sum g (f \<circ> Inr) x"
  by (auto split: sum.splits)

lemma id_transfer: "rel_fun A A id id"
  unfolding rel_fun_def by simp

lemma fst_transfer: "rel_fun (rel_prod A B) A fst fst"
  unfolding rel_fun_def by simp

lemma snd_transfer: "rel_fun (rel_prod A B) B snd snd"
  unfolding rel_fun_def by simp

lemma convol_transfer:
  "rel_fun (rel_fun R S) (rel_fun (rel_fun R T) (rel_fun R (rel_prod S T))) BNF_Def.convol BNF_Def.convol"
  unfolding rel_fun_def convol_def by auto

lemma Let_const: "Let x (\<lambda>_. c) = c"
  unfolding Let_def ..

ML_file \<open>Tools/BNF/bnf_fp_util_tactics.ML\<close>
ML_file \<open>Tools/BNF/bnf_fp_util.ML\<close>
ML_file \<open>Tools/BNF/bnf_fp_def_sugar_tactics.ML\<close>
ML_file \<open>Tools/BNF/bnf_fp_def_sugar.ML\<close>
ML_file \<open>Tools/BNF/bnf_fp_n2m_tactics.ML\<close>
ML_file \<open>Tools/BNF/bnf_fp_n2m.ML\<close>
ML_file \<open>Tools/BNF/bnf_fp_n2m_sugar.ML\<close>

end