theory Clock
  imports "TLA-Utils"
begin

definition next_hour :: "nat \<Rightarrow> nat" where "\<And>n. next_hour n \<equiv> if n = 12 then 1 else n+1"

lemma next_hour_induct [case_names base step, consumes 1]:
  fixes m :: nat
  assumes type: "m \<in> {1..12}"
  assumes base: "P 1"
  assumes step: "\<And>n. 1 \<le> n \<Longrightarrow> n < 12 \<Longrightarrow> P n \<Longrightarrow> P (next_hour n)"
  shows "P m"
  using type
proof (induct m)
  case (Suc m)
  from `Suc m \<in> {1..12}` have "m = 0 \<or> (m \<in> {1..12} \<and> 1 \<le> m \<and> m < 12)" by auto
  with base show ?case
  proof (elim disjE conjE)
    assume "m \<in> {1..12}" with Suc have "P m" "1 \<le> m" "m < 12" by simp_all
    hence "P (next_hour m)" by (intro step, auto)
    with `m < 12` show ?case by (simp add: next_hour_def)
  qed simp
qed simp

locale HourClock =
  fixes hr :: "nat stfun"
  assumes hr_basevar: "basevars hr"
  fixes HCini HCnxt HC
  assumes HCini_def: "HCini \<equiv> PRED hr \<in> #{1..12}"
  assumes HCnxt_def: "HCnxt \<equiv> ACT hr$ = next_hour<$hr>"
  assumes HC_def:    "HC    \<equiv> TEMP Init HCini \<and> \<box>[HCnxt]_hr \<and> WF(HCnxt)_hr"

context HourClock
begin

lemma HCnxt_angle[simp]: "ACT <HCnxt>_hr = ACT HCnxt"
  unfolding HCnxt_def angle_def next_hour_def by auto

lemma HCnxt_enabled[simp]: "PRED (Enabled HCnxt) = PRED #True"
  using basevars [OF hr_basevar] unfolding enabled_def HCnxt_def by auto

lemma HC_safety: "\<turnstile> HC \<longrightarrow> \<box> HCini"
  unfolding HC_def HCini_def HCnxt_def next_hour_def by (auto_invariant, auto)

lemma HC_liveness_step:
  assumes n: "n \<in> {1..12}"
  shows "\<turnstile> HC \<longrightarrow> (hr = #n \<leadsto> hr = #(next_hour n))"
proof -
  from basevars [OF hr_basevar]
  have "\<turnstile> \<box>[HCnxt]_hr \<and> WF(HCnxt)_hr \<longrightarrow> (hr = #n \<leadsto> hr = #(next_hour n))"
    apply (intro WF1, auto simp add: HCnxt_def square_def next_hour_def angle_def enabled_def, auto)
    apply fastforce
    by fastforce
  thus ?thesis
    by (auto simp add: HC_def)
qed

lemma HC_liveness_progress_forwards:
  assumes m: "m \<in> {1..12}"
  assumes n: "n \<in> {1..12}"
  assumes mn: "m \<le> n"
  shows "\<turnstile> HC \<longrightarrow> (hr = #m \<leadsto> hr = #n)"
  using n mn
proof (induct n rule: next_hour_induct)
  case base with m show ?case apply auto using LatticeReflexivity by blast
next
  case (step n)
  hence "m \<le> n \<or> m = next_hour n" by (auto simp add: next_hour_def)
  thus ?case
  proof (elim disjE)
    assume "m = next_hour n" thus ?case apply auto using LatticeReflexivity by blast
  next
    assume "m \<le> n"
    with step have "\<turnstile> HC \<longrightarrow> (hr = #m \<leadsto> hr = #n)" by blast
    also from step have "\<turnstile> HC \<longrightarrow> (hr = #n \<leadsto> hr = #(next_hour n))"
      by (intro HC_liveness_step, auto)
    finally show ?thesis .
  qed
qed

lemma HC_liveness_progress:
  assumes m: "m \<in> {1..12}"
  assumes n: "n \<in> {1..12}"
  shows "\<turnstile> HC \<longrightarrow> (hr = #m \<leadsto> hr = #n)"
proof -
  from m have "\<turnstile> HC \<longrightarrow> (hr = #m \<leadsto> hr = #12)" by (intro HC_liveness_progress_forwards, auto)
  also from HC_liveness_step [where n = 12]
  have "\<turnstile> HC \<longrightarrow> (hr = #12 \<leadsto> hr = #1)" by (simp add: next_hour_def)
  also from n have "\<turnstile> HC \<longrightarrow> (hr = #1 \<leadsto> hr = #n)" by (intro HC_liveness_progress_forwards, auto)
  finally show ?thesis .
qed

lemma HC_liveness:
  assumes n: "n \<in> {1..12}"
  shows "\<turnstile> HC \<longrightarrow> \<box>\<diamond> hr = #n"
proof -
  from HC_safety have "\<turnstile> HC \<longrightarrow> ((#True :: stpred) \<leadsto> HCini)"
    by (intro imp_leadsto_invariant, simp)

  also have "\<turnstile> HC \<longrightarrow> (HCini \<leadsto> (\<exists> h0. #(h0 \<in> {1..12}) \<and> hr = #h0))"
    by (intro imp_imp_leadsto, auto simp add: HCini_def)

  also have "\<turnstile> HC \<longrightarrow> ((\<exists> h0. #(h0 \<in> {1..12}) \<and> hr = #h0) \<leadsto> hr = #n)"
    unfolding inteq_reflection [OF leadsto_exists]
  proof (intro imp_forall_leadsto)
    fix h0
    from n show "h0 \<in> {1..12} \<Longrightarrow> \<turnstile> HC \<longrightarrow> (hr = #h0 \<leadsto> hr = #n)" by (intro HC_liveness_progress)
  qed

  finally have "\<turnstile> HC \<longrightarrow> ((#True :: stpred) \<leadsto> hr = #n)" .
  thus ?thesis unfolding leadsto_def by auto
qed

end

locale HourMinuteClock = HourClock +
  fixes mn :: "nat stfun"
  assumes hr_mn_basevars: "basevars (hr,mn)"
  fixes HMCini Mn Hr HMCnxt HMC
  assumes HMCini_def: "HMCini \<equiv> PRED HCini \<and> mn \<in> #{0..59}"
  assumes Mn_def:     "Mn     \<equiv> ACT mn$ = (if $mn = #59 then #0 else $mn + #1)"
  assumes Hr_def:     "Hr     \<equiv> ACT ($mn = #59 \<and> HCnxt) \<or> ($mn < #59 \<and> unchanged hr)"
  assumes HMCnxt_def: "HMCnxt \<equiv> ACT (Mn \<and> Hr)"
  assumes HMC_def:    "HMC    \<equiv> TEMP Init HMCini \<and> \<box>[HMCnxt]_(hr, mn) \<and> WF(HMCnxt)_(hr, mn)"

context HourMinuteClock
begin

