(* Title: thys/ComposedTMs.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten

   Minor modifications, comments by Franz Regensburger (FABR) 02/2022
 *)

theory ComposedTMs
  imports ComposableTMs
begin

section \<open>Composition of Turing Machines\<close>

fun
  shift :: "instr list \<Rightarrow> nat \<Rightarrow> instr list"
  where
    "shift p n = (map (\<lambda> (a, s). (a, (if s = 0 then 0 else s + n))) p)"

fun
  adjust :: "instr list \<Rightarrow> nat \<Rightarrow> instr list"
  where
    "adjust p e = map (\<lambda> (a, s). (a, if s = 0 then e else s)) p"

abbreviation
  "adjust0 p \<equiv> adjust p (Suc (length p div 2))"

lemma length_shift [simp]:
  shows "length (shift p n) = length p"
  by simp

lemma length_adjust [simp]:
  shows "length (adjust p n) = length p"
  by (induct p) (auto)

(* composition of two Turing machines *)
fun
  seq_tm :: "instr list \<Rightarrow> instr list \<Rightarrow> instr list" (infixl "|+|" 60)
  where
    "seq_tm p1 p2 = ((adjust0 p1) @ (shift p2 (length p1 div 2)))"

lemma seq_tm_length:
  shows "length (A |+| B) = length A + length B"
  by auto

lemma seq_tm_composable[intro]:
  "\<lbrakk>composable_tm (A, 0); composable_tm (B, 0)\<rbrakk> \<Longrightarrow> composable_tm (A |+| B, 0)"
  by (fastforce)

lemma seq_tm_step:
  assumes unfinal: "\<not> is_final (step0 c A)"
  shows "step0 c (A |+| B) = step0 c A"
proof -
  obtain s l r where eq: "c = (s, l, r)" by (metis is_final.cases)
  have "\<not> is_final (step0 (s, l, r) A)" using unfinal eq by simp
  then have "case (fetch A s (read r)) of (a, s) \<Rightarrow> s \<noteq> 0"
    by (auto simp add: is_final_eq)
  then have "fetch (A |+| B) s (read r) = fetch A s (read r)"
    apply (cases "read r";cases s)
    by (auto simp: seq_tm_length nth_append)
  then show "step0 c (A |+| B) = step0 c A" by (simp add: eq)
qed

lemma seq_tm_steps:
  assumes "\<not> is_final (steps0 c A n)"
  shows "steps0 c (A |+| B) n = steps0 c A n"
  using assms
proof(induct n)
  case 0
  then show "steps0 c (A |+| B) 0 = steps0 c A 0" by auto
next
  case (Suc n)
  have ih: "\<not> is_final (steps0 c A n) \<Longrightarrow> steps0 c (A |+| B) n = steps0 c A n" by fact
  have fin: "\<not> is_final (steps0 c A (Suc n))" by fact
  then have fin1: "\<not> is_final (step0 (steps0 c A n) A)"
    by (auto simp only: step_red)
  then have fin2: "\<not> is_final (steps0 c A n)"
    by (metis is_final_eq step_0 surj_pair)

  have "steps0 c (A |+| B) (Suc n) = step0 (steps0 c (A |+| B) n) (A |+| B)"
    by (simp only: step_red)
  also have "... = step0 (steps0 c A n) (A |+| B)" by (simp only: ih[OF fin2])
  also have "... = step0 (steps0 c A n) A" by (simp only: seq_tm_step[OF fin1])
  finally show "steps0 c (A |+| B) (Suc n) = steps0 c A (Suc n)"
    by (simp only: step_red)
qed

lemma seq_tm_fetch_in_A:
  assumes h1: "fetch A s x = (a, 0)"
    and h2: "s \<le> length A div 2"
    and h3: "s \<noteq> 0"
  shows "fetch (A |+| B) s x = (a, Suc (length A div 2))"
  using h1 h2 h3
  apply(cases s;cases x)
  by(auto simp: seq_tm_length nth_append)

lemma seq_tm_exec_after_first:
  assumes h1: "\<not> is_final c"
    and h2: "step0 c A = (0, tap)"
    and h3: "fst c \<le> length A div 2"
  shows "step0 c (A |+| B) = (Suc (length A div 2), tap)"
  using h1 h2 h3
  apply(case_tac c)
  apply(auto simp del: seq_tm.simps)
   apply(case_tac "fetch A a Bk")
   apply(simp del: seq_tm.simps)
   apply(subst seq_tm_fetch_in_A;force)
  apply(case_tac "fetch A a (hd ca)")
  apply(simp del: seq_tm.simps)
  apply(subst seq_tm_fetch_in_A)
     apply(auto)[4]
  done

(* if A goes into the final state, then A |+| B will go into the first state of B *)
lemma seq_tm_next:
  assumes a_ht: "steps0 (1, tap) A n = (0, tap')"
    and a_composable: "composable_tm (A, 0)"
  obtains n' where "steps0 (1, tap) (A |+| B) n' = (Suc (length A div 2), tap')"
proof -
  assume a: "\<And>n. steps (1, tap) (A |+| B, 0) n = (Suc (length A div 2), tap') \<Longrightarrow> thesis"
  obtain stp' where fin: "\<not> is_final (steps0 (1, tap) A stp')" and h: "steps0 (1, tap) A (Suc stp') = (0, tap')"
    using before_final[OF a_ht] by blast
  from fin have h1:"steps0 (1, tap) (A |+| B) stp' = steps0 (1, tap) A stp'"
    by (rule seq_tm_steps)
  from h have h2: "step0 (steps0 (1, tap) A stp') A = (0, tap')"
    by (simp only: step_red)

  have "steps0 (1, tap) (A |+| B) (Suc stp') = step0 (steps0 (1, tap) (A |+| B) stp') (A |+| B)"
    by (simp only: step_red)
  also have "... = step0 (steps0 (1, tap) A stp') (A |+| B)" using h1 by simp
  also have "... = (Suc (length A div 2), tap')"
    by (rule seq_tm_exec_after_first[OF fin h2 steps_in_range[OF fin a_composable]])
  finally show thesis using a by blast
qed

lemma seq_tm_fetch_second_zero:
  assumes h1: "fetch B s x = (a, 0)"
    and hs: "composable_tm (A, 0)" "s \<noteq> 0"
  shows "fetch (A |+| B) (s + (length A div 2)) x = (a, 0)"
  using h1 hs
  by(cases x; cases s; fastforce simp: seq_tm_length nth_append)

lemma seq_tm_fetch_second_inst:
  assumes h1: "fetch B sa x = (a, s)"
    and hs: "composable_tm (A, 0)" "sa \<noteq> 0" "s \<noteq> 0"
  shows "fetch (A |+| B) (sa + length A div 2) x = (a, s + length A div 2)"
  using h1 hs
  by(cases x; cases sa; fastforce simp: seq_tm_length nth_append)

lemma seq_tm_second:
  assumes a_composable: "composable_tm (A, 0)"
    and steps: "steps0 (1, l, r) B stp = (s', l', r')"
  shows "steps0 (Suc (length A div 2), l, r)  (A |+| B) stp
    = (if s' = 0 then 0 else s' + length A div 2, l', r')"
  using steps
