(* Author: Maximilian Schäffeler *)

theory Modified_Policy_Iteration
  imports
    Policy_Iteration
    Value_Iteration
begin

section \<open>Modified Policy Iteration\<close>

locale MDP_MPI = MDP_att_\<L> A K r l + MDP_act_disc arb_act A K r l
  for A and K :: "'s :: countable \<times> 'a :: countable \<Rightarrow> 's pmf" and r l arb_act
begin

subsection \<open>The Advantage Function @{term B}\<close>

definition "B v s = (\<Squnion>d \<in> D\<^sub>R. (r_dec d s + (l *\<^sub>R \<P>\<^sub>1 d - id_blinfun) v s))"

text "The function @{const B} denotes the advantage of choosing the optimal action vs.
  the current value estimate"

lemma cSUP_plus:
  assumes "X \<noteq> {}" "bdd_above (f`X)"
  shows "(\<Squnion>x \<in> X. f x + c) = (\<Squnion>x \<in> X. f x) + (c::real)"
proof (rule antisym)
  show "(\<Squnion>x\<in>X. f x + c) \<le> \<Squnion> (f ` X) + c"
    using assms by (fastforce intro: cSUP_least cSUP_upper)
  show "\<Squnion> (f ` X) + c \<le> (\<Squnion>x\<in>X. f x + c)"
    unfolding le_diff_eq[symmetric]
    using assms
    by (intro cSUP_least) (auto simp add: algebra_simps bdd_above_def intro!: cSUP_upper2 intro: add_left_mono)+
qed

lemma cSUP_minus:
  assumes "X \<noteq> {}" "bdd_above (f`X)"
  shows "(\<Squnion>x \<in> X. f x - c) = (\<Squnion>x \<in> X. f x) - (c::real)"
  using cSUP_plus[OF assms, of "- c"] by auto

lemma B_eq_\<L>: "B v s = \<L> v s - v s"
proof -
  have *: "B v s = (\<Squnion>d \<in> D\<^sub>R. L d v s - v s)"
    unfolding B_def L_def by (auto simp add: blinfun.bilinear_simps add_diff_eq)
  have "bdd_above ((\<lambda>d. L d v s - v s) ` D\<^sub>R)"
    by (auto intro!: bounded_const bounded_minus_comp bounded_imp_bdd_above)
  thus ?thesis
    unfolding * \<L>_def using ex_dec by (fastforce intro!: cSUP_minus)
qed

text \<open>@{const B} is a bounded function.\<close>

lift_definition B\<^sub>b :: "('s \<Rightarrow>\<^sub>b real) \<Rightarrow> 's \<Rightarrow>\<^sub>b real" is "B"
  unfolding B_eq_\<L> using \<L>_bfun by (auto intro: Bounded_Functions.minus_cont)

lemma B\<^sub>b_eq_\<L>\<^sub>b: "B\<^sub>b v = \<L>\<^sub>b v - v"
  by (auto simp: \<L>\<^sub>b.rep_eq B\<^sub>b.rep_eq B_eq_\<L>)

lemma \<L>\<^sub>b_eq_SUP_L\<^sub>a': "\<L>\<^sub>b v s = (\<Squnion>a \<in> A s. L\<^sub>a a v s)"
  using L_eq_L\<^sub>a_det \<L>\<^sub>b_eq_SUP_det SUP_step_det_eq
  by auto

subsection \<open>Optimization of the Value Function over Multiple Steps\<close>

definition "U m v s = (\<Squnion>d \<in> D\<^sub>R. (\<nu>\<^sub>b_fin (mk_stationary d) m + ((l *\<^sub>R \<P>\<^sub>1 d)^^m) v) s)"

text \<open>@{const U} expresses the value estimate obtained by optimizing the first @{term m} steps and
  afterwards using the current estimate.\<close>

lemma U_zero [simp]: "U 0 v = v"
  unfolding U_def \<L>_def by (auto simp: \<nu>\<^sub>b_fin.rep_eq)

lemma U_one_eq_\<L>: "U 1 v s = \<L> v s"
  unfolding U_def \<L>_def by (auto simp: \<nu>\<^sub>b_fin_eq_\<P>\<^sub>X L_def blinfun.bilinear_simps)

lift_definition U\<^sub>b :: "nat \<Rightarrow> ('s \<Rightarrow>\<^sub>b real) \<Rightarrow> ('s \<Rightarrow>\<^sub>b real)" is U
proof -
  fix n v
  have "norm (\<nu>\<^sub>b_fin (mk_stationary d) m) \<le> (\<Sum>i<m. l ^ i * r\<^sub>M)" for d m
    using abs_\<nu>_fin_le \<nu>\<^sub>b_fin.rep_eq by (auto intro!: norm_bound)
  moreover have "norm (((l *\<^sub>R \<P>\<^sub>1 d)^^m) v) \<le> l ^ m * norm v" for d m
    by (auto simp: \<P>\<^sub>X_const[symmetric] blinfun.bilinear_simps blincomp_scaleR_right
        intro!: boundedI order.trans[OF abs_le_norm_bfun] mult_left_mono)
  ultimately have *: "norm (\<nu>\<^sub>b_fin (mk_stationary d) m + ((l *\<^sub>R \<P>\<^sub>1 d)^^m) v) \<le> (\<Sum>i<m. l ^ i * r\<^sub>M) +  l ^ m * norm v" for d m
    using norm_triangle_mono by blast
  show "U n v \<in> bfun"
    using ex_dec order.trans[OF abs_le_norm_bfun *]
    by (fastforce simp: U_def intro!: bfun_normI cSup_abs_le)
qed

lemma U\<^sub>b_contraction: "dist (U\<^sub>b m v) (U\<^sub>b m u) \<le> l ^ m * dist v u"
proof -
  have aux: "dist (U\<^sub>b m v s) (U\<^sub>b m u s) \<le> l ^ m * dist v u" if le: "U\<^sub>b m u s \<le> U\<^sub>b m v s" for s v u
  proof -
    let ?U = "\<lambda>m v d. (\<nu>\<^sub>b_fin (mk_stationary d) m + ((l *\<^sub>R \<P>\<^sub>1 d) ^^ m) v) s"
    have "U\<^sub>b m v s - U\<^sub>b m u s \<le> (\<Squnion>d \<in> D\<^sub>R. ?U m v d - ?U m u d)"
      using bounded_stationary_\<nu>\<^sub>b_fin bounded_disc_\<P>\<^sub>1 le
      unfolding U\<^sub>b.rep_eq U_def
      by (intro le_SUP_diff') (auto intro: bounded_plus_comp)
    also have "\<dots> = (\<Squnion>d \<in> D\<^sub>R. ((l *\<^sub>R \<P>\<^sub>1 d) ^^ m) (v - u) s)"
      by (simp add: L_def scale_right_diff_distrib blinfun.bilinear_simps)
    also have "\<dots> = (\<Squnion>d \<in> D\<^sub>R. l^m * ((\<P>\<^sub>1 d ^^ m) (v - u) s))"
      by (simp add: blincomp_scaleR_right blinfun.scaleR_left)
    also have "\<dots> = l^m * (\<Squnion>d \<in> D\<^sub>R. ((\<P>\<^sub>1 d ^^ m) (v - u) s))"
      using D\<^sub>R_ne bounded_P bounded_disc_\<P>\<^sub>1' by (auto intro: bounded_SUP_mul)
    also have "\<dots> \<le> l^m * norm (\<Squnion>d \<in> D\<^sub>R. ((\<P>\<^sub>1 d ^^ m) (v - u) s))"
      by (simp add: mult_left_mono)
    also have "\<dots> \<le> l^m * (\<Squnion>d \<in> D\<^sub>R. norm (((\<P>\<^sub>1 d ^^ m) (v - u) s)))"
      using D\<^sub>R_ne ex_dec bounded_norm_comp bounded_disc_\<P>\<^sub>1'
      by (fastforce intro!: mult_left_mono)
    also have "\<dots> \<le> l^m * (\<Squnion>d \<in> D\<^sub>R. norm ((\<P>\<^sub>1 d ^^ m) ((v - u))))"
      using ex_dec
      by (fastforce intro!: order.trans[OF norm_blinfun] abs_le_norm_bfun mult_left_mono cSUP_mono)
    also have "\<dots> \<le> l^m * (\<Squnion>d \<in> D\<^sub>R. norm ((v - u)))"
      using norm_\<P>\<^sub>X_apply by (auto simp: \<P>\<^sub>X_const[symmetric] cSUP_least mult_left_mono)
    also have "\<dots> = l ^m * dist v u"
      by (auto simp: dist_norm)
    finally have "U\<^sub>b m v s - U\<^sub>b m u s \<le> l^m * dist v u" .
    thus ?thesis
      by (simp add: dist_real_def le)
  qed
  moreover have "U\<^sub>b m v s \<le> U\<^sub>b m u s \<Longrightarrow> dist (U\<^sub>b m v s) (U\<^sub>b m u s) \<le> l^m * dist v u" for u v s
    by (simp add: aux dist_commute)
  ultimately have "dist (U\<^sub>b m v s) (U\<^sub>b m u s) \<le> l^m * dist v u" for u v s
    using linear by blast
  thus "dist (U\<^sub>b m v) (U\<^sub>b m u) \<le> l^m * dist v u"
    by (simp add: dist_bound)
qed

lemma U\<^sub>b_conv:
  "\<exists>!v. U\<^sub>b (Suc m) v = v"
  "(\<lambda>n. (U\<^sub>b (Suc m) ^^ n) v) \<longlonglongrightarrow> (THE v. U\<^sub>b (Suc m) v = v)"
proof -
  have *: "is_contraction (U\<^sub>b (Suc m))"
    unfolding is_contraction_def
    using U\<^sub>b_contraction[of "Suc m"] le_neq_trans[OF zero_le_disc]
    by (cases "l = 0") (auto intro!: power_Suc_less_one intro: exI[of _ "l^(Suc m)"])
  show "\<exists>!v. U\<^sub>b (Suc m) v = v" "(\<lambda>n. (U\<^sub>b (Suc m) ^^ n) v) \<longlonglongrightarrow> (THE v. U\<^sub>b (Suc m) v = v)"
    using banach'[OF *] by auto
qed

lemma U\<^sub>b_convergent: "convergent (\<lambda>n. (U\<^sub>b (Suc m) ^^ n) v)"
  by (intro convergentI[OF U\<^sub>b_conv(2)])

lemma U\<^sub>b_mono:
  assumes "v \<le> u"
  shows "U\<^sub>b m v \<le> U\<^sub>b m u"
proof  -
  have "U\<^sub>b m v s \<le> U\<^sub>b m u s" for s
    unfolding U\<^sub>b.rep_eq U_def
  proof (intro cSUP_mono, goal_cases)
    case 2
    thus ?case
      by (simp add: bounded_imp_bdd_above bounded_disc_\<P>\<^sub>1 bounded_plus_comp bounded_stationary_\<nu>\<^sub>b_fin)
  next
    case (3 n)
    thus ?case
      using less_eq_bfunD[OF \<P>\<^sub>X_mono[OF assms]]
      by (auto simp: \<P>\<^sub>X_const[symmetric] blincomp_scaleR_right blinfun.scaleR_left intro!: mult_left_mono exI)
  qed auto
  thus ?thesis
    using assms by auto
qed

lemma U\<^sub>b_le_\<L>\<^sub>b: "U\<^sub>b m v \<le> (\<L>\<^sub>b ^^ m) v"
proof -
  have "U\<^sub>b m v s = (\<Squnion>d \<in> D\<^sub>R. (L d^^ m) v s)" for m v s
    by (auto simp: L_iter U\<^sub>b.rep_eq \<L>\<^sub>b.rep_eq U_def \<L>_def)
  thus ?thesis
    using L_iter_le_\<L>\<^sub>b ex_dec by (fastforce intro!: cSUP_least)
qed

lemma L_iter_le_U\<^sub>b:
  assumes "d \<in> D\<^sub>R"
  shows "(L d^^m) v \<le> U\<^sub>b m v"
  using assms
  by (fastforce intro!: cSUP_upper bounded_imp_bdd_above
      simp: L_iter U\<^sub>b.rep_eq U_def bounded_disc_\<P>\<^sub>1 bounded_plus_comp bounded_stationary_\<nu>\<^sub>b_fin)

lemma lim_U\<^sub>b: "lim (\<lambda>n. (U\<^sub>b (Suc m) ^^ n) v) = \<nu>\<^sub>b_opt"
proof -
  have le_U: "\<nu>\<^sub>b_opt \<le> U\<^sub>b m \<nu>\<^sub>b_opt" for m
  proof -
    obtain d where d: "\<nu>_improving \<nu>\<^sub>b_opt (mk_dec_det d)" "d \<in> D\<^sub>D"
      using ex_improving_det by auto
    have "\<nu>\<^sub>b_opt = (L (mk_dec_det d) ^^ m) \<nu>\<^sub>b_opt"
      by (induction m) (metis L_\<nu>_fix_iff \<L>\<^sub>b_opt \<nu>_improving_imp_\<L>\<^sub>b d(1) funpow_swap1)+
    thus ?thesis
      using \<open>d \<in> D\<^sub>D\<close> by (auto intro!: order.trans[OF _ L_iter_le_U\<^sub>b])
  qed
  have "U\<^sub>b m \<nu>\<^sub>b_opt \<le> \<nu>\<^sub>b_opt" for m
    using \<L>_inc_le_opt  by (auto intro!: order.trans[OF U\<^sub>b_le_\<L>\<^sub>b] simp: funpow_swap1)
  hence "U\<^sub>b (Suc m) \<nu>\<^sub>b_opt = \<nu>\<^sub>b_opt"
    using le_U by (simp add: antisym)
  moreover have "(lim (\<lambda>n. (U\<^sub>b (Suc m) ^^n) v)) = U\<^sub>b (Suc m) (lim (\<lambda>n. (U\<^sub>b (Suc m) ^^n) v))"
    using limI[OF U\<^sub>b_conv(2)] theI'[OF U\<^sub>b_conv(1)] by auto
  ultimately show ?thesis
    using U\<^sub>b_conv(1) by metis
qed

lemma U\<^sub>b_tendsto: "(\<lambda>n. (U\<^sub>b (Suc m) ^^ n) v) \<longlonglongrightarrow> \<nu>\<^sub>b_opt"
  using lim_U\<^sub>b U\<^sub>b_convergent convergent_LIMSEQ_iff by metis

lemma U\<^sub>b_fix_unique: "U\<^sub>b (Suc m) v = v \<longleftrightarrow> v = \<nu>\<^sub>b_opt"
  using theI'[OF U\<^sub>b_conv(1)] U\<^sub>b_conv(1)
  by (auto simp: LIMSEQ_unique[OF U\<^sub>b_tendsto U\<^sub>b_conv(2)[of m]])

lemma dist_U\<^sub>b_opt: "dist (U\<^sub>b m v) \<nu>\<^sub>b_opt \<le> l^m * dist v \<nu>\<^sub>b_opt"
proof -
  have "dist (U\<^sub>b m v) \<nu>\<^sub>b_opt = dist (U\<^sub>b m v) (U\<^sub>b m \<nu>\<^sub>b_opt)"
    by (metis U\<^sub>b.abs_eq U\<^sub>b_fix_unique U_zero apply_bfun_inverse not0_implies_Suc)
  also have "\<dots> \<le> l^m * dist v \<nu>\<^sub>b_opt"
    by (meson U\<^sub>b_contraction)
  finally show ?thesis .
qed

subsection \<open>Expressing a Single Step of Modified Policy Iteration\<close>
text \<open>The function @{term W} equals the value computed by the Modified Policy Iteration Algorithm
  in a single iteration.
  The right hand addend in the definition describes the advantage of using the optimal action for
  the first m steps.
  \<close>
definition "W d m v = v + (\<Sum>i < m. (l *\<^sub>R \<P>\<^sub>1 d)^^i) (B\<^sub>b v)"

lemma W_eq_L_iter:
  assumes "\<nu>_improving v d"
  shows "W d m v = (L d^^m) v"
proof -
  have "(\<Sum>i<m. (l *\<^sub>R \<P>\<^sub>1 d)^^i) (\<L>\<^sub>b v) = (\<Sum>i<m. (l *\<^sub>R \<P>\<^sub>1 d)^^i) (L d v)"
    using \<nu>_improving_imp_\<L>\<^sub>b assms by auto
  hence "W d m v = v + ((\<Sum>i<m. (l *\<^sub>R \<P>\<^sub>1 d)^^i) (L d v)) - (\<Sum>i<m. (l *\<^sub>R \<P>\<^sub>1 d)^^i) v"
    by (auto simp: W_def B\<^sub>b_eq_\<L>\<^sub>b blinfun.bilinear_simps)
  also have "\<dots> = v + \<nu>\<^sub>b_fin (mk_stationary d) m + (\<Sum>i<m. ((l *\<^sub>R \<P>\<^sub>1 d)^^i) ((l *\<^sub>R \<P>\<^sub>1 d) v)) - (\<Sum>i<m. (l *\<^sub>R \<P>\<^sub>1 d)^^i) v"
    by (auto simp: L_def \<nu>\<^sub>b_fin_eq blinfun.bilinear_simps scaleR_right.sum)
  also have "\<dots> = v + \<nu>\<^sub>b_fin (mk_stationary d) m + (\<Sum>i<m. ((l *\<^sub>R \<P>\<^sub>1 d)^^Suc i) v) - (\<Sum>i<m. (l *\<^sub>R \<P>\<^sub>1 d)^^i) v"
    by (auto simp del: blinfunpow.simps simp: blinfunpow_assoc)
  also have "\<dots> = \<nu>\<^sub>b_fin (mk_stationary d) m + (\<Sum>i<Suc m. ((l *\<^sub>R \<P>\<^sub>1 d)^^ i) v)  - (\<Sum>i<m. (l *\<^sub>R \<P>\<^sub>1 d)^^ i) v"
    by (subst sum.lessThan_Suc_shift) auto
  also have "\<dots> =  \<nu>\<^sub>b_fin (mk_stationary d) m + ((l *\<^sub>R \<P>\<^sub>1 d)^^m) v"
    by (simp add: blinfun.sum_left)
  also have "\<dots> = (L d ^^ m) v"
    using L_iter by auto
  finally show ?thesis .
qed

lemma U\<^sub>b_ge: "d \<in> D\<^sub>R \<Longrightarrow> U\<^sub>b m u \<ge> \<nu>\<^sub>b_fin (mk_stationary d) m + ((l *\<^sub>R \<P>\<^sub>1 d) ^^ m) u"
  using \<nu>_improving_D_MR bounded_stationary_\<nu>\<^sub>b_fin bounded_disc_\<P>\<^sub>1
  by (fastforce intro!: diff_mono bounded_imp_bdd_above cSUP_upper bounded_plus_comp simp: U\<^sub>b.rep_eq U_def)

lemma W_le_U\<^sub>b:
  assumes "v \<le> u" "\<nu>_improving v d"
  shows "W d m v \<le> U\<^sub>b m u"
  using assms
  by (fastforce simp: W_eq_L_iter intro!: order.trans[OF L_iter_le_U\<^sub>b U\<^sub>b_mono])

lemma W_ge_\<L>\<^sub>b:
  assumes "v \<le> u" "0 \<le> B\<^sub>b u" "\<nu>_improving u d'"
  shows "\<L>\<^sub>b v \<le> W d' (Suc m) u"
proof -
  have "\<L>\<^sub>b v \<le> u + B\<^sub>b u"
    using assms(1) \<L>\<^sub>b_mono B\<^sub>b_eq_\<L>\<^sub>b by auto
  also have "\<dots> \<le> W d' (Suc m) u"
    using L_mono \<nu>_improving_imp_\<L>\<^sub>b assms(3) assms
    by (induction m) (auto simp: W_eq_L_iter B\<^sub>b_eq_\<L>\<^sub>b)
  finally show ?thesis .
qed

lemma B\<^sub>b_le:
  assumes "\<nu>_improving v d"
  shows "B\<^sub>b v + (l *\<^sub>R \<P>\<^sub>1 d - id_blinfun) (u - v) \<le> B\<^sub>b u"
proof -
  have "r_dec\<^sub>b d + (l *\<^sub>R \<P>\<^sub>1 d - id_blinfun) u \<le> B\<^sub>b u"
    using L_def L_le_\<L>\<^sub>b assms by (auto simp: B\<^sub>b_eq_\<L>\<^sub>b \<L>\<^sub>b.rep_eq \<L>_def blinfun.bilinear_simps)
  moreover have "B\<^sub>b v = r_dec\<^sub>b d + (l *\<^sub>R \<P>\<^sub>1 d - id_blinfun) v"
    using assms by (auto simp: B\<^sub>b_eq_\<L>\<^sub>b \<nu>_improving_imp_\<L>\<^sub>b[of _ d] L_def blinfun.bilinear_simps)
  ultimately show ?thesis
    by (simp add: blinfun.diff_right)
qed

subsection \<open>Computing the Bellman Operator over Multiple Steps\<close>
definition "L_pow v d m = (L (mk_dec_det d) ^^ m) v"

(*
lemma sum_telescope': "(\<Sum>i\<le>k. f (Suc i) - f i ) = f (Suc k) - (f 0 :: 'c :: ab_group_add)"
  using sum_telescope[of "-f" k]
  by auto
*)