lemma HMCnxt_eq:
  "HMCnxt = ACT ($mn < #59 \<and> mn$ = $mn + #1 \<and> hr$ = $hr)
              \<or> ($mn = #59 \<and> mn$ = #0       \<and> $hr = #12 \<and> hr$ = #1)
              \<or> ($mn = #59 \<and> mn$ = #0       \<and> $hr \<noteq> #12 \<and> hr$ = $hr + #1)"
  by (intro ext, auto simp add: HMCnxt_def Mn_def Hr_def next_hour_def HCnxt_def)

lemma HMCnxt_angle[simp]: "ACT <HMCnxt>_(hr, mn) = ACT HMCnxt"
  by (intro ext, auto simp add: angle_def HMCnxt_eq)

lemma HMCnxt_enabled[simp]: "PRED Enabled HMCnxt = PRED mn \<le> #59"
  using basevars [OF hr_mn_basevars]
  apply (intro ext, auto simp add: enabled_def HMCnxt_eq next_hour_def)
  by (meson nat_less_le)

lemma HMC_safety: "\<turnstile> HMC \<longrightarrow> \<box> (hr \<in> #{1..12} \<and> mn \<in> #{0..59})"
proof -
  have "\<turnstile> HMC \<longrightarrow> \<box>HMCini"
  proof invariant
    fix sigma assume "sigma \<Turnstile> HMC" thus "sigma \<Turnstile> stable HMCini" and "sigma \<Turnstile> Init HMCini"
      by (intro Stable [where A = "ACT [HMCnxt]_(hr, mn)"], auto simp add: HMC_def square_def HMCnxt_def Hr_def HCnxt_def next_hour_def Mn_def HMCini_def Init_simps HCini_def)
  qed
  thus ?thesis by (simp add: HMCini_def HCini_def)
qed

definition timeIs :: "nat \<times> nat \<Rightarrow> stpred" where "timeIs t \<equiv> PRED (hr, mn) = #t"

lemma timeIs[simp]: "PRED (timeIs (h,m)) = PRED (hr = #h \<and> mn = #m)"
  by (auto simp add: timeIs_def)

lemma HMC_liveness_step:
  assumes "m \<le> 59"
  shows "\<turnstile> HMC \<longrightarrow> (timeIs (h, m) \<leadsto> (timeIs (if m = 59 then (if h = 12 then (1, 0) else (h+1, 0)) else (h, m+1))))"
    (is "\<turnstile> HMC \<longrightarrow> ?P")
proof -
  from assms
  have "\<turnstile> \<box>[HMCnxt]_(hr, mn) \<and> WF(HMCnxt)_(hr,mn) \<longrightarrow> ?P"
    by (intro WF1 actionI temp_impI, auto simp add: square_def, auto simp add: HMCnxt_eq)
  thus ?thesis by (auto simp add: HMC_def)
qed

lemma HMC_liveness_step_minute:
  assumes "m < 59"
  shows "\<turnstile> HMC \<longrightarrow> (timeIs (h,m) \<leadsto> timeIs (h, Suc m))"
  using HMC_liveness_step [of m h] assms by auto

lemma HMC_liveness_step_hour:
  shows "\<turnstile> HMC \<longrightarrow> (timeIs (h,59) \<leadsto> timeIs (next_hour h, 0))"
  using HMC_liveness_step [of 59 h] unfolding next_hour_def by auto

lemma HMC_liveness_progress_forwards_minute:
  assumes m12: "m1 \<le> m2" and m2: "m2 \<le> 59"
  shows "\<turnstile> HMC \<longrightarrow> (timeIs (h,m1) \<leadsto> timeIs (h,m2))"
  using assms
proof (induct m2)
  case 0 thus ?case apply auto using LatticeReflexivity by blast
next
  case (Suc m)
  hence m59: "m \<le> 59" by simp

  from Suc have "m1 \<le> m \<or> m1 = Suc m" by auto
  thus ?case
  proof (elim disjE)
    assume "m1 = Suc m" thus ?thesis apply auto using LatticeReflexivity by blast
  next
    assume "m1 \<le> m"
    with Suc.hyps m59
    have "\<turnstile> HMC \<longrightarrow> (timeIs (h,m1) \<leadsto> timeIs (h,m))" by metis

    also from Suc have "\<turnstile> HMC \<longrightarrow> (timeIs (h,m) \<leadsto> timeIs (h, Suc m))"
      by (intro HMC_liveness_step_minute, auto)

    finally show ?thesis .
  qed
qed

lemma HMC_liveness_progress_forwards_hour:
  assumes h1: "h1 \<in> {1..12}"
  assumes h2: "h2 \<in> {1..12}"
  assumes h1h2: "h1 \<le> h2"
  shows "\<turnstile> HMC \<longrightarrow> (timeIs (h1,59) \<leadsto> timeIs (h2,59))"
  using h2 h1h2
proof (induct h2 rule: next_hour_induct)
  case base with h1 show ?case apply auto using LatticeReflexivity by blast
next
  case (step h)
  hence "h1 \<le> h \<or> h1 = next_hour h" unfolding next_hour_def by auto
  thus ?case
  proof (elim disjE)
    assume "h1 = next_hour h" thus ?thesis apply auto using LatticeReflexivity by blast
  next
    assume "h1 \<le> h"
    with step have "\<turnstile> HMC \<longrightarrow> (timeIs (h1, 59) \<leadsto> timeIs (h, 59))" by metis

    also have "\<turnstile> HMC \<longrightarrow> (timeIs (h, 59) \<leadsto> timeIs (next_hour h, 0))" by (intro HMC_liveness_step_hour)

    also have "\<turnstile> HMC \<longrightarrow> (timeIs (next_hour h, 0) \<leadsto> timeIs (next_hour h, 59))"
      by (intro HMC_liveness_progress_forwards_minute, simp_all)

    finally show ?thesis.
  qed
qed

lemma HMC_liveness_progress:
  assumes h1: "h1 \<in> {1..12}"
  assumes h2: "h2 \<in> {1..12}"
  assumes m1: "m1 \<le> 59"
  assumes m2: "m2 \<le> 59"
  shows "\<turnstile> HMC \<longrightarrow> (timeIs (h1,m1) \<leadsto> timeIs (h2,m2))"
proof -
  from m1 have "\<turnstile> HMC \<longrightarrow> (timeIs (h1,m1) \<leadsto> timeIs (h1,59))"
    by (intro HMC_liveness_progress_forwards_minute, simp_all)

  also from h1 have "\<turnstile> HMC \<longrightarrow> (timeIs (h1,59) \<leadsto> timeIs (12,59))"
    by (intro HMC_liveness_progress_forwards_hour, simp_all)

  also from HMC_liveness_step_hour [of 12]
  have "\<turnstile> HMC \<longrightarrow> (timeIs (12,59) \<leadsto> timeIs (1,0))"
    by (simp add: next_hour_def)

  also have "\<turnstile> HMC \<longrightarrow> (timeIs (1,0) \<leadsto> timeIs (h2,0))"
  proof (cases "h2 = 1")
    case True thus ?thesis apply auto using LatticeReflexivity by blast
  next
    case False
    have "\<turnstile> HMC \<longrightarrow> (timeIs (1, 0) \<leadsto> timeIs (1, 59))"
      by (intro HMC_liveness_progress_forwards_minute, simp_all)

    also from False h2
    have "\<turnstile> HMC \<longrightarrow> (timeIs (1, 59) \<leadsto> timeIs (h2 - 1, 59))"
      by (intro HMC_liveness_progress_forwards_hour, auto)

    also from False h2 have "next_hour (h2 - 1) = h2"
      by (auto simp add: next_hour_def)

    with HMC_liveness_step_hour [of "h2 - 1"]
    have "\<turnstile> HMC \<longrightarrow> (timeIs (h2 - 1, 59) \<leadsto> timeIs (h2, 0))" by auto

    finally show ?thesis .
  qed

  also from m2 have "\<turnstile> HMC \<longrightarrow> (timeIs (h2, 0) \<leadsto> timeIs (h2, m2))"
    by (intro HMC_liveness_progress_forwards_minute, simp_all)

  finally show ?thesis .
qed

lemma HMC_liveness:
  assumes h: "h \<in> {1..12}"
  assumes m: "m \<le> 59"
  shows "\<turnstile> HMC \<longrightarrow> \<box>\<diamond> timeIs (h,m)"
proof -
  from HMC_safety
  have "\<turnstile> HMC \<longrightarrow> ((#True :: stpred) \<leadsto> (hr \<in> #{1..12} \<and> mn \<in> #{0..59}))"
    by (intro imp_leadsto_invariant, simp)

  also have "\<turnstile> HMC \<longrightarrow> ((hr \<in> #{1..12} \<and> mn \<in> #{0..59}) \<leadsto> (\<exists>t. #(fst t \<in> {1..12} \<and> snd t \<le> 59) \<and> timeIs t))"
    by (intro imp_imp_leadsto, auto)

  also have "\<turnstile> HMC \<longrightarrow> ((\<exists>t. #(fst t \<in> {1..12} \<and> snd t \<le> 59) \<and> timeIs t) \<leadsto> timeIs (h,m))"
    unfolding inteq_reflection [OF leadsto_exists]
  proof (intro imp_forall_leadsto)
    fix t :: "nat \<times> nat"
    obtain h' m' where t: "t = (h', m')" by fastforce
    show "fst t \<in> {1..12} \<and> snd t \<le> 59 \<Longrightarrow> \<turnstile> HMC \<longrightarrow> (timeIs t \<leadsto> timeIs (h, m))"
      unfolding t using h m
      by (intro HMC_liveness_progress, auto)
  qed

  finally show ?thesis
    by (auto simp add: leadsto_def)
qed

lemma HMC_refines_HC: "\<turnstile> HMC \<longrightarrow> HC"
  unfolding HC_def
proof (intro temp_imp_conjI)
  show "\<turnstile> HMC \<longrightarrow> Init HCini" by (auto simp add: HMC_def HMCini_def Init_def)

  have "\<turnstile> HMC \<longrightarrow> \<box>[HMCnxt]_(hr, mn)" by auto (simp add: HMC_def)
  moreover have "\<turnstile> [HMCnxt]_(hr, mn) \<longrightarrow> [HCnxt]_hr"
  proof (intro intI temp_impI, clarify)
    fix before after
    assume "(before, after) \<Turnstile> [HMCnxt]_(hr, mn)"
    thus "(before, after) \<Turnstile> [HCnxt]_hr"
      by (cases "mn before = 59", auto simp add: square_def HMCnxt_eq HCnxt_def next_hour_def)
  qed
  ultimately show "\<turnstile> HMC \<longrightarrow> \<box>[HCnxt]_hr" by (metis STL4 temp_imp_trans)

  define P :: stpred   where "P \<equiv> timeIs (1,59)"
  define B :: action   where "B \<equiv> ACT $P"
  define F :: temporal where "F \<equiv> TEMP \<diamond>P"
  define N :: action   where "N \<equiv> ACT [HMCnxt]_(hr,mn)"
  define A :: action   where "A \<equiv> HMCnxt"

  have "\<turnstile> <$P \<and> HMCnxt>_(hr, mn) = ($P \<and> HMCnxt)" by (auto simp add: angle_def HMCnxt_eq)
  note eqs = inteq_reflection [OF this]

  have "\<turnstile> HMC \<longrightarrow> \<box>N \<and> WF(A)_(hr,mn) \<and> \<box>F"
  proof (intro temp_imp_conjI)
    show "\<turnstile> HMC \<longrightarrow> \<box>N" by (auto simp add: N_def HMC_def)
    from HMC_liveness show "\<turnstile> HMC \<longrightarrow> \<box>F" unfolding F_def P_def by auto

    show "\<turnstile> HMC \<longrightarrow> WF(A)_(hr, mn)"
      unfolding HMC_def WF_def eqs A_def by auto
  qed

  also have "\<turnstile> \<box>N \<and> WF(A)_(hr,mn) \<and> \<box>F \<longrightarrow> WF(HCnxt)_hr"
  proof (intro WF2 stable_dmd_stuck)

    show "\<turnstile> N \<and> <B>_(hr, mn) \<longrightarrow> <HCnxt>_hr"
      by (auto simp add: N_def square_def angle_def P_def B_def HMCnxt_eq HCnxt_def next_hour_def)

    show "\<turnstile> $P \<and> P$ \<and> <N \<and> A>_(hr, mn) \<longrightarrow> B"
      by (auto simp add: angle_def P_def)

    show "\<turnstile> P \<and> Enabled (<HCnxt>_hr) \<longrightarrow> Enabled (<A>_(hr, mn))"
      unfolding eqs A_def by (auto simp add: P_def)

    let ?PREM = "TEMP \<box>(N \<and> [\<not> B]_(hr, mn)) \<and> WF(A)_(hr, mn) \<and> \<box>F \<and> \<diamond>\<box>Enabled (<HCnxt>_hr)"

    show "\<turnstile> ?PREM \<longrightarrow> stable P"
      apply (intro tempI temp_impI Stable [where A = "ACT N \<and> [\<not> $P]_(hr, mn)"])
      by (auto simp add: square_def P_def N_def B_def)

    have "\<turnstile> ?PREM \<longrightarrow> \<box>\<diamond>P" unfolding F_def by auto
    also have "\<turnstile> \<box>\<diamond>P \<longrightarrow> \<diamond>P" by (intro STL2)
    finally show "\<turnstile> ?PREM \<longrightarrow> \<diamond> P" .
  qed

  finally show "\<turnstile> HMC \<longrightarrow> WF(HCnxt)_hr" .

qed

end

end


(*  Title:      HOL/MicroJava/DFA/Opt.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM
*)

section \<open>More about Options\<close>

theory Opt
imports Err
begin

definition le :: "'a ord \<Rightarrow> 'a option ord" where
"le r o1 o2 == case o2 of None \<Rightarrow> o1=None |
                              Some y \<Rightarrow> (case o1 of None \<Rightarrow> True
                                                  | Some x \<Rightarrow> x <=_r y)"

definition opt :: "'a set \<Rightarrow> 'a option set" where
"opt A == insert None {x. \<exists>y\<in>A. x = Some y}"

definition sup :: "'a ebinop \<Rightarrow> 'a option ebinop" where
"sup f o1 o2 ==
 case o1 of None \<Rightarrow> OK o2 | Some x \<Rightarrow> (case o2 of None \<Rightarrow> OK o1
     | Some y \<Rightarrow> (case f x y of Err \<Rightarrow> Err | OK z \<Rightarrow> OK (Some z)))"

definition esl :: "'a esl \<Rightarrow> 'a option esl" where
"esl == %(A,r,f). (opt A, le r, sup f)"

lemma unfold_le_opt:
  "o1 <=_(le r) o2 =
  (case o2 of None \<Rightarrow> o1=None |
              Some y \<Rightarrow> (case o1 of None \<Rightarrow> True | Some x \<Rightarrow> x <=_r y))"
apply (unfold lesub_def le_def)
apply (rule refl)
done

lemma le_opt_refl:
  "order r \<Longrightarrow> o1 <=_(le r) o1"
by (simp add: unfold_le_opt split: option.split)

lemma le_opt_trans [rule_format]:
  "order r \<Longrightarrow>
   o1 <=_(le r) o2 \<longrightarrow> o2 <=_(le r) o3 \<longrightarrow> o1 <=_(le r) o3"
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_trans)
done

lemma le_opt_antisym [rule_format]:
  "order r \<Longrightarrow> o1 <=_(le r) o2 \<longrightarrow> o2 <=_(le r) o1 \<longrightarrow> o1=o2"
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_antisym)
done

lemma order_le_opt [intro!,simp]:
  "order r \<Longrightarrow> order(le r)"
apply (subst Semilat.order_def)
apply (blast intro: le_opt_refl le_opt_trans le_opt_antisym)
done

lemma None_bot [iff]:
  "None <=_(le r) ox"
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done

lemma Some_le [iff]:
  "(Some x <=_(le r) ox) = (\<exists>y. ox = Some y \<and> x <=_r y)"
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done

lemma le_None [iff]:
  "(ox <=_(le r) None) = (ox = None)"
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done

lemma OK_None_bot [iff]:
  "OK None <=_(Err.le (le r)) x"
  by (simp add: lesub_def Err.le_def le_def split: option.split err.split)

lemma sup_None1 [iff]:
  "x +_(sup f) None = OK x"
  by (simp add: plussub_def sup_def split: option.split)

lemma sup_None2 [iff]:
  "None +_(sup f) x = OK x"
  by (simp add: plussub_def sup_def split: option.split)

lemma None_in_opt [iff]:
  "None \<in> opt A"
by (simp add: opt_def)

lemma Some_in_opt [iff]:
  "(Some x \<in> opt A) = (x\<in>A)"
apply (unfold opt_def)
apply auto
done

lemma semilat_opt [intro, simp]:
  "\<And>L. err_semilat L \<Longrightarrow> err_semilat (Opt.esl L)"
proof (unfold Opt.esl_def Err.sl_def, simp add: split_tupled_all)

  fix A r f
  assume s: "semilat (err A, Err.le r, lift2 f)"

  let ?A0 = "err A"
  let ?r0 = "Err.le r"
  let ?f0 = "lift2 f"

  from s
  obtain
    ord: "order ?r0" and
    clo: "closed ?A0 ?f0" and
    ub1: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. x <=_?r0 x +_?f0 y" and
    ub2: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. y <=_?r0 x +_?f0 y" and
    lub: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. \<forall>z\<in>?A0. x <=_?r0 z \<and> y <=_?r0 z \<longrightarrow> x +_?f0 y <=_?r0 z"
    by (unfold semilat_def) simp

  let ?A = "err (opt A)"
  let ?r = "Err.le (Opt.le r)"
  let ?f = "lift2 (Opt.sup f)"

  from ord
  have "order ?r"
    by simp

  moreover

  have "closed ?A ?f"
  proof (unfold closed_def, intro strip)
    fix x y
    assume x: "x \<in> ?A"
    assume y: "y \<in> ?A"

    { fix a b
      assume ab: "x = OK a" "y = OK b"

      with x
      have a: "\<And>c. a = Some c \<Longrightarrow> c \<in> A"
        by (clarsimp simp add: opt_def)

      from ab y
      have b: "\<And>d. b = Some d \<Longrightarrow> d \<in> A"
        by (clarsimp simp add: opt_def)

      { fix c d assume "a = Some c" "b = Some d"
        with ab x y
        have "c \<in> A \<and> d \<in> A"
          by (simp add: err_def opt_def Bex_def)
        with clo
        have "f c d \<in> err A"
          by (simp add: closed_def plussub_def err_def lift2_def)
        moreover
        fix z assume "f c d = OK z"
        ultimately
        have "z \<in> A" by simp
      } note f_closed = this

      have "sup f a b \<in> ?A"
      proof (cases a)
        case None
        thus ?thesis
          by (simp add: sup_def opt_def) (cases b, simp, simp add: b Bex_def)
      next
        case Some
        thus ?thesis
          by (auto simp add: sup_def opt_def Bex_def a b f_closed split: err.split option.split)
      qed
    }

    thus "x +_?f y \<in> ?A"
      by (simp add: plussub_def lift2_def split: err.split)
  qed

  moreover

  { fix a b c
    assume "a \<in> opt A" "b \<in> opt A" "a +_(sup f) b = OK c"
    moreover
    from ord have "order r" by simp
    moreover
    { fix x y z
      assume "x \<in> A" "y \<in> A"
      hence "OK x \<in> err A \<and> OK y \<in> err A" by simp
      with ub1 ub2
      have "(OK x) <=_(Err.le r) (OK x) +_(lift2 f) (OK y) \<and>
            (OK y) <=_(Err.le r) (OK x) +_(lift2 f) (OK y)"
        by blast
      moreover
      assume "x +_f y = OK z"
      ultimately
      have "x <=_r z \<and> y <=_r z"
        by (auto simp add: plussub_def lift2_def Err.le_def lesub_def)
    }
    ultimately
    have "a <=_(le r) c \<and> b <=_(le r) c"
      by (auto simp add: sup_def le_def lesub_def plussub_def
               dest: order_refl split: option.splits err.splits)
  }

  hence "(\<forall>x\<in>?A. \<forall>y\<in>?A. x <=_?r x +_?f y) \<and> (\<forall>x\<in>?A. \<forall>y\<in>?A. y <=_?r x +_?f y)"
    by (auto simp add: lesub_def plussub_def Err.le_def lift2_def split: err.split)

  moreover

  have "\<forall>x\<in>?A. \<forall>y\<in>?A. \<forall>z\<in>?A. x <=_?r z \<and> y <=_?r z \<longrightarrow> x +_?f y <=_?r z"
  proof (intro strip, elim conjE)
    fix x y z
    assume xyz: "x \<in> ?A" "y \<in> ?A" "z \<in> ?A"
    assume xz: "x <=_?r z"
    assume yz: "y <=_?r z"

    { fix a b c
      assume ok: "x = OK a" "y = OK b" "z = OK c"

      { fix d e g
        assume some: "a = Some d" "b = Some e" "c = Some g"

        with ok xyz
        obtain "OK d \<in> err A" "OK e \<in> err A" "OK g \<in> err A"
          by simp
        with lub
        have "\<lbrakk> (OK d) <=_(Err.le r) (OK g); (OK e) <=_(Err.le r) (OK g) \<rbrakk>
          \<Longrightarrow> (OK d) +_(lift2 f) (OK e) <=_(Err.le r) (OK g)"
          by blast
        hence "\<lbrakk> d <=_r g; e <=_r g \<rbrakk> \<Longrightarrow> \<exists>y. d +_f e = OK y \<and> y <=_r g"
          by simp

        with ok some xyz xz yz
        have "x +_?f y <=_?r z"
          by (auto simp add: sup_def le_def lesub_def lift2_def plussub_def Err.le_def)
      } note this [intro!]

      from ok xyz xz yz
      have "x +_?f y <=_?r z"
        by - (cases a, simp, cases b, simp, cases c, simp, blast)
    }

    with xyz xz yz
    show "x +_?f y <=_?r z"
      by - (cases x, simp, cases y, simp, cases z, simp+)
  qed

  ultimately

  show "semilat (?A,?r,?f)"
    by (unfold semilat_def) simp