proof(induct stp arbitrary: s' l' r')
  case 0
  then show ?case by simp
next
  case (Suc stp s' l' r')
  obtain s'' l'' r'' where a: "steps0 (1, l, r) B stp = (s'', l'', r'')"
    by (metis is_final.cases)
  then have ih1: "s'' = 0 \<Longrightarrow> steps0 (Suc (length A div 2), l, r) (A |+| B) stp = (0, l'', r'')"
    and ih2: "s'' \<noteq> 0 \<Longrightarrow> steps0 (Suc (length A div 2), l, r) (A |+| B) stp = (s'' + length A div 2, l'', r'')"
    using Suc by (auto)
  have h: "steps0 (1, l, r) B (Suc stp) = (s', l', r')" by fact

  { assume "s'' = 0"
    then have ?case using a h ih1 by (simp del: steps.simps)
  } moreover
  { assume as: "s'' \<noteq> 0" "s' = 0"
    from as a h
    have "step0 (s'', l'', r'') B = (0, l', r')" by (simp del: steps.simps)
    with as have ?case
      apply(cases "fetch B s'' (read r'')")
      by (auto simp add: seq_tm_fetch_second_zero[OF _ a_composable] ih2[OF as(1)]
          simp del: seq_tm.simps steps.simps)
  } moreover
  { assume as: "s'' \<noteq> 0" "s' \<noteq> 0"
    from as a h
    have "step0 (s'', l'', r'') B = (s', l', r')" by (simp del: steps.simps)
    with as have ?case
      apply(simp add: ih2[OF as(1)] del: seq_tm.simps steps.simps)
      apply(case_tac "fetch B s'' (read r'')")
      apply(auto simp add: seq_tm_fetch_second_inst[OF _ a_composable as] simp del: seq_tm.simps)
      done
  }
  ultimately show ?case by blast
qed

lemma seq_tm_final:
  assumes "composable_tm (A, 0)"
    and "steps0 (1, l, r) B stp = (0, l', r')"
  shows "steps0 (Suc (length A div 2), l, r)  (A |+| B) stp = (0, l', r')"
  using seq_tm_second[OF assms] by (simp)

end


theory MDP_reward_Util
  imports Blinfun_Util
begin
section \<open>Auxiliary Lemmas\<close>

subsection \<open>Summability\<close>

lemma summable_powser_const:
  fixes c :: real
  assumes "\<bar>c\<bar> < 1"
  shows "summable (\<lambda>n. c^n * x)"
  using assms
  by (auto simp: mult.commute)

subsection \<open>Infinite sums\<close>

lemma suminf_split_head':
  "summable (f :: nat \<Rightarrow> 'x :: real_normed_vector) \<Longrightarrow> suminf f = f 0 + (\<Sum>n. f (Suc n))"
  by (auto simp: suminf_split_head)

lemma sum_disc_lim:
  assumes "\<bar>c :: real\<bar> < 1"
  shows "(\<Sum>x. c^x * B) = B /(1-c)"
  by (simp add: assms suminf_geometric summable_geometric suminf_mult2[symmetric])

subsection \<open>Bounded Functions\<close>

lemma suminf_apply_bfun:
  fixes f :: "nat \<Rightarrow> 'c \<Rightarrow>\<^sub>b real"
  assumes "summable f"
  shows "(\<Sum>i. f i) x = (\<Sum>i. f i x)"
  by (auto intro!: bounded_linear.suminf assms bounded_linear_intro[where K = 1] abs_le_norm_bfun)

lemma sum_apply_bfun:
  fixes f :: "nat \<Rightarrow> 'c \<Rightarrow>\<^sub>b real"
  shows "(\<Sum>i<n. f i) x = (\<Sum>i<n. apply_bfun (f i) x)"
  by (induction n) auto

subsection \<open>Push-Forward of a Bounded Function\<close>

lemma integrable_bfun_prob_space [simp]:
  "integrable (measure_pmf P) (\<lambda>t. apply_bfun f (F t) :: real)"
proof -
  obtain b where "\<forall>t. \<bar>f (F t)\<bar> \<le> b"
    by (metis norm_le_norm_bfun real_norm_def)
  hence "(\<integral>\<^sup>+ x. ennreal \<bar>f (F x)\<bar> \<partial>P) \<le> b"
    using nn_integral_mono ennreal_leI
    by (auto intro: measure_pmf.nn_integral_le_const)
  then show ?thesis
    using ennreal_less_top le_less_trans
    by (fastforce simp: integrable_iff_bounded)
qed

lift_definition push_exp :: "('b \<Rightarrow> 'c pmf) \<Rightarrow> ('c \<Rightarrow>\<^sub>b real) \<Rightarrow> ('b \<Rightarrow>\<^sub>b real)" is
  "\<lambda>c f s. measure_pmf.expectation (c s) f"
  using bfun_integral_bound' .

declare push_exp.rep_eq[simp]

lemma norm_push_exp_le_norm: "norm (push_exp d x) \<le> norm x"
proof -
  have "\<And>s. (\<integral>s'. norm (x s') \<partial>d s) \<le> norm x"
    using measure_pmf.prob_space_axioms norm_le_norm_bfun[of x]
    by (auto intro!: prob_space.integral_le_const)
  hence aux: "\<And>s. norm (\<integral>s'. x s' \<partial>d s) \<le> norm x"
    using integral_norm_bound order_trans by blast
  have "norm (push_exp d x) = (\<Squnion>s. norm (\<integral>s'. x s' \<partial>d s))"
    unfolding norm_bfun_def'
    by auto
  also have "\<dots> \<le> norm x"
    using aux by (fastforce intro!: cSUP_least)
  finally show ?thesis .
qed

lemma push_exp_bounded_linear [simp]: "bounded_linear (push_exp d)"
  using norm_push_exp_le_norm
  by (auto intro!: bounded_linear_intro[where K = 1])

lemma onorm_push_exp [simp]: "onorm (push_exp d) = 1"
proof (intro antisym)
  show "onorm (push_exp d) \<le> 1"
    using norm_push_exp_le_norm
    by (auto intro!: onorm_bound)
next
  show "1 \<le> onorm (push_exp d)"
    using onorm[of _ 1, OF push_exp_bounded_linear]
    by (auto simp: norm_bfun_def')
qed

lemma push_exp_return[simp]: "push_exp return_pmf = id"
  by (auto simp: eq_id_iff[symmetric])

subsection \<open>Boundedness\<close>

lemma bounded_abs[intro]:
  "bounded (X' :: real set) \<Longrightarrow> bounded (abs ` X')"
  by (auto simp: bounded_iff)

lemma bounded_abs_range[intro]:
  "bounded (range f :: real set) \<Longrightarrow> bounded (range (\<lambda>x. abs (f x)))"
  by (auto simp: bounded_iff)

subsection \<open>Probability Theory\<close>

lemma integral_measure_pmf_bind:
  assumes "(\<And>x. \<bar>(f :: 'b \<Rightarrow> real) x\<bar> \<le> B)"
  shows "(\<integral>x. f x \<partial>((measure_pmf M) \<bind> (\<lambda>x. measure_pmf (N x)))) = (\<integral>x. \<integral>y. f y \<partial>N x \<partial>M)"
  using assms
  by (subst integral_bind[of _ "count_space UNIV" B]) (auto simp: measure_pmf_in_subprob_space)

lemma lemma_4_3_1':
  assumes "set_pmf p \<subseteq> W"
    and "bounded ((w :: 'c \<Rightarrow> real) ` W)"
    and "W \<noteq> {}"
    and "measure_pmf.expectation p w = (\<Squnion>p \<in> {p. set_pmf p \<subseteq> W}. measure_pmf.expectation p w)"
  shows "\<exists>x \<in> W. measure_pmf.expectation p w = w x"
proof -
  have abs_w_le_sup: "y \<in> W \<Longrightarrow> \<bar>w y\<bar> \<le> (\<Squnion>x \<in> W. \<bar>w x\<bar>)" for y
    using assms bounded_abs[OF assms(2)]
    by (auto intro!: cSUP_upper bounded_imp_bdd_above simp: image_image)
  have "False" if "x \<in> set_pmf p" "w x < \<Squnion>(w ` W)" for x
  proof -
    have ex_gr: "\<exists>x'. x' \<in> W \<and> w x < w x'"
      using cSUP_least[of W w "w x"] that assms
      by fastforce
    let ?s = "\<lambda>s. (if x = s then SOME x'. x' \<in> W \<and> w x < w x' else s)"
    have "measure_pmf.expectation p w < measure_pmf.expectation p (\<lambda>xa. w (?s xa))"
    proof (intro measure_pmf.integral_less_AE[where A = "{x}"])
      show "integrable (measure_pmf p) w"
        using assms abs_w_le_sup
        by (fastforce simp: AE_measure_pmf_iff
            intro!: measure_pmf.integrable_const_bound)
      show "integrable (measure_pmf p) (\<lambda>xa. w (?s xa))"
        using assms(1) ex_gr someI[where P = "\<lambda>x'. (x' \<in> W) \<and> (w x < w x')"]
        by (fastforce simp: AE_measure_pmf_iff
            intro!: abs_w_le_sup measure_pmf.integrable_const_bound)
      show "emeasure (measure_pmf p) {x} \<noteq> 0"
        by (simp add: emeasure_pmf_single_eq_zero_iff \<open>x \<in> p\<close>)
      show "{x} \<in> measure_pmf.events p"
        by auto
      show "AE xa\<in>{x} in p. w xa \<noteq> w (?s xa)" "AE xa in p. w xa \<le> w (?s xa)"
        using someI[where P = "\<lambda>x'. (x' \<in> W) \<and> (w x < w x')"] ex_gr
        by (fastforce intro!: AE_pmfI)+
    qed
    hence "measure_pmf.expectation p w < \<Squnion>((\<lambda>p. measure_pmf.expectation p w) ` {p. set_pmf p \<subseteq> W})"
    proof (subst less_cSUP_iff, goal_cases)
      case 1
      then show ?case
        using assms(1)
        by blast
    next
      case 2
      then show ?case
        using abs_w_le_sup
        by (fastforce
            simp: AE_measure_pmf_iff
            intro: cSUP_upper2 bdd_aboveI[where M = "(\<Squnion>x\<in>W. \<bar>w x\<bar>)"]
            intro!: measure_pmf.integral_le_const measure_pmf.integrable_const_bound)
    next
      case 3
      then show ?case
        using ex_gr someI[where P = "\<lambda>x'. (x' \<in> W) \<and> (w x < w x')"] assms(1)
        by (auto intro!: exI[of _ "map_pmf ?s p"])
    qed
    thus False
      using assms by auto
  qed
  hence 1: "x \<in> set_pmf p \<Longrightarrow> w x = \<Squnion> (w ` W)" for x
    using assms
    by (fastforce intro: antisym simp: bounded_imp_bdd_above cSUP_upper)
  hence "w (SOME x. x \<in> set_pmf p) =  \<Squnion> (w ` W)"
    by (simp add: set_pmf_not_empty some_in_eq)
  thus ?thesis
    using 1 assms(1) set_pmf_not_empty some_in_eq
    by (fastforce intro!: bexI[of _ "SOME x. x \<in> set_pmf p"]
        simp: AE_measure_pmf_iff Bochner_Integration.integral_cong_AE[where ?g = "\<lambda>_. \<Squnion> (w ` W)"])
qed

lemma lemma_4_3_1:
  assumes "set_pmf p \<subseteq> W" "integrable (measure_pmf p) w" "bounded ((w :: 'c \<Rightarrow> real) ` W)"
  shows "measure_pmf.expectation p w \<le> \<Squnion>(w ` W)"
  using assms bounded_has_Sup(1) prob_space_measure_pmf
  by (fastforce simp: AE_measure_pmf_iff intro!: prob_space.integral_le_const)

lemma bounded_integrable:
  assumes "bounded (range v)" "v \<in> borel_measurable (measure_pmf p)"
  shows "integrable (measure_pmf p) (v :: 'c \<Rightarrow> real)"
  using assms
  by (auto simp: bounded_iff AE_measure_pmf_iff intro!: measure_pmf.integrable_const_bound)

subsection \<open>Argmax\<close>
lemma finite_is_arg_max: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> \<exists>x. is_arg_max (f :: 'c \<Rightarrow> real) (\<lambda>x. x \<in> X) x"
  unfolding is_arg_max_def
proof (induction rule: finite_induct)
  case (insert x F)
  then show ?case
  proof (cases "\<forall>y \<in> F. f y \<le> f x")
    case True
    then show ?thesis
      by (auto intro!: exI[of _ x])
  next
    case False
    then show ?thesis
      using insert by force
  qed
qed simp

lemma finite_arg_max_le:
  assumes "finite (X :: 'c set)" "X \<noteq> {}"
  shows "s \<in> X \<Longrightarrow> (f :: 'c \<Rightarrow> real) s \<le> f (arg_max_on (f :: 'c \<Rightarrow> real) X)"
  unfolding arg_max_def arg_max_on_def
  by (metis assms(1) assms(2) finite_is_arg_max is_arg_max_linorder someI_ex)

lemma arg_max_on_in:
  assumes "finite (X :: 'c set)" "X \<noteq> {}"
  shows "(arg_max_on (f :: 'c \<Rightarrow> real)  X) \<in> X"
  unfolding arg_max_on_def arg_max_def
  by (metis assms(1) assms(2) finite_is_arg_max is_arg_max_def someI)

lemma finite_arg_max_eq_Max:
  assumes "finite (X :: 'c set)" "X \<noteq> {}"
  shows "(f :: 'c \<Rightarrow> real) (arg_max_on f X) = Max (f ` X)"
  using assms
  by (auto intro!: Max_eqI[symmetric] finite_arg_max_le arg_max_on_in)

lemma arg_max_SUP: "is_arg_max (f :: 'b \<Rightarrow> real) (\<lambda>x. x \<in> X) m \<Longrightarrow> f m = (\<Squnion>(f ` X))"
  unfolding is_arg_max_def
  by (auto intro!: antisym cSUP_upper bdd_aboveI[of _ "f m"] cSUP_least)

definition "has_max X \<equiv> \<exists>x \<in> X. \<forall>x' \<in> X. x' \<le> x"
definition "has_arg_max f X \<equiv> \<exists>x. is_arg_max f (\<lambda>x. x \<in> X) x"

lemma "has_max ((f :: 'b \<Rightarrow> real) ` X) \<longleftrightarrow> has_arg_max f X"
  unfolding has_max_def has_arg_max_def is_arg_max_def
  using not_less by (auto dest!: leD simp: not_less)

lemma has_arg_max_is_arg_max: "has_arg_max f X \<Longrightarrow> is_arg_max f (\<lambda>x. x \<in> X) (arg_max f (\<lambda>x. x \<in> X))"
  unfolding has_arg_max_def arg_max_def
  by (auto intro: someI)

lemma has_arg_max_arg_max: "has_arg_max f X \<Longrightarrow> (arg_max f (\<lambda>x. x \<in> X)) \<in> X"
  unfolding has_arg_max_def arg_max_def is_arg_max_def by (auto intro: someI2_ex)

lemma app_arg_max_ge: "has_arg_max (f :: 'b \<Rightarrow> real) X \<Longrightarrow> x \<in> X \<Longrightarrow> f x \<le> f (arg_max_on f X)"
  unfolding has_arg_max_def arg_max_on_def arg_max_def is_arg_max_def
  using someI[where ?P = "\<lambda>x. x \<in> X \<and> (\<nexists>y. y \<in> X \<and> f x < f y)"] le_less_linear
  by auto

lemma app_arg_max_eq_SUP: "has_arg_max (f :: 'b \<Rightarrow> real) X \<Longrightarrow> f (arg_max_on f X) = \<Squnion>(f ` X)"
  by (simp add: arg_max_SUP arg_max_on_def has_arg_max_is_arg_max)

lemma SUP_is_arg_max:
  assumes "x \<in> X" "bdd_above (f ` X)" "(f :: 'c \<Rightarrow> real) x = \<Squnion>(f ` X)"
  shows "is_arg_max f (\<lambda>x. x \<in> X) x"
  unfolding is_arg_max_def
  using not_less assms cSUP_upper[of _ X f]
  by auto

lemma is_arg_max_linorderI[intro]: fixes f :: "'c \<Rightarrow> 'b :: linorder"
  assumes "P x" "\<And>y. (P y \<Longrightarrow> f x \<ge> f y)"
  shows "is_arg_max f P x"
  using assms by (auto simp: is_arg_max_linorder)

lemma is_arg_max_linorderD[dest]: fixes f :: "'c \<Rightarrow> 'b :: linorder"
  assumes "is_arg_max f P x"
  shows "P x" "(P y \<Longrightarrow> f x \<ge> f y)"
  using assms by (auto simp: is_arg_max_linorder)

lemma is_arg_max_cong:
  assumes "\<And>x. P x \<Longrightarrow> f x = g x"
  shows "is_arg_max f P x \<longleftrightarrow> is_arg_max g P x"
  unfolding is_arg_max_def using assms by auto

lemma is_arg_max_cong':
  assumes "\<And>x. P x \<Longrightarrow> f x = g x"
  shows "is_arg_max f P = is_arg_max g P"
  using assms by (auto cong: is_arg_max_cong)

lemma is_arg_max_congI:
  assumes "is_arg_max f P x" "\<And>x. P x \<Longrightarrow> f x = g x"
  shows "is_arg_max g P x"
  using is_arg_max_cong assms by force

subsection \<open>Contraction Mappings\<close>

definition "is_contraction C \<equiv> \<exists>l. 0 \<le> l \<and> l < 1 \<and> (\<forall>v u. dist (C v) (C u) \<le> l * dist v u)"

lemma banach':
  fixes C :: "'b :: complete_space \<Rightarrow> 'b"
  assumes "is_contraction C"
  shows "\<exists>!v. C v = v" "\<And>v. (\<lambda>n. (C ^^ n) v) \<longlonglongrightarrow> (THE v. C v = v)"
proof -
  obtain v where C: "C v = v" "\<forall>v'. C v' = v' \<longrightarrow> v' = v"
    by (metis assms is_contraction_def banach_fix_type)
  obtain l where cont: "dist (C v) (C u) \<le> l * dist v u" "0 \<le> l" "l < 1" for v u
    using assms is_contraction_def by blast
  have *: "\<And>n v0. dist ((C ^^ n) v0) v \<le> l ^ n * dist v0 v"
  proof -
    fix n v0
    show "dist ((C ^^ n) v0) v \<le> l ^ n * dist v0 v"
    proof (induction n)
      case (Suc n)
      thus "dist ((C ^^ Suc n) v0) v \<le> l ^ Suc n * dist v0 v"
        using \<open>0 \<le> l\<close>
        by (subst C(1)[symmetric]) (auto simp: algebra_simps intro!: order_trans[OF cont(1)] mult_left_mono)
    qed simp
  qed
  have "(\<lambda>n. l ^ n) \<longlonglongrightarrow> 0"
    by (simp add: LIMSEQ_realpow_zero \<open>0 \<le> l\<close> \<open>l < 1\<close>)
  hence "\<And>v0. (\<lambda>n. l ^ n * dist v0 v) \<longlonglongrightarrow> 0"
    by (simp add: tendsto_mult_left_zero)
  hence "(\<lambda>n. dist ((C ^^ n) v0) v) \<longlonglongrightarrow> 0" for v0
      using * order_trans abs_ge_self
      by (subst Limits.tendsto_0_le[of "(\<lambda>n. l ^ n * dist v0 v)" _ _ 1])
        (fastforce intro!: eventuallyI)+
  hence "\<And>v0. (\<lambda>n. (C ^^ n) v0) \<longlonglongrightarrow> v"
    using tendsto_dist_iff by blast
  thus "\<And>v0. (\<lambda>n. (C ^^ n) v0) \<longlonglongrightarrow> (THE v. C v = v)"
    by (metis (mono_tags, lifting) C theI')
next
  show "\<exists>!v. C v = v"
    using assms banach_fix_type unfolding is_contraction_def by blast
qed

lemma contraction_dist:
  fixes C :: "'b :: complete_space \<Rightarrow> 'b"
  assumes "\<And>v u. dist (C v) (C u) \<le> c  * dist v u"
  assumes "0 \<le> c" "c < 1"
  shows "(1 - c) * dist v (THE v. C v = v) \<le> dist v (C v)"
proof -
  have "is_contraction C"
    unfolding is_contraction_def using assms by auto
  then obtain v_fix where v_fix: "v_fix = (THE v. C v = v)"
    using the1_equality by blast
  hence "(\<lambda>n. (C ^^ n) v) \<longlonglongrightarrow> v_fix"
    using banach'[OF \<open>is_contraction C\<close>] by simp
  have dist_contr_le_pow: "\<And>n. dist ((C ^^ n) v) ((C ^^ Suc n) v) \<le> c ^ n * dist v (C v)"
  proof -
    fix n
    show "dist ((C ^^ n) v) ((C ^^ Suc n) v) \<le> c ^ n * dist v (C v)"
      using assms
      by (induction n) (auto simp: algebra_simps intro!: order.trans[OF assms(1)] mult_left_mono)
  qed
  have summable_C: "summable (\<lambda>i. dist ((C ^^ i) v) ((C ^^ Suc i) v))"
        using dist_contr_le_pow assms summable_powser_const
        by (intro summable_comparison_test[of "(\<lambda>i. dist ((C ^^ i) v) ((C ^^ Suc i) v))" "\<lambda>i. c^i * dist v (C v)"])
          auto
  have "\<forall>e > 0. dist v v_fix \<le> (\<Sum>i. dist ((C ^^ i) v) ((C ^^ (Suc i)) v)) + e"
  proof safe
    fix e ::real assume "0 < e"
    have "\<forall>\<^sub>F n in sequentially. dist ((C^^n) v) v_fix < e"
      using \<open>(\<lambda>n. (C ^^ n) v) \<longlonglongrightarrow> v_fix\<close> \<open>0 < e\<close> tendsto_iff by force
    then obtain N where "dist ((C^^N) v) v_fix < e"
      by fastforce
    hence *: "dist v v_fix \<le> dist v ((C^^N) v) + e"
      by (metis add_le_cancel_left dist_commute dist_triangle_le less_eq_real_def)
    have "dist v ((C^^N) v) \<le> (\<Sum>i\<le>N. dist ((C ^^ i) v) ((C ^^ (Suc i)) v))"
    proof (induction N arbitrary: v)
      case 0
      then show ?case by simp
    next
      case (Suc N)
      have "dist v ((C ^^ Suc N) v) \<le> dist v (C v) + dist (C v) ((C^^(Suc N)) v)"
        by metric
      also have "\<dots> =  dist v (C v) + dist (C v) ((C^^N) (C v))"
        by (metis funpow_simps_right(2) o_def)
      also have "\<dots> \<le> dist v (C v) + (\<Sum>i\<le>N. dist ((C ^^ i) (C v)) ((C ^^ Suc i) (C v)))"
        using Suc.IH add_le_cancel_left by blast
      also have "\<dots> \<le> dist v (C v) + (\<Sum>i\<le>N. dist ((C ^^Suc i) v) ((C ^^ (Suc (Suc i))) v))"
        by (simp only: funpow_simps_right(2) o_def)
      also have "\<dots> \<le> (\<Sum>i\<le>Suc N. dist ((C ^^ i) v) ((C ^^ (Suc i)) v))"
        by (subst sum.atMost_Suc_shift) simp
      finally show "dist v ((C ^^ Suc N) v) \<le> (\<Sum>i\<le>Suc N. dist ((C ^^ i) v) ((C ^^ Suc i) v))" .
    qed
    moreover have
      "(\<Sum>i\<le>N. dist ((C ^^ i) v) ((C ^^ Suc i) v)) \<le> (\<Sum>i. dist ((C ^^ i) v) ((C ^^ (Suc i)) v))"
      using summable_C
      by (auto intro: sum_le_suminf)
    ultimately have "dist v ((C^^N) v) \<le> (\<Sum>i. dist ((C ^^ i) v) ((C ^^ (Suc i)) v))"
      by linarith
    thus "dist v v_fix \<le> (\<Sum>i. dist ((C ^^ i) v) ((C ^^ Suc i) v)) + e"
      using * by fastforce
  qed
  hence le_suminf: "dist v v_fix \<le> (\<Sum>i. dist ((C ^^ i) v) ((C ^^ Suc i) v))"
    using field_le_epsilon by blast
  have "dist v v_fix \<le> (\<Sum>i. c ^ i * dist v (C v))"
    using dist_contr_le_pow summable_C assms summable_powser_const
    by (auto intro!: order_trans[OF le_suminf] suminf_le)
  hence "dist v v_fix \<le> dist v (C v) / (1 - c)"
    using sum_disc_lim
    by (metis sum_disc_lim abs_of_nonneg assms(2) assms(3))
  hence "(1 - c) * dist v v_fix \<le> dist v (C v)"
    using assms(3) mult.commute pos_le_divide_eq
    by (metis diff_gt_0_iff_gt)
  thus ?thesis
    using v_fix by blast
qed

subsection \<open>Limits\<close>
lemma tendsto_bfun_sandwich:
  assumes
    "(f :: nat \<Rightarrow> 'b \<Rightarrow>\<^sub>b real) \<longlonglongrightarrow> x" "(g :: nat \<Rightarrow> 'b \<Rightarrow>\<^sub>b real) \<longlonglongrightarrow> x"
    "eventually (\<lambda>n. f n \<le> h n) sequentially" "eventually (\<lambda>n. h n \<le> g n) sequentially"
  shows "(h :: nat \<Rightarrow> 'b \<Rightarrow>\<^sub>b real) \<longlonglongrightarrow> x"
proof -
  have 1: "(\<lambda>n.  dist (f n) (g n) + dist (g n) x) \<longlonglongrightarrow> 0"
    using tendsto_dist[OF assms(1) assms(2)] tendsto_dist_iff assms
    by (auto intro!: tendsto_add_zero)
  have "eventually (\<lambda>n. dist (h n) (g n) \<le> dist (f n) (g n)) sequentially"
    using assms(3) assms(4)
  proof eventually_elim
    case (elim n)
    hence "dist (h n a) (g n a) \<le> dist (f n a) (g n a)" for a
    proof -
      have "f n a \<le> h n a" "h n a \<le> g n a"
        using elim unfolding less_eq_bfun_def by auto
      thus ?thesis
        using dist_real_def by fastforce
    qed
    thus ?case
      unfolding dist_bfun.rep_eq
      by (auto intro!: cSUP_mono bounded_imp_bdd_above simp: dist_real_def bounded_minus_comp bounded_abs_range)
  qed
  moreover have "eventually (\<lambda>n. dist (h n) x \<le> dist (h n) (g n) + dist (g n) x) sequentially"
    by (simp add: dist_triangle)
  ultimately have 2: "eventually (\<lambda>n. dist (h n) x \<le> dist (f n) (g n) + dist (g n) x) sequentially"
    using eventually_elim2 by fastforce
  have "(\<lambda>n. dist (h n) x) \<longlonglongrightarrow> 0"
  proof (subst tendsto_iff, safe)
    fix e ::real
    assume "e > 0"
    hence 3: "\<forall>\<^sub>F xa in sequentially. dist (f xa) (g xa) + dist (g xa) x < e"
      using 1
      by (auto simp: tendsto_iff)
    show "\<forall>\<^sub>F xa in sequentially. dist (dist (h xa) x) 0 < e"
      by (rule eventually_mp[OF _ 3]) (fastforce intro: 2 eventually_mono)
  qed
  thus ?thesis
    using tendsto_dist_iff
    by auto
qed

subsection \<open>Supremum\<close>

lemma SUP_add_le:
  assumes "X \<noteq> {}" "bounded (B ` X)" "bounded (A' ` X)"
  shows "(\<Squnion>c \<in> X. (B :: 'a \<Rightarrow> real) c + A' c) \<le> (\<Squnion>b \<in> X. B b) + (\<Squnion>a \<in> X. A' a)"
  using assms
  by (auto simp: add_mono bounded_has_Sup(1) intro!: cSUP_least)+

lemma le_SUP_diff':
  assumes ne: "X \<noteq> {}"
    and bdd: "bounded (B ` X)" "bounded (A' ` X)"
    and sup_le: "(\<Squnion>a \<in> X. (A' :: 'a \<Rightarrow> real) a) \<le> (\<Squnion>b \<in> X. B b)"
  shows  "(\<Squnion>b \<in> X. B b) - (\<Squnion>a \<in> X. (A' :: 'a \<Rightarrow> real) a) \<le> (\<Squnion>c \<in> X. B c - A' c)"
proof -
  have "bounded ((\<lambda>x. (B x - A' x)) ` X)"
    using bdd bounded_minus_comp by blast
  have "(\<Squnion>b \<in> X. B b) - (\<Squnion>a \<in> X. A' a) - e \<le> (\<Squnion>c \<in> X. B c - A' c)" if e: "e > 0" for e
  proof -
    obtain z where z: "(\<Squnion>b \<in> X. B b) - e\<le> B z" "z \<in> X"
       using e ne
       by (subst less_cSupE[where ?y = "\<Squnion> (B ` X) - e", where ?X = "B`X"]) fastforce+
    hence " ((\<Squnion>a \<in> X. A' a) \<le> B z + e)"
      using sup_le
      by force
    hence "A' z \<le> B z + e"
      using \<open>z \<in> X\<close> bdd bounded_has_Sup(1) by fastforce
    thus "(\<Squnion>b \<in> X. B b) - (\<Squnion>a \<in> X. A' a) -e \<le> (\<Squnion>c \<in> X. B c - A' c)"
      using \<open>bounded ((\<lambda>x. B x - A' x) ` X)\<close> z bounded_has_Sup(1)[OF bdd(2)]
      by (subst cSUP_upper2[where x = z]) (fastforce intro!: bounded_imp_bdd_above)+
  qed
  thus ?thesis
    by (subst field_le_epsilon) fastforce+
qed

lemma le_SUP_diff:
  fixes A' :: "'a \<Rightarrow> real"
  assumes "X \<noteq> {}" "bounded (B ` X)" "bounded (A' ` X)" "(\<Squnion>a \<in> X. A' a) \<le> (\<Squnion>b \<in> X. B b)"
  shows  "0 \<le> (\<Squnion>c \<in> X. B c - A' c)"
  using assms
  by (auto intro!: order.trans[OF _ le_SUP_diff'])

lemma bounded_SUP_mul[simp]:
  "X \<noteq> {} \<Longrightarrow> 0 \<le> l \<Longrightarrow> bounded (f ` X) \<Longrightarrow> (\<Squnion>x \<in> X. (l :: real) * f x) = (l * (\<Squnion>x \<in> X. f x))"
proof -
  assume "X \<noteq> {} "" bounded (f ` X)" "0 \<le> l"
  have "(\<Squnion>x \<in> X. ereal l * ereal (f x)) = (l * (\<Squnion>x \<in> X. ereal (f x)))"
    by (simp add: Sup_ereal_mult_left' \<open>0 \<le> l\<close> \<open>X \<noteq> {}\<close>)
  obtain b where "\<forall>a \<in>X. \<bar>f a\<bar> \<le> b"
    using \<open>bounded (f ` X)\<close> bounded_real by auto
  have "\<forall>a \<in>X. \<bar>ereal (f a)\<bar> \<le> b"
    by (simp add: \<open>\<forall>a\<in>X. \<bar>f a\<bar> \<le> b\<close>)
  hence sup_leb: "(\<Squnion>a\<in>X. \<bar>ereal (f a)\<bar>)\<le> b"
    by (simp add: SUP_least)
  have "(\<Squnion>a\<in>X. ereal (f a)) \<le> (\<Squnion>a\<in>X. \<bar>ereal (f a)\<bar>)"
    by (auto intro: Complete_Lattices.SUP_mono')
  moreover have "-(\<Squnion>a\<in>X. ereal (f a)) \<le> (\<Squnion>a\<in>X. \<bar>ereal (f a)\<bar>)"
    using \<open>X \<noteq> {}\<close>
    by (auto intro!: Inf_less_eq cSUP_upper2 simp add: ereal_INF_uminus_eq[symmetric])
  ultimately have "\<bar>(\<Squnion>a\<in>X. ereal (f a))\<bar> \<le> (\<Squnion>a\<in>X. \<bar>ereal (f a)\<bar>)"
    by (auto intro: ereal_abs_leI)
  hence "\<bar>\<Squnion>a\<in>X. ereal (f a)\<bar> \<le> b"
    using sup_leb by auto
  hence "\<bar>\<Squnion>a\<in>X. ereal (f a)\<bar> \<noteq> \<infinity>"
    by auto
  hence "(\<Squnion>x \<in> X. ereal (f x)) = ereal (\<Squnion>x \<in> X. (f x))"
    using ereal_SUP by metis
  hence "(\<Squnion>x \<in> X. ereal (l * f x)) = ereal (l * (\<Squnion>x \<in> X. f x))"
    using \<open>(\<Squnion>x\<in>X. ereal l * ereal (f x)) = ereal l * (\<Squnion>x\<in>X. ereal (f x))\<close> by auto
  hence "ereal (\<Squnion>x \<in> X. l * f x) = ereal (l * (\<Squnion>x \<in> X. f x))"
    by (simp add: ereal_SUP)
  thus ?thesis
    by auto
qed

lemma abs_cSUP_le[intro]:
  "X \<noteq> {} \<Longrightarrow> bounded (F ` X) \<Longrightarrow> \<bar>\<Squnion>x \<in> X. (F x) :: real\<bar> \<le> (\<Squnion>x \<in> X. \<bar>F x\<bar>)"
  by (auto intro!: cSup_abs_le cSUP_upper2 bounded_imp_bdd_above simp: image_image[symmetric])

section \<open>Least argmax\<close>
definition "least_arg_max f P = (LEAST x. is_arg_max f P x)"

lemma least_arg_max_prop: "\<exists>x::'a::wellorder. P x \<Longrightarrow> finite {x. P x} \<Longrightarrow> P (least_arg_max (f :: _ \<Rightarrow> real) P)"
  unfolding least_arg_max_def
  apply (rule LeastI2_ex)
  using finite_is_arg_max[of "{x. P x}", where f = f]
  by auto

lemma is_arg_max_apply_eq: "is_arg_max (f :: _ \<Rightarrow> _ :: linorder)  P x \<Longrightarrow> is_arg_max f P y \<Longrightarrow> f x = f y"
  by (auto simp: is_arg_max_def not_less dual_order.eq_iff)

lemma least_arg_max_apply:
  assumes "is_arg_max (f :: _ \<Rightarrow> _ :: linorder) P (x::_::wellorder)"
  shows "f (least_arg_max f P) = f x"
proof -
  have "is_arg_max f P (least_arg_max f P)"
    by (metis LeastI_ex assms least_arg_max_def)
  thus ?thesis
    using is_arg_max_apply_eq assms by metis
qed

lemma apply_arg_max_eq_max: "finite {x . P x} \<Longrightarrow> is_arg_max (f :: _ \<Rightarrow> _ :: linorder) P x \<Longrightarrow> f x = Max (f ` {x. P x})"
  by (auto simp: is_arg_max_def intro!: Max_eqI[symmetric])

lemma apply_arg_max_eq_max': "finite X\<Longrightarrow> is_arg_max (f :: _ \<Rightarrow> _ :: linorder) (\<lambda>x. x \<in> X) x \<Longrightarrow> (MAX x \<in> X. f x) = f x"
  by (auto simp: is_arg_max_linorder intro!: Max_eqI)

lemma least_arg_max_is_arg_max: "P \<noteq> {} \<Longrightarrow> finite P \<Longrightarrow> is_arg_max f (\<lambda>x::_::wellorder. x \<in> P) (least_arg_max (f :: _ \<Rightarrow> real) (\<lambda>x. x \<in> P))"
  unfolding least_arg_max_def
  apply (rule LeastI_ex)
  using finite_is_arg_max
  by auto

lemma is_arg_max_const: "is_arg_max (f :: _ \<Rightarrow> _ :: linorder) (\<lambda>y. y = c) x \<longleftrightarrow> x = c"
  unfolding is_arg_max_def
  by auto

lemma least_arg_max_cong':
  assumes "\<And>x. is_arg_max f P x = is_arg_max g P x"
  shows "least_arg_max f P = least_arg_max g P"
  unfolding least_arg_max_def using assms by metis

end


(*  Title:      HOL/Matrix_LP/ComputeFloat.thy
    Author:     Steven Obua
*)

section \<open>Floating Point Representation of the Reals\<close>

theory ComputeFloat
imports Complex_Main "~~/src/HOL/Library/Lattice_Algebras"
begin

ML_file "~~/src/Tools/float.ML"

(*FIXME surely floor should be used? This file is full of redundant material.*)

definition int_of_real :: "real \<Rightarrow> int"
  where "int_of_real x = (SOME y. real_of_int y = x)"

definition real_is_int :: "real \<Rightarrow> bool"
  where "real_is_int x = (EX (u::int). x = real_of_int u)"

lemma real_is_int_def2: "real_is_int x = (x = real_of_int (int_of_real x))"
  by (auto simp add: real_is_int_def int_of_real_def)

lemma real_is_int_real[simp]: "real_is_int (real_of_int (x::int))"
by (auto simp add: real_is_int_def int_of_real_def)

lemma int_of_real_real[simp]: "int_of_real (real_of_int x) = x"
by (simp add: int_of_real_def)

lemma real_int_of_real[simp]: "real_is_int x \<Longrightarrow> real_of_int (int_of_real x) = x"
by (auto simp add: int_of_real_def real_is_int_def)

lemma real_is_int_add_int_of_real: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> (int_of_real (a+b)) = (int_of_real a) + (int_of_real b)"
by (auto simp add: int_of_real_def real_is_int_def)

lemma real_is_int_add[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a+b)"
apply (subst real_is_int_def2)
apply (simp add: real_is_int_add_int_of_real real_int_of_real)
done

lemma int_of_real_sub: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> (int_of_real (a-b)) = (int_of_real a) - (int_of_real b)"
by (auto simp add: int_of_real_def real_is_int_def)

lemma real_is_int_sub[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a-b)"
apply (subst real_is_int_def2)
apply (simp add: int_of_real_sub real_int_of_real)
done

lemma real_is_int_rep: "real_is_int x \<Longrightarrow> \<exists>!(a::int). real_of_int a = x"
by (auto simp add: real_is_int_def)

lemma int_of_real_mult:
  assumes "real_is_int a" "real_is_int b"
  shows "(int_of_real (a*b)) = (int_of_real a) * (int_of_real b)"
  using assms
  by (auto simp add: real_is_int_def of_int_mult[symmetric]
           simp del: of_int_mult)

lemma real_is_int_mult[simp]: "real_is_int a \<Longrightarrow> real_is_int b \<Longrightarrow> real_is_int (a*b)"
apply (subst real_is_int_def2)
apply (simp add: int_of_real_mult)
done

lemma real_is_int_0[simp]: "real_is_int (0::real)"
by (simp add: real_is_int_def int_of_real_def)

lemma real_is_int_1[simp]: "real_is_int (1::real)"
proof -
  have "real_is_int (1::real) = real_is_int(real_of_int (1::int))" by auto
  also have "\<dots> = True" by (simp only: real_is_int_real)
  ultimately show ?thesis by auto
qed

lemma real_is_int_n1: "real_is_int (-1::real)"
proof -
  have "real_is_int (-1::real) = real_is_int(real_of_int (-1::int))" by auto
  also have "\<dots> = True" by (simp only: real_is_int_real)
  ultimately show ?thesis by auto
qed

lemma real_is_int_numeral[simp]: "real_is_int (numeral x)"
  by (auto simp: real_is_int_def intro!: exI[of _ "numeral x"])

lemma real_is_int_neg_numeral[simp]: "real_is_int (- numeral x)"
  by (auto simp: real_is_int_def intro!: exI[of _ "- numeral x"])

lemma int_of_real_0[simp]: "int_of_real (0::real) = (0::int)"
by (simp add: int_of_real_def)

lemma int_of_real_1[simp]: "int_of_real (1::real) = (1::int)"
proof -
  have 1: "(1::real) = real_of_int (1::int)" by auto
  show ?thesis by (simp only: 1 int_of_real_real)
qed

lemma int_of_real_numeral[simp]: "int_of_real (numeral b) = numeral b"
  unfolding int_of_real_def by simp

lemma int_of_real_neg_numeral[simp]: "int_of_real (- numeral b) = - numeral b"
  unfolding int_of_real_def
  by (metis int_of_real_def int_of_real_real of_int_minus of_int_of_nat_eq of_nat_numeral)

lemma int_div_zdiv: "int (a div b) = (int a) div (int b)"
by (rule zdiv_int)

lemma int_mod_zmod: "int (a mod b) = (int a) mod (int b)"
by (rule zmod_int)

lemma abs_div_2_less: "a \<noteq> 0 \<Longrightarrow> a \<noteq> -1 \<Longrightarrow> \<bar>(a::int) div 2\<bar> < \<bar>a\<bar>"
by arith

lemma norm_0_1: "(1::_::numeral) = Numeral1"
  by auto

lemma add_left_zero: "0 + a = (a::'a::comm_monoid_add)"
  by simp

lemma add_right_zero: "a + 0 = (a::'a::comm_monoid_add)"
  by simp

lemma mult_left_one: "1 * a = (a::'a::semiring_1)"
  by simp

lemma mult_right_one: "a * 1 = (a::'a::semiring_1)"
  by simp

lemma int_pow_0: "(a::int)^0 = 1"
  by simp

lemma int_pow_1: "(a::int)^(Numeral1) = a"
  by simp

lemma one_eq_Numeral1_nring: "(1::'a::numeral) = Numeral1"
  by simp

lemma one_eq_Numeral1_nat: "(1::nat) = Numeral1"
  by simp

lemma zpower_Pls: "(z::int)^0 = Numeral1"
  by simp

lemma fst_cong: "a=a' \<Longrightarrow> fst (a,b) = fst (a',b)"
  by simp

lemma snd_cong: "b=b' \<Longrightarrow> snd (a,b) = snd (a,b')"
  by simp

lemma lift_bool: "x \<Longrightarrow> x=True"
  by simp

lemma nlift_bool: "~x \<Longrightarrow> x=False"
  by simp

lemma not_false_eq_true: "(~ False) = True" by simp

lemma not_true_eq_false: "(~ True) = False" by simp

lemmas powerarith = nat_numeral power_numeral_even
  power_numeral_odd zpower_Pls

definition float :: "(int \<times> int) \<Rightarrow> real" where
  "float = (\<lambda>(a, b). real_of_int a * 2 powr real_of_int b)"

lemma float_add_l0: "float (0, e) + x = x"
  by (simp add: float_def)

lemma float_add_r0: "x + float (0, e) = x"
  by (simp add: float_def)

lemma float_add:
  "float (a1, e1) + float (a2, e2) =
  (if e1<=e2 then float (a1+a2*2^(nat(e2-e1)), e1) else float (a1*2^(nat (e1-e2))+a2, e2))"
  by (simp add: float_def algebra_simps powr_realpow[symmetric] powr_divide2[symmetric])

lemma float_mult_l0: "float (0, e) * x = float (0, 0)"
  by (simp add: float_def)

lemma float_mult_r0: "x * float (0, e) = float (0, 0)"
  by (simp add: float_def)

lemma float_mult:
  "float (a1, e1) * float (a2, e2) = (float (a1 * a2, e1 + e2))"
  by (simp add: float_def powr_add)

lemma float_minus:
  "- (float (a,b)) = float (-a, b)"
  by (simp add: float_def)

lemma zero_le_float:
  "(0 <= float (a,b)) = (0 <= a)"
  by (simp add: float_def zero_le_mult_iff) (simp add: not_less [symmetric])

lemma float_le_zero:
  "(float (a,b) <= 0) = (a <= 0)"
  by (simp add: float_def mult_le_0_iff) (simp add: not_less [symmetric])

lemma float_abs:
  "\<bar>float (a,b)\<bar> = (if 0 <= a then (float (a,b)) else (float (-a,b)))"
  by (simp add: float_def abs_if mult_less_0_iff not_less)

lemma float_zero:
  "float (0, b) = 0"
  by (simp add: float_def)

lemma float_pprt:
  "pprt (float (a, b)) = (if 0 <= a then (float (a,b)) else (float (0, b)))"
  by (auto simp add: zero_le_float float_le_zero float_zero)

lemma float_nprt:
  "nprt (float (a, b)) = (if 0 <= a then (float (0,b)) else (float (a, b)))"
  by (auto simp add: zero_le_float float_le_zero float_zero)

definition lbound :: "real \<Rightarrow> real"
  where "lbound x = min 0 x"

definition ubound :: "real \<Rightarrow> real"
  where "ubound x = max 0 x"

lemma lbound: "lbound x \<le> x"
  by (simp add: lbound_def)

lemma ubound: "x \<le> ubound x"
  by (simp add: ubound_def)

lemma pprt_lbound: "pprt (lbound x) = float (0, 0)"
  by (auto simp: float_def lbound_def)

lemma nprt_ubound: "nprt (ubound x) = float (0, 0)"
  by (auto simp: float_def ubound_def)

lemmas floatarith[simplified norm_0_1] = float_add float_add_l0 float_add_r0 float_mult float_mult_l0 float_mult_r0
          float_minus float_abs zero_le_float float_pprt float_nprt pprt_lbound nprt_ubound

(* for use with the compute oracle *)
lemmas arith = arith_simps rel_simps diff_nat_numeral nat_0
  nat_neg_numeral powerarith floatarith not_false_eq_true not_true_eq_false

ML_file "float_arith.ML"

end


(*  Title:      ZF/Induct/Binary_Trees.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section {* Binary trees *}

theory Binary_Trees imports Main begin

subsection {* Datatype definition *}

consts
  bt :: "i => i"

datatype "bt(A)" =
  Lf | Br ("a \<in> A", "t1 \<in> bt(A)", "t2 \<in> bt(A)")

declare bt.intros [simp]

lemma Br_neq_left: "l \<in> bt(A) ==> Br(x, l, r) \<noteq> l"
  by (induct arbitrary: x r set: bt) auto

lemma Br_iff: "Br(a, l, r) = Br(a', l', r') \<longleftrightarrow> a = a' & l = l' & r = r'"
  -- "Proving a freeness theorem."
  by (fast elim!: bt.free_elims)

inductive_cases BrE: "Br(a, l, r) \<in> bt(A)"
  -- "An elimination rule, for type-checking."

text {*
  \medskip Lemmas to justify using @{term bt} in other recursive type
  definitions.
*}

lemma bt_mono: "A \<subseteq> B ==> bt(A) \<subseteq> bt(B)"
  apply (unfold bt.defs)
  apply (rule lfp_mono)
    apply (rule bt.bnd_mono)+
  apply (rule univ_mono basic_monos | assumption)+
  done

lemma bt_univ: "bt(univ(A)) \<subseteq> univ(A)"
  apply (unfold bt.defs bt.con_defs)
  apply (rule lfp_lowerbound)
   apply (rule_tac [2] A_subset_univ [THEN univ_mono])
  apply (fast intro!: zero_in_univ Inl_in_univ Inr_in_univ Pair_in_univ)
  done

lemma bt_subset_univ: "A \<subseteq> univ(B) ==> bt(A) \<subseteq> univ(B)"
  apply (rule subset_trans)
   apply (erule bt_mono)
  apply (rule bt_univ)
  done

lemma bt_rec_type:
  "[| t \<in> bt(A);
    c \<in> C(Lf);
    !!x y z r s. [| x \<in> A;  y \<in> bt(A);  z \<in> bt(A);  r \<in> C(y);  s \<in> C(z) |] ==>
    h(x, y, z, r, s) \<in> C(Br(x, y, z))
  |] ==> bt_rec(c, h, t) \<in> C(t)"
  -- {* Type checking for recursor -- example only; not really needed. *}
  apply (induct_tac t)
   apply simp_all
  done

subsection {* Number of nodes, with an example of tail-recursion *}

consts  n_nodes :: "i => i"
primrec
  "n_nodes(Lf) = 0"
  "n_nodes(Br(a, l, r)) = succ(n_nodes(l) #+ n_nodes(r))"

lemma n_nodes_type [simp]: "t \<in> bt(A) ==> n_nodes(t) \<in> nat"
  by (induct set: bt) auto

consts  n_nodes_aux :: "i => i"
primrec
  "n_nodes_aux(Lf) = (\<lambda>k \<in> nat. k)"
  "n_nodes_aux(Br(a, l, r)) =
      (\<lambda>k \<in> nat. n_nodes_aux(r) `  (n_nodes_aux(l) ` succ(k)))"

lemma n_nodes_aux_eq:
    "t \<in> bt(A) ==> k \<in> nat ==> n_nodes_aux(t)`k = n_nodes(t) #+ k"
  apply (induct arbitrary: k set: bt)
   apply simp
  apply (atomize, simp)
  done

definition
  n_nodes_tail :: "i => i"  where
  "n_nodes_tail(t) == n_nodes_aux(t) ` 0"

lemma "t \<in> bt(A) ==> n_nodes_tail(t) = n_nodes(t)"
  by (simp add: n_nodes_tail_def n_nodes_aux_eq)

subsection {* Number of leaves *}

consts
  n_leaves :: "i => i"
primrec
  "n_leaves(Lf) = 1"
  "n_leaves(Br(a, l, r)) = n_leaves(l) #+ n_leaves(r)"

lemma n_leaves_type [simp]: "t \<in> bt(A) ==> n_leaves(t) \<in> nat"
  by (induct set: bt) auto

subsection {* Reflecting trees *}

consts
  bt_reflect :: "i => i"
primrec
  "bt_reflect(Lf) = Lf"
  "bt_reflect(Br(a, l, r)) = Br(a, bt_reflect(r), bt_reflect(l))"

lemma bt_reflect_type [simp]: "t \<in> bt(A) ==> bt_reflect(t) \<in> bt(A)"
  by (induct set: bt) auto

text {*
  \medskip Theorems about @{term n_leaves}.
*}

lemma n_leaves_reflect: "t \<in> bt(A) ==> n_leaves(bt_reflect(t)) = n_leaves(t)"
  by (induct set: bt) (simp_all add: add_commute)

lemma n_leaves_nodes: "t \<in> bt(A) ==> n_leaves(t) = succ(n_nodes(t))"
  by (induct set: bt) simp_all

text {*
  Theorems about @{term bt_reflect}.
*}

lemma bt_reflect_bt_reflect_ident: "t \<in> bt(A) ==> bt_reflect(bt_reflect(t)) = t"
  by (induct set: bt) simp_all

end


(* Authors: Lammich, Wimmer *)
theory FW_Code
  imports
    Recursion_Combinators
    Floyd_Warshall
begin

section \<open>Refinement to Efficient Imperative Code\<close>

text \<open>
  We will now refine the recursive version of the \fw to an efficient imperative version.
  To this end, we use the Imperative Refinement Framework, yielding an implementation in Imperative HOL.
\<close>

definition fw_upd' :: "('a::linordered_ab_monoid_add) mtx \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mtx nres" where
  "fw_upd' m k i j =
  RETURN (
    op_mtx_set m (i, j) (min (op_mtx_get m (i, j)) (op_mtx_get m (i, k) + op_mtx_get m (k, j)))
  )"

definition fwi' ::  "('a::linordered_ab_monoid_add) mtx \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mtx nres"
where
  "fwi' m n k i j = RECT (\<lambda> fw (m, k, i, j).
      case (i, j) of
        (0, 0) \<Rightarrow> fw_upd' m k 0 0 |
        (Suc i, 0) \<Rightarrow> do {m' \<leftarrow> fw (m, k, i, n); fw_upd' m' k (Suc i) 0} |
        (i, Suc j) \<Rightarrow> do {m' \<leftarrow> fw (m, k, i, j); fw_upd' m' k i (Suc j)}
    ) (m, k, i, j)"

lemma fwi'_simps:
  "fwi' m n k 0       0        = fw_upd' m k 0 0"
  "fwi' m n k (Suc i) 0        = do {m' \<leftarrow> fwi' m n k i n; fw_upd' m' k (Suc i) 0}"
  "fwi' m n k i       (Suc j)  = do {m' \<leftarrow> fwi' m n k i j; fw_upd' m' k i (Suc j)}"
unfolding fwi'_def by (subst RECT_unfold, (refine_mono; fail), (auto split: nat.split; fail))+

lemma
  "fwi' m n k i j \<le> SPEC (\<lambda> r. r = uncurry (fwi (curry m) n k i j))"
by (induction "curry m" n k i j arbitrary: m rule: fwi.induct)
   (fastforce simp add: fw_upd'_def fw_upd_def upd_def fwi'_simps pw_le_iff refine_pw_simps)+

lemma fw_upd'_spec:
  "fw_upd' M k i j \<le> SPEC (\<lambda> M'. M' = uncurry (fw_upd (curry M) k i j))"
by (auto simp: fw_upd'_def fw_upd_def upd_def pw_le_iff refine_pw_simps)

lemma for_rec2_fwi:
  "for_rec2 (\<lambda> M. fw_upd' M k) M n i j \<le> SPEC (\<lambda> M'. M' = uncurry (fwi (curry M) n k i j))"
using fw_upd'_spec
by (induction "\<lambda> M. fw_upd' (M :: (nat \<times> nat \<Rightarrow> 'a)) k" M n i j rule: for_rec2.induct)
   (fastforce simp: pw_le_iff refine_pw_simps)+

definition fw' ::  "('a::linordered_ab_monoid_add) mtx \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a mtx nres" where
  "fw' m n k = nfoldli [0..<k + 1] (\<lambda> _. True) (\<lambda> k M. for_rec2 (\<lambda> M. fw_upd' M k) M n n n) m"

lemma fw'_spec:
  "fw' m n k \<le> SPEC (\<lambda> M'. M' = uncurry (fw (curry m) n k))"
  unfolding fw'_def
  apply (induction k)
  using for_rec2_fwi by (fastforce simp add: pw_le_iff refine_pw_simps curry_def)+

context
  fixes n :: nat
  fixes dummy :: "'a::{linordered_ab_monoid_add,zero,heap}"
begin

lemma [sepref_import_param]: "((+),(+)::'a\<Rightarrow>_) \<in> Id \<rightarrow> Id \<rightarrow> Id" by simp
lemma [sepref_import_param]: "(min,min::'a\<Rightarrow>_) \<in> Id \<rightarrow> Id \<rightarrow> Id" by simp

abbreviation "node_assn \<equiv> nat_assn"
abbreviation "mtx_assn \<equiv> asmtx_assn (Suc n) id_assn::('a mtx \<Rightarrow>_)"

sepref_definition fw_upd_impl is
  "uncurry2 (uncurry fw_upd')" ::
  "[\<lambda> (((_,k),i),j). k \<le> n \<and> i \<le> n \<and> j \<le> n]\<^sub>a mtx_assn\<^sup>d *\<^sub>a node_assn\<^sup>k *\<^sub>a node_assn\<^sup>k *\<^sub>a node_assn\<^sup>k
  \<rightarrow> mtx_assn"
unfolding fw_upd'_def[abs_def] by sepref

declare fw_upd_impl.refine[sepref_fr_rules]

sepref_register fw_upd' :: "'a i_mtx \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a i_mtx nres"

definition
  "fwi_impl' (M :: 'a mtx) k = for_rec2 (\<lambda> M. fw_upd' M k) M n n n"

definition
  "fw_impl' (M :: 'a mtx) = fw' M n n"

context
  notes [id_rules] = itypeI[of n "TYPE (nat)"]
    and [sepref_import_param] = IdI[of n]
begin

sepref_definition fw_impl is
  "fw_impl'" :: "mtx_assn\<^sup>d \<rightarrow>\<^sub>a mtx_assn"
unfolding fw_impl'_def[abs_def] fw'_def for_rec2_eq by sepref

sepref_definition fwi_impl is
  "uncurry fwi_impl'" :: "[\<lambda> (_,k). k \<le> n]\<^sub>a mtx_assn\<^sup>d *\<^sub>a node_assn\<^sup>k \<rightarrow> mtx_assn"
unfolding fwi_impl'_def[abs_def] for_rec2_eq by sepref

end (* End of sepref setup *)

end (* End of n *)

export_code fw_impl checking SML_imp

text \<open>
  A compact specification for the characteristic property of the \fw.
\<close>
definition fw_spec where
  "fw_spec n M \<equiv> SPEC (\<lambda> M'.
    if (\<exists> i \<le> n. M' i i < 0)
    then \<not> cyc_free M n
    else \<forall>i \<le> n. \<forall>j \<le> n. M' i j = D M i j n \<and> cyc_free M n)"

lemma D_diag_nonnegI:
  assumes "cycle_free M n" "i \<le> n"
  shows "D M i i n \<ge> 0"
using assms D_dest''[OF refl, of M i i n] unfolding cycle_free_def by auto

lemma fw_fw_spec:
  "RETURN (FW M n) \<le> fw_spec n M"
unfolding fw_spec_def cycle_free_diag_equiv
proof (simp, safe, goal_cases)
  case prems: (1 i)
  with fw_shortest_path[unfolded cycle_free_diag_equiv, OF prems(3)] D_diag_nonnegI show ?case
    by fastforce
next
  case 2 then show ?case using FW_neg_cycle_detect[unfolded cycle_free_diag_equiv]
    by (force intro: fw_shortest_path[symmetric, unfolded cycle_free_diag_equiv])
next
  case 3 then show ?case using FW_neg_cycle_detect[unfolded cycle_free_diag_equiv] by blast
qed

definition
  "mat_curry_rel = {(Mu, Mc). curry Mu = Mc}"

definition
  "mtx_curry_assn n = hr_comp (mtx_assn n) (br curry (\<lambda>_. True))"

declare mtx_curry_assn_def[symmetric, fcomp_norm_unfold]

lemma fw_impl'_correct:
  "(fw_impl', fw_spec) \<in> Id \<rightarrow> br curry (\<lambda> _. True) \<rightarrow> \<langle>br curry (\<lambda> _. True)\<rangle> nres_rel"
unfolding fw_impl'_def[abs_def] using fw'_spec fw_fw_spec
by (fastforce simp: in_br_conv pw_le_iff refine_pw_simps intro!: nres_relI)

subsection \<open>Main Result\<close>

text \<open>This is one way to state that \<open>fw_impl\<close> fulfills the specification \<open>fw_spec\<close>.\<close>
theorem fw_impl_correct:
  "(fw_impl n, fw_spec n) \<in> (mtx_curry_assn n)\<^sup>d \<rightarrow>\<^sub>a mtx_curry_assn n"
using fw_impl.refine[FCOMP fw_impl'_correct[THEN fun_relD, OF IdI]] .

text \<open>An alternative version: a Hoare triple for total correctness.\<close>
corollary
  "<mtx_curry_assn n M Mi> fw_impl n Mi <\<lambda> Mi'. \<exists>\<^sub>A M'. mtx_curry_assn n M' Mi' * \<up>
    (if (\<exists> i \<le> n. M' i i < 0)
    then \<not> cyc_free M n
    else \<forall>i \<le> n. \<forall>j \<le> n. M' i j = D M i j n \<and> cyc_free M n)>\<^sub>t"
unfolding cycle_free_diag_equiv
by (rule cons_rule[OF _ _ fw_impl_correct[THEN hfrefD, THEN hn_refineD]])
   (sep_auto simp: fw_spec_def[unfolded cycle_free_diag_equiv])+

subsection \<open>Alternative Versions for Uncurried Matrices.\<close>

definition "FWI' = uncurry ooo FWI o curry"

lemma fwi_impl'_refine_FWI':
  "(fwi_impl' n, RETURN oo PR_CONST (\<lambda> M. FWI' M n)) \<in> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle> nres_rel"
unfolding fwi_impl'_def[abs_def] FWI_def[abs_def] FWI'_def using for_rec2_fwi
by (force simp: pw_le_iff pw_nres_rel_iff refine_pw_simps)

lemmas fwi_impl_refine_FWI' = fwi_impl.refine[FCOMP fwi_impl'_refine_FWI']

definition "FW' = uncurry oo FW o curry"

definition "FW'' n M = FW' M n"

lemma fw_impl'_refine_FW'':
  "(fw_impl' n, RETURN o PR_CONST (FW'' n)) \<in> Id \<rightarrow> \<langle>Id\<rangle> nres_rel"
unfolding fw_impl'_def[abs_def] FW''_def[abs_def] FW'_def using fw'_spec
by (force simp: pw_le_iff pw_nres_rel_iff refine_pw_simps)

lemmas fw_impl_refine_FW'' = fw_impl.refine[FCOMP fw_impl'_refine_FW'']

end


(* Author: Tobias Nipkow *)

section \<open>Red-Black Tree Implementation of Maps\<close>

theory RBT_Map
imports
  RBT_Set
  Lookup2
begin

fun upd :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a*'b) rbt \<Rightarrow> ('a*'b) rbt" where
"upd x y Leaf = R Leaf (x,y) Leaf" |
"upd x y (B l (a,b) r) = (case cmp x a of
  LT \<Rightarrow> baliL (upd x y l) (a,b) r |
  GT \<Rightarrow> baliR l (a,b) (upd x y r) |
  EQ \<Rightarrow> B l (x,y) r)" |
"upd x y (R l (a,b) r) = (case cmp x a of
  LT \<Rightarrow> R (upd x y l) (a,b) r |
  GT \<Rightarrow> R l (a,b) (upd x y r) |
  EQ \<Rightarrow> R l (x,y) r)"

definition update :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a*'b) rbt \<Rightarrow> ('a*'b) rbt" where
"update x y t = paint Black (upd x y t)"

fun del :: "'a::linorder \<Rightarrow> ('a*'b)rbt \<Rightarrow> ('a*'b)rbt" where
"del x Leaf = Leaf" |
"del x (Node l ((a,b), c) r) = (case cmp x a of
     LT \<Rightarrow> if l \<noteq> Leaf \<and> color l = Black
           then baldL (del x l) (a,b) r else R (del x l) (a,b) r |
     GT \<Rightarrow> if r \<noteq> Leaf\<and> color r = Black
           then baldR l (a,b) (del x r) else R l (a,b) (del x r) |
  EQ \<Rightarrow> join l r)"

definition delete :: "'a::linorder \<Rightarrow> ('a*'b) rbt \<Rightarrow> ('a*'b) rbt" where
"delete x t = paint Black (del x t)"

subsection "Functional Correctness Proofs"

lemma inorder_upd:
  "sorted1(inorder t) \<Longrightarrow> inorder(upd x y t) = upd_list x y (inorder t)"
by(induction x y t rule: upd.induct)
  (auto simp: upd_list_simps inorder_baliL inorder_baliR)

lemma inorder_update:
  "sorted1(inorder t) \<Longrightarrow> inorder(update x y t) = upd_list x y (inorder t)"
by(simp add: update_def inorder_upd inorder_paint)

lemma inorder_del:
 "sorted1(inorder t) \<Longrightarrow>  inorder(del x t) = del_list x (inorder t)"
by(induction x t rule: del.induct)
  (auto simp: del_list_simps inorder_join inorder_baldL inorder_baldR)

lemma inorder_delete:
  "sorted1(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
by(simp add: delete_def inorder_del inorder_paint)

subsection \<open>Structural invariants\<close>

subsubsection \<open>Update\<close>

lemma invc_upd: assumes "invc t"
  shows "color t = Black \<Longrightarrow> invc (upd x y t)" "invc2 (upd x y t)"
using assms
by (induct x y t rule: upd.induct) (auto simp: invc_baliL invc_baliR invc2I)

lemma invh_upd: assumes "invh t"
  shows "invh (upd x y t)" "bheight (upd x y t) = bheight t"
using assms
by(induct x y t rule: upd.induct)
  (auto simp: invh_baliL invh_baliR bheight_baliL bheight_baliR)

theorem rbt_update: "rbt t \<Longrightarrow> rbt (update x y t)"
by (simp add: invc_upd(2) invh_upd(1) color_paint_Black invh_paint rbt_def update_def)

subsubsection \<open>Deletion\<close>

lemma del_invc_invh: "invh t \<Longrightarrow> invc t \<Longrightarrow> invh (del x t) \<and>
   (color t = Red \<and> bheight (del x t) = bheight t \<and> invc (del x t) \<or>
    color t = Black \<and> bheight (del x t) = bheight t - 1 \<and> invc2 (del x t))"
proof (induct x t rule: del.induct)
case (2 x _ y _ c)
  have "x = y \<or> x < y \<or> x > y" by auto
  thus ?case proof (elim disjE)
    assume "x = y"
    with 2 show ?thesis
    by (cases c) (simp_all add: invh_join invc_join)
  next
    assume "x < y"
    with 2 show ?thesis
      by(cases c)
        (auto simp: invh_baldL_invc invc_baldL invc2_baldL dest: neq_LeafD)
  next
    assume "y < x"
    with 2 show ?thesis
      by(cases c)
        (auto simp: invh_baldR_invc invc_baldR invc2_baldR dest: neq_LeafD)
  qed
qed auto

theorem rbt_delete: "rbt t \<Longrightarrow> rbt (delete k t)"
by (metis delete_def rbt_def color_paint_Black del_invc_invh invc2I invh_paint)

interpretation M: Map_by_Ordered
where empty = empty and lookup = lookup and update = update and delete = delete
and inorder = inorder and inv = rbt
proof (standard, goal_cases)
  case 1 show ?case by (simp add: empty_def)
next
  case 2 thus ?case by(simp add: lookup_map_of)
next
  case 3 thus ?case by(simp add: inorder_update)
next
  case 4 thus ?case by(simp add: inorder_delete)
next
  case 5 thus ?case by (simp add: rbt_def empty_def)
next
  case 6 thus ?case by (simp add: rbt_update)
next
  case 7 thus ?case by (simp add: rbt_delete)
qed

end