(* eq 6.5.7 *)
lemma L_pow_eq:
  fixes d defines "d' \<equiv> mk_dec_det d"
  assumes "\<nu>_improving v d'"
  shows "L_pow v d m = v + (\<Sum>i < m. ((l *\<^sub>R \<P>\<^sub>1 d')^^i)) (B\<^sub>b v)"
  using L_pow_def W_def W_eq_L_iter assms by presburger

lemma L_pow_eq_W:
  assumes "d \<in> D\<^sub>D"
  shows "L_pow v (policy_improvement d v) m = W (mk_dec_det (policy_improvement d v)) m v"
  using assms policy_improvement_improving by (auto simp: W_eq_L_iter L_pow_def)

lemma find_policy'_is_dec_det: "is_dec_det (find_policy' v)"
  using find_policy'_def is_dec_det_def some_opt_acts_in_A by presburger

lemma find_policy'_improving: "\<nu>_improving v (mk_dec_det (find_policy' v))"
  using \<nu>_improving_opt_acts find_policy'_def by presburger

lemma L_pow_eq_W': "L_pow v (find_policy' v) m = W (mk_dec_det (find_policy' v)) m v"
  using find_policy'_improving by (auto simp: W_eq_L_iter L_pow_def)

lemma \<L>\<^sub>b_W_ge:
  assumes "u \<le> \<L>\<^sub>b u" "\<nu>_improving u d"
  shows "W d m u \<le> \<L>\<^sub>b (W d m u)"
proof -
  have "0 \<le> ((l *\<^sub>R \<P>\<^sub>1 d) ^^ m) (B\<^sub>b u)"
    by (metis B\<^sub>b_eq_\<L>\<^sub>b \<P>\<^sub>1_n_disc_pos assms(1) blincomp_scaleR_right diff_ge_0_iff_ge)
  also have "\<dots> = ((l *\<^sub>R \<P>\<^sub>1 d)^^0 + (\<Sum>i < m. (l *\<^sub>R \<P>\<^sub>1 d)^^(Suc i))) (B\<^sub>b u) - (\<Sum>i < m. (l *\<^sub>R \<P>\<^sub>1 d)^^ i) (B\<^sub>b u)"
    by (subst sum.lessThan_Suc_shift[symmetric]) (auto simp: blinfun.diff_left[symmetric])
  also have "\<dots> = B\<^sub>b u + ((l *\<^sub>R \<P>\<^sub>1 d - id_blinfun) o\<^sub>L (\<Sum>i < m. (l *\<^sub>R \<P>\<^sub>1 d)^^i)) (B\<^sub>b u)"
    by (auto simp: blinfun.bilinear_simps sum_subtractf)
  also have "\<dots> = B\<^sub>b u + (l *\<^sub>R \<P>\<^sub>1 d - id_blinfun) (W d m u - u)"
    by (auto simp: W_def sum.lessThan_Suc[unfolded lessThan_Suc_atMost])
  also have "\<dots> \<le> B\<^sub>b (W d m u)"
    using B\<^sub>b_le assms(2) by blast
  finally have "0 \<le> B\<^sub>b (W d m u)" .
  thus ?thesis
    using B\<^sub>b_eq_\<L>\<^sub>b by auto
qed

lemma L_pow_\<L>\<^sub>b_mono_inv:
  assumes "d \<in> D\<^sub>D" "v \<le> \<L>\<^sub>b v"
  shows "L_pow v (policy_improvement d v) m \<le> \<L>\<^sub>b (L_pow v (policy_improvement d v) m)"
  using assms L_pow_eq_W \<L>\<^sub>b_W_ge policy_improvement_improving by auto

lemma L_pow_\<L>\<^sub>b_mono_inv':
  assumes "v \<le> \<L>\<^sub>b v"
  shows "L_pow v (find_policy' v) m \<le> \<L>\<^sub>b (L_pow v (find_policy' v) m)"
  using assms L_pow_eq_W' \<L>\<^sub>b_W_ge find_policy'_improving by auto

subsection \<open>The Modified Policy Iteration Algorithm\<close>
context
  fixes d0 :: "'s \<Rightarrow> 'a"
  fixes v0 :: "'s \<Rightarrow>\<^sub>b real"
  fixes m :: "nat \<Rightarrow> ('s \<Rightarrow>\<^sub>b real) \<Rightarrow> nat"
  assumes d0: "d0 \<in> D\<^sub>D"
begin

text \<open>We first define a function that executes the algorithm for n steps.\<close>
fun mpi :: "nat \<Rightarrow> (('s \<Rightarrow> 'a) \<times> ('s \<Rightarrow>\<^sub>b real))" where
  "mpi 0 = (find_policy' v0, v0)" |
  "mpi (Suc n) =
  (let (d, v) = mpi n; v' = L_pow v d (Suc (m n v)) in
  (find_policy' v', v'))"

definition "mpi_val n = snd (mpi n)"
definition "mpi_pol n = fst (mpi n)"

lemma mpi_pol_zero[simp]: "mpi_pol 0 = find_policy' v0"
  unfolding mpi_pol_def
  by auto

lemma mpi_pol_Suc: "mpi_pol (Suc n) = find_policy' (mpi_val (Suc n))"
  by (auto simp: case_prod_beta' Let_def mpi_pol_def mpi_val_def)

lemma mpi_pol_is_dec_det: "mpi_pol n \<in> D\<^sub>D"
  unfolding mpi_pol_def
  using find_policy'_is_dec_det d0
  by (induction n)  (auto simp: Let_def split: prod.splits)

lemma \<nu>_improving_mpi_pol: "\<nu>_improving (mpi_val n) (mk_dec_det (mpi_pol n))"
  using d0 find_policy'_improving mpi_pol_is_dec_det mpi_pol_Suc
  by (cases n) (auto simp: mpi_pol_def mpi_val_def)

lemma mpi_val_zero[simp]: "mpi_val 0 = v0"
  unfolding mpi_val_def by auto

lemma mpi_val_Suc: "mpi_val (Suc n) = L_pow (mpi_val n) (mpi_pol n) (Suc (m n (mpi_val n)))"
  unfolding mpi_val_def mpi_pol_def
  by (auto simp: case_prod_beta' Let_def)

lemma mpi_val_eq: "mpi_val (Suc n) =
  mpi_val n + (\<Sum>i \<le> (m n (mpi_val n)). (l *\<^sub>R \<P>\<^sub>1 (mk_dec_det (mpi_pol n))) ^^ i) (B\<^sub>b (mpi_val n))"
  using lessThan_Suc_atMost by (auto simp: mpi_val_Suc L_pow_eq[OF \<nu>_improving_mpi_pol])

text \<open>Value Iteration is a special case of MPI where @{term "\<forall>n v. m n v = 0"}.\<close>
lemma mpi_includes_value_it:
  assumes "\<forall>n v. m n v = 0"
  shows "mpi_val (Suc n) = \<L>\<^sub>b (mpi_val n)"
  using assms B\<^sub>b_eq_\<L>\<^sub>b mpi_val_eq by auto

subsection \<open>Convergence Proof\<close>
text \<open>We define the sequence @{term w} as an upper bound for the values of MPI.\<close>
fun w where
  "w 0 = v0" |
  "w (Suc n) = U\<^sub>b (Suc (m n (mpi_val n))) (w n)"

lemma dist_\<nu>\<^sub>b_opt: "dist (w (Suc n)) \<nu>\<^sub>b_opt \<le> l * dist (w n) \<nu>\<^sub>b_opt"
  by (fastforce simp: algebra_simps intro: order.trans[OF dist_U\<^sub>b_opt] mult_left_mono power_le_one
      mult_left_le_one_le order.strict_implies_order)

lemma dist_\<nu>\<^sub>b_opt_n: "dist (w n) \<nu>\<^sub>b_opt \<le> l^n * dist v0 \<nu>\<^sub>b_opt"
  by (induction n) (fastforce simp: algebra_simps intro: order.trans[OF dist_\<nu>\<^sub>b_opt] mult_left_mono)+

lemma w_conv: "w \<longlonglongrightarrow> \<nu>\<^sub>b_opt"
proof -
  have "(\<lambda>n. l^n * dist v0 \<nu>\<^sub>b_opt) \<longlonglongrightarrow> 0"
    using LIMSEQ_realpow_zero by (cases "v0 = \<nu>\<^sub>b_opt") auto
  then show ?thesis
    by (fastforce intro: metric_LIMSEQ_I order.strict_trans1[OF dist_\<nu>\<^sub>b_opt_n] simp: LIMSEQ_def)
qed

text \<open>MPI converges monotonically to the optimal value from below.
  The iterates are sandwiched between @{const \<L>\<^sub>b} from below and @{const U\<^sub>b} from above.\<close>
theorem mpi_conv:
  assumes "v0 \<le> \<L>\<^sub>b v0"
  shows "mpi_val \<longlonglongrightarrow> \<nu>\<^sub>b_opt" and "\<And>n. mpi_val n \<le> mpi_val (Suc n)"
proof -
  define y where "y n = (\<L>\<^sub>b^^n) v0" for n
  have aux: "mpi_val n \<le> \<L>\<^sub>b (mpi_val n) \<and> mpi_val n \<le> mpi_val (Suc n) \<and> y n \<le> mpi_val n \<and> mpi_val n \<le> w n" for n
  proof (induction n)
    case 0
    show ?case
      using assms B\<^sub>b_eq_\<L>\<^sub>b
      unfolding y_def
      by (auto simp: mpi_val_eq blinfun.sum_left \<P>\<^sub>1_n_disc_pos blincomp_scaleR_right sum_nonneg)
  next
    case (Suc n)
    have val_eq_W: "mpi_val (Suc n) = W (mk_dec_det (mpi_pol n)) (Suc (m n (mpi_val n))) (mpi_val n)"
      using \<nu>_improving_mpi_pol mpi_val_Suc W_eq_L_iter L_pow_def by auto
    hence *: "mpi_val (Suc n) \<le> \<L>\<^sub>b (mpi_val (Suc n))"
      using Suc.IH \<L>\<^sub>b_W_ge \<nu>_improving_mpi_pol by presburger
    moreover have "mpi_val (Suc n) \<le> mpi_val (Suc (Suc n))"
      using *
      by (simp add: B\<^sub>b_eq_\<L>\<^sub>b mpi_val_eq \<P>\<^sub>1_n_disc_pos blincomp_scaleR_right blinfun.sum_left sum_nonneg)
    moreover have "mpi_val (Suc n) \<le> w (Suc n)"
      using Suc.IH \<nu>_improving_mpi_pol by (auto simp: val_eq_W intro: order.trans[OF _ W_le_U\<^sub>b])
    moreover have "y (Suc n) \<le> mpi_val (Suc n)"
      using Suc.IH \<nu>_improving_mpi_pol W_ge_\<L>\<^sub>b by (auto simp: y_def B\<^sub>b_eq_\<L>\<^sub>b val_eq_W)
    ultimately show ?case
      by auto
  qed
  thus "mpi_val n \<le> mpi_val (Suc n)" for n
    by auto
  have "y \<longlonglongrightarrow> \<nu>\<^sub>b_opt"
    using \<L>\<^sub>b_lim y_def by presburger
  thus "mpi_val \<longlonglongrightarrow> \<nu>\<^sub>b_opt"
    using aux by (auto intro: tendsto_bfun_sandwich[OF _ w_conv])
qed

subsection \<open>$\epsilon$-Optimality\<close>
text \<open>This gives an upper bound on the error of MPI.\<close>
lemma mpi_pol_eps_opt:
  assumes "2 * l * dist (mpi_val n) (\<L>\<^sub>b (mpi_val n)) < eps * (1 - l)" "eps > 0"
  shows "dist (\<nu>\<^sub>b (mk_stationary_det (mpi_pol n))) (\<L>\<^sub>b (mpi_val n)) \<le> eps / 2"
proof -
  let ?p = "mk_stationary_det (mpi_pol n)"
  let ?d = "mk_dec_det (mpi_pol n)"
  let ?v = "mpi_val n"
  have "dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b ?v) = dist (L ?d (\<nu>\<^sub>b ?p)) (\<L>\<^sub>b ?v)"
    using L_\<nu>_fix by force
  also have "\<dots> = dist (L ?d (\<nu>\<^sub>b ?p)) (L ?d ?v)"
    by (metis \<nu>_improving_imp_\<L>\<^sub>b \<nu>_improving_mpi_pol)
  also have "\<dots> \<le> dist (L ?d (\<nu>\<^sub>b ?p)) (L ?d (\<L>\<^sub>b ?v)) + dist (L ?d (\<L>\<^sub>b ?v)) (L ?d ?v)"
    using dist_triangle by blast
  also have "\<dots> \<le> l * dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b ?v) + dist (L ?d (\<L>\<^sub>b ?v)) (L ?d ?v)"
    using contraction_L by auto
  also have "\<dots> \<le> l * dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b ?v) + l * dist (\<L>\<^sub>b ?v) ?v"
    using contraction_L by auto
  finally have "dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b ?v) \<le> l * dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b ?v) + l * dist (\<L>\<^sub>b ?v) ?v".
  hence *:"(1-l) * dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b ?v) \<le> l * dist (\<L>\<^sub>b ?v) ?v"
    by (auto simp: left_diff_distrib)
  thus ?thesis
  proof (cases "l = 0")
    case True
    thus ?thesis
      using assms * by auto
  next
    case False
    have **: "dist (\<L>\<^sub>b ?v) (mpi_val n) < eps * (1 - l) / (2 * l)"
      using False le_neq_trans[OF zero_le_disc False[symmetric]] assms
      by (auto simp: dist_commute pos_less_divide_eq Groups.mult_ac(2))
    have "dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b ?v) \<le> (l/ (1-l)) * dist (\<L>\<^sub>b ?v) ?v"
      using * by (auto simp: mult.commute pos_le_divide_eq)
    also have "\<dots> \<le> (l/ (1-l)) * (eps * (1 - l) / (2 * l))"
      using ** by (fastforce intro!: mult_left_mono simp: divide_nonneg_pos)
    also have "\<dots> = eps / 2"
      using False disc_lt_one by (auto simp: order.strict_iff_order)
    finally show "dist (\<nu>\<^sub>b ?p) (\<L>\<^sub>b ?v) \<le> eps / 2".
  qed
qed

lemma mpi_pol_opt:
  assumes "2 * l * dist (mpi_val n) (\<L>\<^sub>b (mpi_val n)) < eps * (1 - l)" "eps > 0"
  shows "dist (\<nu>\<^sub>b (mk_stationary_det (mpi_pol n))) (\<nu>\<^sub>b_opt) < eps"
proof -
  have "dist (\<nu>\<^sub>b (mk_stationary_det (mpi_pol n))) (\<nu>\<^sub>b_opt) \<le> eps/2 + dist (\<L>\<^sub>b (mpi_val n)) \<nu>\<^sub>b_opt"
    by (metis mpi_pol_eps_opt[OF assms] dist_commute dist_triangle_le add_right_mono)
  thus ?thesis
    using dist_\<L>\<^sub>b_opt_eps assms by fastforce
qed

lemma mpi_val_term_ex:
  assumes "v0 \<le> \<L>\<^sub>b v0" "eps > 0"
  shows "\<exists>n. 2 * l * dist (mpi_val n) (\<L>\<^sub>b (mpi_val n)) < eps * (1 - l)"
proof -
  have "(\<lambda>n. dist (mpi_val n) \<nu>\<^sub>b_opt) \<longlonglongrightarrow> 0"
    using mpi_conv(1)[OF assms(1)] tendsto_dist_iff
    by blast
  hence "(\<lambda>n. dist (mpi_val n) (\<L>\<^sub>b (mpi_val n))) \<longlonglongrightarrow> 0"
    using dist_\<L>\<^sub>b_lt_dist_opt
    by (auto simp: metric_LIMSEQ_I intro: tendsto_sandwich[of "\<lambda>_. 0" _ _ "\<lambda>n. 2 * dist (mpi_val n) \<nu>\<^sub>b_opt"])
  hence "\<forall>e >0. \<exists>n. dist (mpi_val n) (\<L>\<^sub>b (mpi_val n)) < e"
    by (fastforce dest!: metric_LIMSEQ_D)
  hence "l \<noteq> 0 \<Longrightarrow> \<exists>n. dist (mpi_val n) (\<L>\<^sub>b (mpi_val n)) < eps * (1 - l) / (2 * l)"
    by (simp add: assms order.not_eq_order_implies_strict)
  thus "\<exists>n. (2 * l) * dist (mpi_val n) (\<L>\<^sub>b (mpi_val n)) < eps * (1 - l)"
    using assms le_neq_trans[OF zero_le_disc]
    by (cases "l = 0") (auto simp: mult.commute pos_less_divide_eq)
qed
end

subsection \<open>Unbounded MPI\<close>
context
  fixes eps \<delta> :: real and M :: nat
begin

function (domintros) mpi_algo where "mpi_algo d v m = (
  if 2 * l * dist v (\<L>\<^sub>b v) <  eps * (1 - l)
  then (find_policy' v, v)
  else mpi_algo (find_policy' v) (L_pow v (find_policy' v) (Suc (m 0 v))) (\<lambda>n. m (Suc n)))"
  by auto

text \<open>We define a tailrecursive version of @{const mpi} which more closely resembles @{const mpi_algo}.\<close>
fun mpi' where
  "mpi' d v 0 m = (find_policy' v, v)" |
  "mpi' d v (Suc n) m = (
  let d' = find_policy' v; v' = L_pow v d' (Suc (m 0 v)) in mpi' d' v' n (\<lambda>n. m (Suc n)))"

lemma mpi_Suc':
  assumes "d \<in> D\<^sub>D"
  shows "mpi v m (Suc n) = mpi (L_pow v (find_policy' v) (Suc (m 0 v))) (\<lambda>a. m (Suc a)) n"
  using assms
  by (induction n rule: nat.induct) (auto simp: Let_def)

lemma
  assumes "d \<in> D\<^sub>D"
  shows "mpi v m n = mpi' d v n m"
  using assms
proof (induction n arbitrary: d v m rule: nat.induct)
  case (Suc nat)
  thus ?case
    using find_policy'_is_dec_det by (fastforce simp: Let_def mpi_Suc'[OF Suc(2)])
qed auto

lemma termination_mpi_algo:
  assumes "eps > 0" "d \<in> D\<^sub>D" "v \<le> \<L>\<^sub>b v"
  shows "mpi_algo_dom (d, v, m)"
proof -
  define n where "n = (LEAST n. 2 * l * dist (mpi_val v m n) (\<L>\<^sub>b (mpi_val v m n)) < eps * (1 - l))" (is "n = (LEAST n. ?P d v m n)")
  have least0: "\<exists>n. P n \<Longrightarrow> (LEAST n. P n) = (0 :: nat) \<Longrightarrow> P 0"  for P
    by (metis LeastI_ex)
  from n_def assms show ?thesis
  proof (induction n arbitrary: v d m)
    case 0
    have "2 * l * dist (mpi_val v m 0) (\<L>\<^sub>b (mpi_val v m 0)) < eps * (1 - l)"
      using least0 mpi_val_term_ex 0 by (metis (no_types, lifting))
    thus ?case
      using 0 mpi_algo.domintros mpi_val_zero by (metis (no_types, opaque_lifting))
  next
    case (Suc n v d m)
    let ?d = "find_policy' v"
    have "Suc n = Suc (LEAST n. 2 * l * dist (mpi_val v m (Suc n)) (\<L>\<^sub>b (mpi_val v m (Suc n))) < eps * (1 - l))"
      using mpi_val_term_ex[OF Suc.prems(3) \<open>v \<le> \<L>\<^sub>b v\<close> \<open>0 < eps\<close>, of m] Suc.prems
      by (subst Nat.Least_Suc[symmetric]) (auto intro: LeastI_ex)
    hence "n = (LEAST n. 2 * l * dist (mpi_val v m (Suc n)) (\<L>\<^sub>b (mpi_val v m (Suc n))) < eps * (1 - l))"
      by auto
    hence n_eq: "n =
    (LEAST n. 2 * l * dist (mpi_val (L_pow v ?d (Suc (m 0 v))) (\<lambda>a. m (Suc a)) n) (\<L>\<^sub>b (mpi_val (L_pow v ?d (Suc (m 0 v))) (\<lambda>a. m (Suc a)) n))
        < eps * (1 - l))"
      using Suc.prems mpi_Suc' by (auto simp: is_dec_det_pi mpi_val_def)
    have "\<not> 2 * l * dist v (\<L>\<^sub>b v) < eps * (1 - l)"
      using Suc mpi_val_zero by force
    moreover have "mpi_algo_dom (?d, L_pow v ?d (Suc (m 0 v)), \<lambda>a. m (Suc a))"
      apply (rule Suc.IH[OF n_eq \<open>0 < eps\<close>])
          using Suc.prems is_dec_det_pi L_pow_\<L>\<^sub>b_mono_inv' find_policy'_is_dec_det by auto
    ultimately show ?case
      using mpi_algo.domintros by blast
  qed
qed

abbreviation "mpi_alg_rec d v m \<equiv>
    (if 2 * l * dist v (\<L>\<^sub>b v) < eps * (1 - l) then (find_policy' v, v)
     else mpi_algo (find_policy' v) (L_pow v (find_policy' v) (Suc (m 0 v)))
           (\<lambda>n. m (Suc n)))"

lemma mpi_algo_def':
  assumes "d \<in> D\<^sub>D" "v \<le> \<L>\<^sub>b v" "eps > 0"
  shows "mpi_algo d v m = mpi_alg_rec d v m"
  using mpi_algo.psimps termination_mpi_algo assms by auto

lemma mpi_algo_def'':
  assumes "d \<in> D\<^sub>D" "v \<le> \<L>\<^sub>b v" "eps > 0"
  shows "mpi_algo d v m = (
  let v' = \<L>\<^sub>b v; d' = find_policy' v in
    if 2 * l * dist v v'  < eps * (1 - l)
    then (d', v)
    else mpi_algo d' (L_pow v' d' ((m 0 v))) (\<lambda>n. m (Suc n)))"
proof -
  have "\<nu>_improving v (mk_dec_det (find_policy' v))"
    using \<nu>_improving_opt_acts find_policy'_def by presburger
  hence aux: "L_pow (\<L>\<^sub>b v) (find_policy' v) n = L_pow v (find_policy' v) (Suc n)" for n
    using \<open>d \<in> D\<^sub>D\<close>  \<nu>_improving_imp_\<L>\<^sub>b
    by (auto simp: funpow_swap1 L_pow_def)
  show ?thesis
    unfolding mpi_algo_def'[OF assms] Let_def aux[symmetric] by auto
qed

lemma mpi_algo_eq_mpi:
  assumes "d \<in> D\<^sub>D" "v \<le> \<L>\<^sub>b v" "eps > 0"
  shows "mpi_algo d v m = mpi v m (LEAST n. 2 * l * dist (mpi_val v m n) (\<L>\<^sub>b (mpi_val v m n)) < eps * (1 - l))"
proof -
  define n where "n = (LEAST n. 2 * l * dist (mpi_val v m n) (\<L>\<^sub>b (mpi_val v m n)) < eps * (1 - l))" (is "n = (LEAST n. ?P d v m n)")
  from n_def assms show ?thesis
  proof (induction n arbitrary: d v m)
    case 0
    have "?P d v m 0"
      by (metis (no_types, lifting) assms(3) LeastI_ex 0 mpi_val_term_ex)
    thus ?case
      using assms 0 by (auto simp: mpi_val_def mpi_algo_def')
  next
    case (Suc n)
    hence not0: "\<not> (2 * l * dist v (\<L>\<^sub>b v) < eps * (1 - l))"
      using Suc(3) mpi_val_zero by auto
    obtain n' where "2 * l * dist (mpi_val v m n') (\<L>\<^sub>b (mpi_val v m n')) < eps * (1 - l)"
      using mpi_val_term_ex[OF Suc(3) Suc(4), of _ m] assms by blast
    hence "n = (LEAST n. ?P d v m (Suc n))"
      using Suc(2) Suc by (subst (asm) Least_Suc) auto
    hence "n = (LEAST n. ?P (find_policy' v) (L_pow v (find_policy' v) (Suc (m 0 v))) (\<lambda>n. m (Suc n)) n)"
      using Suc(3)  mpi_Suc' by (auto simp: mpi_val_def)
    hence "mpi_algo d v m = mpi v m (Suc n)"
      unfolding mpi_algo_def'[OF Suc.prems(2-4)]
      using Suc(1) Suc.prems(2-4) is_dec_det_pi mpi_Suc' not0 L_pow_\<L>\<^sub>b_mono_inv' find_policy'_is_dec_det
      by fastforce
    thus ?case
      using Suc.prems(1) by presburger
  qed
qed

lemma mpi_algo_opt:
  assumes "v0 \<le> \<L>\<^sub>b v0" "eps > 0" "d \<in> D\<^sub>D"
  shows "dist (\<nu>\<^sub>b (mk_stationary_det (fst (mpi_algo d v0 m)))) \<nu>\<^sub>b_opt < eps"
proof -
  let ?P = "\<lambda>n. 2 * l * dist (mpi_val v0 m n) (\<L>\<^sub>b (mpi_val v0 m n)) <  eps * (1 - l)"
  let ?n = "Least ?P"
  have "mpi_algo d v0 m = mpi v0 m ?n" and "?P ?n"
    using mpi_algo_eq_mpi LeastI_ex[OF mpi_val_term_ex] assms by auto
  thus ?thesis
    using assms by (auto simp: mpi_pol_opt mpi_pol_def[symmetric])
qed

end

subsection \<open>Initial Value Estimate @{term v0_mpi}\<close>
text \<open>We define an initial estimate of the value function for which Modified Policy Iteration
  always terminates.\<close>

abbreviation "r_min \<equiv> (\<Sqinter>s'. (\<Sqinter>a \<in> A s'. r (s', a)))"
definition "v0_mpi s = r_min / (1 - l)"

lift_definition v0_mpi\<^sub>b :: "'s \<Rightarrow>\<^sub>b real" is "v0_mpi"
  by (auto simp: v0_mpi_def)

lemma v0_mpi\<^sub>b_le_\<L>\<^sub>b: "v0_mpi\<^sub>b \<le> \<L>\<^sub>b v0_mpi\<^sub>b"
proof (rule less_eq_bfunI)
  fix x
  have bounded_r': "bounded ((\<lambda>a. r (x, a)) ` A x)" for x
    using r_bounded'
    unfolding bounded_def
    by simp (meson UNIV_I)
  have *: "(\<Sqinter>a\<in>A x. r (x, a)) \<le> r (x,a)" if "a \<in> A x" for  a x
    using  bounded_r' that
    by (auto intro!: cInf_lower bounded_imp_bdd_below)
  have ****: "r (s,a) \<le> r\<^sub>M" for s a
    using abs_le_iff abs_r_le_r\<^sub>M by blast
  have **: "bounded (range (\<lambda>s'. \<Sqinter>a\<in>A s'. r (s', a)))"
    using abs_r_le_r\<^sub>M  ex_dec_det is_dec_det_def A_ne
    by (auto simp add: minus_le_iff abs_le_iff intro!: cINF_greatest order.trans[OF *]  boundedI[of _ "r\<^sub>M"])
  have "r_min \<le> r (s, a)" if "a \<in> A s" for s a
    using  r_bounded' that **
    by (auto intro!: bounded_imp_bdd_below cInf_lower2[OF _ *])

    hence "r_min \<le> (1-l) * r (s, a) + l * r_min" if "a \<in> A s" for s a
    using disc_lt_one zero_le_disc that by (meson order_less_imp_le order_refl segment_bound_lemma)
  hence "r_min / (1 - l) \<le> ((1-l) * r (s, a) + l * r_min) / (1 - l)" if "a \<in> A s" for s a
    using order_less_imp_le[OF disc_lt_one] that  by (auto intro!: divide_right_mono)
  hence "r_min / (1 - l) \<le> r (s, a) + (l * r_min) / (1 - l)" if "a \<in> A s" for s a
    using disc_lt_one that by (auto simp: add_divide_distrib)
  hence "r_min / (1 - l) \<le> L\<^sub>a (arb_act (A x)) (\<lambda>s. r_min / (1 - l)) x"
    using A_ne arb_act_in by auto
  moreover have "bdd_above ((\<lambda>a. L\<^sub>a a (\<lambda>s. r_min / (1 - l)) x) ` A x)"
    using r_bounded
    by (fastforce simp: bounded_def intro!: bounded_imp_bdd_above bounded_plus_comp)
  ultimately show "v0_mpi\<^sub>b x \<le> \<L>\<^sub>b v0_mpi\<^sub>b x"
    unfolding \<L>\<^sub>b_eq_SUP_L\<^sub>a' v0_mpi\<^sub>b.rep_eq v0_mpi_def by (auto simp: A_ne intro!: cSUP_upper2)
qed

subsection \<open>An Instance of Modified Policy Iteration with a Valid Conservative Initial Value Estimate\<close>
definition "mpi_user eps m = (
  if eps \<le> 0 then undefined else mpi_algo eps (\<lambda>x. arb_act (A x)) v0_mpi\<^sub>b m)"

lemma mpi_user_eq:
  assumes "eps > 0"
  shows "mpi_user eps = mpi_alg_rec eps (\<lambda>x. arb_act (A x)) v0_mpi\<^sub>b"
  using v0_mpi\<^sub>b_le_\<L>\<^sub>b assms
  by (auto simp: mpi_user_def mpi_algo_def' A_ne is_dec_det_def)

lemma mpi_user_opt:
  assumes "eps > 0"
  shows "dist (\<nu>\<^sub>b (mk_stationary_det (fst (mpi_user eps n)))) \<nu>\<^sub>b_opt < eps"
  unfolding mpi_user_def using assms
  by (auto intro: mpi_algo_opt simp: is_dec_det_def A_ne v0_mpi\<^sub>b_le_\<L>\<^sub>b)
end

end


section \<open> Bounded Lists \<close>

theory Bounded_List
  imports "List_Extra" "HOL-Library.Numeral_Type"
begin

text \<open> The term @{term "CARD('n)"} retrieves the cardinality of a finite type @{typ 'n}. Examples
  include the types @{typ 1}, @{typ 2} and @{typ 3}.\<close>

typedef ('a, 'n::finite) blist = "{xs :: 'a list. length xs \<le> CARD('n)}"
  morphisms list_of_blist blist_of_list
  by (rule_tac x="[]" in exI, auto)

declare list_of_blist_inverse [simp]

syntax "_blist" :: "type \<Rightarrow> type \<Rightarrow> type" ("_ blist[_]" [100, 0] 100)
translations (type) "'a blist['n]" == (type) "('a, 'n) blist"

text \<open> We construct various functions using the lifting package to lift corresponding list functions. \<close>

setup_lifting type_definition_blist

lift_definition blength :: "'a blist['n::finite] \<Rightarrow> nat" is length .

lift_definition bnth :: "'a blist['n::finite] \<Rightarrow> nat \<Rightarrow> 'a" is nth .

lift_definition bappend :: "'a blist['m::finite] \<Rightarrow> 'a blist['n::finite] \<Rightarrow> 'a blist['m + 'n]" (infixr "@\<^sub>s" 65) is append
  by auto

lift_definition bmake :: "'n itself \<Rightarrow> 'a list \<Rightarrow> 'a blist['n::finite]" is "\<lambda> _. take CARD('n)"
  by auto

code_datatype bmake

lemma bmake_length_card:
  "blength (bmake TYPE('n::finite) xs) = (if length xs \<le> CARD('n) then length xs else CARD('n))"
  apply (simp add: blength_def bmake_def, auto)
  by (simp add: blist_of_list_inverse)+

lemma blist_always_bounded:
  "length (list_of_blist (bl::'a blist['n::finite])) \<le> CARD('n)"
  using list_of_blist by blast

lemma blist_remove_head:
  fixes bl :: "'a blist['n::finite]"
  assumes "blength bl > 0"
  shows "blength (bmake TYPE('n::finite) (tl (list_of_blist (bl::'a blist['n::finite])))) < blength bl"
  by (metis One_nat_def Suc_pred assms blength.rep_eq bmake_length_card length_tl less_Suc_eq_le linear)

text \<open> This proof is performed by transfer \<close>

lemma bappend_bmake [code]:
  "bmake TYPE('a::finite) xs @\<^sub>s bmake TYPE('b::finite) ys
    = bmake TYPE('a + 'b) (take CARD('a) xs @ take CARD('b) ys)"
  by (transfer, simp add: min.absorb2)

instantiation blist :: (type, finite) equal
begin

definition equal_blist :: "'a blist['b] \<Rightarrow> 'a blist['b] \<Rightarrow> bool" where
"equal_blist m1 m2 \<longleftrightarrow> (list_of_blist m1 = list_of_blist m2)"

instance by (intro_classes, auto simp add: equal_blist_def, transfer, auto)
end

lemma list_of_blist_code [code]:
  "list_of_blist (bmake TYPE('n::finite) xs) = take CARD('n) xs"
  by (transfer, simp)+

definition blists :: "'n::finite itself \<Rightarrow> 'a list \<Rightarrow> ('a blist['n]) list" where
"blists n xs = map blist_of_list (b_lists CARD('n) xs)"

lemma n_blists_as_b_lists:
  fixes n::"'n::finite itself"
  shows "map list_of_blist (blists n xs) = b_lists CARD('n) xs" (is "?lhs = ?rhs")
proof -
  have "?lhs = map (list_of_blist \<circ> (blist_of_list :: _ \<Rightarrow> _ blist['n])) (b_lists CARD('n) xs)"
    by (simp add: blists_def)
  also have "... = map id (b_lists CARD('n) xs)"
    by (rule map_cong, auto simp add: blist_of_list_inverse length_b_lists_elem)
  also have "... = b_lists CARD('n) xs"
    by simp
  finally show ?thesis .
qed

lemma set_blists_enum_UNIV: "set (blists TYPE('n::finite) enum_class.enum) = UNIV"
  apply (auto simp add: blists_def image_iff)
  apply (rule_tac x="list_of_blist x" in bexI, auto)
  apply (rule in_blistsI)
   apply (simp add: blist_always_bounded)
  apply (auto simp add: lists_eq_set enum_UNIV)
  done

lemma distinct_blists: "distinct xs \<Longrightarrow> distinct (blists n xs)"
  by (metis distinct_b_lists distinct_map n_blists_as_b_lists)

definition all_blists :: "(('a::enum) blist['n::finite] \<Rightarrow> bool) \<Rightarrow> bool"
where
  "all_blists P \<longleftrightarrow> (\<forall>xs \<in> set (blists TYPE('n) Enum.enum). P xs)"

definition ex_blists :: "(('a :: enum) blist['n::finite] \<Rightarrow> bool) \<Rightarrow> bool"
where
  "ex_blists P \<longleftrightarrow> (\<exists>xs \<in> set (blists TYPE('n) Enum.enum). P xs)"

instantiation blist :: (enum, finite) enum
begin

definition enum_blist :: "('a blist['b]) list" where
"enum_blist = blists TYPE('b) Enum.enum"

definition enum_all_blist :: "('a blist['b] \<Rightarrow> bool) \<Rightarrow> bool" where
"enum_all_blist P = all_blists P"

definition enum_ex_blist :: "('a blist['b] \<Rightarrow> bool) \<Rightarrow> bool" where
"enum_ex_blist P = ex_blists P"

instance
  by (intro_classes)
     (simp_all add: enum_blist_def set_blists_enum_UNIV distinct_blists enum_distinct enum_all_blist_def enum_ex_blist_def all_blists_def ex_blists_def)

end

end


(*  Title:      HOL/UNITY/ProgressSets.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2003  University of Cambridge

Progress Sets.  From

    David Meier and Beverly Sanders,
    Composing Leads-to Properties
    Theoretical Computer Science 243:1-2 (2000), 339-361.

    David Meier,
    Progress Properties in Program Refinement and Parallel Composition
    Swiss Federal Institute of Technology Zurich (1997)
*)

section\<open>Progress Sets\<close>

theory ProgressSets imports Transformers begin

subsection \<open>Complete Lattices and the Operator @{term cl}\<close>

definition lattice :: "'a set set => bool" where
   \<comment>\<open>Meier calls them closure sets, but they are just complete lattices\<close>
   "lattice L ==
         (\<forall>M. M \<subseteq> L --> \<Inter>M \<in> L) & (\<forall>M. M \<subseteq> L --> \<Union>M \<in> L)"

definition cl :: "['a set set, 'a set] => 'a set" where
   \<comment>\<open>short for ``closure''\<close>
   "cl L r == \<Inter>{x. x\<in>L & r \<subseteq> x}"

lemma UNIV_in_lattice: "lattice L ==> UNIV \<in> L"
by (force simp add: lattice_def)

lemma empty_in_lattice: "lattice L ==> {} \<in> L"
by (force simp add: lattice_def)

lemma Union_in_lattice: "[|M \<subseteq> L; lattice L|] ==> \<Union>M \<in> L"
by (simp add: lattice_def)

lemma Inter_in_lattice: "[|M \<subseteq> L; lattice L|] ==> \<Inter>M \<in> L"
by (simp add: lattice_def)

lemma UN_in_lattice:
     "[|lattice L; !!i. i\<in>I ==> r i \<in> L|] ==> (\<Union>i\<in>I. r i) \<in> L"
apply (blast intro: Union_in_lattice)
done

lemma INT_in_lattice:
     "[|lattice L; !!i. i\<in>I ==> r i \<in> L|] ==> (\<Inter>i\<in>I. r i)  \<in> L"
apply (blast intro: Inter_in_lattice)
done

lemma Un_in_lattice: "[|x\<in>L; y\<in>L; lattice L|] ==> x\<union>y \<in> L"
  using Union_in_lattice [of "{x, y}" L] by simp

lemma Int_in_lattice: "[|x\<in>L; y\<in>L; lattice L|] ==> x\<inter>y \<in> L"
  using Inter_in_lattice [of "{x, y}" L] by simp

lemma lattice_stable: "lattice {X. F \<in> stable X}"
by (simp add: lattice_def stable_def constrains_def, blast)

text\<open>The next three results state that @{term "cl L r"} is the minimal
 element of @{term L} that includes @{term r}.\<close>
lemma cl_in_lattice: "lattice L ==> cl L r \<in> L"
apply (simp add: lattice_def cl_def)
apply (erule conjE)
apply (drule spec, erule mp, blast)
done

lemma cl_least: "[|c\<in>L; r\<subseteq>c|] ==> cl L r \<subseteq> c"
by (force simp add: cl_def)

text\<open>The next three lemmas constitute assertion (4.61)\<close>
lemma cl_mono: "r \<subseteq> r' ==> cl L r \<subseteq> cl L r'"
by (simp add: cl_def, blast)

lemma subset_cl: "r \<subseteq> cl L r"
by (simp add: cl_def le_Inf_iff)

text\<open>A reformulation of @{thm subset_cl}\<close>
lemma clI: "x \<in> r ==> x \<in> cl L r"
by (simp add: cl_def, blast)

text\<open>A reformulation of @{thm cl_least}\<close>
lemma clD: "[|c \<in> cl L r; B \<in> L; r \<subseteq> B|] ==> c \<in> B"
by (force simp add: cl_def)

lemma cl_UN_subset: "(\<Union>i\<in>I. cl L (r i)) \<subseteq> cl L (\<Union>i\<in>I. r i)"
by (simp add: cl_def, blast)

lemma cl_Un: "lattice L ==> cl L (r\<union>s) = cl L r \<union> cl L s"
apply (rule equalityI)
 prefer 2
  apply (simp add: cl_def, blast)
apply (rule cl_least)
 apply (blast intro: Un_in_lattice cl_in_lattice)
apply (blast intro: subset_cl [THEN subsetD])
done

lemma cl_UN: "lattice L ==> cl L (\<Union>i\<in>I. r i) = (\<Union>i\<in>I. cl L (r i))"
apply (rule equalityI)
 prefer 2 apply (simp add: cl_def, blast)
apply (rule cl_least)
 apply (blast intro: UN_in_lattice cl_in_lattice)
apply (blast intro: subset_cl [THEN subsetD])
done

lemma cl_Int_subset: "cl L (r\<inter>s) \<subseteq> cl L r \<inter> cl L s"
by (simp add: cl_def, blast)

lemma cl_idem [simp]: "cl L (cl L r) = cl L r"
by (simp add: cl_def, blast)

lemma cl_ident: "r\<in>L ==> cl L r = r"
by (force simp add: cl_def)

lemma cl_empty [simp]: "lattice L ==> cl L {} = {}"
by (simp add: cl_ident empty_in_lattice)

lemma cl_UNIV [simp]: "lattice L ==> cl L UNIV = UNIV"
by (simp add: cl_ident UNIV_in_lattice)

text\<open>Assertion (4.62)\<close>
lemma cl_ident_iff: "lattice L ==> (cl L r = r) = (r\<in>L)"
apply (rule iffI)
 apply (erule subst)
 apply (erule cl_in_lattice)
apply (erule cl_ident)
done

lemma cl_subset_in_lattice: "[|cl L r \<subseteq> r; lattice L|] ==> r\<in>L"
by (simp add: cl_ident_iff [symmetric] equalityI subset_cl)

subsection \<open>Progress Sets and the Main Lemma\<close>
text\<open>A progress set satisfies certain closure conditions and is a
simple way of including the set @{term "wens_set F B"}.\<close>

definition closed :: "['a program, 'a set, 'a set,  'a set set] => bool" where
   "closed F T B L == \<forall>M. \<forall>act \<in> Acts F. B\<subseteq>M & T\<inter>M \<in> L -->
                              T \<inter> (B \<union> wp act M) \<in> L"

definition progress_set :: "['a program, 'a set, 'a set] => 'a set set set" where
   "progress_set F T B ==
      {L. lattice L & B \<in> L & T \<in> L & closed F T B L}"

lemma closedD:
   "[|closed F T B L; act \<in> Acts F; B\<subseteq>M; T\<inter>M \<in> L|]
    ==> T \<inter> (B \<union> wp act M) \<in> L"
by (simp add: closed_def)

text\<open>Note: the formalization below replaces Meier's @{term q} by @{term B}
and @{term m} by @{term X}.\<close>

text\<open>Part of the proof of the claim at the bottom of page 97.  It's
proved separately because the argument requires a generalization over
all @{term "act \<in> Acts F"}.\<close>
lemma lattice_awp_lemma:
  assumes TXC:  "T\<inter>X \<in> C" \<comment>\<open>induction hypothesis in theorem below\<close>
      and BsubX:  "B \<subseteq> X"   \<comment>\<open>holds in inductive step\<close>
      and latt: "lattice C"
      and TC:   "T \<in> C"
      and BC:   "B \<in> C"
      and clos: "closed F T B C"
    shows "T \<inter> (B \<union> awp F (X \<union> cl C (T\<inter>r))) \<in> C"
apply (simp del: INT_simps add: awp_def INT_extend_simps)
apply (rule INT_in_lattice [OF latt])
apply (erule closedD [OF clos])
apply (simp add: subset_trans [OF BsubX Un_upper1])
apply (subgoal_tac "T \<inter> (X \<union> cl C (T\<inter>r)) = (T\<inter>X) \<union> cl C (T\<inter>r)")
 prefer 2 apply (blast intro: TC clD)
apply (erule ssubst)
apply (blast intro: Un_in_lattice latt cl_in_lattice TXC)
done

text\<open>Remainder of the proof of the claim at the bottom of page 97.\<close>
lemma lattice_lemma:
  assumes TXC:  "T\<inter>X \<in> C" \<comment>\<open>induction hypothesis in theorem below\<close>
      and BsubX:  "B \<subseteq> X"   \<comment>\<open>holds in inductive step\<close>
      and act:  "act \<in> Acts F"
      and latt: "lattice C"
      and TC:   "T \<in> C"
      and BC:   "B \<in> C"
      and clos: "closed F T B C"
    shows "T \<inter> (wp act X \<inter> awp F (X \<union> cl C (T\<inter>r)) \<union> X) \<in> C"
apply (subgoal_tac "T \<inter> (B \<union> wp act X) \<in> C")
 prefer 2 apply (simp add: closedD [OF clos] act BsubX TXC)
apply (drule Int_in_lattice
              [OF _ lattice_awp_lemma [OF TXC BsubX latt TC BC clos, of r]
                    latt])
apply (subgoal_tac
         "T \<inter> (B \<union> wp act X) \<inter> (T \<inter> (B \<union> awp F (X \<union> cl C (T\<inter>r)))) =
          T \<inter> (B \<union> wp act X \<inter> awp F (X \<union> cl C (T\<inter>r)))")
 prefer 2 apply blast
apply simp
apply (drule Un_in_lattice [OF _ TXC latt])
apply (subgoal_tac
         "T \<inter> (B \<union> wp act X \<inter> awp F (X \<union> cl C (T\<inter>r))) \<union> T\<inter>X =
          T \<inter> (wp act X \<inter> awp F (X \<union> cl C (T\<inter>r)) \<union> X)")
 apply simp
apply (blast intro: BsubX [THEN subsetD])
done

text\<open>Induction step for the main lemma\<close>
lemma progress_induction_step:
  assumes TXC:  "T\<inter>X \<in> C" \<comment>\<open>induction hypothesis in theorem below\<close>
      and act:  "act \<in> Acts F"
      and Xwens: "X \<in> wens_set F B"
      and latt: "lattice C"
      and  TC:  "T \<in> C"
      and  BC:  "B \<in> C"
      and clos: "closed F T B C"
      and Fstable: "F \<in> stable T"
  shows "T \<inter> wens F act X \<in> C"
proof -
  from Xwens have BsubX: "B \<subseteq> X"
    by (rule wens_set_imp_subset)
  let ?r = "wens F act X"
  have "?r \<subseteq> (wp act X \<inter> awp F (X\<union>?r)) \<union> X"
    by (simp add: wens_unfold [symmetric])
  then have "T\<inter>?r \<subseteq> T \<inter> ((wp act X \<inter> awp F (X\<union>?r)) \<union> X)"
    by blast
  then have "T\<inter>?r \<subseteq> T \<inter> ((wp act X \<inter> awp F (T \<inter> (X\<union>?r))) \<union> X)"
    by (simp add: awp_Int_eq Fstable stable_imp_awp_ident, blast)
  then have "T\<inter>?r \<subseteq> T \<inter> ((wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X)"
    by (blast intro: awp_mono [THEN [2] rev_subsetD] subset_cl [THEN subsetD])
  then have "cl C (T\<inter>?r) \<subseteq>
             cl C (T \<inter> ((wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X))"
    by (rule cl_mono)
  then have "cl C (T\<inter>?r) \<subseteq>
             T \<inter> ((wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X)"
    by (simp add: cl_ident lattice_lemma [OF TXC BsubX act latt TC BC clos])
  then have "cl C (T\<inter>?r) \<subseteq> (wp act X \<inter> awp F (X \<union> cl C (T\<inter>?r))) \<union> X"
    by blast
  then have "cl C (T\<inter>?r) \<subseteq> ?r"
    by (blast intro!: subset_wens)
  then have cl_subset: "cl C (T\<inter>?r) \<subseteq> T\<inter>?r"
    by (simp add: cl_ident TC
                  subset_trans [OF cl_mono [OF Int_lower1]])
  show ?thesis
    by (rule cl_subset_in_lattice [OF cl_subset latt])
qed

text\<open>Proved on page 96 of Meier's thesis.  The special case when
   @{term "T=UNIV"} states that every progress set for the program @{term F}
   and set @{term B} includes the set @{term "wens_set F B"}.\<close>
lemma progress_set_lemma:
     "[|C \<in> progress_set F T B; r \<in> wens_set F B; F \<in> stable T|] ==> T\<inter>r \<in> C"
apply (simp add: progress_set_def, clarify)
apply (erule wens_set.induct)
  txt\<open>Base\<close>
  apply (simp add: Int_in_lattice)
 txt\<open>The difficult @{term wens} case\<close>
 apply (simp add: progress_induction_step)
txt\<open>Disjunctive case\<close>
apply (subgoal_tac "(\<Union>U\<in>W. T \<inter> U) \<in> C")
 apply simp
apply (blast intro: UN_in_lattice)
done

subsection \<open>The Progress Set Union Theorem\<close>

lemma closed_mono:
  assumes BB':  "B \<subseteq> B'"
      and TBwp: "T \<inter> (B \<union> wp act M) \<in> C"
      and B'C:  "B' \<in> C"
      and TC:   "T \<in> C"
      and latt: "lattice C"
  shows "T \<inter> (B' \<union> wp act M) \<in> C"
proof -
  from TBwp have "(T\<inter>B) \<union> (T \<inter> wp act M) \<in> C"
    by (simp add: Int_Un_distrib)
  then have TBBC: "(T\<inter>B') \<union> ((T\<inter>B) \<union> (T \<inter> wp act M)) \<in> C"
    by (blast intro: Int_in_lattice Un_in_lattice TC B'C latt)
  show ?thesis
    by (rule eqelem_imp_iff [THEN iffD1, OF _ TBBC],
        blast intro: BB' [THEN subsetD])
qed

lemma progress_set_mono:
    assumes BB':  "B \<subseteq> B'"
    shows
     "[| B' \<in> C;  C \<in> progress_set F T B|]
      ==> C \<in> progress_set F T B'"
by (simp add: progress_set_def closed_def closed_mono [OF BB']
                 subset_trans [OF BB'])

theorem progress_set_Union:
  assumes leadsTo: "F \<in> A leadsTo B'"
      and prog: "C \<in> progress_set F T B"
      and Fstable: "F \<in> stable T"
      and BB':  "B \<subseteq> B'"
      and B'C:  "B' \<in> C"
      and Gco: "!!X. X\<in>C ==> G \<in> X-B co X"
  shows "F\<squnion>G \<in> T\<inter>A leadsTo B'"
apply (insert prog Fstable)
apply (rule leadsTo_Join [OF leadsTo])
  apply (force simp add: progress_set_def awp_iff_stable [symmetric])
apply (simp add: awp_iff_constrains)
apply (drule progress_set_mono [OF BB' B'C])
apply (blast intro: progress_set_lemma Gco constrains_weaken_L
                    BB' [THEN subsetD])
done

subsection \<open>Some Progress Sets\<close>

lemma UNIV_in_progress_set: "UNIV \<in> progress_set F T B"
by (simp add: progress_set_def lattice_def closed_def)

subsubsection \<open>Lattices and Relations\<close>
text\<open>From Meier's thesis, section 4.5.3\<close>

definition relcl :: "'a set set => ('a * 'a) set" where
    \<comment> \<open>Derived relation from a lattice\<close>
    "relcl L == {(x,y). y \<in> cl L {x}}"

definition latticeof :: "('a * 'a) set => 'a set set" where
    \<comment> \<open>Derived lattice from a relation: the set of upwards-closed sets\<close>
    "latticeof r == {X. \<forall>s t. s \<in> X & (s,t) \<in> r --> t \<in> X}"

lemma relcl_refl: "(a,a) \<in> relcl L"
by (simp add: relcl_def subset_cl [THEN subsetD])

lemma relcl_trans:
     "[| (a,b) \<in> relcl L; (b,c) \<in> relcl L; lattice L |] ==> (a,c) \<in> relcl L"
apply (simp add: relcl_def)
apply (blast intro: clD cl_in_lattice)
done

lemma refl_relcl: "lattice L ==> refl (relcl L)"
by (simp add: refl_onI relcl_def subset_cl [THEN subsetD])

lemma trans_relcl: "lattice L ==> trans (relcl L)"
by (blast intro: relcl_trans transI)

lemma lattice_latticeof: "lattice (latticeof r)"
by (auto simp add: lattice_def latticeof_def)

lemma lattice_singletonI:
     "[|lattice L; !!s. s \<in> X ==> {s} \<in> L|] ==> X \<in> L"
apply (cut_tac UN_singleton [of X])
apply (erule subst)
apply (simp only: UN_in_lattice)
done

text\<open>Equation (4.71) of Meier's thesis.  He gives no proof.\<close>
lemma cl_latticeof:
     "[|refl r; trans r|]
      ==> cl (latticeof r) X = {t. \<exists>s. s\<in>X & (s,t) \<in> r}"
apply (rule equalityI)
 apply (rule cl_least)
  apply (simp (no_asm_use) add: latticeof_def trans_def, blast)
 apply (simp add: latticeof_def refl_on_def, blast)
apply (simp add: latticeof_def, clarify)
apply (unfold cl_def, blast)
done

text\<open>Related to (4.71).\<close>
lemma cl_eq_Collect_relcl:
     "lattice L ==> cl L X = {t. \<exists>s. s\<in>X & (s,t) \<in> relcl L}"
apply (cut_tac UN_singleton [of X])
apply (erule subst)
apply (force simp only: relcl_def cl_UN)
done

text\<open>Meier's theorem of section 4.5.3\<close>
theorem latticeof_relcl_eq: "lattice L ==> latticeof (relcl L) = L"
apply (rule equalityI)
 prefer 2 apply (force simp add: latticeof_def relcl_def cl_def, clarify)
apply (rename_tac X)
apply (rule cl_subset_in_lattice)
 prefer 2 apply assumption
apply (drule cl_ident_iff [OF lattice_latticeof, THEN iffD2])
apply (drule equalityD1)
apply (rule subset_trans)
 prefer 2 apply assumption
apply (thin_tac "_ \<subseteq> X")
apply (cut_tac A=X in UN_singleton)
apply (erule subst)
apply (simp only: cl_UN lattice_latticeof
                  cl_latticeof [OF refl_relcl trans_relcl])
apply (simp add: relcl_def)
done

theorem relcl_latticeof_eq:
     "[|refl r; trans r|] ==> relcl (latticeof r) = r"
by (simp add: relcl_def cl_latticeof)

subsubsection \<open>Decoupling Theorems\<close>

definition decoupled :: "['a program, 'a program] => bool" where
   "decoupled F G ==
        \<forall>act \<in> Acts F. \<forall>B. G \<in> stable B --> G \<in> stable (wp act B)"

text\<open>Rao's Decoupling Theorem\<close>
lemma stableco: "F \<in> stable A ==> F \<in> A-B co A"
by (simp add: stable_def constrains_def, blast)

theorem decoupling:
  assumes leadsTo: "F \<in> A leadsTo B"
      and Gstable: "G \<in> stable B"
      and dec:     "decoupled F G"
  shows "F\<squnion>G \<in> A leadsTo B"
proof -
  have prog: "{X. G \<in> stable X} \<in> progress_set F UNIV B"
    by (simp add: progress_set_def lattice_stable Gstable closed_def
                  stable_Un [OF Gstable] dec [unfolded decoupled_def])
  have "F\<squnion>G \<in> (UNIV\<inter>A) leadsTo B"
    by (rule progress_set_Union [OF leadsTo prog],
        simp_all add: Gstable stableco)
  thus ?thesis by simp
qed

text\<open>Rao's Weak Decoupling Theorem\<close>
theorem weak_decoupling:
  assumes leadsTo: "F \<in> A leadsTo B"
      and stable: "F\<squnion>G \<in> stable B"
      and dec:     "decoupled F (F\<squnion>G)"
  shows "F\<squnion>G \<in> A leadsTo B"
proof -
  have prog: "{X. F\<squnion>G \<in> stable X} \<in> progress_set F UNIV B"
    by (simp del: Join_stable
             add: progress_set_def lattice_stable stable closed_def
                  stable_Un [OF stable] dec [unfolded decoupled_def])
  have "F\<squnion>G \<in> (UNIV\<inter>A) leadsTo B"
    by (rule progress_set_Union [OF leadsTo prog],
        simp_all del: Join_stable add: stable,
        simp add: stableco)
  thus ?thesis by simp
qed

text\<open>The ``Decoupling via @{term G'} Union Theorem''\<close>
theorem decoupling_via_aux:
  assumes leadsTo: "F \<in> A leadsTo B"
      and prog: "{X. G' \<in> stable X} \<in> progress_set F UNIV B"
      and GG':  "G \<le> G'"
               \<comment>\<open>Beware!  This is the converse of the refinement relation!\<close>
  shows "F\<squnion>G \<in> A leadsTo B"
proof -
  from prog have stable: "G' \<in> stable B"
    by (simp add: progress_set_def)
  have "F\<squnion>G \<in> (UNIV\<inter>A) leadsTo B"
    by (rule progress_set_Union [OF leadsTo prog],
        simp_all add: stable stableco component_stable [OF GG'])
  thus ?thesis by simp
qed

subsection\<open>Composition Theorems Based on Monotonicity and Commutativity\<close>

subsubsection\<open>Commutativity of @{term "cl L"} and assignment.\<close>
definition commutes :: "['a program, 'a set, 'a set,  'a set set] => bool" where
   "commutes F T B L ==
       \<forall>M. \<forall>act \<in> Acts F. B \<subseteq> M -->
           cl L (T \<inter> wp act M) \<subseteq> T \<inter> (B \<union> wp act (cl L (T\<inter>M)))"

text\<open>From Meier's thesis, section 4.5.6\<close>
lemma commutativity1_lemma:
  assumes commutes: "commutes F T B L"
      and lattice:  "lattice L"
      and BL: "B \<in> L"
      and TL: "T \<in> L"
  shows "closed F T B L"
apply (simp add: closed_def, clarify)
apply (rule ProgressSets.cl_subset_in_lattice [OF _ lattice])
apply (simp add: Int_Un_distrib cl_Un [OF lattice]
                 cl_ident Int_in_lattice [OF TL BL lattice] Un_upper1)
apply (subgoal_tac "cl L (T \<inter> wp act M) \<subseteq> T \<inter> (B \<union> wp act (cl L (T \<inter> M)))")
 prefer 2
 apply (cut_tac commutes, simp add: commutes_def)
apply (erule subset_trans)
apply (simp add: cl_ident)
apply (blast intro: rev_subsetD [OF _ wp_mono])
done

text\<open>Version packaged with @{thm progress_set_Union}\<close>
lemma commutativity1:
  assumes leadsTo: "F \<in> A leadsTo B"
      and lattice:  "lattice L"
      and BL: "B \<in> L"
      and TL: "T \<in> L"
      and Fstable: "F \<in> stable T"
      and Gco: "!!X. X\<in>L ==> G \<in> X-B co X"
      and commutes: "commutes F T B L"
  shows "F\<squnion>G \<in> T\<inter>A leadsTo B"
by (rule progress_set_Union [OF leadsTo _ Fstable subset_refl BL Gco],
    simp add: progress_set_def commutativity1_lemma commutes lattice BL TL)

text\<open>Possibly move to Relation.thy, after @{term single_valued}\<close>
definition funof :: "[('a*'b)set, 'a] => 'b" where
   "funof r == (\<lambda>x. THE y. (x,y) \<in> r)"

lemma funof_eq: "[|single_valued r; (x,y) \<in> r|] ==> funof r x = y"
by (simp add: funof_def single_valued_def, blast)

lemma funof_Pair_in:
     "[|single_valued r; x \<in> Domain r|] ==> (x, funof r x) \<in> r"
by (force simp add: funof_eq)

lemma funof_in:
     "[|r``{x} \<subseteq> A; single_valued r; x \<in> Domain r|] ==> funof r x \<in> A"
by (force simp add: funof_eq)

lemma funof_imp_wp: "[|funof act t \<in> A; single_valued act|] ==> t \<in> wp act A"
by (force simp add: in_wp_iff funof_eq)

subsubsection\<open>Commutativity of Functions and Relation\<close>
text\<open>Thesis, page 109\<close>

(*FIXME: this proof is still an ungodly mess*)
text\<open>From Meier's thesis, section 4.5.6\<close>
lemma commutativity2_lemma:
  assumes dcommutes:
      "\<And>act s t. act \<in> Acts F \<Longrightarrow> s \<in> T \<Longrightarrow> (s, t) \<in> relcl L \<Longrightarrow>
        s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L"
    and determ: "!!act. act \<in> Acts F ==> single_valued act"
    and total: "!!act. act \<in> Acts F ==> Domain act = UNIV"
    and lattice:  "lattice L"
    and BL: "B \<in> L"
    and TL: "T \<in> L"
    and Fstable: "F \<in> stable T"
  shows  "commutes F T B L"
proof -
  { fix M and act and t
    assume 1: "B \<subseteq> M" "act \<in> Acts F" "t \<in> cl L (T \<inter> wp act M)"
    then have "\<exists>s. (s,t) \<in> relcl L \<and> s \<in> T \<inter> wp act M"
      by (force simp add: cl_eq_Collect_relcl [OF lattice])
    then obtain s where 2: "(s, t) \<in> relcl L" "s \<in> T" "s \<in> wp act M"
      by blast
    then have 3: "\<forall>u\<in>L. s \<in> u --> t \<in> u"
      apply (intro ballI impI)
      apply (subst cl_ident [symmetric], assumption)
      apply (simp add: relcl_def)
      apply (blast intro: cl_mono [THEN [2] rev_subsetD])
      done
    with 1 2 Fstable have 4: "funof act s \<in> T\<inter>M"
      by (force intro!: funof_in
        simp add: wp_def stable_def constrains_def determ total)
    with 1 2 3 have 5: "s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L"
      by (intro dcommutes) assumption+
    with 1 2 3 4 have "t \<in> B | funof act t \<in> cl L (T\<inter>M)"
      by (simp add: relcl_def) (blast intro: BL cl_mono [THEN [2] rev_subsetD])
    with 1 2 3 4 5 have "t \<in> B | t \<in> wp act (cl L (T\<inter>M))"
      by (blast intro: funof_imp_wp determ)
    with 2 3 have "t \<in> T \<and> (t \<in> B \<or> t \<in> wp act (cl L (T \<inter> M)))"
      by (blast intro: TL cl_mono [THEN [2] rev_subsetD])
    then have"t \<in> T \<inter> (B \<union> wp act (cl L (T \<inter> M)))"
      by simp
  }
  then show "commutes F T B L" unfolding commutes_def by clarify
qed

text\<open>Version packaged with @{thm progress_set_Union}\<close>
lemma commutativity2:
  assumes leadsTo: "F \<in> A leadsTo B"
      and dcommutes:
        "\<forall>act \<in> Acts F.
         \<forall>s \<in> T. \<forall>t. (s,t) \<in> relcl L -->
                      s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L"
      and determ: "!!act. act \<in> Acts F ==> single_valued act"
      and total: "!!act. act \<in> Acts F ==> Domain act = UNIV"
      and lattice:  "lattice L"
      and BL: "B \<in> L"
      and TL: "T \<in> L"
      and Fstable: "F \<in> stable T"
      and Gco: "!!X. X\<in>L ==> G \<in> X-B co X"
  shows "F\<squnion>G \<in> T\<inter>A leadsTo B"
apply (rule commutativity1 [OF leadsTo lattice])
apply (simp_all add: Gco commutativity2_lemma dcommutes determ total
                     lattice BL TL Fstable)
done

subsection \<open>Monotonicity\<close>
text\<open>From Meier's thesis, section 4.5.7, page 110\<close>
(*to be continued?*)

end


theory Experiments
imports Taylor_Models
begin

(* Performance tests on taylor models. We compute range bounds on a floatarith expression and
   compare the results and execution time of taylor models with standard interval arithmetic.
            n - The number of recursive subdivisions on the domain, i.e. a total of 2^n subdivision.
         prec - The floating point precision.
   expression - The floatarith expression used.
       domain - The domain we test on.
     tm_order - Order of the taylor models generated. *)
definition "n = 3"
definition "prec = 64"
definition "expression = (Add (Power (Cos (Var 0)) 2) (Power (Sin (Var 0)) 2))"
definition "domain = [Ivl 0 10]"
definition "tm_order = 7"

definition "test_ia (u::unit) = compute_bound_fa_via_ia prec n expression domain"
definition "test_tm (u::unit) = compute_bound_fa_via_tm' prec tm_order n expression domain"

ML \<open>val test_ia = @{code test_ia}\<close>
ML \<open>val test_tm = @{code test_tm}\<close>

value "test_ia ()"
value "test_tm ()"

ML \<open>Timing.timeit test_ia\<close>
ML \<open>Timing.timeit test_tm\<close>

(* The caprasse example from file thys/Affine_Arithmetic/Ex_Ineqs.thy in the AFP.  *)
definition "caprasse = (\<lambda>x1 x2 x3 x4::real.
  (- x1 * x3 * x3 * x3 + 4 * x2 * x3 * x3 * x4 +
    4 * x1 * x3 * x4 * x4 + 2 * x2 * x4 * x4 * x4 + 4 * x1 * x3 + 4 * x3 * x3 + - 10 * x2 * x4 +
    -10 * x4 * x4 + 2))"
definition "caprasse_fa =
  (floatarith.Add
       (floatarith.Add
         (floatarith.Add
           (floatarith.Add
             (floatarith.Add
               (floatarith.Add
                 (floatarith.Add
                   (floatarith.Add
                     (Mult (Mult (Mult (Minus (Var 0)) (Var (Suc (Suc 0))))
                             (Var (Suc (Suc 0))))
                       (Var (Suc (Suc 0))))
                     (Mult (Mult (Mult (Mult (Num (Float 4 0)) (Var (Suc 0))) (Var (Suc (Suc 0))))
                             (Var (Suc (Suc 0))))
                       (Var 3)))
                   (Mult (Mult (Mult (Mult (Num (Float 4 0)) (Var 0)) (Var (Suc (Suc 0))))
                           (Var 3))
                     (Var 3)))
                 (Mult (Mult (Mult (Mult (Num (Float 2 0)) (Var (Suc 0))) (Var 3)) (Var 3)) (Var 3)))
               (Mult (Mult (Num (Float 4 0)) (Var 0)) (Var (Suc (Suc 0)))))
             (Mult (Mult (Num (Float 4 0)) (Var (Suc (Suc 0)))) (Var (Suc (Suc 0)))))
           (Mult (Mult (Minus (Num (Float 10 0))) (Var (Suc 0))) (Var 3)))
         (Mult (Mult (Minus (Num (Float 10 0))) (Var 3)) (Var 3)))
       (Num (Float 2 0)))
"

lemma "interpret_floatarith caprasse_fa [x\<^sub>1, x\<^sub>2, x\<^sub>3, x\<^sub>4] = caprasse x\<^sub>1 x\<^sub>2 x\<^sub>3 x\<^sub>4"
by (simp add: caprasse_fa_def caprasse_def power2_eq_square)

definition "domain2 = (\<lambda>d. [d, d, d, d]) (Ivl (-10) 10)"

definition "test_ia2 (u::unit) = compute_bound_fa_via_ia prec n caprasse_fa domain2"
definition "test_tm2 (u::unit) = compute_bound_fa_via_tm' prec tm_order n caprasse_fa domain2"

ML \<open>val test_ia2 = @{code test_ia2}\<close>
ML \<open>val test_tm2 = @{code test_tm2}\<close>

value "test_ia2 ()"
value "test_tm2 ()"

ML \<open>Timing.timeit test_ia2\<close>
ML \<open>Timing.timeit test_tm2\<close>

end


section {* Relators *}
theory Relators
imports "../Lib/Refine_Lib"
begin

text {*
  We define the concept of relators. The relation between a concrete type and
  an abstract type is expressed by a relation of type @{text "('c\<times>'a) set"}.
  For each composed type, say @{text "'a list"}, we can define a {\em relator},
  that takes as argument a relation for the element type, and returns a relation
  for the list type. For most datatypes, there exists a {\em natural relator}.
  For algebraic datatypes, this is the relator that preserves the structure
  of the datatype, and changes the components. For example,
  @{text "list_rel::('c\<times>'a) set \<Rightarrow> ('c list\<times>'a list) set"} is the natural
  relator for lists.

  However, relators can also be used to change the representation, and thus
  relate an implementation with an abstract type. For example, the relator
  @{text "list_set_rel::('c\<times>'a) set \<Rightarrow> ('c list\<times>'a set) set"} relates lists
  with the set of their elements.

  In this theory, we define some basic notions for relators, and
  then define natural relators for all HOL-types, including the function type.
  For each relator, we also show a single-valuedness property, and initialize a
  solver for single-valued properties.
*}

subsection {* Basic Definitions *}

text {*
  For smoother handling of relator unification, we require relator arguments to
  be applied by a special operator, such that we avoid higher-order
  unification problems. We try to set up some syntax to make this more
  transparent, and give relators a type-like prefix-syntax.
*}

definition relAPP
  :: "(('c1\<times>'a1) set \<Rightarrow> _) \<Rightarrow> ('c1\<times>'a1) set \<Rightarrow> _"
  where "relAPP f x \<equiv> f x"

syntax "_rel_APP" :: "args \<Rightarrow> 'a \<Rightarrow> 'b" ("\<langle>_\<rangle>_" [0,900] 900)

translations
  "\<langle>x,xs\<rangle>R" == "\<langle>xs\<rangle>(CONST relAPP R x)"
  "\<langle>x\<rangle>R" == "CONST relAPP R x"

ML {*
  structure Refine_Relators_Thms = struct
    structure rel_comb_def_rules = Named_Thms (
      val name = @{binding refine_rel_defs}
      val description = "Refinement Framework: " ^
          "Relator definitions"
    );
  end
*}

setup Refine_Relators_Thms.rel_comb_def_rules.setup

subsection {* Basic HOL Relators *}
subsubsection {* Function *}
definition fun_rel where
  fun_rel_def_internal: "fun_rel A B \<equiv> { (f,f'). \<forall>(a,a')\<in>A. (f a, f' a')\<in>B }"
abbreviation fun_rel_syn (infixr "\<rightarrow>" 60) where "A\<rightarrow>B \<equiv> \<langle>A,B\<rangle>fun_rel"

lemma fun_rel_def[refine_rel_defs]:
  "A\<rightarrow>B \<equiv> { (f,f'). \<forall>(a,a')\<in>A. (f a, f' a')\<in>B }"
  by (simp add: relAPP_def fun_rel_def_internal)

lemma fun_relI[intro!]: "\<lbrakk>\<And>a a'. (a,a')\<in>A \<Longrightarrow> (f a,f' a')\<in>B\<rbrakk> \<Longrightarrow> (f,f')\<in>A\<rightarrow>B"
  by (auto simp: fun_rel_def)

lemma fun_relD:
  shows " ((f,f')\<in>(A\<rightarrow>B)) \<Longrightarrow>
  (\<And>x x'. \<lbrakk> (x,x')\<in>A \<rbrakk> \<Longrightarrow> (f x, f' x')\<in>B)"
  apply rule
  by (auto simp: fun_rel_def)

lemma fun_relD1:
  assumes "(f,f')\<in>Ra\<rightarrow>Rr"
  assumes "f x = r"
  shows "\<forall>x'. (x,x')\<in>Ra \<longrightarrow> (r,f' x')\<in>Rr"
  using assms by (auto simp: fun_rel_def)

lemma fun_relD2:
  assumes "(f,f')\<in>Ra\<rightarrow>Rr"
  assumes "f' x' = r'"
  shows "\<forall>x. (x,x')\<in>Ra \<longrightarrow> (f x,r')\<in>Rr"
  using assms by (auto simp: fun_rel_def)

lemma fun_relE1:
  assumes "(f,f')\<in>Id \<rightarrow> Rv"
  assumes "t' = f' x"
  shows "(f x,t')\<in>Rv" using assms
  by (auto elim: fun_relD)

lemma fun_relE2:
  assumes "(f,f')\<in>Id \<rightarrow> Rv"
  assumes "t = f x"
  shows "(t,f' x)\<in>Rv" using assms
  by (auto elim: fun_relD)

subsubsection {* Terminal Types *}
abbreviation unit_rel :: "(unit\<times>unit) set" where "unit_rel == Id"

abbreviation "nat_rel \<equiv> Id::(nat\<times>_) set"
abbreviation "int_rel \<equiv> Id::(int\<times>_) set"
abbreviation "bool_rel \<equiv> Id::(bool\<times>_) set"

subsubsection {* Product *}
definition prod_rel where
  prod_rel_def_internal: "prod_rel R1 R2
    \<equiv> { ((a,b),(a',b')) . (a,a')\<in>R1 \<and> (b,b')\<in>R2 }"

abbreviation prod_rel_syn (infixr "\<times>\<^sub>r" 70) where "a\<times>\<^sub>rb \<equiv> \<langle>a,b\<rangle>prod_rel"

lemma prod_rel_def[refine_rel_defs]:
  "(\<langle>R1,R2\<rangle>prod_rel) \<equiv> { ((a,b),(a',b')) . (a,a')\<in>R1 \<and> (b,b')\<in>R2 }"
  by (simp add: prod_rel_def_internal relAPP_def)

lemma prod_relI: "\<lbrakk>(a,a')\<in>R1; (b,b')\<in>R2\<rbrakk> \<Longrightarrow> ((a,b),(a',b'))\<in>\<langle>R1,R2\<rangle>prod_rel"
  by (auto simp: prod_rel_def)
lemma prod_relE:
  assumes "(p,p')\<in>\<langle>R1,R2\<rangle>prod_rel"
  obtains a b a' b' where "p=(a,b)" and "p'=(a',b')"
  and "(a,a')\<in>R1" and "(b,b')\<in>R2"
  using assms
  by (auto simp: prod_rel_def)

lemma prod_rel_simp[simp]:
  "((a,b),(a',b'))\<in>\<langle>R1,R2\<rangle>prod_rel \<longleftrightarrow> (a,a')\<in>R1 \<and> (b,b')\<in>R2"
  by (auto intro: prod_relI elim: prod_relE)

subsubsection {*Option*}
definition option_rel where
  option_rel_def_internal:
  "option_rel R \<equiv> { (Some a,Some a') | a a'. (a,a')\<in>R } \<union> {(None,None)}"

lemma option_rel_def[refine_rel_defs]:
  "\<langle>R\<rangle>option_rel \<equiv> { (Some a,Some a') | a a'. (a,a')\<in>R } \<union> {(None,None)}"
  by (simp add: option_rel_def_internal relAPP_def)

lemma option_relI:
  "(None,None)\<in>\<langle>R\<rangle> option_rel"
  "\<lbrakk> (a,a')\<in>R \<rbrakk> \<Longrightarrow> (Some a, Some a')\<in>\<langle>R\<rangle>option_rel"
  by (auto simp: option_rel_def)

lemma option_relE:
  assumes "(x,x')\<in>\<langle>R\<rangle>option_rel"
  obtains "x=None" and "x'=None"
  | a a' where "x=Some a" and "x'=Some a'" and "(a,a')\<in>R"
  using assms by (auto simp: option_rel_def)

lemma option_rel_simp[simp]:
  "(None,a)\<in>\<langle>R\<rangle>option_rel \<longleftrightarrow> a=None"
  "(c,None)\<in>\<langle>R\<rangle>option_rel \<longleftrightarrow> c=None"
  "(Some x,Some y)\<in>\<langle>R\<rangle>option_rel \<longleftrightarrow> (x,y)\<in>R"
  by (auto intro: option_relI elim: option_relE)

subsubsection {* Sum *}
definition sum_rel where sum_rel_def_internal:
  "sum_rel Rl Rr
   \<equiv> { (Inl a, Inl a') | a a'. (a,a')\<in>Rl } \<union>
     { (Inr a, Inr a') | a a'. (a,a')\<in>Rr }"

lemma sum_rel_def[refine_rel_defs]:
  "\<langle>Rl,Rr\<rangle>sum_rel \<equiv>
     { (Inl a, Inl a') | a a'. (a,a')\<in>Rl } \<union>
     { (Inr a, Inr a') | a a'. (a,a')\<in>Rr }"
  by (simp add: sum_rel_def_internal relAPP_def)

lemma sum_rel_simp[simp]:
  "\<And>a a'. (Inl a, Inl a') \<in> \<langle>Rl,Rr\<rangle>sum_rel \<longleftrightarrow> (a,a')\<in>Rl"
  "\<And>a a'. (Inr a, Inr a') \<in> \<langle>Rl,Rr\<rangle>sum_rel \<longleftrightarrow> (a,a')\<in>Rr"
  "\<And>a a'. (Inl a, Inr a') \<notin> \<langle>Rl,Rr\<rangle>sum_rel"
  "\<And>a a'. (Inr a, Inl a') \<notin> \<langle>Rl,Rr\<rangle>sum_rel"
  unfolding sum_rel_def by auto

lemma sum_relI:
  "(a,a')\<in>Rl \<Longrightarrow> (Inl a, Inl a') \<in> \<langle>Rl,Rr\<rangle>sum_rel"
  "(a,a')\<in>Rr \<Longrightarrow> (Inr a, Inr a') \<in> \<langle>Rl,Rr\<rangle>sum_rel"
  by simp_all

lemma sum_relE:
  assumes "(x,x')\<in>\<langle>Rl,Rr\<rangle>sum_rel"
  obtains
    l l' where "x=Inl l" and "x'=Inl l'" and "(l,l')\<in>Rl"
  | r r' where "x=Inr r" and "x'=Inr r'" and "(r,r')\<in>Rr"
  using assms by (auto simp: sum_rel_def)

subsubsection {* Lists *}
definition list_rel where list_rel_def_internal:
  "list_rel R \<equiv> {(l,l'). list_all2 (\<lambda>x x'. (x,x')\<in>R) l l'}"

lemma list_rel_def[refine_rel_defs]:
  "\<langle>R\<rangle>list_rel \<equiv> {(l,l'). list_all2 (\<lambda>x x'. (x,x')\<in>R) l l'}"
  by (simp add: list_rel_def_internal relAPP_def)

lemma list_rel_induct[induct set,consumes 1, case_names Nil Cons]:
  assumes "(l,l')\<in>\<langle>R\<rangle> list_rel"
  assumes "P [] []"
  assumes "\<And>x x' l l'. \<lbrakk> (x,x')\<in>R; (l,l')\<in>\<langle>R\<rangle>list_rel; P l l' \<rbrakk>
    \<Longrightarrow> P (x#l) (x'#l')"
  shows "P l l'"
  using assms unfolding list_rel_def
  apply simp
  by (rule list_all2_induct)

lemma list_rel_eq_listrel: "list_rel = listrel"
  apply (rule ext)
  apply safe
proof goal_cases
  case (1 x a b) thus ?case
    unfolding list_rel_def_internal
    apply simp
    apply (induct a b rule: list_all2_induct)
    apply (auto intro: listrel.intros)
    done
next
  case 2 thus ?case
    apply (induct)
    apply (auto simp: list_rel_def_internal)
    done
qed

lemma list_relI:
  "([],[])\<in>\<langle>R\<rangle>list_rel"
  "\<lbrakk> (x,x')\<in>R; (l,l')\<in>\<langle>R\<rangle>list_rel \<rbrakk> \<Longrightarrow> (x#l,x'#l')\<in>\<langle>R\<rangle>list_rel"
  by (auto simp: list_rel_def)

lemma list_rel_simp[simp]:
  "([],l')\<in>\<langle>R\<rangle>list_rel \<longleftrightarrow> l'=[]"
  "(l,[])\<in>\<langle>R\<rangle>list_rel \<longleftrightarrow> l=[]"
  "([],[])\<in>\<langle>R\<rangle>list_rel"
  "(x#l,x'#l')\<in>\<langle>R\<rangle>list_rel \<longleftrightarrow> (x,x')\<in>R \<and> (l,l')\<in>\<langle>R\<rangle>list_rel"
  by (auto simp: list_rel_def)

lemma list_relE1:
  assumes "(l,[])\<in>\<langle>R\<rangle>list_rel" obtains "l=[]" using assms by auto

lemma list_relE2:
  assumes "([],l)\<in>\<langle>R\<rangle>list_rel" obtains "l=[]" using assms by auto

lemma list_relE3:
  assumes "(x#xs,l')\<in>\<langle>R\<rangle>list_rel" obtains x' xs' where
  "l'=x'#xs'" and "(x,x')\<in>R" and "(xs,xs')\<in>\<langle>R\<rangle>list_rel"
  using assms
  apply (cases l')
  apply auto
  done

lemma list_relE4:
  assumes "(l,x'#xs')\<in>\<langle>R\<rangle>list_rel" obtains x xs where
  "l=x#xs" and "(x,x')\<in>R" and "(xs,xs')\<in>\<langle>R\<rangle>list_rel"
  using assms
  apply (cases l)
  apply auto
  done

lemmas list_relE = list_relE1 list_relE2 list_relE3 list_relE4

lemma list_rel_imp_same_length:
    "(l, l') \<in> \<langle>R\<rangle>list_rel \<Longrightarrow> length l = length l'"
  unfolding list_rel_eq_listrel relAPP_def
  by (rule listrel_eq_len)

subsubsection {* Sets *}
text {* Pointwise refinement: The abstract set is the image of
  the concrete set, and the concrete set only contains elements that
  have an abstract counterpart *}
definition set_rel where set_rel_def_internal:
  "set_rel R \<equiv> {(S,S'). S'=R``S \<and> S\<subseteq>Domain R}"

lemma set_rel_def[refine_rel_defs]:
  "\<langle>R\<rangle>set_rel \<equiv> {(S,S'). S'=R``S \<and> S\<subseteq>Domain R}"
  by (simp add: set_rel_def_internal relAPP_def)

lemma set_rel_simp[simp]:
  "({},{})\<in>\<langle>R\<rangle>set_rel"
  by (auto simp: set_rel_def)

lemma set_relD: "(s,s')\<in>\<langle>R\<rangle>set_rel \<Longrightarrow> x\<in>s \<Longrightarrow> \<exists>x'\<in>s'. (x,x')\<in>R"
  unfolding set_rel_def by blast

lemma set_relE[consumes 2]:
  assumes "(s,s')\<in>\<langle>R\<rangle>set_rel" "x\<in>s"
  obtains x' where "x'\<in>s'" "(x,x')\<in>R"
  using set_relD[OF assms] ..

subsection {* Automation *}
subsubsection {* A solver for relator properties *}
lemma relprop_triggers:
  "\<And>R. single_valued R \<Longrightarrow> single_valued R"
  "\<And>R. R=Id \<Longrightarrow> R=Id"
  "\<And>R. R=Id \<Longrightarrow> Id=R"
  "\<And>R. Range R = UNIV \<Longrightarrow> Range R = UNIV"
  "\<And>R. Range R = UNIV \<Longrightarrow> UNIV = Range R"
  "\<And>R R'. R\<subseteq>R' \<Longrightarrow> R\<subseteq>R'"
  by auto

ML {*
  structure relator_props = Named_Thms (
    val name = @{binding relator_props}
    val description = "Additional relator properties"
  )

  structure solve_relator_props = Named_Thms (
    val name = @{binding solve_relator_props}
    val description = "Relator properties that solve goal"
  )

*}
setup relator_props.setup
setup solve_relator_props.setup

declaration {*
  Tagged_Solver.declare_solver
    @{thms relprop_triggers}
    @{binding relator_props_solver}
    "Additional relator properties solver"
    (fn ctxt => (REPEAT_ALL_NEW (CHANGED o (
      match_tac ctxt (solve_relator_props.get ctxt) ORELSE'
      match_tac ctxt (relator_props.get ctxt)
    ))))
*}

declaration {*
  Tagged_Solver.declare_solver
    []
    @{binding force_relator_props_solver}
    "Additional relator properties solver (instantiate schematics)"
    (fn ctxt => (REPEAT_ALL_NEW (CHANGED o (
      resolve_tac ctxt (solve_relator_props.get ctxt) ORELSE'
      match_tac ctxt (relator_props.get ctxt)
    ))))
*}

lemma
  relprop_id_orient[relator_props]: "R=Id \<Longrightarrow> Id=R" and
  relprop_eq_refl[solve_relator_props]: "t = t"
  by auto

lemma
  relprop_UNIV_orient[relator_props]: "R=UNIV \<Longrightarrow> UNIV=R"
  by auto

subsubsection {* ML-Level utilities *}

ML {*
  signature RELATORS = sig
    val mk_relT: typ * typ -> typ
    val dest_relT: typ -> typ * typ

    val mk_relAPP: term -> term -> term
    val list_relAPP: term list -> term -> term
    val strip_relAPP: term -> term list * term

    val declare_natural_relator:
      (string*string) -> Context.generic -> Context.generic
    val remove_natural_relator: string -> Context.generic -> Context.generic
    val natural_relator_of: Proof.context -> string -> string option

    val mk_natural_relator: Proof.context -> term list -> string -> term option
    val mk_fun_rel: term -> term -> term

    val setup: theory -> theory
  end

  structure Relators :RELATORS = struct
    val mk_relT = HOLogic.mk_prodT #> HOLogic.mk_setT

    fun dest_relT (Type (@{type_name set},[Type (@{type_name prod},[cT,aT])]))
      = (cT,aT)
      | dest_relT ty = raise TYPE ("dest_relT",[ty],[])

    fun mk_relAPP x f = let
      val xT = fastype_of x
      val fT = fastype_of f
      val rT = range_type fT
    in
      Const (@{const_name relAPP},fT-->xT-->rT)$f$x
    end

    val list_relAPP = fold mk_relAPP

    fun strip_relAPP R = let
      fun aux @{mpat "\<langle>?R\<rangle>?S"} l = aux S (R::l)
        | aux R l = (l,R)
    in aux R [] end

    structure natural_relators = Generic_Data (
      type T = string Symtab.table
      val empty = Symtab.empty
      val extend = I
      val merge = Symtab.join (fn _ => fn (_,cn) => cn)
    )

    fun declare_natural_relator tcp =
      natural_relators.map (Symtab.update tcp)

    fun remove_natural_relator tname =
      natural_relators.map (Symtab.delete_safe tname)

    fun natural_relator_of ctxt =
      Symtab.lookup (natural_relators.get (Context.Proof ctxt))

    (* [R1,\<dots>,Rn] T is mapped to \<langle>R1,\<dots>,Rn\<rangle> Trel *)
    fun mk_natural_relator ctxt args Tname =
      case natural_relator_of ctxt Tname of
        NONE => NONE
      | SOME Cname => SOME let
          val argsT = map fastype_of args
          val (cTs, aTs) = map dest_relT argsT |> split_list
          val aT = Type (Tname,aTs)
          val cT = Type (Tname,cTs)
          val rT = mk_relT (cT,aT)
        in
          list_relAPP args (Const (Cname,argsT--->rT))
        end

    fun
      natural_relator_from_term (t as Const (name,T)) = let
        fun err msg = raise TERM (msg,[t])

        val (argTs,bodyT) = strip_type T
        val (conTs,absTs) = argTs |> map (HOLogic.dest_setT #> HOLogic.dest_prodT) |> split_list
        val (bconT,babsT) = bodyT |> HOLogic.dest_setT |> HOLogic.dest_prodT
        val (Tcon,bconTs) = dest_Type bconT
        val (Tcon',babsTs) = dest_Type babsT

        val _ = Tcon = Tcon' orelse err "Type constructors do not match"
        val _ = conTs = bconTs orelse err "Concrete types do not match"
        val _ = absTs = babsTs orelse err "Abstract types do not match"

      in
        (Tcon,name)
      end
    | natural_relator_from_term t =
        raise TERM ("Expected constant",[t]) (* TODO: Localize this! *)

    local
      fun decl_natrel_aux t context = let
        fun warn msg = let
          val tP =
            Context.cases Syntax.pretty_term_global Syntax.pretty_term
              context t
          val m = Pretty.block [
            Pretty.str "Ignoring invalid natural_relator declaration:",
            Pretty.brk 1,
            Pretty.str msg,
            Pretty.brk 1,
            tP
          ] |> Pretty.string_of
          val _ = warning m
        in context end
      in
        declare_natural_relator (natural_relator_from_term t) context
        handle
          TERM (msg,_) => warn msg
        | exn => if Exn.is_interrupt exn then Exn.reraise exn else warn ""
      end
    in
      val natural_relator_attr = Scan.repeat1 Args.term >> (fn ts =>
        Thm.declaration_attribute ( fn _ => fold decl_natrel_aux ts)
      )
    end

    fun mk_fun_rel r1 r2 = let
      val (r1T,r2T) = (fastype_of r1,fastype_of r2)
      val (c1T,a1T) = dest_relT r1T
      val (c2T,a2T) = dest_relT r2T
      val (cT,aT) = (c1T --> c2T, a1T --> a2T)
      val rT = mk_relT (cT,aT)
    in
      list_relAPP [r1,r2] (Const (@{const_name fun_rel},r1T-->r2T-->rT))
    end

    val setup = I
      #> Attrib.setup
        @{binding natural_relator} natural_relator_attr "Declare natural relator"

  end
*}

setup Relators.setup

subsection {* Setup *}
subsubsection "Natural Relators"

declare [[natural_relator
  unit_rel int_rel nat_rel bool_rel
  fun_rel prod_rel option_rel sum_rel list_rel
  ]]

(*declaration {* let open Relators in
  fn _ =>
     declare_natural_relator (@{type_name unit},@{const_name unit_rel})
  #> declare_natural_relator (@{type_name fun},@{const_name fun_rel})
  #> declare_natural_relator (@{type_name prod},@{const_name prod_rel})
  #> declare_natural_relator (@{type_name option},@{const_name option_rel})
  #> declare_natural_relator (@{type_name sum},@{const_name sum_rel})
  #> declare_natural_relator (@{type_name list},@{const_name list_rel})

end
*}*)

ML_val {*
  Relators.mk_natural_relator
    @{context}
    [@{term "Ra::('c\<times>'a) set"},@{term "\<langle>Rb\<rangle>option_rel"}]
    @{type_name prod}
  |> the
  |> Thm.cterm_of @{context}
;
  Relators.mk_fun_rel @{term "\<langle>Id\<rangle>option_rel"} @{term "\<langle>Id\<rangle>list_rel"}
  |> Thm.cterm_of @{context}
*}

subsubsection "Additional Properties"
lemmas [relator_props] =
  single_valued_Id
  subset_refl
  refl

(* TODO: Move *)
lemma eq_UNIV_iff: "S=UNIV \<longleftrightarrow> (\<forall>x. x\<in>S)" by auto

lemma fun_rel_sv[relator_props]:
  assumes RAN: "Range Ra = UNIV"
  assumes SV: "single_valued Rv"
  shows "single_valued (Ra \<rightarrow> Rv)"
proof (intro single_valuedI ext impI allI)
  fix f g h x'
  assume R1: "(f,g)\<in>Ra\<rightarrow>Rv"
  and R2: "(f,h)\<in>Ra\<rightarrow>Rv"

  from RAN obtain x where AR: "(x,x')\<in>Ra" by auto
  from fun_relD[OF R1 AR] have "(f x,g x') \<in> Rv" .
  moreover from fun_relD[OF R2 AR] have "(f x,h x') \<in> Rv" .
  ultimately show "g x' = h x'" using SV by (auto dest: single_valuedD)
qed

lemmas [relator_props] = Range_Id

lemma fun_rel_id[relator_props]: "\<lbrakk>R1=Id; R2=Id\<rbrakk> \<Longrightarrow> R1 \<rightarrow> R2 = Id"
  by (auto simp: fun_rel_def)

lemma fun_rel_id_simp[simp]: "Id\<rightarrow>Id = Id" by tagged_solver

lemma fun_rel_comp_dist[relator_props]:
  "(R1\<rightarrow>R2) O (R3\<rightarrow>R4) \<subseteq> ((R1 O R3) \<rightarrow> (R2 O R4))"
  by (auto simp: fun_rel_def)

lemma fun_rel_mono[relator_props]: "\<lbrakk> R1\<subseteq>R2; R3\<subseteq>R4 \<rbrakk> \<Longrightarrow> R2\<rightarrow>R3 \<subseteq> R1\<rightarrow>R4"
  by (force simp: fun_rel_def)

lemma prod_rel_sv[relator_props]:
  "\<lbrakk>single_valued R1; single_valued R2\<rbrakk> \<Longrightarrow> single_valued (\<langle>R1,R2\<rangle>prod_rel)"
  by (auto intro: single_valuedI dest: single_valuedD simp: prod_rel_def)

lemma prod_rel_id[relator_props]: "\<lbrakk>R1=Id; R2=Id\<rbrakk> \<Longrightarrow> \<langle>R1,R2\<rangle>prod_rel = Id"
  by (auto simp: prod_rel_def)

lemma prod_rel_id_simp[simp]: "\<langle>Id,Id\<rangle>prod_rel = Id" by tagged_solver

lemma prod_rel_mono[relator_props]:
"\<lbrakk> R2\<subseteq>R1; R3\<subseteq>R4 \<rbrakk> \<Longrightarrow> \<langle>R2,R3\<rangle>prod_rel \<subseteq> \<langle>R1,R4\<rangle>prod_rel"
  by (auto simp: prod_rel_def)

lemma prod_rel_range[relator_props]: "\<lbrakk>Range Ra=UNIV; Range Rb=UNIV\<rbrakk>
  \<Longrightarrow> Range (\<langle>Ra,Rb\<rangle>prod_rel) = UNIV"
  apply (auto simp: prod_rel_def)
  by (metis Range_iff UNIV_I)+

lemma option_rel_sv[relator_props]:
  "\<lbrakk>single_valued R\<rbrakk> \<Longrightarrow> single_valued (\<langle>R\<rangle>option_rel)"
  by (auto intro: single_valuedI dest: single_valuedD simp: option_rel_def)

lemma option_rel_id[relator_props]:
  "R=Id \<Longrightarrow> \<langle>R\<rangle>option_rel = Id" by (auto simp: option_rel_def)

lemma option_rel_id_simp[simp]: "\<langle>Id\<rangle>option_rel = Id" by tagged_solver

lemma option_rel_mono[relator_props]: "R\<subseteq>R' \<Longrightarrow> \<langle>R\<rangle>option_rel \<subseteq> \<langle>R'\<rangle>option_rel"
  by (auto simp: option_rel_def)

lemma option_rel_range: "Range R = UNIV \<Longrightarrow> Range (\<langle>R\<rangle>option_rel) = UNIV"
  apply (auto simp: option_rel_def Range_iff)
  by (metis Range_iff UNIV_I option.exhaust)

lemma sum_rel_sv[relator_props]:
  "\<lbrakk>single_valued Rl; single_valued Rr\<rbrakk> \<Longrightarrow> single_valued (\<langle>Rl,Rr\<rangle>sum_rel)"
  by (auto intro: single_valuedI dest: single_valuedD simp: sum_rel_def)

lemma sum_rel_id[relator_props]: "\<lbrakk>Rl=Id; Rr=Id\<rbrakk> \<Longrightarrow> \<langle>Rl,Rr\<rangle>sum_rel = Id"
  apply (auto elim: sum_relE)
  apply (case_tac b)
  apply simp_all
  done

lemma sum_rel_id_simp[simp]: "\<langle>Id,Id\<rangle>sum_rel = Id" by tagged_solver

lemma sum_rel_mono[relator_props]:
  "\<lbrakk> Rl\<subseteq>Rl'; Rr\<subseteq>Rr' \<rbrakk> \<Longrightarrow> \<langle>Rl,Rr\<rangle>sum_rel \<subseteq> \<langle>Rl',Rr'\<rangle>sum_rel"
  by (auto simp: sum_rel_def)

lemma sum_rel_range[relator_props]:
  "\<lbrakk> Range Rl=UNIV; Range Rr=UNIV \<rbrakk> \<Longrightarrow> Range (\<langle>Rl,Rr\<rangle>sum_rel) = UNIV"
  apply (auto simp: sum_rel_def Range_iff)
  by (metis Range_iff UNIV_I sumE)

lemma list_rel_sv_iff:
  "single_valued (\<langle>R\<rangle>list_rel) \<longleftrightarrow> single_valued R"
  apply (intro iffI[rotated] single_valuedI allI impI)
  apply (clarsimp simp: list_rel_def)
proof -
  fix x y z
  assume SV: "single_valued R"
  assume "list_all2 (\<lambda>x x'. (x, x') \<in> R) x y" and
    "list_all2 (\<lambda>x x'. (x, x') \<in> R) x z"
  thus "y=z"
    apply (induct arbitrary: z rule: list_all2_induct)
    apply simp
    apply (case_tac z)
    apply force
    apply (force intro: single_valuedD[OF SV])
    done
next
  fix x y z
  assume SV: "single_valued (\<langle>R\<rangle>list_rel)"
  assume "(x,y)\<in>R" "(x,z)\<in>R"
  hence "([x],[y])\<in>\<langle>R\<rangle>list_rel" and "([x],[z])\<in>\<langle>R\<rangle>list_rel"
    by (auto simp: list_rel_def)
  with single_valuedD[OF SV] show "y=z" by blast
qed

lemma list_rel_sv[relator_props]:
  "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>list_rel)"
  by (simp add: list_rel_sv_iff)

lemma list_rel_id[relator_props]: "\<lbrakk>R=Id\<rbrakk> \<Longrightarrow> \<langle>R\<rangle>list_rel = Id"
  by (auto simp add: list_rel_def list_all2_eq[symmetric])

lemma list_rel_id_simp[simp]: "\<langle>Id\<rangle>list_rel = Id" by tagged_solver

lemma list_rel_mono[relator_props]:
  assumes A: "R\<subseteq>R'"
  shows "\<langle>R\<rangle>list_rel \<subseteq> \<langle>R'\<rangle>list_rel"
proof clarsimp
  fix l l'
  assume "(l,l')\<in>\<langle>R\<rangle>list_rel"
  thus "(l,l')\<in>\<langle>R'\<rangle>list_rel"
    apply induct
    using A
    by auto
qed

lemma list_rel_range[relator_props]:
  assumes A: "Range R = UNIV"
  shows "Range (\<langle>R\<rangle>list_rel) = UNIV"
proof (clarsimp simp: eq_UNIV_iff)
  fix l
  show "l\<in>Range (\<langle>R\<rangle>list_rel)"
    apply (induct l)
    using A[unfolded eq_UNIV_iff]
    by (auto simp: Range_iff intro: list_relI)
qed

lemma bijective_imp_sv:
  "bijective R \<Longrightarrow> single_valued R"
  "bijective R \<Longrightarrow> single_valued (R\<inverse>)"
  by (simp_all add: bijective_alt)

(* TODO: Move *)
declare bijective_Id[relator_props]
declare bijective_Empty[relator_props]

text {* Pointwise refinement for set types: *}
lemma set_rel_sv[relator_props]:
  "single_valued (\<langle>R\<rangle>set_rel)"
  by (auto intro: single_valuedI dest: single_valuedD simp: set_rel_def) []

lemma set_rel_id[relator_props]: "R=Id \<Longrightarrow> \<langle>R\<rangle>set_rel = Id"
  by (auto simp add: set_rel_def)

lemma set_rel_id_simp[simp]: "\<langle>Id\<rangle>set_rel = Id" by tagged_solver

lemma set_rel_csv[relator_props]:
  "\<lbrakk> single_valued (R\<inverse>) \<rbrakk>
  \<Longrightarrow> single_valued ((\<langle>R\<rangle>set_rel)\<inverse>)"
  apply (rule single_valuedI)
  apply (simp only: converse_iff)

  apply (simp add: single_valued_def Image_def set_rel_def)
  apply (intro allI impI equalityI)
    apply (clarsimp, blast) []
    apply (clarsimp, drule (1) set_mp, blast) []
  done

subsection {* Invariant and Abstraction *}

text {*
  Quite often, a relation can be described as combination of an
  abstraction function and an invariant, such that the invariant describes valid
  values on the concrete domain, and the abstraction function maps valid
  concrete values to its corresponding abstract value.
*}
definition build_rel where
  "build_rel \<alpha> I \<equiv> {(c,a) . a=\<alpha> c \<and> I c}"
abbreviation "br\<equiv>build_rel"
lemmas br_def[refine_rel_defs] = build_rel_def

lemma brI[intro?]: "\<lbrakk> a=\<alpha> c; I c \<rbrakk> \<Longrightarrow> (c,a)\<in>br \<alpha> I"
  by (simp add: br_def)

lemma br_id[simp]: "br id (\<lambda>_. True) = Id"
  unfolding build_rel_def by auto

lemma br_chain:
  "(build_rel \<beta> J) O (build_rel \<alpha> I) = build_rel (\<alpha>\<circ>\<beta>) (\<lambda>s. J s \<and> I (\<beta> s))"
  unfolding build_rel_def by auto

lemma br_sv[simp, intro!,relator_props]: "single_valued (br \<alpha> I)"
  unfolding build_rel_def
  apply (rule single_valuedI)
  apply auto
  done

lemma converse_br_sv_iff[simp]:
  "single_valued (converse (br \<alpha> I)) \<longleftrightarrow> inj_on \<alpha> (Collect I)"
  by (auto intro!: inj_onI single_valuedI dest: single_valuedD inj_onD
    simp: br_def) []

lemmas [relator_props] = single_valued_relcomp

lemma br_comp_alt: "br \<alpha> I O R = { (c,a) . I c \<and> (\<alpha> c,a)\<in>R }"
  by (auto simp add: br_def)

lemma br_comp_alt':
  "{(c,a) . a=\<alpha> c \<and> I c} O R = { (c,a) . I c \<and> (\<alpha> c,a)\<in>R }"
  by auto

lemma single_valued_as_brE:
  assumes "single_valued R"
  obtains \<alpha> invar where "R=br \<alpha> invar"
  apply (rule that[of "\<lambda>x. THE y. (x,y)\<in>R" "\<lambda>x. x\<in>Domain R"])
  using assms unfolding br_def
  by (auto dest: single_valuedD
    intro: the_equality[symmetric] theI)

lemma sv_add_invar:
  "single_valued R \<Longrightarrow> single_valued {(c, a). (c, a) \<in> R \<and> I c}"
  by (auto dest: single_valuedD intro: single_valuedI)

subsection {* Miscellanneous *}
lemma rel_cong: "(f,g)\<in>Id \<Longrightarrow> (x,y)\<in>Id \<Longrightarrow> (f x, g y)\<in>Id" by simp
lemma rel_fun_cong: "(f,g)\<in>Id \<Longrightarrow> (f x, g x)\<in>Id" by simp
lemma rel_arg_cong: "(x,y)\<in>Id \<Longrightarrow> (f x, f y)\<in>Id" by simp

end