qed

lemma top_le_opt_Some [iff]:
  "top (le r) (Some T) = top r T"
apply (unfold top_def)
apply (rule iffI)
 apply blast
apply (rule allI)
apply (case_tac "x")
apply simp+
done

lemma Top_le_conv:
  "\<lbrakk> order r; top r T \<rbrakk> \<Longrightarrow> (T <=_r x) = (x = T)"
apply (unfold top_def)
apply (blast intro: order_antisym)
done

lemma acc_le_optI [intro!]:
  "acc r \<Longrightarrow> acc(le r)"
apply (unfold acc_def lesub_def le_def lesssub_def)
apply (simp add: wf_eq_minimal split: option.split)
apply clarify
apply (case_tac "\<exists>a. Some a \<in> Q")
 apply (erule_tac x = "{a. Some a \<in> Q}" in allE)
 apply blast
apply (case_tac "x")
 apply blast
apply blast
done

lemma option_map_in_optionI:
  "\<lbrakk> ox \<in> opt S; \<forall>x\<in>S. ox = Some x \<longrightarrow> f x \<in> S \<rbrakk>
  \<Longrightarrow> map_option f ox \<in> opt S"
apply (unfold map_option_case)
apply (simp split: option.split)
apply blast
done

end


theory GS_Code
  imports
    "Code_Setup"
    "../Splitting_Methods_Fin"
    "HOL-Library.Code_Target_Numeral"
    "HOL-Data_Structures.Array_Braun"
begin

context MDP_nat_disc begin

lemma \<L>\<^sub>b_split_zero:
  assumes "\<And>s. s \<ge> states \<Longrightarrow> apply_bfun v s = 0"
  shows "GS.\<L>\<^sub>b_split v s = GS_rec_upto states v 0 s"
proof (cases "s < states")
  case True
  then show ?thesis using GS_rec_upto_correct by auto
next
  case False
  have aux: "s \<ge> states \<Longrightarrow> apply_bfun (GS.\<L>\<^sub>b_split v) s = 0" for s
  proof (induction s rule: less_induct)
    case (less x)
    have "r (x, a) = 0" if "a \<in> A x" for a
      by (simp add: less.prems reward_zero_outside)
    moreover have "measure_pmf.expectation (K (x, a)) ((bfun_if (\<lambda>s'. s' < x) (GS.\<L>\<^sub>b_split v) v)) = 0" for a
      using K_closed_compl assms less
      by (fastforce simp: bfun_if.rep_eq intro!: AE_pmfI integral_eq_zero_AE)
    ultimately show ?case
      by (auto simp: A_ne \<L>\<^sub>b_split_GS)
  qed
  then show ?thesis
    by (metis False GS_rec_upto_ge assms not_less)
qed
end

context MDP_Code begin

function GS_iter_aux :: "nat \<Rightarrow> 'tv \<Rightarrow> real \<Rightarrow> ('tv \<times> real)" where
  "GS_iter_aux s v md = (
  if s \<ge> states
  then (v, md)
  else (
    let vs_old = v_lookup v s;
        vs_new = \<L>_GS_code (s_lookup mdp s) v;
        vs_diff = abs (vs_old - vs_new);
        v' = v_update s vs_new v
    in
        GS_iter_aux (Suc s) v' (max md vs_diff)))"
  by auto
termination
  by (relation "Wellfounded.measure (\<lambda>(n, _). states - n)") auto

definition "GS_iter v = GS_iter_aux 0 v 0"

lemmas GS_iter_aux.simps[simp del]

lemma GS_iter_aux_fst_correct:
  assumes "v_len v = states" "v_invar v"
  shows "s < states \<longrightarrow> v_lookup (fst (GS_iter_aux n v md)) s = MDP.GS_rec_upto states (V_Map.map_to_bfun v) n s \<and> v_invar (fst (GS_iter_aux n v md))"
  using assms unfolding GS_iter_def
proof (induction n v md rule: GS_iter_aux.induct)
  case (1 s v md)
  show ?case
    unfolding GS_iter_aux.simps[of s] MDP.GS_rec_upto.simps[of _ _ s]
    apply (auto simp add: "1.prems" assms(1) intro!: v_lookup_map_to_bfun)
     apply (simp add: 1 \<L>_GS_code_correct)
    using "1.IH"
     apply (smt (verit) "1.IH" "1.prems"(1) "1.prems"(2) Sup.SUP_cong V_Map.invar_update V_Map.map_to_bfun_update \<L>_GS_code_correct linorder_le_less_linear v_len_update)
    by (auto simp add: "1.IH" \<L>_GS_code_correct 1 V_Map.map_to_bfun_update v_lookup_map_to_bfun v_len_update V_Map.invar_update)
qed

lemma snd_GS_iter_aux_correct:
  assumes "v_len v = states" "v_invar v"
  shows "snd (GS_iter_aux n v md) = Max (Set.insert md ((\<lambda>s. abs (MDP.GS_rec_upto states (V_Map.map_to_bfun v) n s - (V_Map.map_to_bfun v) s)) `  {n..<states}))"
  using assms unfolding GS_iter_def
proof (induction n v md rule: GS_iter_aux.induct)
  case (1 s' v md)
  {
    assume s'_le: "s' < states"
    have "snd (GS_iter_aux s' v md) = (snd (GS_iter_aux (Suc s') (v_update s' (\<L>_GS_code (s_lookup mdp s') v) v) (max md \<bar>v_lookup v s' - \<L>_GS_code (s_lookup mdp s') v\<bar>)))"
      unfolding GS_iter_aux.simps[of s']
      using s'_le
      by auto
    also have "\<dots> = Max (Set.insert (max md \<bar>v_lookup v s' - \<L>_GS_code (s_lookup mdp s') v\<bar>)
          ((\<lambda>s. \<bar>MDP.GS_rec_upto states (apply_bfun (V_Map.map_to_bfun (v_update s' (\<L>_GS_code (s_lookup mdp s') v) v)))  (Suc s') s - apply_bfun (V_Map.map_to_bfun (v_update s' (\<L>_GS_code (s_lookup mdp s') v) v)) s\<bar>) ` {Suc s'..<states}))"
      apply (subst "1.IH")
      subgoal using s'_le by auto
      using s'_le v_len_update
      by (auto simp add: "1.prems" V_Map.invar_update s'_le)
    also have "\<dots> = Max (Set.insert (max md \<bar>v_lookup v s' - \<L>_GS_code (s_lookup mdp s') v\<bar>)
          ((\<lambda>s. \<bar>MDP.GS_rec_upto states ((V_Map.map_to_bfun v)(s' := (\<L>_GS_code (s_lookup mdp s') v))) (Suc s') s - apply_bfun (V_Map.map_to_bfun (v_update s' (\<L>_GS_code (s_lookup mdp s') v) v)) s\<bar>) ` {Suc s'..<states}))"
      using "1.prems"(1) "1.prems"(2) V_Map.map_to_bfun_update s'_le by presburger
    also have "\<dots> = Max (Set.insert (max md \<bar>v_lookup v s' - \<L>_GS_code (s_lookup mdp s') v\<bar>)
          ((\<lambda>s. \<bar>MDP.GS_rec_upto states ((V_Map.map_to_bfun v)(s' := \<Squnion>a\<in>MDP_A s'. MDP.L\<^sub>a a (V_Map.map_to_bfun v) s')) (Suc s') s - ((V_Map.map_to_bfun v) (s' := \<Squnion>a\<in>MDP_A s'. MDP.L\<^sub>a a (V_Map.map_to_bfun v) s')) s \<bar>) ` {Suc s'..<states}))"
      using "1.prems"(1) "1.prems"(2) MDP.SUP_L\<^sub>a_eq_det MDP.\<L>\<^sub>b_eq_SUP_L\<^sub>a V_Map.map_to_fun_update \<L>_code_correct \<L>_code_lookup map_to_bfun_eq_fun by auto

    also have "\<dots> = Max (Set.insert (max md \<bar>v_lookup v s' - \<L>_GS_code (s_lookup mdp s') v\<bar>)
          ((\<lambda>s. \<bar>MDP.GS_rec_upto states ((V_Map.map_to_bfun v)(s' := \<Squnion>a\<in>MDP_A s'. MDP.L\<^sub>a a (V_Map.map_to_bfun v) s')) (Suc s') s - V_Map.map_to_bfun v s \<bar>) ` {Suc s'..<states}))"
      using "1.prems"(1) "1.prems"(2) MDP.SUP_L\<^sub>a_eq_det MDP.\<L>\<^sub>b_eq_SUP_L\<^sub>a V_Map.map_to_fun_update \<L>_code_correct \<L>_code_lookup map_to_bfun_eq_fun by auto
    also have "\<dots> = Max (Set.insert (max md \<bar>v_lookup v s' - \<L>_GS_code (s_lookup mdp s') v\<bar>)
          ((\<lambda>s. \<bar>MDP.GS_rec_upto states (apply_bfun (V_Map.map_to_bfun v))  s' s - V_Map.map_to_bfun v s\<bar>) ` {Suc s'..<states}))"
      using s'_le MDP.GS_rec_upto.simps[symmetric, of states "s'" "(apply_bfun (V_Map.map_to_bfun v))"]
      by presburger
    also have "\<dots> = max md (Max (Set.insert (\<bar>v_lookup v s' - \<L>_GS_code (s_lookup mdp s') v\<bar>)
          ((\<lambda>s. \<bar>MDP.GS_rec_upto states (apply_bfun (V_Map.map_to_bfun v))  s' s - V_Map.map_to_bfun v s\<bar>) ` {Suc s'..<states})))"
    proof -
      have *: "Max (Set.insert (max x y) X) = max x (Max (Set.insert y X))" if "finite X" for X x y
        by (metis Max_insert Max_singleton max.assoc that)
      thus ?thesis
        by blast
    qed
    also have "\<dots> = max md (Max (Set.insert (\<bar>\<L>_GS_code (s_lookup mdp s') v - V_Map.map_to_bfun v s'\<bar>)
          ((\<lambda>s. \<bar>MDP.GS_rec_upto states (apply_bfun (V_Map.map_to_bfun v))  s' s - V_Map.map_to_bfun v s\<bar>) ` {Suc s'..<states})))"
      by (smt (verit, best) "1.prems"(1) "1.prems"(2) v_lookup_map_to_bfun s'_le)
    also have "\<dots> = max md (Max ((\<lambda>s. (\<bar>MDP.GS_rec_upto states (apply_bfun (V_Map.map_to_bfun v))  s' s - V_Map.map_to_bfun v s\<bar>)) ` {s'} \<union>
          ((\<lambda>s. \<bar>MDP.GS_rec_upto states (apply_bfun (V_Map.map_to_bfun v))  s' s - V_Map.map_to_bfun v s\<bar>) ` {Suc s'..<states})))"
    proof -
      have * :"\<L>_GS_code (s_lookup mdp s') v = MDP.GS_rec_upto states (apply_bfun (V_Map.map_to_bfun v))  s' s'"
        apply (subst MDP.GS_rec_upto_eq)
        using s'_le
         apply blast
        using \<L>_GS_code_correct 1 s'_le
        by presburger
      show ?thesis
        by (auto simp: *)
    qed
    also have "\<dots> = max md (Max ((\<lambda>s. \<bar>MDP.GS_rec_upto states (apply_bfun (V_Map.map_to_bfun v))  s' s - V_Map.map_to_bfun v s\<bar>) ` ({s'} \<union> {Suc s'..<states})))"
      unfolding atLeastLessThan_def lessThan_def
      by auto
    also have "\<dots> = max md (Max ((\<lambda>s. \<bar>MDP.GS_rec_upto states (apply_bfun (V_Map.map_to_bfun v))  s' s - V_Map.map_to_bfun v s\<bar>) ` ({s'..<states})))"
    proof -
      have "({s'} \<union> {Suc s'..<states}) = {s'..<states}"
        using s'_le
        by auto
      thus ?thesis by auto
    qed
    finally have "snd (GS_iter_aux s' v md) = max md (MAX s\<in>{s'..<states}. \<bar>MDP.GS_rec_upto states ((V_Map.map_to_bfun v)) s' s - (V_Map.map_to_bfun v) s\<bar>)".
  }
  thus ?case
    apply (cases "s' < states")
     apply auto
    using "1.prems"(1) "1.prems"(2) GS_iter_aux_fst_correct assms(1)
    apply (simp add: "1.prems"(1) "1.prems"(2) GS_iter_aux_fst_correct assms(1))
    by (simp add: GS_iter_aux.simps)
qed

lemma invar_GS_iter_aux: "v_len v = states \<Longrightarrow> v_invar v \<Longrightarrow> v_invar (fst (GS_iter_aux n v md))"
  by (metis GS_iter_aux.simps GS_iter_aux_fst_correct fst_conv linorder_not_le)

lemma invar_GS_iter: "v_len v = states \<Longrightarrow> v_invar v \<Longrightarrow> v_invar (fst (GS_iter v))"
  using invar_GS_iter_aux GS_iter_def by auto

lemma len_GS_iter_aux[simp]: "v_invar v \<Longrightarrow> v_len v = states \<Longrightarrow> v_len (fst (GS_iter_aux n v md)) = states"
proof (induction n v md   rule: GS_iter_aux.induct)
  case (1 s v md)
  have 2: " v_len (v_update s (\<L>_GS_code (s_lookup mdp s) v) v) = v_len v" if "s < states"
    using 1 that v_len_update by blast
  have "v_len (fst (GS_iter_aux (Suc s) (v_update s (\<L>_GS_code (s_lookup mdp s) v) v) (max md \<bar>v_lookup v s - \<L>_GS_code (s_lookup mdp s) v\<bar>))) = v_len v" if "s < states"
    unfolding 2[OF that, symmetric]
    using 1(2,3) that
    apply (subst "1.IH"[OF _ ])
           apply auto
    using V_Map.invar_update 2 by force+
  thus ?case
    by (metis "1.prems"(2) GS_iter_aux.elims fst_conv less_eq_Suc_le not_less_eq_eq)
qed

lemma len_GS_iter[simp]: "v_invar v \<Longrightarrow> v_len v = states \<Longrightarrow> v_len (fst (GS_iter v)) = v_len v"
  using len_GS_iter_aux GS_iter_def by auto

lemma GS_iter_aux_correct':
  assumes "v_len v = states" "v_invar v"
  shows "apply_bfun (V_Map.map_to_bfun (fst (GS_iter_aux 0 v md))) s = MDP.GS_rec_upto states (V_Map.map_to_bfun v) 0 s"
proof (cases "s < states")
  case True
  then show ?thesis
    using assms
    by (metis GS_iter_aux_fst_correct len_GS_iter_aux v_lookup_map_to_bfun)
next
  case False
  then show ?thesis
    by (simp add: MDP.GS_rec_upto_ge V_Map.map_to_bfun.rep_eq assms(1) assms(2))
qed

lemma GS_iter_aux_correct'':
  assumes "v_len v = states" "v_invar v"
  shows "V_Map.map_to_bfun (fst (GS_iter v)) = MDP.GS.\<L>\<^sub>b_split (V_Map.map_to_bfun v)"
  apply (rule bfun_eqI)
  unfolding V_Map.map_to_bfun.rep_eq
  apply auto
    apply (simp add: GS_iter_aux_fst_correct GS_iter_def MDP.GS_rec_upto_correct assms(1) assms(2))
   apply (simp add: GS_iter_def assms(1) assms(2) invar_GS_iter_aux)
  by (metis GS_iter_aux_correct' GS_iter_def MDP.\<L>\<^sub>b_split_zero V_Map.map_to_bfun.rep_eq assms(1) assms(2) linorder_not_less)

lemma snd_GS_iter_correct':
  assumes "v_len v = states" "v_invar v"
  shows "snd (GS_iter v) = dist (V_Map.map_to_bfun (fst (GS_iter v))) (V_Map.map_to_bfun v)"
proof -
  have "dist (apply_bfun (MDP.GS.\<L>\<^sub>b_split (V_Map.map_to_bfun v)) x) (apply_bfun (V_Map.map_to_bfun v) x) = 0" if "x \<ge> states" for x
    by (metis GS_iter_aux_correct'' V_Map.map_to_bfun.rep_eq assms(1) assms(2) dist_eq_0_iff leD len_GS_iter that)
  hence "(\<Squnion>x. dist (apply_bfun (MDP.GS.\<L>\<^sub>b_split (V_Map.map_to_bfun v)) x) (apply_bfun (V_Map.map_to_bfun v) x)) =
    (\<Squnion>x\<in>{0..<Suc states}. dist (apply_bfun (MDP.GS.\<L>\<^sub>b_split (V_Map.map_to_bfun v)) x) (apply_bfun (V_Map.map_to_bfun v) x)) \<squnion> (\<Squnion>x\<in>{Suc states..}. dist (apply_bfun (MDP.GS.\<L>\<^sub>b_split (V_Map.map_to_bfun v)) x) (apply_bfun (V_Map.map_to_bfun v) x))"
    apply (subst cSUP_union[symmetric])
        apply auto
    by (simp add: ivl_disj_un_one(8))
  also have "\<dots> = max 0 (\<Squnion>(Set.insert 0 ((\<lambda>x. dist (apply_bfun (MDP.GS.\<L>\<^sub>b_split (V_Map.map_to_bfun v)) x) (apply_bfun (V_Map.map_to_bfun v) x)) ` {0..< states})))"
  proof -
    have "dist (apply_bfun (MDP.GS.\<L>\<^sub>b_split (V_Map.map_to_bfun v)) x) (apply_bfun (V_Map.map_to_bfun v) x) = 0" if "x \<in> {Suc states..}" for x
      apply auto
      using MDP.\<L>\<^sub>b_split_zero
      by (meson Suc_leD \<open>\<And>x. states \<le> x \<Longrightarrow> dist (apply_bfun (MDP.GS.\<L>\<^sub>b_split (V_Map.map_to_bfun v)) x) (apply_bfun (V_Map.map_to_bfun v) x) = 0\<close> atLeast_iff dist_eq_0_iff that)
    thus ?thesis
      using sup_real_def
      by (simp add: \<open>\<And>x. states \<le> x \<Longrightarrow> dist (apply_bfun (MDP.GS.\<L>\<^sub>b_split (V_Map.map_to_bfun v)) x) (apply_bfun (V_Map.map_to_bfun v) x) = 0\<close> atLeast0_lessThan_Suc)
  qed
  also have "\<dots> = max 0 (Max (Set.insert 0 ((\<lambda>x. dist (apply_bfun (MDP.GS.\<L>\<^sub>b_split (V_Map.map_to_bfun v)) x) (apply_bfun (V_Map.map_to_bfun v) x)) ` {0..< states})))"
    by (auto simp: cSup_eq_Max)
  also have "\<dots> = (Max (Set.insert 0 ((\<lambda>x. dist (apply_bfun (MDP.GS.\<L>\<^sub>b_split (V_Map.map_to_bfun v)) x) (apply_bfun (V_Map.map_to_bfun v) x)) ` {0..< states})))"
    by auto
  also have "\<dots> = snd (GS_iter v)"
    unfolding GS_iter_def
    apply (subst snd_GS_iter_aux_correct)
      apply (simp add: assms)
     apply (simp add: assms)
    apply (auto simp: dist_real_def)
    apply (subst MDP.\<L>\<^sub>b_split_zero)
     apply (simp add: V_Map.map_to_bfun.rep_eq assms(1))
    by (auto simp: dist_real_def)
  finally show ?thesis
    by (simp add: GS_iter_aux_correct'' assms(1) assms(2) dist_bfun.rep_eq)
qed

lemma GS_iter_aux_correct:
  assumes "s < states" "v_len v = states" "v_invar v"
  shows "v_lookup (fst (GS_iter_aux n v eps)) s = MDP.GS_rec_upto states (V_Map.map_to_bfun v) n s"
  using GS_iter_aux_fst_correct assms(1) assms(2) assms(3) by blast

definition "find_policy_code_aux_upt (v::'tv) n = (
  fold (\<lambda>s (d,v). let (d', v') = find_policy_state_code_aux' v s in
      (d_update s d' d, v_update s v' v)) [0..<n] (d_empty, v))"

lemma find_policy_code_aux_upt_Suc:
  "find_policy_code_aux_upt v (Suc s) = (
  let (d, v) = (find_policy_code_aux_upt v s) in
    (d_update s ((fst (find_policy_state_code_aux' v s))) d, v_update s (snd (find_policy_state_code_aux' v s)) v))"
  unfolding find_policy_code_aux_upt_def
  by (auto simp: case_prod_beta)

definition "find_policy_code_aux v = find_policy_code_aux_upt v states"
definition "find_policy_code v = fst (find_policy_code_aux v)"

lemma d_invar_find_policy_code_aux_upt: "D_Map.invar (fst (find_policy_code_aux_upt v n))"
  by (induction n) (auto simp: D_Map.map_specs case_prod_beta find_policy_code_aux_upt_def)

lemma v_len_invar_find_policy_code_aux_upt: "n \<le> j \<Longrightarrow> v_len v = j \<Longrightarrow> v_invar v \<Longrightarrow> v_len (snd (find_policy_code_aux_upt v n)) = j \<and> v_invar (snd (find_policy_code_aux_upt v n))"
  apply (induction n arbitrary: v)
   apply (simp add: find_policy_code_aux_upt_def)
  apply (simp add: case_prod_beta find_policy_code_aux_upt_def)
  apply (subst V_Map.invar_update)
    apply blast
   apply simp
  using Suc_le_lessD v_len_update by presburger

lemma assumes "s < states" "v_invar v" "v_len v \<ge> states"
  shows
    "d_lookup (fst (find_policy_code_aux v)) s = d_lookup (fst (find_policy_code_aux_upt v (Suc s))) s"
    "v_lookup (snd (find_policy_code_aux v)) s = v_lookup (snd (find_policy_code_aux_upt v (Suc s))) s"
  unfolding find_policy_code_aux_def
  using assms
proof (induction states arbitrary: v)
  case (Suc states)
  {
    case 1
    show ?case
    proof (cases "s = states")
    next
      case False
      then show ?thesis
        using 1 less_Suc_eq
        apply (subst find_policy_code_aux_upt_Suc)
        by (auto simp: case_prod_beta D_Map.map_update[OF d_invar_find_policy_code_aux_upt] Suc(1)[symmetric])
    qed auto
  next
    case 2
    then show ?case
    proof (cases "s = states")
    next
      case False
      then show ?thesis
        using 2 less_Suc_eq
        apply (subst find_policy_code_aux_upt_Suc)
        apply (auto simp: case_prod_beta Suc(2)[symmetric])
        by (metis False Suc_leD dec_induct v_len_invar_find_policy_code_aux_upt v_lookup_update)
    qed auto
  }
qed auto

lemma find_policy_code_invar: "D_Map.invar (find_policy_code v)"
  unfolding find_policy_code_def find_policy_code_aux_def
  by (induction states) (auto simp: find_policy_code_aux_upt_def D_Map.map_specs case_prod_unfold)

lemma find_policy_code_notin:
  assumes "s \<ge> states" shows "d_lookup (find_policy_code v) s = None"
  using assms d_invar_find_policy_code_aux_upt
  unfolding find_policy_code_def find_policy_code_aux_def
  by (induction states) (auto simp: find_policy_code_aux_upt_def case_prod_beta D_Map.map_specs)

lemma find_policy_code_in:
  assumes "s < states" shows "\<exists>x. d_lookup (find_policy_code v) s = Some x"
  using assms
  unfolding find_policy_code_def find_policy_code_aux_def
proof (induction states)
  case 0
  then show ?case
    by simp
next
  case (Suc states)
  then show ?case
    using d_invar_find_policy_code_aux_upt
    by (auto simp: find_policy_code_aux_upt_Suc case_prod_beta D_Map.map_specs)
qed

lemma GS_iter_aux_fold: "fst (GS_iter_aux s v md) = fold (\<lambda>s v. v_update s (\<L>_GS_code (s_lookup mdp s) v) v) [s..<states] v"
proof (induction s v md arbitrary: rule: GS_iter_aux.induct)
  case (1 s v)
  have aux: "s < states \<Longrightarrow> [s..<states] = s#[Suc s..<states]"
    using upt_conv_Cons by presburger
  show ?case
    by (subst GS_iter_aux.simps) (auto simp: 1 aux)
qed

lemma find_policy_state_code_aux'_eq_\<L>_GS_code:
  assumes "v_len v = states" "v_invar v" "s < states"
  shows "snd (find_policy_state_code_aux' v s) = \<L>_GS_code (s_lookup mdp s) v"
  using assms
  by (auto simp: \<L>_GS_code_correct cSup_eq_Max find_policy_state_code_aux'_eq')

lemma snd_find_policy_code_aux_upt:
  assumes "v_len v = states" "v_invar v"
  shows "(snd (find_policy_code_aux_upt v states)) = fst (GS_iter_aux 0 v md)"
proof -
  have "fst (GS_iter_aux 0 v md) = fold (\<lambda>s v. v_update s (\<L>_GS_code (s_lookup mdp s) v) v) [0..<states] v"
    unfolding GS_iter_aux_fold ..
  also have "\<dots> = fold (\<lambda>s v. v_update s (snd (find_policy_state_code_aux' v s)) v) [0..<states] v"
    using find_policy_state_code_aux'_eq_\<L>_GS_code assms
    by (auto simp:V_Map.invar_update v_len_update intro!: fold_cong'[where P = "\<lambda>v. v_len v = states \<and> v_invar v"])
  also have "\<dots> = (snd (find_policy_code_aux_upt v states))"
    unfolding find_policy_code_aux_upt_def
    by (induction states) (auto simp add: split_def)
  finally show ?thesis..
qed

lemma GS_rec_upto_Suc: "MDP.GS_rec_upto (Suc n) v 0 = (MDP.GS_rec_upto n v 0)(n := (\<Squnion>a\<in>MDP_A n. MDP.L\<^sub>a a (MDP.GS_rec_upto n v 0) n))"
proof -
  have "s \<noteq> n \<Longrightarrow> MDP.GS_rec_upto (Suc n) v 0 s = MDP.GS_rec_upto n v 0 s" for s
    using MDP.GS_rec_upto_Suc MDP.GS_rec_upto_ge
    by (metis Suc_leI le_neq_implies_less not_less)
  moreover have "s = n \<Longrightarrow> MDP.GS_rec_upto (Suc n) v 0 s = (\<Squnion>a\<in>MDP_A n. MDP.L\<^sub>a a (MDP.GS_rec_upto n v 0) n)" for s
    using MDP.GS_rec_upto_Suc' by auto
  ultimately show ?thesis
    by auto
qed

lemma keys_fst_find_policy_code_aux_upt: "s \<le> states \<Longrightarrow> D_Map.keys (fst (find_policy_code_aux_upt v s)) = {0..<s}"
  using d_invar_find_policy_code_aux_upt find_policy_code_aux_upt_def
  by (induction s arbitrary: v) (auto simp: find_policy_code_aux_upt_Suc case_prod_beta)

lemma keys_fst_find_policy_code_aux: "D_Map.keys (fst (find_policy_code_aux v)) = {0..<states}"
  using keys_fst_find_policy_code_aux_upt find_policy_code_aux_def
  by force

lemma find_policy_code_ge: "s \<ge> states \<Longrightarrow> D_Map.map_to_fun (find_policy_code v) s = 0"
  using find_policy_code_notin find_policy_code_def
  by (auto simp: D_Map.map_to_fun_def)

lemma find_policy_code_aux_upt_zero[simp]: "find_policy_code_aux_upt v 0 = (d_empty, v)"
  unfolding find_policy_code_aux_upt_def
  by auto

lemma GS_rec_upto_zero[simp]: "MDP.GS_rec_upto 0 v n = v"
  by (auto simp: MDP.GS_rec_upto.simps)

lemma keys_find_policy_code_aux_upt:"n < states \<Longrightarrow> v_invar v \<Longrightarrow> v_len v = states \<Longrightarrow> v_len (snd (find_policy_code_aux_upt v n)) = states"
  apply (induction n arbitrary: v)
   apply (auto simp: case_prod_beta find_policy_code_aux_upt_Suc)
  by (metis Suc_lessD less_or_eq_imp_le v_len_invar_find_policy_code_aux_upt v_len_update)

lemma split_eq_GS_rec_upto_Sup:
  "MDP.GS.\<L>\<^sub>b_split v s = (\<Squnion>a\<in>MDP_A s. MDP.L\<^sub>a a (MDP.GS_rec_upto s (apply_bfun v) 0) s)"
  using MDP.GS_rec_upto_correct MDP.GS_rec_upto_ge MDP.\<L>\<^sub>b_split_GS_iter[symmetric, of _ _ v] by auto

lemma split_eq_GS_rec_upto_is_arg_max:
  assumes "is_arg_max (\<lambda>a. MDP.L\<^sub>a a (MDP.GS_rec_upto s (apply_bfun v) 0) s) (\<lambda>a. a \<in> MDP_A s) a"
  shows "MDP.GS.\<L>\<^sub>b_split v s = MDP.L\<^sub>a a (MDP.GS_rec_upto s (apply_bfun v) 0) s"
  using arg_max_SUP[OF assms] split_eq_GS_rec_upto_Sup
  by auto

lemma "MDP.GS_rec_upto n (apply_bfun v) 0 s = (if s < n then MDP.GS.\<L>\<^sub>b_split v s else v s)"
  using MDP.GS_rec_upto_correct MDP.GS_rec_upto_ge
  by auto

lemma GS_rec_upto_eq_\<L>\<^sub>b_split': "MDP.GS_rec_upto n (apply_bfun v) 0 = (\<lambda>s. if s < n then MDP.GS.\<L>\<^sub>b_split v s else v s)"
  using MDP.GS_rec_upto_correct MDP.GS_rec_upto_ge not_le
  by auto

lemma snd_find_policy_code_aux_upt_correct:
  assumes "v_len v = states" "v_invar v" "n \<le> states"
  shows "V_Map.map_to_fun (snd (find_policy_code_aux_upt v n)) = MDP.GS_rec_upto n (V_Map.map_to_fun v) 0"
  using assms
proof (induction n)
  case 0
  then show ?case
    by auto
next
  case (Suc n)
  have "V_Map.map_to_fun (snd (find_policy_code_aux_upt v (Suc n))) n = snd (find_policy_state_code_aux' (snd (find_policy_code_aux_upt v n)) n)"
    unfolding find_policy_code_aux_upt_Suc
    using  Suc(3)  Suc(2)
    apply (auto simp: case_prod_unfold V_Map.map_to_fun_update)
    apply (subst V_Map.map_to_fun_update)
    using v_len_invar_find_policy_code_aux_upt
      apply auto
    by (metis Suc.prems(3) Suc_leD Suc_le_lessD assms(1))+
  also have "\<dots> = (MAX a\<in>MDP_A n. MDP.L\<^sub>a a (apply_bfun (V_Map.map_to_bfun (snd (find_policy_code_aux_upt v n)))) n)"
    using keys_find_policy_code_aux_upt Suc v_len_invar_find_policy_code_aux_upt
    by (smt (verit, ccfv_SIG) Suc_leD Suc_le_lessD Sup.SUP_cong find_policy_state_code_aux'_eq' snd_conv)
  also have "\<dots> = (\<Squnion>a\<in>MDP_A n. MDP.L\<^sub>a a (apply_bfun (V_Map.map_to_bfun (snd (find_policy_code_aux_upt v n)))) n)"
    using Suc
    by (auto simp: cSup_eq_Max[symmetric] V_Map.map_to_fun_def V_Map.map_to_bfun.rep_eq)
  also have "\<dots> = (\<Squnion>a\<in>MDP_A n. MDP.L\<^sub>a a ((V_Map.map_to_fun (snd (find_policy_code_aux_upt v n)))) n)"
    using Suc.prems
    by (auto simp: map_to_bfun_eq_fun)
  also have "\<dots> = MDP.GS_rec_upto (Suc n) (V_Map.map_to_fun v) 0 n"
    using MDP.GS_rec_upto_Suc' Suc
    by auto
  finally have "V_Map.map_to_fun (snd (find_policy_code_aux_upt v (Suc n))) n = MDP.GS_rec_upto (Suc n) (V_Map.map_to_fun v) 0 n".
  moreover have "V_Map.map_to_fun (snd (find_policy_code_aux_upt v (Suc n))) s = MDP.GS_rec_upto (Suc n) (V_Map.map_to_fun v) 0 s" if "s \<noteq> n" for s
    unfolding find_policy_code_aux_upt_Suc
    using Suc Suc_lessD that
    apply (auto simp: case_prod_beta V_Map.map_to_fun_update GS_rec_upto_Suc)
    by (metis Suc_leD Suc_le_lessD V_Map.invar_update V_Map.map_to_fun_def v_len_invar_find_policy_code_aux_upt v_len_update v_lookup_update)
  ultimately show ?case
    by fastforce
qed

lemma GS_inv_eq_L: "apply_bfun (MDP.GS_inv d v) s = MDP.L (MDP.mk_dec_det d) ((bfun_if ((\<le>) s) v (MDP.GS_inv d v))) s"
  using MDP.GS_inv_elem_eq MDP.L_def by presburger

lemma GS_inv_eq_L\<^sub>a: "MDP.GS_inv d v s = MDP.L\<^sub>a (d s) (bfun_if ((\<le>) s) v (MDP.GS_inv d v)) s"
  using GS_inv_eq_L MDP.L_eq_L\<^sub>a_det by presburger

lemma is_arg_max_L\<^sub>a_GS_inv:
  "is_arg_max (\<lambda>a. MDP.L\<^sub>a a (bfun_if ((\<le>) s) v (MDP.GS_inv d v)) s) (\<lambda>a. a \<in> MDP_A s) a
  \<longleftrightarrow> is_arg_max (\<lambda>a. (MDP.GS_inv (d(s := a)) v s)) (\<lambda>a. a \<in> MDP_A s) a"
proof -
  have *: "s' < s \<Longrightarrow> MDP.GS_inv (d(s := a)) v s' =  MDP.GS_inv d v s'" for s' a
    using MDP.GS_indep_high_states by fastforce
  show ?thesis
    unfolding GS_inv_eq_L\<^sub>a by (fastforce simp: bfun_if.rep_eq * cong: if_cong)
qed

lemma GS_rec_upto_eq_\<L>\<^sub>b_split'': "MDP.GS_rec_upto s (apply_bfun v) 0 = bfun_if ((\<le>) s) v (MDP.GS.\<L>\<^sub>b_split v)"
  by (fastforce simp: MDP.GS_rec_upto_ge bfun_if.rep_eq MDP.GS_rec_upto_correct not_le)

lemma GS_inv_GS_least_eq_split: "MDP.GS_inv (MDP.d_GS_least v) v = MDP.GS.\<L>\<^sub>b_split v"
  using arg_max_SUP[OF MDP.d_GS_least_is_arg_max]
  by (auto simp: MDP.GS.\<L>\<^sub>b_split.rep_eq MDP.GS.\<L>_split_def MDP.GS_inv_def[symmetric])

lemma is_arg_max_L\<^sub>a_GS_inv_d_GS_least:
  "is_arg_max (\<lambda>a. MDP.L\<^sub>a a (MDP.GS_rec_upto s (apply_bfun v) 0) s) (\<lambda>a. a \<in> MDP_A s) a
  \<longleftrightarrow> is_arg_max (\<lambda>a. (MDP.GS_inv ((MDP.d_GS_least v)(s := a)) v s)) (\<lambda>a. a \<in> MDP_A s) a"
  by (auto simp: GS_inv_GS_least_eq_split GS_rec_upto_eq_\<L>\<^sub>b_split'' is_arg_max_L\<^sub>a_GS_inv[symmetric])

lemma d_GS_least_ge: "s \<ge> states \<Longrightarrow> MDP.d_GS_least (V_Map.map_to_bfun v) s = 0"
  by (subst MDP.d_GS_least_eq) (auto intro!: Least_equality simp: is_arg_max_linorder MDP_A_def)

lemma fst_find_policy_code_aux_upt_correct:
  assumes "v_len v = states" "v_invar v" "n \<le> states" "s < n"
  shows "D_Map.map_to_fun (fst (find_policy_code_aux_upt v n)) s = least_arg_max (\<lambda>a. MDP.L\<^sub>a a (MDP.GS_rec_upto s (V_Map.map_to_fun v) 0) s) (\<lambda>a. a \<in> MDP_A s)"
  using assms
proof (induction n arbitrary: s)
  case 0
  then show ?case
    by auto
next
  case (Suc n)
  have "D_Map.map_to_fun (fst (find_policy_code_aux_upt v (Suc n))) n = fst (find_policy_state_code_aux' (snd (find_policy_code_aux_upt v n)) n)"
    using d_invar_find_policy_code_aux_upt Suc
    by (auto simp: find_policy_code_aux_upt_Suc case_prod_unfold D_Map.map_to_fun_update)
  also have "\<dots> = least_arg_max (\<lambda>a. MDP.L\<^sub>a a (apply_bfun (V_Map.map_to_bfun (snd (find_policy_code_aux_upt v n)))) n) (\<lambda>a. a \<in> MDP_A n)"
    using Suc keys_find_policy_code_aux_upt
    apply (auto simp: find_policy_state_code_aux'_eq')
    apply (subst find_policy_state_code_aux'_eq')
    using Suc_le_lessD apply presburger+
     apply (meson Suc_leD v_len_invar_find_policy_code_aux_upt)
    by force
  also have "\<dots> = least_arg_max (\<lambda>a. MDP.L\<^sub>a a (MDP.GS_rec_upto n (V_Map.map_to_fun v) 0) n) (\<lambda>a. a \<in> MDP_A n)"
    using Suc map_to_bfun_eq_fun
    by (auto simp: snd_find_policy_code_aux_upt_correct)
  finally have "D_Map.map_to_fun (fst (find_policy_code_aux_upt v (Suc n))) n = least_arg_max (\<lambda>a. MDP.L\<^sub>a a (MDP.GS_rec_upto n (V_Map.map_to_fun v) 0) n) (\<lambda>a. a \<in> MDP_A n)".
  moreover have "D_Map.map_to_fun (fst (find_policy_code_aux_upt v (Suc n))) s = least_arg_max (\<lambda>a. MDP.L\<^sub>a a (MDP.GS_rec_upto s (V_Map.map_to_fun v) 0) s) (\<lambda>a. a \<in> MDP_A s)" if "s < n" for s
    using that d_invar_find_policy_code_aux_upt Suc
    by (auto simp: find_policy_code_aux_upt_Suc case_prod_unfold D_Map.map_to_fun_update)
  ultimately show ?case
    using Suc by (cases "s = n") auto
qed

lemma GS_iter'_correct:
  assumes "v_len v = states" "v_invar v"
  shows "D_Map.map_to_fun (find_policy_code v) = (MDP.d_GS_least (V_Map.map_to_bfun v))"
proof -
  have "D_Map.map_to_fun (find_policy_code v) s = (MDP.d_GS_least (V_Map.map_to_bfun v)) s" if "s \<ge> states" for s
    using find_policy_code_ge d_GS_least_ge that
    by auto
  moreover have "D_Map.map_to_fun (find_policy_code v) s = (MDP.d_GS_least (V_Map.map_to_bfun v)) s" if "s < states" for s
    using that assms
  proof (induction s rule: less_induct)
    case (less x)
    show ?case
      unfolding find_policy_code_def find_policy_code_aux_def
      using less assms
      by (auto intro!: least_arg_max_cong' simp: MDP.d_GS_least_eq fst_find_policy_code_aux_upt_correct map_to_bfun_eq_fun is_arg_max_L\<^sub>a_GS_inv_d_GS_least[symmetric] least_arg_max_def[symmetric])
  qed
  ultimately show ?thesis
    using not_le by blast
qed

partial_function (tailrec) GS_code_aux where
  "GS_code_aux v eps = (
  let (v', md) = GS_iter v in
    if (2 * l) * md < eps * (1 - l)
    then v'
    else GS_code_aux v' eps)"

lemmas GS_code_aux.simps[code]

definition "GS_code v eps = (if l = 0 \<or> eps \<le> 0 then fst (GS_iter v) else GS_code_aux v eps)"

lemma GS_code_aux_correct_aux:
  assumes "eps > 0" "v_invar v" "v_len v = states" "l \<noteq> 0"
  shows "V_Map.map_to_fun (GS_code_aux v eps) = MDP.gs_iteration eps (V_Map.map_to_bfun v)
  \<and> v_len (GS_code_aux v eps) = states \<and> v_invar (GS_code_aux v eps)"
  using assms
proof (induction eps "(V_Map.map_to_bfun v)" arbitrary: v rule: MDP.gs_iteration.induct)
  case (1 eps)
  have *:"2 * l * snd (GS_iter v) < eps * (1 - l) \<longleftrightarrow> 2 * l * dist (MDP.GS.\<L>\<^sub>b_split (V_Map.map_to_bfun v)) (V_Map.map_to_bfun v) < eps * (1 - l)"
    using GS_iter_aux_correct''
    by (auto simp: snd_GS_iter_correct' 1)

  thus ?case
  proof (cases "2 * l * snd (GS_iter v) < eps * (1 - l)")
    case True
    then show ?thesis
      unfolding GS_code_aux.simps[of v]
      apply (simp add: case_prod_beta)
      apply (subst MDP.gs_iteration.simps)
      apply (auto simp: case_prod_beta *)
              apply (metis "1.prems"(2) "1.prems"(3) GS_iter_aux_correct'' map_to_bfun_eq_fun)
      using "1.prems"(1) apply (auto simp: dist_commute)
       apply (simp add: "1.prems"(2) "1.prems"(3))
      using "1.prems"(2) "1.prems"(3) invar_GS_iter by blast
  next
    case False
    then show ?thesis
      unfolding GS_code_aux.simps[of v]
      apply (simp add: case_prod_beta)
      apply (subst MDP.gs_iteration.simps)
      apply (auto simp: case_prod_beta *)
      using "1.prems"(1) apply (auto simp: dist_commute)
      by (auto simp add: "1.hyps" "1.prems"(2) "1.prems"(3) GS_iter_aux_correct'' assms(4) invar_GS_iter)
  qed
qed

lemma GS_code_aux_correct:
  assumes "eps > 0" "v_invar v" "v_len v = states" "l \<noteq> 0"
  shows "V_Map.map_to_fun (GS_code_aux v eps) = MDP.gs_iteration eps (V_Map.map_to_bfun v)"
  using assms GS_code_aux_correct_aux by auto

lemma GS_code_aux_keys:
  assumes "eps > 0" "v_invar v" "v_len v = states" "l \<noteq> 0"
  shows "v_len (GS_code_aux v eps) = states"
  using assms GS_code_aux_correct_aux by auto

lemma GS_code_aux_invar:
  assumes "eps > 0" "v_invar v" "v_len v = states" "l \<noteq> 0"
  shows "v_invar (GS_code_aux v eps)"
  using assms GS_code_aux_correct_aux by auto

lemma GS_code_correct:
  assumes "eps > 0" "v_invar v" "v_len v = states"
  shows "V_Map.map_to_fun (GS_code v eps) = MDP.gs_iteration eps (V_Map.map_to_bfun v)"
proof (cases "l = 0")
  case True
  then show ?thesis
    using assms invar_GS_iter GS_iter_aux_correct''
    unfolding GS_code_def MDP.gs_iteration.simps[of _ "V_Map.map_to_bfun v"]
    by (fastforce simp: map_to_bfun_eq_fun)
next
  case False
  then show ?thesis
    using assms
    by (auto simp add: GS_code_def GS_code_aux_correct  MDP.gs_iteration.simps )
qed

definition "GS_policy_code v eps = find_policy_code (GS_code v eps)"

lemma GS_policy_code_correct:
  assumes "eps > 0" "v_invar v" "v_len v = states"
  shows "D_Map.map_to_fun (GS_policy_code v eps) = MDP.vi_gs_policy eps (V_Map.map_to_bfun v)"
proof -
  have aux: "V_Map.map_to_bfun (GS_code v eps) = (MDP.gs_iteration eps (V_Map.map_to_bfun v))"
    using GS_code_correct[OF assms] assms(2) map_to_bfun_eq_fun by auto
  have "D_Map.map_to_fun (GS_policy_code v eps) = MDP.d_GS_least (V_Map.map_to_bfun (GS_code v eps))"
    unfolding GS_code_def GS_policy_code_def MDP.vi_gs_policy_def
  proof (subst GS_iter'_correct)
    show "v_len (if l = 0 \<or> eps \<le> 0 then fst (GS_iter v) else GS_code_aux v eps) = states"
      using assms len_GS_iter GS_code_aux_keys assms by presburger
  qed (auto simp: assms GS_code_aux_invar invar_GS_iter)
  also have "\<dots> = MDP.d_GS_least (MDP.gs_iteration eps (V_Map.map_to_bfun v))"
    using GS_code_correct[of eps v] assms by (auto simp: aux)
  finally show ?thesis unfolding MDP.vi_gs_policy_def by auto
qed

end

lemma inorder_empty: "Tree2.inorder am = [] \<Longrightarrow> am = \<langle>\<rangle>"
  using Tree2.inorder.elims by blast

context MDP_nat_disc
begin

lemma dist_opt_bound_\<L>\<^sub>b_split: "dist v \<nu>\<^sub>b_opt \<le> dist v (GS.\<L>\<^sub>b_split v) / (1 - l)"
  using contraction_\<L>_split_dist
  by (simp add: mult.commute mult_imp_le_div_pos)

lemma cert_\<L>\<^sub>b_split:
  assumes "\<epsilon> \<ge> 0" "dist v (GS.\<L>\<^sub>b_split v) / (1 - l) \<le> \<epsilon>"
  shows "dist v \<nu>\<^sub>b_opt \<le> \<epsilon>"
  using assms dist_opt_bound_\<L>\<^sub>b_split order_trans by auto

definition "check_value_GS eps v \<longleftrightarrow> dist v (GS.\<L>\<^sub>b_split v) / (1 - l) \<le> eps"

definition "gs_policy_bound_error v = (
  let v' = (GS.\<L>\<^sub>b_split v); err = (2 * l) * dist v v' / (1 - l) in
  (err, d_GS_least v'))"

lemma \<L>\<^sub>b_split_eq_L_opt: "GS.\<L>\<^sub>b_split v = GS.L_split (d_GS_least v) v"
  by (simp add: GS_inv_def \<L>\<^sub>b_split_eq_GS_inv)

lemma L_split_fix_\<nu>:
  assumes "d \<in> D\<^sub>D"
  assumes "GS.L_split d v = v"
  shows "v = \<nu>\<^sub>b (mk_stationary_det d)"
proof -
  have "r_dec\<^sub>b (mk_dec_det d) = (id_blinfun - l *\<^sub>R \<P>\<^sub>1 (mk_dec_det d)) v"
    using GS_inv_rec[of d v]
    unfolding GS_inv_def assms(2)  \<P>\<^sub>1_sum_lower_upper
    by (auto simp: blinfun.bilinear_simps algebra_simps)
  hence "v = (\<Sum>t. (l *\<^sub>R \<P>\<^sub>1 (mk_dec_det d))^^t) (r_dec\<^sub>b (mk_dec_det d))"
    using inv_norm_le'(2)[OF norm_\<P>\<^sub>1_l_less] by auto
  thus "v = \<nu>\<^sub>b (mk_stationary (mk_dec_det d))"
    by (auto simp: \<nu>_stationary blincomp_scaleR_right)
qed

lemma
  assumes "gs_policy_bound_error v = (err, d)"
  shows "dist (\<nu>\<^sub>b (mk_stationary_det d)) \<nu>\<^sub>b_opt \<le> err"
proof (cases "l = 0")
  case True
  hence "gs_policy_bound_error v = (0, d_GS_least (GS.\<L>\<^sub>b_split v))"
    unfolding gs_policy_bound_error_def by auto
  have "GS.\<L>\<^sub>b_split v = GS.\<L>\<^sub>b_split \<nu>\<^sub>b_opt"
    by (auto simp: GS.\<L>\<^sub>b_split.rep_eq R_GS_def GS.\<L>_split_def simp del: GS.\<L>\<^sub>b_split_fix intro!: bfun_eqI)
      (simp add: True)
  hence "GS.\<L>\<^sub>b_split v = \<nu>\<^sub>b_opt"
    by auto
  hence "\<nu>\<^sub>b (mk_stationary_det (d_GS_least (GS.\<L>\<^sub>b_split v))) = \<nu>\<^sub>b_opt"
    using GS.\<L>\<^sub>b_split_fix GS_inv_def Q_GS_def R_GS_def True \<L>\<^sub>b_split_eq_GS_inv \<nu>_stationary_inv
    by force
  then show ?thesis
    using assms unfolding gs_policy_bound_error_def
    by (auto simp: True)
next
  case False
  then show ?thesis
  proof (cases "GS.\<L>\<^sub>b_split v = v")
    case True
    have v_opt: "v = \<nu>\<^sub>b_opt"
      using GS.\<L>\<^sub>b_lim(1) GS.\<L>\<^sub>b_split_fix True by blast
    have *: "(\<nu>\<^sub>b (mk_stationary_det d) = v) = (GS.L_split d v = v)" if "d \<in> D\<^sub>D" for d v
      using that L_split_fix_\<nu> GS.L_split_fix by auto

    have "GS.L_split (d_GS_least \<nu>\<^sub>b_opt) \<nu>\<^sub>b_opt = \<nu>\<^sub>b_opt"
      using GS.\<L>\<^sub>b_split_fix \<L>\<^sub>b_split_eq_L_opt by auto
    hence "\<nu>\<^sub>b (mk_stationary_det (d_GS_least (GS.\<L>\<^sub>b_split v))) = \<nu>\<^sub>b_opt"
      using d_GS_least_is_dec by (auto simp: v_opt *)
    then show ?thesis
      using assms unfolding gs_policy_bound_error_def
      by (auto simp: True)
  next
    case False
    hence 1: "dist v (GS.\<L>\<^sub>b_split v) > 0"
      by fastforce
    hence "2 * l * dist v (GS.\<L>\<^sub>b_split v) > 0"
      using \<open>l \<noteq> 0\<close> zero_le_disc by (simp add: less_le)
    hence "err > 0"
      using assms unfolding gs_policy_bound_error_def by auto
    hence "dist (\<nu>\<^sub>b (mk_stationary_det (d_GS_least (GS.\<L>\<^sub>b_split v)))) \<nu>\<^sub>b_opt < err'" if "err < err'" for err'
      using that assms
      unfolding gs_policy_bound_error_def
      by (auto simp: pos_divide_less_eq[symmetric] intro: find_policy_error_bound_gs)
    then show ?thesis
      using assms unfolding gs_policy_bound_error_def by force
  qed
qed

end

context MDP_Code
begin
definition "gs_policy_bound_error_code v = (
  let v' = fst (GS_iter v);
    d = if states = 0 then 0 else (MAX s \<in> {..< states}. dist (v_lookup v s) (v_lookup v' s));
   err = (2 * l) * d / (1 - l) in
  (err, find_policy_code v'))"

lemma
  assumes "v_len v = states" "v_invar v"
  shows "D_Map.map_to_fun (snd (gs_policy_bound_error_code v)) = snd (MDP.gs_policy_bound_error (V_Map.map_to_bfun v))"
  unfolding MDP.gs_policy_bound_error_def  gs_policy_bound_error_code_def
  by (simp add: GS_iter'_correct GS_iter_aux_correct'' assms invar_GS_iter)

lemma
  assumes "v_len v = states" "v_invar v"
  shows "(fst (gs_policy_bound_error_code v)) = fst (MDP.gs_policy_bound_error (V_Map.map_to_bfun v))"
proof-
  have dist_zero_ge: "dist ((V_Map.map_to_bfun v) x) ((V_Map.map_to_bfun (fst (GS_iter v))) x) = 0" if "x \<ge> states" for x
    using assms that
    by (auto simp: V_Map.map_to_bfun.rep_eq split: option.splits)
  have univ: "UNIV = {0..<states} \<union> {states..}" by auto
  let ?d = "\<lambda>x. dist ((V_Map.map_to_bfun v) x) ((V_Map.map_to_bfun (fst (GS_iter v))) x)"

  have fin: "finite (range (\<lambda>x. ?d x))"
    by (auto simp: dist_zero_ge univ Set.image_Un Set.image_constant[of states])
  have r: "range (\<lambda>x. ?d x) = ?d ` {..<states} \<union> ?d ` {states..}"
    by force
  hence "Sup (range ?d) = Max (range ?d)"
    using fin cSup_eq_Max by blast
  also have "\<dots> = (if states = 0 then (Max (?d ` {states..})) else max (Max (?d ` {..<states})) (Max (?d ` {states..})))"
    using r fin by (auto intro: Max_Un)
  also have "\<dots> = (if states = 0 then 0 else max (Max (?d ` {..<states})) 0)"
    using dist_zero_ge
    by (auto simp: Set.image_constant[of states] cSup_eq_Max[symmetric, of "(\<lambda>_. 0) ` {states..}"])
  also have "\<dots> = (if states = 0 then 0 else (Max (?d ` {..<states})))"
    by (auto intro!: max_absorb1 max_geI)
  finally have 1: "Sup (range ?d) = (if states = 0 then 0 else (Max (?d ` {..<states})))".
  thus ?thesis
    unfolding MDP.gs_policy_bound_error_def gs_policy_bound_error_code_def dist_bfun_def
    using assms GS_iter'_correct GS_iter_aux_correct'' invar_GS_iter
    apply auto
    using GS_iter_aux_correct GS_iter_def MDP.GS_rec_upto_correct V_Map.map_to_fun_def map_to_bfun_eq_fun by auto
qed

end

global_interpretation GS_Code: MDP_Code
  (* state map (transition system) *)
  "IArray.sub" "\<lambda>n x arr. IArray ((IArray.list_of arr)[n:= x])" "IArray.length" "IArray" "IArray.list_of" "\<lambda>_. True"

(* action map *)
RBT_Set.empty RBT_Map.update RBT_Map.delete Lookup2.lookup Tree2.inorder rbt

"MDP.transitions (Rep_Valid_MDP mdp)" "MDP.states (Rep_Valid_MDP mdp)"

(* value map *)
starray_get "\<lambda>i x arr. starray_set arr i x"  starray_length starray_of_list  "\<lambda>arr. starray_foldr (\<lambda>x xs. x # xs) arr []" "\<lambda>_. True"

(* decision rule map *)
RBT_Set.empty RBT_Map.update RBT_Map.delete Lookup2.lookup Tree2.inorder rbt

"MDP.disc (Rep_Valid_MDP mdp)"

for mdp states l
defines GS_code = GS_Code.GS_code
  and find_policy_code = GS_Code.find_policy_code
  and GS_policy_code = GS_Code.GS_policy_code
  and GS_code_aux = GS_Code.GS_code_aux
  and check_dist = GS_Code.check_dist
  and GS_iter = GS_Code.GS_iter
  and GS_iter_aux = GS_Code.GS_iter_aux
  and \<L>_GS_code = GS_Code.\<L>_GS_code
  and L\<^sub>a_code = GS_Code.L\<^sub>a_code
  and a_lookup' = GS_Code.a_lookup'
  and d_lookup' = GS_Code.d_lookup'
  and v0 = GS_Code.v0
  and find_policy_code_aux = GS_Code.find_policy_code_aux
  and find_policy_code_aux_upt = GS_Code.find_policy_code_aux_upt
  and find_policy_state_code_aux' = GS_Code.find_policy_state_code_aux'
  and find_policy_state_code_aux = GS_Code.find_policy_state_code_aux
  and entries = M.entries
  and from_list = M.from_list
  and arr_tabulate = starray_Array.arr_tabulate

and v_map_from_list = GS_Code.v_map_from_list
and gs_policy_bound_error_code = GS_Code.gs_policy_bound_error_code
  using Rep_Valid_MDP
  by unfold_locales
    (fastforce simp: pmf_of_list_wf_def Ball_set_list_all[symmetric] case_prod_beta is_MDP_def M.invar_def M.entries_def M.is_empty_def RBT_Set.empty_def  length_0_conv[symmetric])+

lemmas entries_def[unfolded M.entries_def, code]
lemmas from_list_def[unfolded M.from_list_def, code]
lemmas arr_tabulate_def[unfolded starray_Array.arr_tabulate_def, code]

end


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

section\<open>Ordered Pairs\<close>

theory pair imports upair
begin

ML_file "simpdata.ML"

setup \<open>
  map_theory_simpset
    (Simplifier.set_mksimps (fn ctxt => map mk_eq o ZF_atomize o Variable.gen_all ctxt)
      #> Simplifier.add_cong @{thm if_weak_cong})
\<close>

ML \<open>val ZF_ss = simpset_of @{context}\<close>

simproc_setup defined_Bex ("\<exists>x\<in>A. P(x) & Q(x)") = \<open>
  fn _ => Quantifier1.rearrange_bex
    (fn ctxt =>
      unfold_tac ctxt @{thms Bex_def} THEN
      Quantifier1.prove_one_point_ex_tac ctxt)
\<close>

simproc_setup defined_Ball ("\<forall>x\<in>A. P(x) \<longrightarrow> Q(x)") = \<open>
  fn _ => Quantifier1.rearrange_ball
    (fn ctxt =>
      unfold_tac ctxt @{thms Ball_def} THEN
      Quantifier1.prove_one_point_all_tac ctxt)
\<close>

(** Lemmas for showing that <a,b> uniquely determines a and b **)

lemma singleton_eq_iff [iff]: "{a} = {b} \<longleftrightarrow> a=b"
by (rule extension [THEN iff_trans], blast)

lemma doubleton_eq_iff: "{a,b} = {c,d} \<longleftrightarrow> (a=c & b=d) | (a=d & b=c)"
by (rule extension [THEN iff_trans], blast)

lemma Pair_iff [simp]: "<a,b> = <c,d> \<longleftrightarrow> a=c & b=d"
by (simp add: Pair_def doubleton_eq_iff, blast)

lemmas Pair_inject = Pair_iff [THEN iffD1, THEN conjE, elim!]

lemmas Pair_inject1 = Pair_iff [THEN iffD1, THEN conjunct1]
lemmas Pair_inject2 = Pair_iff [THEN iffD1, THEN conjunct2]

lemma Pair_not_0: "<a,b> \<noteq> 0"
apply (unfold Pair_def)
apply (blast elim: equalityE)
done

lemmas Pair_neq_0 = Pair_not_0 [THEN notE, elim!]

declare sym [THEN Pair_neq_0, elim!]

lemma Pair_neq_fst: "<a,b>=a ==> P"
proof (unfold Pair_def)
  assume eq: "{{a, a}, {a, b}} = a"
  have  "{a, a} \<in> {{a, a}, {a, b}}" by (rule consI1)
  hence "{a, a} \<in> a" by (simp add: eq)
  moreover have "a \<in> {a, a}" by (rule consI1)
  ultimately show "P" by (rule mem_asym)
qed

lemma Pair_neq_snd: "<a,b>=b ==> P"
proof (unfold Pair_def)
  assume eq: "{{a, a}, {a, b}} = b"
  have  "{a, b} \<in> {{a, a}, {a, b}}" by blast
  hence "{a, b} \<in> b" by (simp add: eq)
  moreover have "b \<in> {a, b}" by blast
  ultimately show "P" by (rule mem_asym)
qed

subsection\<open>Sigma: Disjoint Union of a Family of Sets\<close>

text\<open>Generalizes Cartesian product\<close>

lemma Sigma_iff [simp]: "<a,b>: Sigma(A,B) \<longleftrightarrow> a \<in> A & b \<in> B(a)"
by (simp add: Sigma_def)

lemma SigmaI [TC,intro!]: "[| a \<in> A;  b \<in> B(a) |] ==> <a,b> \<in> Sigma(A,B)"
by simp

lemmas SigmaD1 = Sigma_iff [THEN iffD1, THEN conjunct1]
lemmas SigmaD2 = Sigma_iff [THEN iffD1, THEN conjunct2]

(*The general elimination rule*)
lemma SigmaE [elim!]:
    "[| c \<in> Sigma(A,B);
        !!x y.[| x \<in> A;  y \<in> B(x);  c=<x,y> |] ==> P
     |] ==> P"
by (unfold Sigma_def, blast)

lemma SigmaE2 [elim!]:
    "[| <a,b> \<in> Sigma(A,B);
        [| a \<in> A;  b \<in> B(a) |] ==> P
     |] ==> P"
by (unfold Sigma_def, blast)

lemma Sigma_cong:
    "[| A=A';  !!x. x \<in> A' ==> B(x)=B'(x) |] ==>
     Sigma(A,B) = Sigma(A',B')"
by (simp add: Sigma_def)

(*Sigma_cong, Pi_cong NOT given to Addcongs: they cause
  flex-flex pairs and the "Check your prover" error.  Most
  Sigmas and Pis are abbreviated as * or -> *)

lemma Sigma_empty1 [simp]: "Sigma(0,B) = 0"
by blast

lemma Sigma_empty2 [simp]: "A*0 = 0"
by blast

lemma Sigma_empty_iff: "A*B=0 \<longleftrightarrow> A=0 | B=0"
by blast

subsection\<open>Projections @{term fst} and @{term snd}\<close>

lemma fst_conv [simp]: "fst(<a,b>) = a"
by (simp add: fst_def)

lemma snd_conv [simp]: "snd(<a,b>) = b"
by (simp add: snd_def)

lemma fst_type [TC]: "p \<in> Sigma(A,B) ==> fst(p) \<in> A"
by auto

lemma snd_type [TC]: "p \<in> Sigma(A,B) ==> snd(p) \<in> B(fst(p))"
by auto

lemma Pair_fst_snd_eq: "a \<in> Sigma(A,B) ==> <fst(a),snd(a)> = a"
by auto

subsection\<open>The Eliminator, @{term split}\<close>

(*A META-equality, so that it applies to higher types as well...*)
lemma split [simp]: "split(%x y. c(x,y), <a,b>) == c(a,b)"
by (simp add: split_def)

lemma split_type [TC]:
    "[|  p \<in> Sigma(A,B);
         !!x y.[| x \<in> A; y \<in> B(x) |] ==> c(x,y):C(<x,y>)
     |] ==> split(%x y. c(x,y), p) \<in> C(p)"
by (erule SigmaE, auto)

lemma expand_split:
  "u \<in> A*B ==>
        R(split(c,u)) \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>B. u = <x,y> \<longrightarrow> R(c(x,y)))"
by (auto simp add: split_def)

subsection\<open>A version of @{term split} for Formulae: Result Type @{typ o}\<close>

lemma splitI: "R(a,b) ==> split(R, <a,b>)"
by (simp add: split_def)

lemma splitE:
    "[| split(R,z);  z \<in> Sigma(A,B);
        !!x y. [| z = <x,y>;  R(x,y) |] ==> P
     |] ==> P"
by (auto simp add: split_def)

lemma splitD: "split(R,<a,b>) ==> R(a,b)"
by (simp add: split_def)

text \<open>
  \bigskip Complex rules for Sigma.
\<close>

lemma split_paired_Bex_Sigma [simp]:
     "(\<exists>z \<in> Sigma(A,B). P(z)) \<longleftrightarrow> (\<exists>x \<in> A. \<exists>y \<in> B(x). P(<x,y>))"
by blast

lemma split_paired_Ball_Sigma [simp]:
     "(\<forall>z \<in> Sigma(A,B). P(z)) \<longleftrightarrow> (\<forall>x \<in> A. \<forall>y \<in> B(x). P(<x,y>))"
by blast

end


theory regexp_RecAtom
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype A = X | Y

datatype R
  = Nil2 | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   case x of
     | other =>
         case y of
           | other =>
               case x of
                 | other =>
                     case y of
                       | other => Seq x y
                       | Eps => x
                     end
                 | Eps => y
               end
           | Nil2 => y
         end
     | Nil2 => x
   end"

fun plus :: "R => R => R" where
"plus x y =
   case x of
     | other =>
         case y of
           | other => Plus x y
           | Nil2 => x
         end
     | Nil2 => y
   end"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun eqA :: "A => A => bool" where
"eqA (X) y = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun eps :: "R => bool" where
"eps x =
   case x of
     | other => False
     | Eps => True
     | Plus p q => or2 (eps p) (eps q)
     | Seq p2 q2 => and2 (eps p2) (eps q2)
     | Star y => True
   end"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil2)"

fun step :: "R => A => R" where
"step x y =
   case x of
     | other => Nil2
     | Atom a => (if eqA a y then Eps else Nil2)
     | Plus p q => plus (step p y) (step q y)
     | Seq p2 q2 =>
         plus (seq (step p2 y) q2) (seq (epsR p2) (step q2 y))
     | Star p3 => seq (step p3 y) x
   end"

fun recognise :: "R => A list => bool" where
"recognise x (Nil2) = eps x"
| "recognise x (Cons2 z xs) = recognise (step x z) xs"

fun eqList :: "A list => A list => bool" where
"eqList (Nil2) (Nil2) = True"
| "eqList (Nil2) (Cons2 z x2) = False"
| "eqList (Cons2 x3 xs) (Nil2) = False"
| "eqList (Cons2 x3 xs) (Cons2 y2 ys) =
     and2 (eqA x3 y2) (eqList xs ys)"

(*hipster seq plus or2 eqA and2 eps epsR step recognise eqList *)

theorem x0 :
  "!! (a :: A) (s :: A list) .
     (recognise (Atom a) s) = (eqList s (Cons2 a (Nil2)))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory prop_04
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun count :: "Nat => Nat list => Nat" where
  "count x (Nil2) = Z"
  | "count x (Cons2 z ys) =
       (if equal2 x z then S (count x ys) else count x ys)"
  (*hipster equal2 count *)
  hipster equal2
lemma lemma_a [thy_expl]: "equal2 x4 y4 = equal2 y4 x4"
by (hipster_induct_schemes prop_04.equal2.simps)

lemma lemma_aa [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes prop_04.equal2.simps)

lemma lemma_ab [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes prop_04.equal2.simps)
  theorem x0 :
    "(S (count n xs)) = (count n (Cons2 n xs))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


section\<open>FSet Utilities\<close>
text\<open>This theory provides various additional lemmas, definitions, and syntax over the fset data type.\<close>
theory FSet_Utils
  imports "HOL-Library.FSet"
begin

notation (latex output)
  "FSet.fempty" ("\<emptyset>") and
  "FSet.fmember" ("\<in>")

syntax (ASCII)
  "_fBall"       :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3ALL (_/:_)./ _)" [0, 0, 10] 10)
  "_fBex"        :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3EX (_/:_)./ _)" [0, 0, 10] 10)
  "_fBex1"       :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3EX! (_/:_)./ _)" [0, 0, 10] 10)

syntax (input)
  "_fBall"       :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3! (_/:_)./ _)" [0, 0, 10] 10)
  "_fBex"        :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3? (_/:_)./ _)" [0, 0, 10] 10)
  "_fBex1"       :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3?! (_/:_)./ _)" [0, 0, 10] 10)

syntax
  "_fBall"       :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<forall>(_/|\<in>|_)./ _)" [0, 0, 10] 10)
  "_fBex"        :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<exists>(_/|\<in>|_)./ _)" [0, 0, 10] 10)
  "_fBnex"       :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<nexists>(_/|\<in>|_)./ _)" [0, 0, 10] 10)
  "_fBex1"       :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<exists>!(_/|\<in>|_)./ _)" [0, 0, 10] 10)

translations
  "\<forall>x|\<in>|A. P" \<rightleftharpoons> "CONST fBall A (\<lambda>x. P)"
  "\<exists>x|\<in>|A. P" \<rightleftharpoons> "CONST fBex  A (\<lambda>x. P)"
  "\<nexists>x|\<in>|A. P" \<rightleftharpoons> "CONST fBall A (\<lambda>x. \<not>P)"
  "\<exists>!x|\<in>|A. P" \<rightharpoonup> "\<exists>!x. x |\<in>| A \<and> P"

lemma fset_of_list_remdups [simp]: "fset_of_list (remdups l) = fset_of_list l"
  apply (induct l)
   apply simp
  by (simp add: finsert_absorb fset_of_list_elem)

definition "fSum \<equiv> fsum (\<lambda>x. x)"

lemma fset_both_sides: "(Abs_fset s = f) = (fset (Abs_fset s) = fset f)"
  by (simp add: fset_inject)

lemma Abs_ffilter: "(ffilter f s = s') = ({e \<in> (fset s). f e} = (fset s'))"
  by (simp add: ffilter_def fset_both_sides Abs_fset_inverse Set.filter_def)

lemma size_ffilter_card: "size (ffilter f s) = card ({e \<in> (fset s). f e})"
  by (simp add: ffilter_def fset_both_sides Abs_fset_inverse Set.filter_def)

lemma ffilter_empty [simp]: "ffilter f {||} = {||}"
  by auto

lemma ffilter_finsert:
  "ffilter f (finsert a s) = (if f a then finsert a (ffilter f s) else (ffilter f s))"
  apply simp
  apply standard
   apply (simp add: ffilter_def fset_both_sides Abs_fset_inverse)
   apply auto[1]
  apply (simp add: ffilter_def fset_both_sides Abs_fset_inverse)
  by auto

lemma fset_equiv: "(f1 = f2) = (fset f1 = fset f2)"
  by (simp add: fset_inject)

lemma finsert_equiv: "(finsert e f = f') = (insert e (fset f) = (fset f'))"
  by (simp add: finsert_def fset_both_sides Abs_fset_inverse)

lemma filter_elements:
  "x |\<in>| Abs_fset (Set.filter f (fset s)) = (x \<in> (Set.filter f (fset s)))"
  by (metis ffilter.rep_eq fset_inverse notin_fset)

lemma sorted_list_of_fempty [simp]: "sorted_list_of_fset {||} = []"
  by (simp add: sorted_list_of_fset_def)

lemma fmember_implies_member: "e |\<in>| f \<Longrightarrow> e \<in> fset f"
  by (simp add: fmember_def)

lemma fold_union_ffUnion: "fold (|\<union>|) l {||} = ffUnion (fset_of_list l)"
by(induct l rule: rev_induct, auto)

lemma filter_filter:
  "ffilter P (ffilter Q xs) = ffilter (\<lambda>x. Q x \<and> P x) xs"
  by auto

lemma fsubset_strict:
  "x2 |\<subset>| x1 \<Longrightarrow> \<exists>e. e |\<in>| x1 \<and> e |\<notin>| x2"
  by auto

lemma fsubset:
  "x2 |\<subset>| x1 \<Longrightarrow> \<nexists>e. e |\<in>| x2 \<and> e |\<notin>| x1"
  by auto

lemma size_fsubset_elem:
  assumes "\<exists>e. e |\<in>| x1 \<and> e |\<notin>| x2"
      and "\<nexists>e. e |\<in>| x2 \<and> e |\<notin>| x1"
    shows "size x2 < size x1"
  using assms
  apply (simp add: fmember_def)
  by (metis card_seteq finite_fset linorder_not_le subsetI)

lemma size_fsubset: "x2 |\<subset>| x1 \<Longrightarrow> size x2 < size x1"
  by (metis fsubset fsubset_strict size_fsubset_elem)

definition fremove :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'a fset"
  where [code_abbrev]: "fremove x A = A - {|x|}"

lemma arg_cong_ffilter:
  "\<forall>e |\<in>| f. p e = p' e \<Longrightarrow> ffilter p f = ffilter p' f"
  by auto

lemma ffilter_singleton: "f e \<Longrightarrow> ffilter f {|e|} = {|e|}"
  apply (simp add: ffilter_def fset_both_sides Abs_fset_inverse)
  by auto

lemma fset_eq_alt: "(x = y) = (x |\<subseteq>| y \<and> size x = size y)"
  by (metis exists_least_iff le_less size_fsubset)

lemma ffold_empty [simp]: "ffold f b {||} = b"
  by (simp add: ffold_def)

lemma sorted_list_of_fset_sort:
  "sorted_list_of_fset (fset_of_list l) = sort (remdups l)"
  by (simp add: fset_of_list.rep_eq sorted_list_of_fset.rep_eq sorted_list_of_set_sort_remdups)

lemma fMin_Min: "fMin (fset_of_list l) = Min (set l)"
  by (simp add: fMin.F.rep_eq fset_of_list.rep_eq)

lemma sorted_hd_Min:
  "sorted l \<Longrightarrow>
   l \<noteq> [] \<Longrightarrow>
   hd l = Min (set l)"
  by (metis List.finite_set Min_eqI eq_iff hd_Cons_tl insertE list.set_sel(1) list.simps(15) sorted_simps(2))

lemma hd_sort_remdups: "hd (sort (remdups l)) = hd (sort l)"
  by (metis hd_sort_Min remdups_eq_nil_iff set_remdups)

lemma hd_sorted_list_of_fset:
  "s \<noteq> {||} \<Longrightarrow> hd (sorted_list_of_fset s) = (fMin s)"
  apply (insert exists_fset_of_list[of s])
  apply (erule exE)
  apply simp
  apply (simp add: sorted_list_of_fset_sort fMin_Min hd_sort_remdups)
  by (metis fset_of_list_simps(1) hd_sort_Min)

lemma fminus_filter_singleton:
  "fset_of_list l |-| {|x|} = fset_of_list (filter (\<lambda>e. e \<noteq> x) l)"
  by auto

lemma card_minus_fMin:
  "s \<noteq> {||} \<Longrightarrow> card (fset s - {fMin s}) < card (fset s)"
  by (metis Min_in bot_fset.rep_eq card_Diff1_less fMin.F.rep_eq finite_fset fset_equiv)

(* Provides a deterministic way to fold fsets similar to List.fold that works with the code generator *)
function ffold_ord :: "(('a::linorder) \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> 'b \<Rightarrow> 'b" where
  "ffold_ord f s b = (
    if s = {||} then
      b
    else
      let
        h = fMin s;
        t = s - {|h|}
      in
        ffold_ord f t (f h b)
  )"
  by auto
termination
  apply (relation "measures [\<lambda>(a, s, ab). size s]")
   apply simp
  by (simp add: card_minus_fMin)

lemma sorted_list_of_fset_Cons:
  "\<exists>h t. (sorted_list_of_fset (finsert s ss)) = h#t"
  apply (simp add: sorted_list_of_fset_def)
  by (cases "insort s (sorted_list_of_set (fset ss - {s}))", auto)

lemma list_eq_hd_tl:
  "l \<noteq> [] \<Longrightarrow>
   hd l = h \<Longrightarrow>
   tl l = t \<Longrightarrow>
   l = (h#t)"
  by auto

lemma fset_of_list_sort: "fset_of_list l = fset_of_list (sort l)"
  by (simp add: fset_of_list.abs_eq)

lemma exists_sorted_distinct_fset_of_list:
  "\<exists>l. sorted l \<and> distinct l \<and> f = fset_of_list l"
  by (metis distinct_sorted_list_of_set sorted_list_of_fset.rep_eq sorted_list_of_fset_simps(2) sorted_sorted_list_of_set)

lemma fset_of_list_empty [simp]: "(fset_of_list l = {||}) = (l = [])"
  by (metis fset_of_list.rep_eq fset_of_list_simps(1) set_empty)

lemma ffold_ord_cons: assumes sorted: "sorted (h#t)"
    and distinct: "distinct (h#t)"
  shows "ffold_ord f (fset_of_list (h#t)) b = ffold_ord f (fset_of_list t) (f h b)"
proof-
  have h_is_min: "h = fMin (fset_of_list (h#t))"
    by (metis sorted fMin_Min list.sel(1) list.simps(3) sorted_hd_Min)
  have remove_min: "fset_of_list t = (fset_of_list (h#t)) - {|h|}"
    using distinct fset_of_list_elem by force
  show ?thesis
    apply (simp only: ffold_ord.simps[of f "fset_of_list (h#t)"])
    by (metis h_is_min remove_min fset_of_list_empty list.distinct(1))
qed

lemma sorted_distinct_ffold_ord: assumes "sorted l"
      and "distinct l"
    shows "ffold_ord f (fset_of_list l) b = fold f l b"
  using assms
  apply (induct l arbitrary: b)
   apply simp
  by (metis distinct.simps(2) ffold_ord_cons fold_simps(2) sorted_simps(2))

lemma ffold_ord_fold_sorted: "ffold_ord f s b = fold f (sorted_list_of_fset s) b"
  by (metis exists_sorted_distinct_fset_of_list sorted_distinct_ffold_ord distinct_remdups_id sorted_list_of_fset_sort sorted_sort_id)

context includes fset.lifting begin
  lift_definition fprod  :: "'a fset \<Rightarrow> 'b fset \<Rightarrow> ('a \<times> 'b) fset " (infixr "|\<times>|" 80) is "\<lambda>a b. fset a \<times> fset b"
    by simp

  lift_definition fis_singleton :: "'a fset \<Rightarrow> bool" is "\<lambda>A. is_singleton (fset A)".
end

lemma fprod_empty_l: "{||} |\<times>| a = {||}"
  using bot_fset_def fprod.abs_eq by force

lemma fprod_empty_r: "a |\<times>| {||} = {||}"
  by (simp add: fprod_def bot_fset_def Abs_fset_inverse)

lemmas fprod_empty = fprod_empty_l fprod_empty_r

lemma fprod_finsert: "(finsert a as) |\<times>| (finsert b bs) =
   finsert (a, b) (fimage (\<lambda>b. (a, b)) bs |\<union>| fimage (\<lambda>a. (a, b)) as |\<union>| (as |\<times>| bs))"
  apply (simp add: fprod_def fset_both_sides Abs_fset_inverse)
  by auto

lemma fprod_subseteq:
  "x |\<subseteq>| x' \<and> y |\<subseteq>| y' \<Longrightarrow> x |\<times>| y |\<subseteq>| x' |\<times>| y'"
  apply (simp add: fprod_def less_eq_fset_def Abs_fset_inverse)
  by auto

lemma fimage_fprod:
  "(a, b) |\<in>| A |\<times>| B \<Longrightarrow> f a b |\<in>| (\<lambda>(x, y). f x y) |`| (A |\<times>| B)"
  by force

lemma fprod_singletons: "{|a|} |\<times>| {|b|} = {|(a, b)|}"
  apply (simp add: fprod_def)
  by (metis fset_inverse fset_simps(1) fset_simps(2))

lemma fprod_equiv:
  "(fset (f |\<times>| f') = s) = (((fset f) \<times> (fset f')) = s)"
  by (simp add: fprod_def Abs_fset_inverse)

lemma fis_singleton_alt: "fis_singleton f = (\<exists>e. f = {|e|})"
  by (metis fis_singleton.rep_eq fset_inverse fset_simps(1) fset_simps(2) is_singleton_def)

lemma singleton_singleton [simp]: "fis_singleton {|a|}"
  by (simp add: fis_singleton_def)

lemma not_singleton_empty [simp]: "\<not> fis_singleton {||}"
  apply (simp add: fis_singleton_def)
  by (simp add: is_singleton_altdef)

lemma fis_singleton_fthe_elem:
  "fis_singleton A \<longleftrightarrow> A = {|fthe_elem A|}"
  by (metis fis_singleton_alt fthe_felem_eq)

lemma fBall_ffilter:
  "\<forall>x |\<in>| X. f x \<Longrightarrow> ffilter f X = X"
  by auto

lemma fBall_ffilter2:
  "X = Y \<Longrightarrow>
   \<forall>x |\<in>| X. f x \<Longrightarrow>
   ffilter f X = Y"
  by auto

lemma size_fset_of_list: "size (fset_of_list l) = length (remdups l)"
  apply (induct l)
   apply simp
  by (simp add: fset_of_list.rep_eq insert_absorb)

lemma size_fsingleton: "(size f = 1) = (\<exists>e. f = {|e|})"
  apply (insert exists_fset_of_list[of f])
  apply clarify
  apply (simp only: size_fset_of_list)
  apply (simp add: fset_of_list_def fset_both_sides Abs_fset_inverse)
  by (metis List.card_set One_nat_def card.insert card_1_singletonE card.empty empty_iff finite.intros(1))

lemma ffilter_mono: "(ffilter X xs = f) \<Longrightarrow> \<forall>x |\<in>| xs. X x = Y x \<Longrightarrow> (ffilter Y xs = f)"
  by auto

lemma size_fimage: "size (fimage f s) \<le> size s"
  apply (induct s)
   apply simp
  by (simp add: card_insert_if)

lemma size_ffilter: "size (ffilter P f) \<le> size f"
  apply (induct f)
   apply simp
  apply (simp only: ffilter_finsert)
  apply (case_tac "P x")
   apply (simp add: fmember_iff_member_fset)
  by (simp add: card_insert_if)

lemma ffilter_size_le: "\<And>f s. size s \<le> n \<Longrightarrow> size (ffilter f s) \<le> n"
  using dual_order.trans size_ffilter by blast

lemma set_membership_eq: "A = B \<longleftrightarrow> (\<lambda>x. Set.member x A) = (\<lambda>x. Set.member x B)"
  apply standard
   apply simp
  by (meson equalityI subsetI)

lemmas ffilter_eq_iff = Abs_ffilter set_membership_eq fun_eq_iff

lemma size_le_1: "size f \<le> 1 = (f = {||} \<or> (\<exists>e. f = {|e|}))"
  apply standard
   apply (metis bot.not_eq_extremum gr_implies_not0 le_neq_implies_less less_one size_fsingleton size_fsubset)
  by auto

lemma size_gt_1: "1 < size f \<Longrightarrow> \<exists>e1 e2 f'. e1 \<noteq> e2 \<and> f = finsert e1 (finsert e2 f')"
  apply (induct f)
   apply simp
  apply (rule_tac x=x in exI)
  by (metis finsertCI leD not_le_imp_less size_le_1)

end


section \<open> Resource Manager \<close>

theory ResourceManager
  imports "Z_Machines.Z_Machine"
begin

consts RES :: "integer set"

schema ResourceManager =
  res  :: "integer set"
  free :: "integer set"
  where "free \<subseteq> res" "res \<subseteq> RES"

record_default ResourceManager

zoperation Allocate =
  over ResourceManager
  params r \<in> RES
  update "[free \<leadsto> free - {r}]"
  where "r \<in> free"

zoperation Allocate\<^sub>1 =
  over ResourceManager
  params r \<in> RES
  update "[free \<leadsto> free - {r}]"
  where "r \<in> free \<and> r = Min free"

zoperation Deallocate =
  over ResourceManager
  params r \<in> RES
  pre "r \<notin> free"
  update "[free \<leadsto> free \<union> {r}]"

lemma Allocate\<^sub>1_refines_Allocate: "Allocate r \<sqsubseteq> Allocate\<^sub>1 r"
  unfolding Allocate_def Allocate\<^sub>1_def by refine

zmachine ResourceManagerProc =
  init "[res \<leadsto> RES, free \<leadsto> RES]"
  operations "Allocate\<^sub>1" "Deallocate"

def_consts RES = "set (map integer_of_int [0..5])"

animate ResourceManagerProc

end