(* Author: Tobias Nipkow (based on Hauke Brinkop's tree proofs) *)

subsection \<open>Okasaki's Pairing Heap\<close>

theory Pairing_Heap_List1_Analysis
imports
  Pairing_Heap.Pairing_Heap_List1
  Amortized_Framework
  Priority_Queue_ops_merge
  Lemmas_log
begin

text
\<open>Amortized analysis of pairing heaps as defined by Okasaki \cite{Okasaki}.\<close>

fun hps where
"hps (Hp _ hs) = hs"

lemma merge_Empty[simp]: "merge heap.Empty h = h"
by(cases h) auto

lemma merge2: "merge (Hp x lx) h = (case h of heap.Empty \<Rightarrow> Hp x lx | (Hp y ly) \<Rightarrow>
    (if x < y then Hp x (Hp y ly # lx) else Hp y (Hp x lx # ly)))"
by(auto split: heap.split)

lemma pass1_Nil_iff: "pass\<^sub>1 hs = [] \<longleftrightarrow> hs = []"
by(cases hs rule: pass\<^sub>1.cases) auto

subsubsection \<open>Invariant\<close>

fun no_Empty :: "'a :: linorder heap \<Rightarrow> bool" where
"no_Empty heap.Empty = False" |
"no_Empty (Hp x hs) = (\<forall>h \<in> set hs. no_Empty h)"

abbreviation no_Emptys :: "'a :: linorder heap list \<Rightarrow> bool" where
"no_Emptys hs \<equiv> \<forall>h \<in> set hs. no_Empty h"

fun is_root :: "'a :: linorder heap \<Rightarrow> bool" where
"is_root heap.Empty = True" |
"is_root (Hp x hs) = no_Emptys hs"

lemma is_root_if_no_Empty: "no_Empty h \<Longrightarrow> is_root h"
by(cases h) auto

lemma no_Emptys_hps: "no_Empty h \<Longrightarrow> no_Emptys(hps h)"
by(induction h) auto

lemma no_Empty_merge: "\<lbrakk> no_Empty h1; no_Empty h2\<rbrakk> \<Longrightarrow> no_Empty (merge h1 h2)"
by (cases "(h1,h2)" rule: merge.cases) auto

lemma is_root_merge: "\<lbrakk> is_root h1; is_root h2\<rbrakk> \<Longrightarrow> is_root (merge h1 h2)"
by (cases "(h1,h2)" rule: merge.cases) auto

lemma no_Emptys_pass1:
  "no_Emptys hs \<Longrightarrow> no_Emptys (pass\<^sub>1 hs)"
by(induction hs rule: pass\<^sub>1.induct)(auto simp: no_Empty_merge)

lemma is_root_pass2: "no_Emptys hs \<Longrightarrow> is_root(pass\<^sub>2 hs)"
proof(induction hs)
  case (Cons _ hs)
  show ?case
  proof cases
    assume "hs = []" thus ?thesis using Cons by (auto simp: is_root_if_no_Empty)
  next
    assume "hs \<noteq> []" thus ?thesis using Cons by(auto simp: is_root_merge is_root_if_no_Empty)
  qed
qed simp

subsubsection \<open>Complexity\<close>

fun size_hp :: "'a heap \<Rightarrow> nat" where
"size_hp heap.Empty = 0" |
"size_hp (Hp x hs) = sum_list(map size_hp hs) + 1"

abbreviation size_hps where
"size_hps hs \<equiv> sum_list(map size_hp hs)"

fun \<Phi>_hps :: "'a heap list \<Rightarrow> real" where
"\<Phi>_hps [] = 0" |
"\<Phi>_hps (heap.Empty # hs) = \<Phi>_hps hs" |
"\<Phi>_hps (Hp x hsl # hsr) =
 \<Phi>_hps hsl + \<Phi>_hps hsr + log 2 (size_hps hsl + size_hps hsr + 1)"

fun \<Phi> :: "'a heap \<Rightarrow> real" where
"\<Phi> heap.Empty = 0" |
"\<Phi> (Hp _ hs) = \<Phi>_hps hs + log 2 (size_hps(hs)+1)"

lemma \<Phi>_hps_ge0: "\<Phi>_hps hs \<ge> 0"
by (induction hs rule: \<Phi>_hps.induct) auto

lemma no_Empty_ge0: "no_Empty h \<Longrightarrow> size_hp h > 0"
by(cases h) auto

declare algebra_simps[simp]

lemma \<Phi>_hps1: "\<Phi>_hps [h] = \<Phi> h"
by(cases h) auto

lemma size_hp_merge: "size_hp(merge h1 h2) = size_hp h1 + size_hp h2"
by (induction h1 h2 rule: merge.induct) simp_all

lemma pass\<^sub>1_size[simp]: "size_hps (pass\<^sub>1 hs) = size_hps hs"
by (induct hs rule: pass\<^sub>1.induct) (simp_all add: size_hp_merge)

lemma \<Delta>\<Phi>_insert:
  "\<Phi> (Pairing_Heap_List1.insert x h) - \<Phi> h \<le> log 2 (size_hp h + 1)"
by(cases h)(auto simp: size_hp_merge)

lemma \<Delta>\<Phi>_merge:
  "\<Phi> (merge h1 h2) - \<Phi> h1 - \<Phi> h2
  \<le> log 2 (size_hp h1 + size_hp h2 + 1) + 1"
proof(induction h1 h2 rule: merge.induct)
  case (3 x lx y ly)
  thus ?case
    using ld_le_2ld[of "size_hps lx" "size_hps ly"]
      log_le_cancel_iff[of 2 "size_hps lx + size_hps ly + 2" "size_hps lx + size_hps ly + 3"]
    by (auto simp del: log_le_cancel_iff)
qed auto

fun sum_ub :: "'a heap list \<Rightarrow> real" where
  "sum_ub [] = 0"
| "sum_ub [_] = 0"
| "sum_ub [h1, h2] = 2*log 2 (size_hp h1 + size_hp h2)"
| "sum_ub (h1 # h2 # hs) = 2*log 2 (size_hp h1 + size_hp h2 + size_hps hs)
    - 2*log 2 (size_hps hs) - 2 + sum_ub hs"

lemma \<Delta>\<Phi>_pass1_sum_ub: "no_Emptys hs \<Longrightarrow>
  \<Phi>_hps (pass\<^sub>1 hs) - \<Phi>_hps hs  \<le> sum_ub hs" (is "_ \<Longrightarrow> ?P hs")
proof (induction hs rule: sum_ub.induct)
  case (3 h1 h2)
  then obtain x hsx y hsy where [simp]: "h1 = Hp x hsx" "h2 = Hp y hsy"
    by simp (meson no_Empty.elims(2))
  have 0: "\<And>x y::real. 0 \<le> x \<Longrightarrow> x \<le> y \<Longrightarrow> x \<le> 2*y" by linarith
  show ?case using 3 by (auto simp add: add_increasing 0)
next
  case (4 h1 h2 h3 hs)
  hence IH: "?P(h3#hs)" by auto
  from "4.prems" obtain x hsx y hsy where [simp]: "h1 = Hp x hsx" "h2 = Hp y hsy"
    by simp (meson no_Empty.elims(2))
  from "4.prems" have s3: "size_hp h3 > 0"
    apply auto using size_hp.elims by force
  let ?ry = "h3 # hs"
  let ?rx = "Hp y hsy # ?ry"
  let ?h = "Hp x hsx # ?rx"
  have "\<Phi>_hps(pass\<^sub>1 ?h) - \<Phi>_hps ?h
    \<le> log 2 (1 + size_hps hsx + size_hps hsy) - log 2 (1 + size_hps hsy + size_hps ?ry) + sum_ub ?ry"
    using IH by simp
  also have "log 2 (1 + size_hps hsx + size_hps hsy) - log 2 (1 + size_hps hsy + size_hps ?ry)
    \<le> 2*log 2 (size_hps ?h) - 2*log 2 (size_hps ?ry) - 2"
  proof -
    have "log 2 (1 + size_hps hsx + size_hps hsy) + log 2 (size_hps ?ry) - 2*log 2 (size_hps ?h)
      = log 2 ((1 + size_hps hsx + size_hps hsy)/(size_hps ?h) ) + log 2 (size_hps ?ry / size_hps ?h)"
      using s3 by (simp add: log_divide)
    also have "\<dots> \<le> -2"
    proof -
      have "2 + \<dots>
        \<le> 2*log 2 ((1 + size_hps hsx + size_hps hsy) / size_hps ?h +  size_hps ?ry / size_hps ?h)"
        using ld_sum_inequality [of "(1 + size_hps hsx + size_hps hsy) / size_hps ?h" "(size_hps ?ry / size_hps ?h)"] using s3 by simp
      also have "\<dots> \<le> 0" by (simp add: field_simps log_divide add_pos_nonneg)
      finally show ?thesis by linarith
    qed
    finally have "log 2 (1 + size_hps hsx + size_hps hsy) + log 2 (size_hps ?ry) + 2
      \<le>  2*log 2 (size_hps ?h)" by simp
    moreover have "log 2 (size_hps ?ry) \<le> log 2 (size_hps ?rx)" using s3 by simp
    ultimately have "log 2 (1 + size_hps hsx + size_hps hsy) - \<dots>
      \<le>  2*log 2 (size_hps ?h) - 2*log 2 (size_hps ?ry) - 2" by linarith
    thus ?thesis by simp
  qed
  finally show ?case by (simp)
qed simp_all

lemma \<Delta>\<Phi>_pass1: assumes "hs \<noteq> []" "no_Emptys hs"
  shows "\<Phi>_hps (pass\<^sub>1 hs) - \<Phi>_hps hs \<le> 2 * log 2 (size_hps hs) - length hs + 2"
proof -
  have "sum_ub hs \<le> 2 * log 2 (size_hps hs) - length hs + 2"
    using assms by (induct hs rule: sum_ub.induct) (auto dest: no_Empty_ge0)
  thus ?thesis using \<Delta>\<Phi>_pass1_sum_ub[OF assms(2)] by linarith
qed

lemma \<Delta>\<Phi>_pass2: "hs \<noteq> [] \<Longrightarrow> no_Emptys hs \<Longrightarrow>
  \<Phi> (pass\<^sub>2 hs) - \<Phi>_hps hs \<le> log 2 (size_hps hs)"
proof (induction hs)
  case (Cons h hs)
  thus ?case
  proof cases
    assume "hs = []"
    thus ?thesis using Cons by (auto simp add: \<Phi>_hps1 dest: no_Empty_ge0)
  next
    assume *: "hs \<noteq> []"
    obtain x hs2 where [simp]: "h = Hp x hs2"
      using Cons.prems(2)by simp (meson no_Empty.elims(2))
    show ?thesis
    proof (cases "pass\<^sub>2 hs")
      case Empty thus ?thesis using \<Phi>_hps_ge0[of hs]
        by(simp add: add_increasing xt1(3)[OF mult_2, OF add_increasing])
    next
      case (Hp y hs3)
      with Cons * size_hps_pass2[of hs] show ?thesis by(auto simp: add_mono)
    qed
  qed
qed simp

lemma \<Delta>\<Phi>_del_min: assumes "hps h \<noteq> []" "no_Empty h"
  shows "\<Phi> (del_min h) - \<Phi> h
  \<le> 3 * log 2 (size_hps(hps h)) - length(hps h) + 2"
proof -
  obtain x hs where [simp]: "h = Hp x hs" using assms(2) by (cases h) auto
  let ?\<Delta>\<Phi>\<^sub>1 = "\<Phi>_hps(hps h) - \<Phi> h"
  let ?\<Delta>\<Phi>\<^sub>2 = "\<Phi>(pass\<^sub>2(pass\<^sub>1 (hps h))) - \<Phi>_hps (hps h)"
  let ?\<Delta>\<Phi> = "\<Phi> (del_min h) - \<Phi> h"
  have "\<Phi>(pass\<^sub>2(pass\<^sub>1(hps h))) - \<Phi>_hps (pass\<^sub>1(hps h)) \<le> log 2 (size_hps(hps h))"
    using \<Delta>\<Phi>_pass2[of "pass\<^sub>1(hps h)"] using assms
    by (auto simp: pass1_Nil_iff no_Emptys_pass1 dest: no_Emptys_hps)
  moreover have "\<Phi>_hps (pass\<^sub>1 (hps h)) - \<Phi>_hps (hps h) \<le>  2*\<dots> - length (hps h) + 2"
    using \<Delta>\<Phi>_pass1[OF assms(1) no_Emptys_hps[OF assms(2)]] by blast
  moreover have "?\<Delta>\<Phi>\<^sub>1 \<le> 0" by simp
  moreover have "?\<Delta>\<Phi> = ?\<Delta>\<Phi>\<^sub>1 + ?\<Delta>\<Phi>\<^sub>2" by simp
  ultimately show ?thesis by linarith
qed

fun exec :: "'a :: linorder op \<Rightarrow> 'a heap list \<Rightarrow> 'a heap" where
"exec Empty [] = heap.Empty" |
"exec Del_min [h] = del_min h" |
"exec (Insert x) [h] = Pairing_Heap_List1.insert x h" |
"exec Merge [h1,h2] = merge h1 h2"

fun t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 :: "'a heap list \<Rightarrow> nat" where
  "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 [] = 1"
| "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 [_] = 1"
| "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 (_ # _ # hs) = 1 + t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 hs"

fun t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 :: "'a heap list \<Rightarrow> nat" where
 "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 [] = 1"
| "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (_ # hs) = 1 + t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 hs"

fun cost :: "'a :: linorder op \<Rightarrow> 'a heap list \<Rightarrow> nat" where
"cost Empty _ = 1" |
"cost Del_min [heap.Empty] = 1" |
"cost Del_min [Hp x hs] = t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (pass\<^sub>1 hs) + t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 hs" |
"cost (Insert a) _ = 1" |
"cost Merge _ = 1"

fun U :: "'a :: linorder op \<Rightarrow> 'a heap list \<Rightarrow> real" where
"U Empty _ = 1" |
"U (Insert a) [h] = log 2 (size_hp h + 1) + 1" |
"U Del_min [h] = 3*log 2 (size_hp h + 1) + 4" |
"U Merge [h1,h2] = log 2 (size_hp h1 + size_hp h2 + 1) + 2"

interpretation pairing: Amortized
where arity = arity and exec = exec and cost = cost and inv = "is_root"
and \<Phi> = \<Phi> and U = U
proof (standard, goal_cases)
  case (1 ss f) show ?case
  proof (cases f)
    case Empty with 1 show ?thesis by simp
  next
    case Insert thus ?thesis using 1 by(auto simp: is_root_merge)
  next
    case Merge
    thus ?thesis using 1 by(auto simp: is_root_merge numeral_eq_Suc)
  next
    case [simp]: Del_min
    then obtain h where [simp]: "ss = [h]" using 1 by auto
    show ?thesis
    proof (cases h)
      case [simp]: (Hp _ hs)
      show ?thesis
      proof cases
        assume "hs = []" thus ?thesis by simp
      next
        assume "hs \<noteq> []" thus ?thesis
          using 1(1) no_Emptys_pass1 by (auto intro: is_root_pass2)
      qed
    qed simp
  qed
next
  case (2 s) show ?case by (cases s) (auto simp: \<Phi>_hps_ge0)
next
  case (3 ss f) show ?case
  proof (cases f)
    case Empty with 3 show ?thesis by(auto)
  next
    case Insert thus ?thesis using \<Delta>\<Phi>_insert 3 by auto
  next
    case [simp]: Del_min
    then obtain h where [simp]: "ss = [h]" using 3 by auto
    show ?thesis
    proof (cases h)
      case [simp]: (Hp x hs)
      have "t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>2 (pass\<^sub>1 hs) + t\<^sub>p\<^sub>a\<^sub>s\<^sub>s\<^sub>1 hs \<le> 2 + length hs"
        by (induct hs rule: pass\<^sub>1.induct) simp_all
      hence  "cost f ss \<le> \<dots>" by simp
      moreover have  "\<Phi> (del_min h) - \<Phi> h \<le> 3*log 2 (size_hp h + 1) - length hs + 2"
      proof (cases "hs = []")
        case False
        hence "\<Phi> (del_min h) - \<Phi> h \<le> 3*log 2 (size_hps hs) - length hs + 2"
          using  \<Delta>\<Phi>_del_min[of h] 3(1) by simp
        also have "\<dots> \<le> 3*log 2 (size_hp h + 1) - length hs + 2"
          using False 3(1) size_hps_pass2 by fastforce
        finally show ?thesis .
      qed simp
      ultimately show ?thesis by simp
    qed simp
  next
    case [simp]: Merge
    then obtain h1 h2 where [simp]: "ss = [h1, h2]"
      using 3 by(auto simp: numeral_eq_Suc)
    show ?thesis
    proof (cases "h1 = heap.Empty \<or> h2 = heap.Empty")
      case True thus ?thesis by auto
    next
      case False
      then obtain x1 x2 hs1 hs2 where [simp]: "h1 = Hp x1 hs1" "h2 = Hp x2 hs2"
        by (meson hps.cases)
      have "\<Phi> (merge h1 h2) - \<Phi> h1 - \<Phi> h2 \<le> log 2 (size_hp h1 + size_hp h2 + 1) + 1"
        using \<Delta>\<Phi>_merge[of h1 h2] by simp
      thus ?thesis by(simp)
    qed
  qed
qed

end


section \<open>Dice Roll\label{sec:dice_roll}\<close>

theory Dice_Roll
  imports Tracking_SPMF
begin

text \<open>The following is a dice roll algorithm for an arbitrary number of sides @{term "n"}.
Besides correctness we also show that the expected number of coin flips is at most
@{term "log 2 n + 2"}. It is a specialization of the algorithm presented by Hao and
Hoshi~\cite{hao1997}. \footnote{An interesting alternative algorithm, which we did not formalized
here, has been introduced by Lambruso~\cite{lambruso2013}.}\<close>

lemma floor_le_ceil_minus_one:
  fixes x y :: real
  shows "x < y \<Longrightarrow> \<lfloor>x\<rfloor> \<le> \<lceil>y\<rceil>-1"
  by linarith

lemma combine_spmf_set_coin_spmf:
  fixes f :: "nat \<Rightarrow> 'a spmf"
  fixes k :: nat
  shows "pmf_of_set {..<2^k} \<bind> (\<lambda>l. coin_spmf \<bind>(\<lambda>b. f (2*l+ of_bool b))) =
    pmf_of_set {..<2^(k+1)} \<bind> f" (is "?L = ?R")
proof -
  let ?f = "(\<lambda>(l::nat,b). 2*l+ of_bool b)"
  let ?coin = "pmf_of_set (UNIV :: bool set)"

  have [simp]:"{..<(2::nat) ^ k} \<noteq> {}"
    by (simp add: lessThan_empty_iff)

  have bij:"bij_betw ?f ({..<2^k} \<times> UNIV) {..<2^(k+1)}"
    by (intro bij_betwI[where g="(\<lambda>x. (x div 2, odd x))"]) auto

  have "pmf (pair_pmf (pmf_of_set {..<2^k}) ?coin) x =
    pmf (pmf_of_set ({..<2^k}\<times>UNIV)) x" for x :: "nat\<times> bool"
    by (cases x) (simp add:pmf_pair indicator_def)
  hence 0:"pair_pmf (pmf_of_set {..<(2::nat)^k}) ?coin = pmf_of_set ({..<2^k}\<times>UNIV)"
    by (intro pmf_eqI) simp

  have "map_pmf ?f (pmf_of_set ({..<2^k}\<times>UNIV)) = pmf_of_set (?f ` ({..<2^k}\<times>UNIV))"
    using bij_betw_imp_inj_on[OF bij] by (intro map_pmf_of_set_inj) auto
  also have "... = pmf_of_set {..<2^(k+1)}"
    by (intro arg_cong[where f="pmf_of_set"] bij_betw_imp_surj_on[OF bij])
  finally have 1:"map_pmf ?f (pmf_of_set ({..<2^k}\<times>UNIV)) = pmf_of_set {..<2^(k+1)}"
    by simp

  have "?L = pmf_of_set {..<2^k} \<bind> (\<lambda>l. ?coin \<bind> (\<lambda>b. f (2*l + of_bool b)))"
    unfolding spmf_of_set_def bind_spmf_def spmf_of_pmf_def by (simp add:bind_map_pmf)
  also have "... = pair_pmf (pmf_of_set {..<2^k}) ?coin  \<bind> (\<lambda>(l,b). f (2*l + of_bool b))"
    unfolding pair_pmf_def by (simp add:bind_assoc_pmf bind_return_pmf)
  also have "... = map_pmf (\<lambda>(l,b). 2 * l + of_bool b) (pmf_of_set ({..<2^k}\<times>UNIV)) \<bind> f"
    unfolding 0 bind_map_pmf by (simp add:comp_def case_prod_beta')
  also have "... = ?R"
    unfolding 1 by simp
  finally show ?thesis by simp
qed

lemma count_ints_in_range:
  "real (card {x. of_int x \<in> {u..v}} ) \<ge> v-u-1" (is "?L \<ge> ?R")
proof (cases "u \<le> v")
  case True
  have 0:"of_int x \<in> {u..v} \<longleftrightarrow> x \<in> {\<lceil>u\<rceil>..\<lfloor>v\<rfloor>}" for x by simp linarith

  have "v - u - 1 \<le> \<lfloor>v\<rfloor> - \<lceil>u\<rceil> + 1" using True by linarith
  also have "... = real (nat (\<lfloor>v\<rfloor> - \<lceil>u\<rceil> + 1))" using True by (intro of_nat_nat[symmetric]) linarith
  also have "... = card {\<lceil>u\<rceil>..\<lfloor>v\<rfloor>}" by simp
  also have "... = ?L"
    unfolding 0 by (intro arg_cong[where f="real"] arg_cong[where f="card"]) auto
  finally show ?thesis by simp
next
  case False
  hence "v-u-1 \<le> 0" by simp
  thus ?thesis by simp
qed

partial_function (random_alg) dice_roll_step_ra :: "real \<Rightarrow> real \<Rightarrow> int random_alg"
  where "dice_roll_step_ra l h = (
    if \<lfloor>l\<rfloor> = \<lceil>l+h\<rceil>-1 then
      return_ra \<lfloor>l\<rfloor>
    else
      do { b \<leftarrow> coin_ra; dice_roll_step_ra (l + (h/2) * of_bool b) (h/2) }
    )"

definition "dice_roll_ra n = map_ra nat (dice_roll_step_ra 0 (of_nat n))"

partial_function (spmf) drs_tspmf :: "real \<Rightarrow> real \<Rightarrow> int tspmf"
  where "drs_tspmf l h = (
    if \<lfloor>l\<rfloor> = \<lceil>l+h\<rceil>-1 then
      return_tspmf \<lfloor>l\<rfloor>
    else
      do { b \<leftarrow> coin_tspmf; drs_tspmf (l + (h/2) * of_bool b) (h/2) }
    )"

definition "dice_roll_tspmf n = drs_tspmf 0 (of_nat n) \<bind> (\<lambda>x. return_tspmf (nat x))"

lemma drs_tspmf: "drs_tspmf l u = tspmf_of_ra (dice_roll_step_ra l u)"
proof -
  include lifting_syntax
  have "((=) ===> (=) ===> rel_tspmf_of_ra) drs_tspmf dice_roll_step_ra"
    unfolding drs_tspmf_def dice_roll_step_ra_def
    apply (rule rel_funD[OF curry_transfer])
    apply (rule fixp_rel_tspmf_of_ra_parametric[OF drs_tspmf.mono dice_roll_step_ra.mono])
    by transfer_prover
  thus ?thesis
    unfolding rel_fun_def rel_tspmf_of_ra_def by auto
qed

lemma dice_roll_ra_tspmf: "tspmf_of_ra (dice_roll_ra n) = dice_roll_tspmf n"
  unfolding dice_roll_ra_def dice_roll_tspmf_def map_ra_def tspmf_of_ra_bind tspmf_of_ra_return
    drs_tspmf by simp

lemma dice_roll_step_tspmf_lb:
  assumes "h > 0"
  shows "coin_tspmf \<bind> (\<lambda>b. drs_tspmf (l + (h/2) * of_bool b) (h/2)) \<le>\<^sub>R drs_tspmf l h"
proof (cases "\<lfloor>l\<rfloor> = \<lceil>l+h\<rceil>-1")
  case True
  hence 2:"drs_tspmf l h = return_tspmf \<lfloor>l\<rfloor>"
    by (subst drs_tspmf.simps) simp

  have 0: "\<lfloor>l + h / 2 * of_bool b\<rfloor> = \<lfloor>l\<rfloor>" for b
  proof -
    have "\<lfloor>l + h / 2 * of_bool b\<rfloor> \<le> \<lfloor>l + h / 2\<rfloor>"
      using assms by (intro floor_mono add_mono) auto
    also have "... \<le> \<lceil>l + h\<rceil> - 1"
      using assms by (intro floor_le_ceil_minus_one add_strict_left_mono) auto
    also have "... = \<lfloor>l\<rfloor>" using True by simp
    finally have "\<lfloor>l + h / 2 * of_bool b\<rfloor> \<le> \<lfloor>l\<rfloor>" by simp
    moreover have "\<lfloor>l\<rfloor> \<le> \<lfloor>l + h / 2 * of_bool b\<rfloor>"
      using assms by (intro floor_mono) auto
    ultimately show ?thesis by simp
  qed

  have 1: "\<lceil>l + h / 2 * of_bool b + h / 2\<rceil> - 1 = \<lfloor>l\<rfloor>" for b
  proof -
    have "\<lceil>l + h / 2 * of_bool b + h / 2\<rceil> - 1 \<le> \<lceil>l + h\<rceil>-1"
      using assms by (intro diff_mono ceiling_mono) auto
    also have "... = \<lfloor>l\<rfloor>" using True by simp
    finally have "\<lceil>l + h / 2 * of_bool b + h / 2\<rceil> - 1 \<le> \<lfloor>l\<rfloor>" by simp
    moreover have "\<lfloor>l\<rfloor> \<le> \<lceil>l + h / 2 * of_bool b + h / 2\<rceil> - 1"
      using assms by (intro floor_le_ceil_minus_one) auto
    ultimately show ?thesis by simp
  qed

  have 3:"drs_tspmf (l + (h/2) * of_bool b) (h/2) = return_tspmf \<lfloor>l\<rfloor>" for b
    using 0 1 by (subst drs_tspmf.simps) simp

  show ?thesis
    unfolding 2 3 bind_tspmf_def coin_tspmf_def pair_spmf_alt_def
    by (simp add:bind_spmf_const ord_tspmf_map_spmf)
next
  case False
  thus ?thesis
    by (subst drs_tspmf.simps) (auto intro:ord_tspmf_refl)
qed

abbreviation "coins k \<equiv> pmf_of_set {..<(2::nat)^k}"

lemma dice_roll_step_tspmf_expand:
  assumes "h > 0"
  shows "coins k \<bind> (\<lambda>l. use_coins k (drs_tspmf (real l*h) h)) \<le>\<^sub>R drs_tspmf 0 (h*2^k)"
  using assms
proof (induction k arbitrary:h)
  case 0
  have "{..<Suc 0} = {0}" by auto
  then show ?case
    by (auto intro:ord_tspmf_use_coins simp:pmf_of_set_singleton bind_return_pmf)
next
  case (Suc k)
  have "(coins (k+1) \<bind> (\<lambda>l. use_coins (k+1) (drs_tspmf (real l*h) h))) =
    coins k \<bind> (\<lambda>l. coin_spmf \<bind> (\<lambda>b. use_coins (k+1) (drs_tspmf (real (2*l+ of_bool b) * h) h)))"
    by (intro combine_spmf_set_coin_spmf[symmetric])
  also have "... = coins k \<bind> (\<lambda>l. use_coins (k+1) (coin_spmf \<bind>
    (\<lambda>b. drs_tspmf (real l* (2*h) + h * of_bool b) h)))"
    unfolding use_coins_def map_spmf_conv_bind_spmf by (simp add:algebra_simps)
  also have "... = coins k \<bind> (\<lambda>l. use_coins k (coin_tspmf \<bind>
    (\<lambda>b. drs_tspmf (real l* (2*h) + h * of_bool b) h)))"
    unfolding coin_tspmf_split use_coins_add by simp
  also have "... = coins k \<bind> (\<lambda>l. use_coins k (coin_tspmf \<bind>
    (\<lambda>b. drs_tspmf (real l* (2*h) + ((2*h)/2) * of_bool b) ((2*h)/2))))"
    using Suc(2) by simp
  also have "... \<le>\<^sub>R coins k \<bind> (\<lambda>l. use_coins k (drs_tspmf (real l * (2 * h)) (2*h)))"
    using Suc(2) by (intro ord_tspmf_bind_pmf ord_tspmf_use_coins_2 dice_roll_step_tspmf_lb) simp
  also have "... \<le>\<^sub>R drs_tspmf 0 ((2*h)*2^k)"
    using Suc(2) by (intro Suc(1)) auto
  also have "... = drs_tspmf 0 (h*2^(k+1))"
    unfolding power_add by (simp add:algebra_simps)
  finally show ?case
    by simp
qed

lemma dice_roll_step_tspmf_approx:
  fixes k :: nat
  assumes "h > (0::real)"
  defines "f \<equiv> (\<lambda>l. if \<lfloor>l*h\<rfloor>=\<lceil>(l+1)*h\<rceil>-1 then Some (\<lfloor>l*h\<rfloor>,k) else None)"
  shows "map_pmf f (coins k) \<le>\<^sub>R drs_tspmf 0 (h*2^k)" (is "?L \<le>\<^sub>R ?R")
proof -
  have "?L = coins k \<bind>
    (\<lambda>l. use_coins k (if \<lfloor>real l*h\<rfloor>=\<lceil>(l+1)*h\<rceil>-1 then return_tspmf \<lfloor>l*h\<rfloor> else return_pmf None))"
    unfolding f_def return_tspmf_def use_coins_def map_pmf_def
    by (simp add:if_distribR if_distrib bind_return_pmf algebra_simps cong:if_cong)
  also have "... \<le>\<^sub>R coins k \<bind> (\<lambda>l. use_coins k (drs_tspmf (real l*h) h))"
    by (subst drs_tspmf.simps, intro ord_tspmf_bind_pmf ord_tspmf_use_coins_2)
      (simp add:ord_tspmf_min ord_tspmf_refl algebra_simps)
  also have "... \<le>\<^sub>R drs_tspmf 0 (h*2^k)"
    by (intro dice_roll_step_tspmf_expand assms)
  finally show ?thesis by simp
qed

lemma dice_roll_step_spmf_approx:
  fixes k :: nat
  assumes "h > (0::real)"
  defines "f \<equiv> (\<lambda>l. if \<lfloor>l*h\<rfloor>=\<lceil>(l+1)*h\<rceil>-1 then Some (\<lfloor>l*h\<rfloor>) else None)"
  shows "ord_spmf (=) (map_pmf f (coins k)) (result (drs_tspmf 0 (h*2^k)))"
    (is "ord_spmf _ ?L ?R")
proof -
  have 0: "?L = result (map_pmf (\<lambda>l. if \<lfloor>l*h\<rfloor>=\<lceil>(l+1)*h\<rceil>-1 then Some (\<lfloor>l*h\<rfloor>,k) else None) (coins k))"
    unfolding result_def map_pmf_comp f_def by (intro map_pmf_cong refl) auto

  show ?thesis
    unfolding 0 using assms result_mono[OF dice_roll_step_tspmf_approx] by simp
qed

lemma spmf_dice_roll_step_lb:
  assumes "j < n"
  shows "spmf (result (drs_tspmf 0 (of_nat n))) (of_nat j) \<ge> 1/n" (is "?L \<ge> ?R")
proof (rule ccontr)
  assume "\<not>(spmf (result (drs_tspmf 0 (of_nat n))) (of_nat j) \<ge> 1/n)"
  hence a:"?L < 1/n" by simp
  define k :: nat where "k = nat \<lfloor>2-log 2 (1/n-?L)\<rfloor>"
  define h where "h = real n/2^k"
  define f where "f l = (if \<lfloor>l*h\<rfloor>=\<lceil>(l+1)*h\<rceil>-1 then Some \<lfloor>l*h\<rfloor> else None)" for l :: nat

  have h_gt_0: "h > 0" using assms unfolding h_def by auto
  have n_gt_0: "real n > 0" using assms by simp

  have 0: "x < 2^k" if "real x \<le> (real j+1)*2^k/n-1" for x
  proof -
    have "real x \<le> (real j+1)*2^k/n-1" using that by simp
    also have "... \<le> real n * 2^k/n - 1"
      using assms by (intro diff_mono divide_right_mono mult_right_mono) auto
    also have "... \<le> 2^k-1" by simp
    finally have "real x \<le> 2^k-1" by simp
    thus ?thesis using nat_less_real_le by auto
  qed
  have 2: "int ` {x. P (real x)} = {x. P (real_of_int x)}" if "\<And>x. P x \<Longrightarrow> x \<ge> 0" for P
  proof -
    have "bij_betw int {x. P (real x)} {x. P (real_of_int x)}"
      using that by (intro bij_betwI[where g="nat"]) force+
    thus ?thesis
      using bij_betw_imp_surj_on by auto
  qed
  have 1: "real j*2^k/n \<ge> 0" by auto

  have 3:"\<lfloor>real l*h\<rfloor>\<le>\<lceil>real (l+1)*h\<rceil>-1" for l
    using h_gt_0 by (intro floor_le_ceil_minus_one) force

  have "2 = (1/n - ?L)*2 powr (1-log 2 (1/n-?L))"
    using a n_gt_0 unfolding powr_diff by (subst powr_log_cancel) (auto simp:divide_simps)
  also have "... < (1/n - ?L)*2 powr \<lfloor>2-log 2 (1/n-?L)\<rfloor>"
    using a by (intro mult_strict_left_mono powr_less_mono) linarith+
  also have "... \<le> (1/n - ?L)*2 powr real k"
    using a unfolding k_def by (intro mult_left_mono powr_mono) auto
  also have "... = (1/n - ?L)*2^k" by (subst powr_realpow) auto
  finally have "2 < (1/n - ?L)*2^k" by simp
  hence "?L < 1/n-2/2^k" by (simp add:field_simps)
  also have "... = (((real j+1)*2^k/n-1)-(real j*2^k/n)-1) / 2^k"
    using n_gt_0 by (simp add:field_simps)
  also have "... \<le> real (card {x. of_int x \<in> {real j*2^k/n..(real j+1)*2^k/n-1}})/2^k"
    by (intro divide_right_mono count_ints_in_range) auto
  also have "... = real (card (int ` {x. real x \<in> {real j*2^k/n..(real j+1)*2^k/n-1}}))/2^k"
    using order_trans[OF 1] by (subst 2) auto
  also have "... = real (card {x. real x \<in> {real j*2^k/n..(real j+1)*2^k/n-1}})/2^k"
    by (subst card_image) auto
  also have "... = real (card {x. x<2^k \<and> real x \<in> {real j*2^k/n..(real j+1)*2^k/n-1}})/2^k"
    using 0 by (intro arg_cong[where f="\<lambda>x. real (card x)/2^k"]) auto
  also have "... = real (card {l. l< 2^k \<and> real j \<le> real l * h \<and> (1 + real l)*h\<le>real j+1}) / 2^k"
    using assms unfolding h_def
    by (intro arg_cong[where f="\<lambda>x. real (card x)/2^k"] Collect_cong) (auto simp:field_simps)
  also have "... = measure (coins k) {l. real j \<le> real l*h \<and> real (l+1)*h \<le> real j + 1 }"
    by (subst measure_pmf_of_set) (simp_all add:lessThan_empty_iff Int_def)
  also have "... = measure (coins k) {l. int j \<le> \<lfloor>real l*h\<rfloor> \<and> \<lceil>real (l+1)*h\<rceil> - 1 \<le> int j }"
    by (intro arg_cong2[where f="measure"] refl Collect_cong) linarith
  also have "... = measure (coins k) {l. int j = \<lfloor>real l*h\<rfloor> \<and> int j = \<lceil>real (l+1)*h\<rceil> - 1}"
    using 3 order.trans order_antisym
    by (intro arg_cong2[where f="measure"] refl Collect_cong iffI, blast, simp)
  also have "... = spmf (map_pmf f (coins k)) j"
    unfolding pmf_map f_def vimage_def
    by (intro arg_cong2[where f="measure"] refl Collect_cong) auto
  also have "... \<le> spmf (result (drs_tspmf 0 (h*2^k))) j"
    unfolding f_def by (intro ord_spmf_eq_leD dice_roll_step_spmf_approx h_gt_0)
  also have "... = ?L"
    unfolding h_def by simp
  finally have "?L < ?L" by simp
  thus "False" by simp
qed

lemma dice_roll_correct_aux:
  assumes "n > 0"
  shows "result (drs_tspmf 0 (of_nat n)) = spmf_of_set {0..<n}"
proof -
  have "weight_spmf (spmf_of_set {0..<int n}) \<ge> weight_spmf (result (drs_tspmf 0 (of_nat n)))"
    using assms unfolding weight_spmf_of_set
    by (simp add:lessThan_empty_iff weight_spmf_le_1)
  moreover have "spmf (spmf_of_set {0..<int n}) x \<le> spmf (result (drs_tspmf 0 (of_nat n))) x" for x
  proof (cases "x < n \<and> x \<ge> 0")
    case True
    hence "spmf (spmf_of_set {0..<int n}) x = 1/n"
      unfolding spmf_of_set by auto
    also have "... \<le> spmf (result (drs_tspmf 0 (of_nat n))) (of_nat (nat x))"
      using True by (intro spmf_dice_roll_step_lb) auto
    also have "... = spmf (result (drs_tspmf 0 (of_nat n))) x"
      using True by (subst of_nat_nat) auto
    finally show ?thesis by simp
  next
    case False
    hence "spmf (spmf_of_set {0..<int n}) x = 0"
      unfolding spmf_of_set by auto
    then show ?thesis by simp
  qed
  hence "ord_spmf (=) (spmf_of_set {0..<int n}) (result (drs_tspmf 0 (of_nat n)))"
    by (intro ord_pmf_increaseI refl) auto
  ultimately show ?thesis
    by (intro eq_iff_ord_spmf[symmetric]) auto
qed

theorem dice_roll_correct:
  assumes "n > 0"
  shows
    "result (dice_roll_tspmf n) = spmf_of_set {..<n}" (is "?L = ?R")
    "spmf_of_ra (dice_roll_ra n) = spmf_of_set {..<n}"
proof -
  have bij:"bij_betw nat {0..<int n} {..<n}"
    by (intro bij_betwI[where g="int"]) auto

  have "?L = map_spmf nat (spmf_of_set {0..<int n})"
    unfolding dice_roll_tspmf_def dice_roll_correct_aux[OF assms] result_bind result_return
      map_spmf_conv_bind_spmf by simp
  also have "... = spmf_of_set (nat ` {0..<int n})"
    by (intro map_spmf_of_set_inj_on inj_onI) auto
  also have "... = ?R"
    using bij_betw_imp_surj_on[OF bij] by (intro arg_cong[where f="spmf_of_set"]) auto
  finally show "?L = ?R" by simp
  thus "spmf_of_ra (dice_roll_ra n) = ?R"
    using spmf_of_tspmf dice_roll_ra_tspmf by metis
qed

lemma dice_roll_consumption_bound:
  assumes "n > 0"
  shows "measure (coin_usage_of_tspmf (dice_roll_tspmf n)) {x. x > enat k } \<le> real n/2^k"
    (is "?L \<le> ?R")
proof -
  define h where "h = real n/2^k"
  define f where "f l = (if \<lfloor>l*h\<rfloor>=\<lceil>(l+1)*h\<rceil>-1 then Some (\<lfloor>l*h\<rfloor>,k) else None)" for l :: nat

  have h_gt_0: " h > 0"
    using assms unfolding h_def
    by (intro divide_pos_pos) auto
  have 0:"real n = h * 2^k"
    unfolding h_def by simp

  have 1:"\<lfloor>real l*h\<rfloor><\<lfloor>(real l+1)*h\<rfloor>" if "\<lfloor>real l*h\<rfloor>\<noteq>\<lceil>(real l+1)*h\<rceil>-1" for l
  proof -
    have "\<lfloor>real l*h\<rfloor>\<le>\<lceil>(real l+1)*h\<rceil>-1"
      using h_gt_0 by (intro floor_le_ceil_minus_one) force
    hence "\<lfloor>real l*h\<rfloor><\<lceil>(real l+1)*h\<rceil>-1"
      using that by simp
    also have "... \<le> \<lfloor>(real l+1)*h\<rfloor>"
      by linarith
    finally show ?thesis by simp
  qed

  have "?L = measure (coin_usage_of_tspmf (drs_tspmf 0 n)) {x. x > enat k}"
    unfolding dice_roll_tspmf_def coin_usage_of_tspmf_bind_return by simp
  also have "... \<le> measure (coin_usage_of_tspmf (map_pmf f (coins k))) {x. x > enat k}"
    unfolding f_def 0
    by (intro coin_usage_of_tspmf_mono_rev dice_roll_step_tspmf_approx h_gt_0)
  also have "... = measure (coins k) {l. \<lfloor>real l*h\<rfloor>\<noteq>\<lceil>(real l+1)*h\<rceil>-1}"
    unfolding coin_usage_of_tspmf_def map_pmf_comp
    by (simp add:vimage_def f_def algebra_simps split:option.split)
  also have "... \<le> measure (coins k) {l. \<lfloor>real l*h\<rfloor><\<lfloor>(real l+1)*h\<rfloor>}"
    using 1 by (intro measure_pmf.finite_measure_mono subsetI) (simp_all)
  also have "... = (\<integral>l. indicator {l. \<lfloor>real l*h\<rfloor><\<lfloor>(real l+1)*h\<rfloor>} l \<partial>(coins k))"
    by simp
  also have "... = (\<Sum>j<2 ^ k. indicat_real {l. \<lfloor>real l*h\<rfloor> < \<lfloor>(real l+1)*h\<rfloor>} j * pmf (coins k) j)"
    by (intro integral_measure_pmf_real[where A="{..<2^k}"]) (simp_all add:lessThan_empty_iff)
  also have "... = (\<Sum>l<2 ^ k. of_bool (\<lfloor>real l*h\<rfloor> < \<lfloor>(real l+1)*h\<rfloor>)) / 2^k"
    by (simp add:lessThan_empty_iff indicator_def flip:sum_divide_distrib)
  also have "... \<le> (\<Sum>l<2 ^ k. of_int \<lfloor>real (Suc l)*h\<rfloor> - of_int \<lfloor>real l*h\<rfloor>) / 2^k"
    using h_gt_0 int_less_real_le
    by (intro divide_right_mono sum_mono) (auto intro:floor_mono simp:algebra_simps)
  also have "... = of_int \<lfloor>2 ^ k * h\<rfloor> / 2 ^ k"
    by (subst sum_lessThan_telescope) simp
  also have "... = real n / 2^k"
    unfolding h_def by simp
  finally show ?thesis
    by simp
qed

lemma dice_roll_expected_consumption_aux:
  assumes "n > (0::nat)"
  shows "expected_coin_usage_of_tspmf (dice_roll_tspmf n) \<le> log 2 n + 2" (is "?L \<le> ?R")
proof -
  define k0 where "k0 = nat \<lceil>log 2 n\<rceil>"
  define \<delta> where "\<delta> = log 2 n - \<lceil>log 2 n\<rceil>"

  have 0: "ennreal (measure (coin_usage_of_tspmf (dice_roll_tspmf n)) {x. x > enat k}) \<le>
    ennreal (min (real n/2^k) 1)" (is "?L1 \<le> ?R1") for k
    by (intro iffD2[OF ennreal_le_iff] min.boundedI dice_roll_consumption_bound[OF assms]) auto

  have 1[simp]: "(2::ennreal)^k < Orderings.top" for k::nat
    using ennreal_numeral_less_top power_less_top_ennreal by blast

  have "(\<Sum>k. ennreal ((1/2)^k)) = ennreal (\<Sum>k. ((1/2)^k))"
    by (intro suminf_ennreal2) auto
  also have "... = ennreal 2"
    by (subst suminf_geometric) simp_all
  finally have 2:"(\<Sum>k. ennreal ((1/2)^k)) = ennreal 2"
    by simp

  have "real n \<ge> 1"
    using assms by simp
  hence 3: "log 2 (real n) \<ge> 0"
    by simp

  have "real_of_int \<lceil>log 2 (real n)\<rceil> \<le> 1 + log 2 (real n)"
    by linarith
  hence 4: "\<delta>+1 \<in> {0..1}"
    unfolding \<delta>_def by (auto simp:algebra_simps)

  have twop_conv: "convex_on UNIV (\<lambda>x. 2 powr (x::real))"
    using convex_on_exp[where l="ln 2"] unfolding powr_def
    by (auto simp:algebra_simps)
  have 5:"2 powr x \<le> 1 + x" if "x \<in> {0..1}" for x :: real
    using that convex_onD[OF twop_conv, where x="0" and y="1" and t="x"]
    by (simp add:algebra_simps)

  have "?L = (\<Sum>k. ennreal (measure (coin_usage_of_tspmf (dice_roll_tspmf n)) {x. x > enat k}))"
    unfolding expected_coin_usage_of_tspmf by simp
  also have "... \<le> (\<Sum>k. ennreal (min (real n/2^k) 1))"
    by (intro suminf_le summableI 0)
  also have "... = (\<Sum>k. ennreal (min (real n/2^(k+k0)) 1))+(\<Sum>k < k0. ennreal(min (real n/2^k) 1))"
    by (intro suminf_offset summableI)
  also have "... \<le> (\<Sum>k. ennreal (real n/2^(k+k0))) + (\<Sum>k < k0. 1)"
    by (intro add_mono suminf_le summableI sum_mono iffD2[OF ennreal_le_iff]) auto
  also have "... = (\<Sum>k. ennreal (real n /2^k0) * ennreal ((1/2)^k)) + of_nat k0"
    by (intro suminf_cong arg_cong2[where f="(+)"])
     (simp_all add: ennreal_mult[symmetric] power_add divide_simps)
  also have "... = ennreal (real n /2^k0) * (\<Sum>k. ennreal ((1/2)^k)) + ennreal (real k0)"
    unfolding ennreal_of_nat_eq_real_of_nat by simp
  also have "... = ennreal (real n / 2^k0 * 2 + real k0)"
    unfolding 2 by (subst ennreal_mult[symmetric]) simp_all
  also have "... = ennreal (real n / 2 powr k0 * 2 + real k0)"
    by (subst powr_realpow) auto
  also have "... = ennreal (real n / 2 powr \<lceil>log 2 n\<rceil> * 2 + real k0)"
    using 3 unfolding k0_def by (subst of_nat_nat) auto
  also have "... = ennreal (real n / 2 powr (log 2 n - \<delta>) * 2 + real k0)"
    unfolding \<delta>_def by simp
  also have "... = ennreal (2 powr \<delta> * 2 powr 1 + real k0)"
    using assms unfolding powr_diff by (subst powr_log_cancel) auto
  also have "... \<le> ennreal (1+(\<delta>+1) + real k0)"
    using 4 unfolding powr_add[symmetric]
    by (intro iffD2[OF ennreal_le_iff] add_mono 5) auto
  also have "... = ?R"
    using 3 unfolding \<delta>_def k0_def by (subst of_nat_nat) auto
  finally show ?thesis
    by simp
qed

theorem dice_roll_coin_usage:
  assumes "n > (0::nat)"
  shows "expected_coin_usage_of_ra (dice_roll_ra n) \<le> log 2 n + 2" (is "?L \<le> ?R")
proof -
  have "?L = expected_coin_usage_of_tspmf (tspmf_of_ra (dice_roll_ra n))"
    unfolding expected_coin_usage_of_tspmf_correct[symmetric] by simp
  also have "... = expected_coin_usage_of_tspmf (dice_roll_tspmf n)"
    unfolding dice_roll_ra_tspmf by simp
  also have "... \<le> ?R"
    by (intro dice_roll_expected_consumption_aux assms)
  finally show ?thesis
    by simp
qed

end


header {* Enumerating the SCCs of a Graph \label{sec:scc}*}
theory Gabow_SCC
imports Gabow_Skeleton
begin

text {*
  As a first variant, we implement an algorithm that computes a list of SCCs
  of a graph, in topological order. This is the standard variant described by
  Gabow~\cite{Gabow2000}.
*}

section {* Specification *}
context fr_graph
begin
  text {* We specify a distinct list that covers all reachable nodes and
    contains SCCs in topological order *}

  definition "compute_SCC_spec \<equiv> SPEC (\<lambda>l.
    distinct l \<and> \<Union>set l = E\<^sup>*``V0 \<and> (\<forall>U\<in>set l. is_scc E U)
    \<and> (\<forall>i j. i<j \<and> j<length l \<longrightarrow> l!j \<times> l!i \<inter> E\<^sup>* = {}) )"
end

section {* Extended Invariant *}

locale cscc_invar_ext = fr_graph G
  for G :: "('v,'more) fr_graph_rec_scheme" +
  fixes l :: "'v set list" and D :: "'v set"
  assumes l_is_D: "\<Union>set l = D" -- "The output contains all done CNodes"
  assumes l_scc: "set l \<subseteq> Collect (is_scc E)" -- "The output contains only SCCs"
  assumes l_no_fwd: "\<And>i j. \<lbrakk>i<j; j<length l\<rbrakk> \<Longrightarrow> l!j \<times> l!i \<inter> E\<^sup>* = {}"
    -- "The output contains no forward edges"
begin
  lemma l_no_empty: "{}\<notin>set l" using l_scc by (auto simp: in_set_conv_decomp)
end

locale cscc_outer_invar_loc = outer_invar_loc G it D + cscc_invar_ext G l D
  for G :: "('v,'more) fr_graph_rec_scheme" and it l D
begin
  lemma locale_this: "cscc_outer_invar_loc G it l D" by unfold_locales
  lemma abs_outer_this: "outer_invar_loc G it D" by unfold_locales
end

locale cscc_invar_loc = invar_loc G v0 D0 p D pE + cscc_invar_ext G l D
  for G :: "('v,'more) fr_graph_rec_scheme" and v0 D0 and l :: "'v set list"
  and p D pE
begin
  lemma locale_this: "cscc_invar_loc G v0 D0 l p D pE" by unfold_locales
  lemma invar_this: "invar_loc G v0 D0 p D pE" by unfold_locales
end

context fr_graph
begin
  definition "cscc_outer_invar \<equiv> \<lambda>it (l,D). cscc_outer_invar_loc G it l D"
  definition "cscc_invar \<equiv> \<lambda>v0 D0 (l,p,D,pE). cscc_invar_loc G v0 D0 l p D pE"
end

section {* Definition of the SCC-Algorithm *}

context fr_graph
begin
  definition compute_SCC :: "'v set list nres" where
    "compute_SCC \<equiv> do {
      let so = ([],{});
      (l,D) \<leftarrow> FOREACHi cscc_outer_invar V0 (\<lambda>v0 (l,D0). do {
        if v0\<notin>D0 then do {
          let s = (l,initial v0 D0);

          (l,p,D,pE) \<leftarrow>
          WHILEIT (cscc_invar v0 D0)
            (\<lambda>(l,p,D,pE). p \<noteq> []) (\<lambda>(l,p,D,pE).
          do {
            (* Select edge from end of path *)
            (vo,(p,D,pE)) \<leftarrow> select_edge (p,D,pE);

            ASSERT (p\<noteq>[]);
            case vo of
              Some v \<Rightarrow> do {
                if v \<in> \<Union>set p then do {
                  (* Collapse *)
                  RETURN (l,collapse v (p,D,pE))
                } else if v\<notin>D then do {
                  (* Edge to new node. Append to path *)
                  RETURN (l,push v (p,D,pE))
                } else RETURN (l,p,D,pE)
              }
            | None \<Rightarrow> do {
                (* No more outgoing edges from current node on path *)
                ASSERT (pE \<inter> last p \<times> UNIV = {});
                let V = last p;
                let (p,D,pE) = pop (p,D,pE);
                let l = V#l;
                RETURN (l,p,D,pE)
              }
          }) s;
          ASSERT (p=[] \<and> pE={});
          RETURN (l,D)
        } else
          RETURN (l,D0)
      }) so;
      RETURN l
    }"
end

section {* Preservation of Invariant Extension *}
context cscc_invar_ext
begin
  lemma l_disjoint:
    assumes A: "i<j" "j<length l"
    shows "l!i \<inter> l!j = {}"
  proof (rule disjointI)
    fix u
    assume "u\<in>l!i" "u\<in>l!j"
    with l_no_fwd A show False by auto
  qed

  corollary l_distinct: "distinct l"
    using l_disjoint l_no_empty
    by (metis distinct_conv_nth inf_idem linorder_cases nth_mem)
end

context fr_graph
begin
  definition "cscc_invar_part \<equiv> \<lambda>(l,p,D,pE). cscc_invar_ext G l D"

  lemma cscc_invarI[intro?]:
    assumes "invar v0 D0 PDPE"
    assumes "invar v0 D0 PDPE \<Longrightarrow> cscc_invar_part (l,PDPE)"
    shows "cscc_invar v0 D0 (l,PDPE)"
    using assms
    unfolding initial_def cscc_invar_def invar_def
    apply (simp split: prod.split_asm)
    apply intro_locales
    apply (simp add: invar_loc_def)
    apply (simp add: cscc_invar_part_def cscc_invar_ext_def)
    done

  thm cscc_invarI[of v_0 D_0 s l]

  lemma cscc_outer_invarI[intro?]:
    assumes "outer_invar it D"
    assumes "outer_invar it D \<Longrightarrow> cscc_invar_ext G l D"
    shows "cscc_outer_invar it (l,D)"
    using assms
    unfolding initial_def cscc_outer_invar_def outer_invar_def
    apply (simp split: prod.split_asm)
    apply intro_locales
    apply (simp add: outer_invar_loc_def)
    apply (simp add: cscc_invar_ext_def)
    done

  lemma cscc_invar_initial[simp, intro!]:
    assumes A: "v0\<in>it" "v0\<notin>D0"
    assumes INV: "cscc_outer_invar it (l,D0)"
    shows "cscc_invar_part (l,initial v0 D0)"
  proof -
    from INV interpret cscc_outer_invar_loc G it l D0
      unfolding cscc_outer_invar_def by simp

    show ?thesis
      unfolding cscc_invar_part_def initial_def
      apply simp
      by unfold_locales
  qed

  lemma cscc_invar_pop:
    assumes INV: "cscc_invar v0 D0 (l,p,D,pE)"
    assumes "invar v0 D0 (pop (p,D,pE))"
    assumes NE[simp]: "p\<noteq>[]"
    assumes NO': "pE \<inter> (last p \<times> UNIV) = {}"
    shows "cscc_invar_part (last p # l, pop (p,D,pE))"
  proof -
    from INV interpret cscc_invar_loc G v0 D0 l p D pE
      unfolding cscc_invar_def by simp

    have AUX_l_scc: "is_scc E (last p)"
      unfolding is_scc_pointwise
    proof safe
      {
        assume "last p = {}" thus False
          using p_no_empty by (cases p rule: rev_cases) auto
      }

      fix u v
      assume "u\<in>last p" "v\<in>last p"
      with p_sc[of "last p"] have "(u,v) \<in> (lvE \<inter> last p \<times> last p)\<^sup>*" by auto
      with lvE_ss_E show "(u,v)\<in>(E \<inter> last p \<times> last p)\<^sup>*"
        by (metis Int_mono equalityE rtrancl_mono_mp)

      fix u'
      assume "u'\<notin>last p" "(u,u')\<in>E\<^sup>*" "(u',v)\<in>E\<^sup>*"

      from `u'\<notin>last p` `u\<in>last p` `(u,u')\<in>E\<^sup>*`
        and rtrancl_reachable_induct[OF order_refl lastp_un_D_closed[OF NE NO']]
      have "u'\<in>D" by auto
      with `(u',v)\<in>E\<^sup>*` and rtrancl_reachable_induct[OF order_refl D_closed]
      have "v\<in>D" by auto
      with `v\<in>last p` p_not_D show False by (cases p rule: rev_cases) auto
    qed

    {
      fix i j
      assume A: "i<j" "j<Suc (length l)"
      have "l ! (j - Suc 0) \<times> (last p # l) ! i \<inter> E\<^sup>* = {}"
      proof (rule disjointI, safe)
        fix u v
        assume "(u, v) \<in> E\<^sup>*" "u \<in> l ! (j - Suc 0)" "v \<in> (last p # l) ! i"
        from `u \<in> l ! (j - Suc 0)` A have "u\<in>\<Union>set l"
          by (metis Ex_list_of_length Suc_pred UnionI length_greater_0_conv
            less_nat_zero_code not_less_eq nth_mem)
        with l_is_D have "u\<in>D" by simp
        with rtrancl_reachable_induct[OF order_refl D_closed] `(u,v)\<in>E\<^sup>*`
        have "v\<in>D" by auto

        show False proof cases
          assume "i=0" hence "v\<in>last p" using `v \<in> (last p # l) ! i` by simp
          with p_not_D `v\<in>D` show False by (cases p rule: rev_cases) auto
        next
          assume "i\<noteq>0" with `v \<in> (last p # l) ! i` have "v\<in>l!(i - 1)" by auto
          with l_no_fwd[of "i - 1" "j - 1"]
            and `u \<in> l ! (j - Suc 0)` `(u, v) \<in> E\<^sup>*` `i\<noteq>0` A
          show False by fastforce
        qed
      qed
    } note AUX_l_no_fwd = this

    show ?thesis
      unfolding cscc_invar_part_def pop_def apply simp
      apply unfold_locales
      apply clarsimp_all
      using l_is_D apply auto []

      using l_scc AUX_l_scc apply auto []

      apply (rule AUX_l_no_fwd, assumption+) []
      done
  qed

  thm cscc_invar_pop[of v_0 D_0 l p D pE]

  lemma cscc_invar_unchanged:
    assumes INV: "cscc_invar v0 D0 (l,p,D,pE)"
    shows "cscc_invar_part (l,p',D,pE')"
    using INV unfolding cscc_invar_def cscc_invar_part_def cscc_invar_loc_def
    by simp

  corollary cscc_invar_collapse:
    assumes INV: "cscc_invar v0 D0 (l,p,D,pE)"
    shows "cscc_invar_part (l,collapse v (p',D,pE'))"
    unfolding collapse_def
    by (simp add: cscc_invar_unchanged[OF INV])

  corollary cscc_invar_push:
    assumes INV: "cscc_invar v0 D0 (l,p,D,pE)"
    shows "cscc_invar_part (l,push v (p',D,pE'))"
    unfolding push_def
    by (simp add: cscc_invar_unchanged[OF INV])

  lemma cscc_outer_invar_initial: "cscc_invar_ext G [] {}"
    by unfold_locales auto

  lemma cscc_invar_outer_newnode:
    assumes A: "v0\<notin>D0" "v0\<in>it"
    assumes OINV: "cscc_outer_invar it (l,D0)"
    assumes INV: "cscc_invar v0 D0 (l',[],D',pE)"
    shows "cscc_invar_ext G l' D'"
  proof -
    from OINV interpret cscc_outer_invar_loc G it l D0
      unfolding cscc_outer_invar_def by simp
    from INV interpret inv!: cscc_invar_loc G v0 D0 l' "[]" D' pE
      unfolding cscc_invar_def by simp

    show ?thesis
      by unfold_locales

  qed

  lemma cscc_invar_outer_Dnode:
    assumes "cscc_outer_invar it (l, D)"
    shows "cscc_invar_ext G l D"
    using assms
    by (simp add: cscc_outer_invar_def cscc_outer_invar_loc_def)

  lemmas cscc_invar_preserve = invar_preserve
    cscc_invar_initial
    cscc_invar_pop cscc_invar_collapse cscc_invar_push cscc_invar_unchanged
    cscc_outer_invar_initial cscc_invar_outer_newnode cscc_invar_outer_Dnode

  text {* On termination, the invariant implies the specification *}
  lemma cscc_finI:
    assumes INV: "cscc_outer_invar {} (l,D)"
    shows fin_l_is_scc: "\<lbrakk>U\<in>set l\<rbrakk> \<Longrightarrow> is_scc E U"
    and fin_l_distinct: "distinct l"
    and fin_l_is_reachable: "\<Union>set l = E\<^sup>* `` V0"
    and fin_l_no_fwd: "\<lbrakk>i<j; j<length l\<rbrakk> \<Longrightarrow> l!j \<times>l!i \<inter> E\<^sup>* = {}"
  proof -
    from INV interpret cscc_outer_invar_loc G "{}" l D
      unfolding cscc_outer_invar_def by simp

    show "\<lbrakk>U\<in>set l\<rbrakk> \<Longrightarrow> is_scc E U" using l_scc by auto

    show "distinct l" by (rule l_distinct)

    show "\<Union>set l = E\<^sup>* `` V0"
      using fin_outer_D_is_reachable[OF outer_invar_this] l_is_D
      by auto

    show "\<lbrakk>i<j; j<length l\<rbrakk> \<Longrightarrow> l!j \<times>l!i \<inter> E\<^sup>* = {}"
      by (rule l_no_fwd)

  qed

end

section {* Main Correctness Proof *}

context fr_graph
begin
  lemma invar_from_cscc_invarI: "cscc_invar v0 D0 (L,PDPE) \<Longrightarrow> invar v0 D0 PDPE"
    unfolding cscc_invar_def invar_def
    apply (simp split: prod.splits)
    unfolding cscc_invar_loc_def by simp

  lemma outer_invar_from_cscc_invarI:
    "cscc_outer_invar it (L,D) \<Longrightarrow>outer_invar it D"
    unfolding cscc_outer_invar_def outer_invar_def
    apply (simp split: prod.splits)
    unfolding cscc_outer_invar_loc_def by simp

  text {* With the extended invariant and the auxiliary lemmas, the actual
    correctness proof is straightforward: *}
  theorem compute_SCC_correct: "compute_SCC \<le> compute_SCC_spec"
  proof -
    note [[goals_limit = 2]]
    note [simp del] = Union_iff

    show ?thesis
      unfolding compute_SCC_def compute_SCC_spec_def select_edge_def select_def
      apply (refine_rcg
        WHILEIT_rule[where R="inv_image (abs_wf_rel v0) snd" for v0]
        refine_vcg
      )

      apply (vc_solve
        rec: cscc_invarI cscc_outer_invarI
        solve: cscc_invar_preserve cscc_finI
        intro: invar_from_cscc_invarI outer_invar_from_cscc_invarI
        dest!: sym[of "pop A" for A]
        simp: pE_fin'[OF invar_from_cscc_invarI]
      )
      done
  qed

  text {* Simple proof, for presentation *}
  context
    notes [refine]=refine_vcg
    notes [[goals_limit = 1]]
  begin
    theorem "compute_SCC \<le> compute_SCC_spec"
      unfolding compute_SCC_def compute_SCC_spec_def select_edge_def select_def
      by (refine_rcg
        WHILEIT_rule[where R="inv_image (abs_wf_rel v0) snd" for v0])
      (vc_solve
        rec: cscc_invarI cscc_outer_invarI solve: cscc_invar_preserve cscc_finI
        intro: invar_from_cscc_invarI outer_invar_from_cscc_invarI
        dest!: sym[of "pop A" for A]
        simp: pE_fin'[OF invar_from_cscc_invarI])
  end

end

section {* Refinement to Gabow's Data Structure *}

context GS begin
  definition "seg_set_impl l u \<equiv> do {
    (_,res) \<leftarrow> WHILET
      (\<lambda>(l,_). l<u)
      (\<lambda>(l,res). do {
        ASSERT (l<length S);
        let x = S!l;
        ASSERT (x\<notin>res);
        RETURN (Suc l,insert x res)
      })
      (l,{});

    RETURN res
  }"

    apply (auto simp: less_Suc_eq nth_eq_iff_index_eq)
    done

  lemma (in GS_invar) seg_set_impl_correct:
    assumes "i<length B"
    shows "seg_set_impl (seg_start i) (seg_end i) \<le> SPEC (\<lambda>r. r=p_\<alpha>!i)"
    apply (refine_rcg order_trans[OF seg_set_impl_aux] refine_vcg)

    using assms
    apply (simp_all add: seg_start_less_end seg_end_bound S_distinct) [3]

    apply (auto simp: p_\<alpha>_def assms seg_def) []
    done

  definition "last_seg_impl
    \<equiv> do {
      ASSERT (length B - 1 < length B);
      seg_set_impl (seg_start (length B - 1)) (seg_end (length B - 1))
    }"

  lemma (in GS_invar) last_seg_impl_correct:
    assumes "p_\<alpha> \<noteq> []"
    shows "last_seg_impl \<le> SPEC (\<lambda>r. r=last p_\<alpha>)"
    unfolding last_seg_impl_def
    apply (refine_rcg order_trans[OF seg_set_impl_correct] refine_vcg)
    using assms apply (auto simp add: p_\<alpha>_def last_conv_nth)
    done

end

context fr_graph
begin

  definition "last_seg_impl s \<equiv> GS.last_seg_impl s"
  lemmas last_seg_impl_def_opt =
    last_seg_impl_def[abs_def, THEN opt_GSdef,
      unfolded GS.last_seg_impl_def GS.seg_set_impl_def
    GS.seg_start_def GS.seg_end_def GS_sel_simps]
    (* TODO: Some potential for optimization here: the assertion
      guarantees that length B - 1 + 1 = length B !*)

  lemma last_seg_impl_refine:
    assumes A: "(s,(p,D,pE))\<in>GS_rel"
    assumes NE: "p\<noteq>[]"
    shows "last_seg_impl s \<le> \<Down>Id (RETURN (last p))"
  proof -
    from A have
      [simp]: "p=GS.p_\<alpha> s \<and> D=GS.D_\<alpha> s \<and> pE=GS.pE_\<alpha> s"
        and INV: "GS_invar s"
      by (auto simp add: GS_rel_def br_def GS_\<alpha>_split)

    show ?thesis
      unfolding last_seg_impl_def[abs_def]
      apply (rule order_trans[OF GS_invar.last_seg_impl_correct])
      using INV NE
      apply (simp_all)
      done
  qed

  definition compute_SCC_impl :: "'v set list nres" where
    "compute_SCC_impl \<equiv> do {
      stat_start_nres;
      let so = ([],Map.empty);
      (l,D) \<leftarrow> FOREACHi (\<lambda>it (l,s). cscc_outer_invar it (l,oGS_\<alpha> s))
        V0 (\<lambda>v0 (l,I0). do {
          if \<not>is_done_oimpl v0 I0 then do {
            let ls = (l,initial_impl v0 I0);

            (l,(S,B,I,P))\<leftarrow>WHILEIT (\<lambda>(l,s). cscc_invar v0 (oGS_\<alpha> I0) (l,GS.\<alpha> s))
              (\<lambda>(l,s). \<not>path_is_empty_impl s) (\<lambda>(l,s).
            do {
              (* Select edge from end of path *)
              (vo,s) \<leftarrow> select_edge_impl s;

              case vo of
                Some v \<Rightarrow> do {
                  if is_on_stack_impl v s then do {
                    s\<leftarrow>collapse_impl v s;
                    RETURN (l,s)
                  } else if \<not>is_done_impl v s then do {
                    (* Edge to new node. Append to path *)
                    RETURN (l,push_impl v s)
                  } else do {
                    (* Edge to done node. Skip *)
                    RETURN (l,s)
                  }
                }
              | None \<Rightarrow> do {
                  (* No more outgoing edges from current node on path *)
                  scc \<leftarrow> last_seg_impl s;
                  s\<leftarrow>pop_impl s;
                  let l = scc#l;
                  RETURN (l,s)
                }
            }) (ls);
            RETURN (l,I)
          } else RETURN (l,I0)
      }) so;
      stat_stop_nres;
      RETURN l
    }"

  lemma compute_SCC_impl_refine: "compute_SCC_impl \<le> \<Down>Id compute_SCC"
  proof -
    note [refine2] = bind_Let_refine2[OF last_seg_impl_refine]

    have [refine2]: "\<And>s' p D pE l' l v' v. \<lbrakk>
      (s',(p,D,pE))\<in>GS_rel;
      (l',l)\<in>Id;
      (v',v)\<in>Id;
      v\<in>\<Union>set p
    \<rbrakk> \<Longrightarrow> do { s'\<leftarrow>collapse_impl v' s'; RETURN (l',s') }
      \<le> \<Down>(Id \<times>\<^sub>r GS_rel) (RETURN (l,collapse v (p,D,pE)))"
      apply (refine_rcg order_trans[OF collapse_refine] refine_vcg)
      apply assumption+
      apply (auto simp add: pw_le_iff refine_pw_simps)
      done

    note [[goals_limit = 1]]
    show ?thesis
      unfolding compute_SCC_impl_def compute_SCC_def
      apply (refine_rcg
        bind_refine'
        select_edge_refine push_refine
        pop_refine
        (*collapse_refine*)
        initial_refine
        oinitial_refine
        (*last_seg_impl_refine*)
        prod_relI IdI
        inj_on_id
      )

      apply (vc_solve (nopre) solve: asm_rl I_to_outer
        simp: GS_rel_def br_def GS.\<alpha>_def oGS_rel_def oGS_\<alpha>_def
        is_on_stack_refine path_is_empty_refine is_done_refine is_done_orefine
      )

      done
  qed

end

end


section "Standard semantics"

theory Eval
  imports HOLCF HOLCFUtils CPSScheme
begin

text \<open>
We begin by giving the standard semantics for our language. Although this is not actually used to show any results, it is helpful to see that the later algorithms ``look similar'' to the evaluation code and the relation between calls done during evaluation and calls recorded by the control flow graph.
\<close>

text \<open>
We follow the definition in Figure 3.1 and 3.2 of Shivers' dissertation, with the clarifications from Section 4.1. As explained previously, our set of values encompasses just the integers, there is no separate value for \textit{false}. Also, values and procedures are not distinguished by the type system.

Due to recursion, one variable can have more than one currently valid binding, and due to closures all bindings can possibly be accessed. A simple call stack is therefore not sufficient. Instead we have a \textit{contour counter}, which is increased in each evaluation step. It can also be thought of as a time counter. The variable environment maps tuples of variables and contour counter to values, thus allowing a variable to have more than one active binding.  A contour environment lists the currently visible binding for each binding position and is preserved when a lambda expression is turned into a closure.
\<close>

type_synonym contour = nat
type_synonym benv = "label \<rightharpoonup> contour"
type_synonym closure = "lambda \<times> benv"

text \<open>
The set of semantic values consist of the integers, closures, primitive operations and a special value \<open>Stop\<close>. This is passed as an argument to the program and represents the terminal continuation. When this value occurs in the first position of a call, the program terminates.
\<close>

datatype d = DI int
           | DC closure
           | DP prim
           | Stop

type_synonym venv = "var \<times> contour \<rightharpoonup> d"

text \<open>
The function \<open>\<A>\<close> evaluates a syntactic value into a semantic datum. Constants and primitive operations are left untouched. Variable references are resolved in two stages: First the current binding contour is fetched from the binding environment \<open>\<beta>\<close>, then the stored value is fetched from the variable environment \<open>ve\<close>. A lambda expression is bundled with the current contour environment to form a closure.
\<close>

fun evalV :: "val \<Rightarrow> benv \<Rightarrow> venv \<Rightarrow> d" ("\<A>")
  where "\<A> (C _ i) \<beta> ve = DI i"
  |     "\<A> (P prim) \<beta> ve = DP prim"
  |     "\<A> (R _ var) \<beta> ve =
           (case \<beta> (binder var) of
              Some l \<Rightarrow> (case ve (var,l) of Some d \<Rightarrow> d))"
  |     "\<A> (L lam) \<beta> ve = DC (lam, \<beta>)"

text \<open>
The answer domain of our semantics is the set of integers, lifted to obtain an additional element denoting bottom. Shivers distinguishes runtime errors from non-termination. Here, both are represented by \<open>\<bottom>\<close>.
\<close>

type_synonym ans = "int lift"

text \<open>
To be able to do case analysis on the custom datatypes \<open>lambda\<close>, \<open>d\<close>, \<open>call\<close> and \<open>prim\<close> inside a function defined with \<open>fixrec\<close>, we need continuity results for them. These are all of the same shape and proven by case analysis on the discriminator.
\<close>

lemma cont2cont_case_lambda [simp, cont2cont]:
  assumes "\<And>a b c. cont (\<lambda>x. f x a b c)"
  shows "cont (\<lambda>x. case_lambda (f x) l)"
using assms
by (cases l) auto

lemma cont2cont_case_d [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f1 x y)"
     and  "\<And>y. cont (\<lambda>x. f2 x y)"
     and  "\<And>y. cont (\<lambda>x. f3 x y)"
    and   "cont (\<lambda>x. f4 x)"
  shows "cont (\<lambda>x. case_d (f1 x) (f2 x) (f3 x) (f4 x) d)"
using assms
by (cases d) auto

lemma cont2cont_case_call [simp, cont2cont]:
  assumes "\<And>a b c. cont (\<lambda>x. f1 x a b c)"
     and  "\<And>a b c. cont (\<lambda>x. f2 x a b c)"
  shows "cont (\<lambda>x. case_call (f1 x) (f2 x) c)"
using assms
by (cases c) auto

lemma cont2cont_case_prim [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f1 x y)"
     and  "\<And>y z. cont (\<lambda>x. f2 x y z)"
  shows "cont (\<lambda>x. case_prim (f1 x) (f2 x) p)"
using assms
by (cases p) auto

text \<open>
As usual, the semantics of a functional language is given as a denotational semantics. To that end, two functions are defined here: \<open>\<F>\<close> applies a procedure to a list of arguments. Here closures are unwrapped, the primitive operations are implemented and the terminal continuation \<open>Stop\<close> is handled. \<open>\<C>\<close> evaluates a call expression, either by evaluating procedure and arguments and passing them to \<open>\<F>\<close>, or by adding the bindings of a \<open>Let\<close> expression to the environment.

Note how the contour counter is incremented before each call to \<open>\<F>\<close> or when a \<open>Let\<close> expression is evaluated.

With mutually recursive equations, such as those given here, the existence of a function satisfying these is not obvious. Therefore, the \<open>fixrec\<close> command from the @{theory HOLCF} package is used. This takes a set of equations and builds a functional from that. It mechanically proofs that this functional is continuous and thus a least fixed point exists. This is then used to define \<open>\<F>\<close> and \<open>\<C>\<close> and proof the equations given here. To use the @{theory HOLCF} setup, the continuous function arrow \<open>\<rightarrow>\<close> with application operator \<open>\<cdot>\<close> is used and our types are wrapped in \<open>discr\<close> and \<open>lift\<close> to indicate which partial order is to be used.
\<close>

type_synonym fstate = "(d \<times> d list \<times> venv \<times> contour)"
type_synonym cstate = "(call \<times> benv \<times> venv \<times> contour)"

fixrec   evalF :: "fstate discr \<rightarrow> ans" ("\<F>")
     and evalC :: "cstate discr \<rightarrow> ans" ("\<C>")
  where "evalF\<cdot>fstate = (case undiscr fstate of
             (DC (Lambda lab vs c, \<beta>), as, ve, b) \<Rightarrow>
               (if length vs = length as
                then let \<beta>' = \<beta> (lab \<mapsto> b);
                         ve' = map_upds ve (map (\<lambda>v.(v,b)) vs) as
                     in \<C>\<cdot>(Discr (c,\<beta>',ve',b))
                else \<bottom>)
            | (DP (Plus c),[DI a1, DI a2, cnt],ve,b) \<Rightarrow>
                     let b' = Suc b;
                         \<beta>  = [c \<mapsto> b]
                     in \<F>\<cdot>(Discr (cnt,[DI (a1 + a2)],ve,b'))
            | (DP (prim.If ct cf),[DI v, contt, contf],ve,b) \<Rightarrow>
                  (if v \<noteq> 0
                   then let b' = Suc b;
                            \<beta> = [ct \<mapsto> b]
                        in \<F>\<cdot>(Discr (contt,[],ve,b'))
                   else let b' = Suc b;
                            \<beta> = [cf \<mapsto> b]
                        in \<F>\<cdot>(Discr (contf,[],ve,b')))
            | (Stop,[DI i],_,_) \<Rightarrow> Def i
            | _ \<Rightarrow> \<bottom>
        )"
      | "\<C>\<cdot>cstate = (case undiscr cstate of
             (App lab f vs,\<beta>,ve,b) \<Rightarrow>
                 let f' = \<A> f \<beta> ve;
                     as = map (\<lambda>v. \<A> v \<beta> ve) vs;
                     b' = Suc b
                  in \<F>\<cdot>(Discr (f',as,ve,b'))
            | (Let lab ls c',\<beta>,ve,b) \<Rightarrow>
                 let b' = Suc b;
                     \<beta>' = \<beta> (lab \<mapsto> b');
                    ve' = ve ++ map_of (map (\<lambda>(v,l). ((v,b'), \<A> (L l) \<beta>' ve)) ls)
                 in \<C>\<cdot>(Discr (c',\<beta>',ve',b'))
        )"

text \<open>
To evaluate a full program, it is passed to \<open>\<F>\<close> with proper initializations of the other arguments. We test our semantics function against two example programs and observe that the expected value is returned.
\<close>

definition evalCPS :: "prog \<Rightarrow> ans" ("\<PR>")
  where "\<PR> l = (let ve = Map.empty;
                          \<beta> = Map.empty;
                          f = \<A> (L l) \<beta> ve
                      in  \<F>\<cdot>(Discr (f,[Stop],ve,0)))"

lemma correct_ex1: "\<PR> ex1 = Def 0"
unfolding evalCPS_def
by simp

lemma correct_ex2: "\<PR> ex2 = Def 2"
unfolding evalCPS_def
by simp

(* (The third example takes long to finish, thus is it not ran by default.)
lemma correct_ex3: "evalCPS ex3 = Def 55"
oops
unfolding evalCPS_def
by simp
*)

end


(* Author: Alexander Maletzky *)

theory PP_Type
  imports Power_Products
begin

text \<open>For code generation, we must introduce a copy of type @{typ "'a \<Rightarrow>\<^sub>0 'b"} for power-products.\<close>

typedef (overloaded) ('a, 'b) pp = "UNIV::('a \<Rightarrow>\<^sub>0 'b) set"
  morphisms mapping_of PP ..

setup_lifting type_definition_pp

lift_definition pp_of_fun :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 'b::zero) pp"
  is Abs_poly_mapping .

subsection \<open>\<open>lookup_pp\<close>, \<open>keys_pp\<close> and \<open>single_pp\<close>\<close>

lift_definition lookup_pp :: "('a, 'b::zero) pp \<Rightarrow> 'a \<Rightarrow> 'b" is lookup .

lift_definition keys_pp :: "('a, 'b::zero) pp \<Rightarrow> 'a set" is keys .

lift_definition single_pp :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b::zero) pp" is Poly_Mapping.single .

lemma lookup_pp_of_fun: "finite {x. f x \<noteq> 0} \<Longrightarrow> lookup_pp (pp_of_fun f) = f"
  by (transfer, rule Abs_poly_mapping_inverse, simp)

lemma pp_of_lookup: "pp_of_fun (lookup_pp t) = t"
  by (transfer, fact lookup_inverse)

lemma pp_eqI: "(\<And>u. lookup_pp s u = lookup_pp t u) \<Longrightarrow> s = t"
  by (transfer, rule poly_mapping_eqI)

lemma pp_eq_iff: "(s = t) \<longleftrightarrow> (lookup_pp s = lookup_pp t)"
  by (auto intro: pp_eqI)

lemma keys_pp_iff: "x \<in> keys_pp t \<longleftrightarrow> (lookup_pp t x \<noteq> 0)"
  by (simp add: in_keys_iff keys_pp.rep_eq lookup_pp.rep_eq)

lemma pp_eqI':
  assumes "\<And>u. u \<in> keys_pp s \<union> keys_pp t \<Longrightarrow> lookup_pp s u = lookup_pp t u"
  shows "s = t"
proof (rule pp_eqI)
  fix u
  show "lookup_pp s u = lookup_pp t u"
  proof (cases "u \<in> keys_pp s \<union> keys_pp t")
    case True
    thus ?thesis by (rule assms)
  next
    case False
    thus ?thesis by (simp add: keys_pp_iff)
  qed
qed

lemma lookup_single_pp: "lookup_pp (single_pp x e) y = (e when x = y)"
  by (transfer, simp only: lookup_single)

subsection \<open>Additive Structure\<close>

instantiation pp :: (type, zero) zero
begin

lift_definition zero_pp :: "('a, 'b) pp" is "0::'a \<Rightarrow>\<^sub>0 'b" .

lemma lookup_zero_pp [simp]: "lookup_pp 0 = 0"
  by (transfer, simp add: lookup_zero_fun)

instance ..

end

lemma single_pp_zero [simp]: "single_pp x 0 = 0"
  by (rule pp_eqI, simp add: lookup_single_pp)

instantiation pp :: (type, monoid_add) monoid_add
begin

lift_definition plus_pp :: "('a, 'b) pp \<Rightarrow> ('a, 'b) pp \<Rightarrow> ('a, 'b) pp" is "(+)::('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> _" .

lemma lookup_plus_pp: "lookup_pp (s + t) = lookup_pp s + lookup_pp t"
  by (transfer, simp add: lookup_plus_fun)

instance by intro_classes (transfer, simp add: fun_eq_iff add.assoc)+

end

lemma single_pp_plus: "single_pp x a + single_pp x b = single_pp x (a + b)"
  by (rule pp_eqI, simp add: lookup_single_pp lookup_plus_pp when_def)

instance pp :: (type, comm_monoid_add) comm_monoid_add
  by intro_classes (transfer, simp add: fun_eq_iff ac_simps)+

instantiation pp :: (type, cancel_comm_monoid_add) cancel_comm_monoid_add
begin

lift_definition minus_pp :: "('a, 'b) pp \<Rightarrow> ('a, 'b) pp \<Rightarrow> ('a, 'b) pp" is "(-)::('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> _" .

lemma lookup_minus_pp: "lookup_pp (s - t) = lookup_pp s - lookup_pp t"
  by (transfer, simp only: lookup_minus_fun)

instance by intro_classes (transfer, simp add: fun_eq_iff diff_diff_add)+

end

subsection \<open>@{typ "('a, 'b) poly_mapping"} belongs to class @{class comm_powerprod}\<close>

instance poly_mapping :: (type, cancel_comm_monoid_add) comm_powerprod
  by standard

subsection \<open>@{typ "('a, 'b) poly_mapping"} belongs to class @{class ninv_comm_monoid_add}\<close>

instance poly_mapping :: (type, ninv_comm_monoid_add) ninv_comm_monoid_add
proof (standard, transfer)
  fix s t::"'a \<Rightarrow> 'b"
  assume "(\<lambda>k. s k + t k) = (\<lambda>_. 0)"
  hence "s + t = 0" by (simp only: plus_fun_def zero_fun_def)
  hence "s = 0" by (rule plus_eq_zero)
  thus "s = (\<lambda>_. 0)" by (simp only: zero_fun_def)
qed

subsection \<open>@{typ "('a, 'b) pp"} belongs to class @{class lcs_powerprod}\<close>

lemma adds_pp_iff: "(s adds t) \<longleftrightarrow> (mapping_of s adds mapping_of t)"
  unfolding adds_def by (transfer, fact refl)

instantiation pp :: (type, add_linorder) lcs_powerprod
begin

lift_definition lcs_pp :: "('a, 'b) pp \<Rightarrow> ('a, 'b) pp \<Rightarrow> ('a, 'b) pp" is "lcs_powerprod_class.lcs" .

lemma lookup_lcs_pp: "lookup_pp (lcs s t) x = max (lookup_pp s x) (lookup_pp t x)"
  by (transfer, simp add: lookup_lcs_fun lcs_fun_def)

instance
  apply (intro_classes, simp_all only: adds_pp_iff)
  subgoal by (transfer, rule adds_lcs)
  subgoal by (transfer, elim lcs_adds)
  subgoal by (transfer, rule lcs_comm)
  done

end

subsection \<open>@{typ "('a, 'b) pp"} belongs to class @{class ulcs_powerprod}\<close>

instance pp :: (type, add_linorder_min) ulcs_powerprod by intro_classes (transfer, elim plus_eq_zero)

subsection \<open>Dickson's lemma for power-products in finitely many indeterminates\<close>

lemma almost_full_on_pp_iff:
  "almost_full_on (adds) A \<longleftrightarrow> almost_full_on (adds) (mapping_of ` A)" (is "?l \<longleftrightarrow> ?r")
proof
  assume ?l
  with _ show ?r
  proof (rule almost_full_on_hom)
    fix x y :: "('a, 'b) pp"
    assume "x adds y"
    thus "mapping_of x adds mapping_of y" by (simp only: adds_pp_iff)
  qed
next
  assume ?r
  hence "almost_full_on (\<lambda>x y. mapping_of x adds mapping_of y) A"
    using subset_refl by (rule almost_full_on_map)
  thus ?l by (simp only: adds_pp_iff[symmetric])
qed

lift_definition varnum_pp :: "('a::countable, 'b::zero) pp \<Rightarrow> nat" is "varnum {}" .

lemma dickson_grading_varnum_pp:
  "dickson_grading (varnum_pp::('a::countable, 'b::add_wellorder) pp \<Rightarrow> nat)"
proof (rule dickson_gradingI)
  fix s t :: "('a, 'b) pp"
  show "varnum_pp (s + t) = max (varnum_pp s) (varnum_pp t)" by (transfer, rule varnum_plus)
next
  fix m::nat
  show "almost_full_on (adds) {x::('a, 'b) pp. varnum_pp x \<le> m}" unfolding almost_full_on_pp_iff
  proof (transfer, simp)
    fix m::nat
    from dickson_grading_varnum_empty show "almost_full_on (adds) {x::'a \<Rightarrow>\<^sub>0 'b. varnum {} x \<le> m}"
      by (rule dickson_gradingD2)
  qed
qed

instance pp :: (countable, add_wellorder) graded_dickson_powerprod
  by (standard, rule, fact dickson_grading_varnum_pp)

instance pp :: (finite, add_wellorder) dickson_powerprod
proof
  have eq: "range mapping_of = UNIV" by (rule surjI, rule PP_inverse, rule UNIV_I)
  show "almost_full_on (adds) (UNIV::('a, 'b) pp set)" by (simp add: almost_full_on_pp_iff eq dickson)
qed

subsection \<open>Lexicographic Term Order\<close>

lift_definition lex_pp :: "('a, 'b) pp \<Rightarrow> ('a::linorder, 'b::{zero,linorder}) pp \<Rightarrow> bool" is lex_pm .

lift_definition lex_pp_strict :: "('a, 'b) pp \<Rightarrow> ('a::linorder, 'b::{zero,linorder}) pp \<Rightarrow> bool" is lex_pm_strict .

lemma lex_pp_alt: "lex_pp s t = (s = t \<or> (\<exists>x. lookup_pp s x < lookup_pp t x \<and> (\<forall>y<x. lookup_pp s y = lookup_pp t y)))"
  by (transfer, fact lex_pm_alt)

lemma lex_pp_refl: "lex_pp s s"
  by (transfer, fact lex_pm_refl)

lemma lex_pp_antisym: "lex_pp s t \<Longrightarrow> lex_pp t s \<Longrightarrow> s = t"
  by (transfer, intro lex_pm_antisym)

lemma lex_pp_trans: "lex_pp s t \<Longrightarrow> lex_pp t u \<Longrightarrow> lex_pp s u"
  by (transfer, rule lex_pm_trans)

lemma lex_pp_lin: "lex_pp s t \<or> lex_pp t s"
  by (transfer, fact lex_pm_lin)

lemma lex_pp_lin': "\<not> lex_pp t s \<Longrightarrow> lex_pp s t"
  using lex_pp_lin by blast \<comment>\<open>Better suited for \<open>auto\<close>.\<close>

corollary lex_pp_strict_alt [code]:
  "lex_pp_strict s t = (\<not> lex_pp t s)" for s t::"(_, _::ordered_comm_monoid_add) pp"
  by (transfer, fact lex_pm_strict_alt)

lemma lex_pp_zero_min: "lex_pp 0 s" for s::"(_, _::add_linorder_min) pp"
  by (transfer, fact lex_pm_zero_min)

lemma lex_pp_plus_monotone: "lex_pp s t \<Longrightarrow> lex_pp (s + u) (t + u)"
  for s t::"(_, _::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}) pp"
  by (transfer, intro lex_pm_plus_monotone)

lemma lex_pp_plus_monotone': "lex_pp s t \<Longrightarrow> lex_pp (u + s) (u + t)"
  for s t::"(_, _::{ordered_comm_monoid_add, ordered_ab_semigroup_add_imp_le}) pp"
  unfolding add.commute[of u] by (rule lex_pp_plus_monotone)

instantiation pp :: (linorder, "{ordered_comm_monoid_add, linorder}") linorder
begin

definition less_eq_pp :: "('a, 'b) pp \<Rightarrow> ('a, 'b) pp \<Rightarrow> bool"
  where "less_eq_pp = lex_pp"

definition less_pp :: "('a, 'b) pp \<Rightarrow> ('a, 'b) pp \<Rightarrow> bool"
  where "less_pp = lex_pp_strict"

instance by intro_classes (auto simp: less_eq_pp_def less_pp_def lex_pp_refl lex_pp_strict_alt intro: lex_pp_antisym lex_pp_lin' elim: lex_pp_trans)

end

subsection \<open>Degree\<close>

lift_definition deg_pp :: "('a, 'b::comm_monoid_add) pp \<Rightarrow> 'b" is deg_pm .

lemma deg_pp_alt: "deg_pp s = sum (lookup_pp s) (keys_pp s)"
  by (transfer, transfer, simp add: deg_fun_def supp_fun_def)

lemma deg_pp_eq_0_iff [simp]: "deg_pp s = 0 \<longleftrightarrow> s = 0" for s::"('a, 'b::add_linorder_min) pp"
  by (transfer, fact deg_pm_eq_0_iff)

lemma deg_pp_plus: "deg_pp (s + t) = deg_pp s + deg_pp (t::('a, 'b::comm_monoid_add) pp)"
  by (transfer, fact deg_pm_plus)

lemma deg_pp_single: "deg_pp (single_pp x k) = k"
  by (transfer, fact deg_pm_single)

subsection \<open>Degree-Lexicographic Term Order\<close>

lift_definition dlex_pp :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp \<Rightarrow> ('a, 'b) pp \<Rightarrow> bool"
  is dlex_pm .

lift_definition dlex_pp_strict :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp \<Rightarrow> ('a, 'b) pp \<Rightarrow> bool"
  is dlex_pm_strict .

lemma dlex_pp_alt: "dlex_pp s t \<longleftrightarrow> (deg_pp s < deg_pp t \<or> (deg_pp s = deg_pp t \<and> lex_pp s t))"
  by transfer (simp only: dlex_pm_def dord_pm_alt)

lemma dlex_pp_refl: "dlex_pp s s"
  by (transfer) (fact dlex_pm_refl)

lemma dlex_pp_antisym: "dlex_pp s t \<Longrightarrow> dlex_pp t s \<Longrightarrow> s = t"
  by (transfer, elim dlex_pm_antisym)

lemma dlex_pp_trans: "dlex_pp s t \<Longrightarrow> dlex_pp t u \<Longrightarrow> dlex_pp s u"
  by (transfer, rule dlex_pm_trans)

lemma dlex_pp_lin: "dlex_pp s t \<or> dlex_pp t s"
  by (transfer, fact dlex_pm_lin)

corollary dlex_pp_strict_alt [code]: "dlex_pp_strict s t = (\<not> dlex_pp t s)"
  by (transfer, fact dlex_pm_strict_alt)

lemma dlex_pp_zero_min: "dlex_pp 0 s"
  for s t::"(_, _::add_linorder_min) pp"
  by (transfer, fact dlex_pm_zero_min)

lemma dlex_pp_plus_monotone: "dlex_pp s t \<Longrightarrow> dlex_pp (s + u) (t + u)"
  for s t::"(_, _::{ordered_ab_semigroup_add_imp_le, ordered_cancel_comm_monoid_add}) pp"
  by (transfer, rule dlex_pm_plus_monotone)

subsection \<open>Degree-Reverse-Lexicographic Term Order\<close>

lift_definition drlex_pp :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp \<Rightarrow> ('a, 'b) pp \<Rightarrow> bool"
  is drlex_pm .

lift_definition drlex_pp_strict :: "('a::linorder, 'b::{ordered_comm_monoid_add,linorder}) pp \<Rightarrow> ('a, 'b) pp \<Rightarrow> bool"
  is drlex_pm_strict .

lemma drlex_pp_alt: "drlex_pp s t \<longleftrightarrow> (deg_pp s < deg_pp t \<or> (deg_pp s = deg_pp t \<and> lex_pp t s))"
  by transfer (simp only: drlex_pm_def dord_pm_alt)

lemma drlex_pp_refl: "drlex_pp s s"
  by (transfer, fact drlex_pm_refl)

lemma drlex_pp_antisym: "drlex_pp s t \<Longrightarrow> drlex_pp t s \<Longrightarrow> s = t"
  by (transfer, rule drlex_pm_antisym)

lemma drlex_pp_trans: "drlex_pp s t \<Longrightarrow> drlex_pp t u \<Longrightarrow> drlex_pp s u"
  by (transfer, rule drlex_pm_trans)

lemma drlex_pp_lin: "drlex_pp s t \<or> drlex_pp t s"
  by (transfer, fact drlex_pm_lin)

corollary drlex_pp_strict_alt [code]: "drlex_pp_strict s t = (\<not> drlex_pp t s)"
  by (transfer, fact drlex_pm_strict_alt)

lemma drlex_pp_zero_min: "drlex_pp 0 s"
  for s t::"(_, _::add_linorder_min) pp"
  by (transfer, fact drlex_pm_zero_min)

lemma drlex_pp_plus_monotone: "drlex_pp s t \<Longrightarrow> drlex_pp (s + u) (t + u)"
  for s t::"(_, _::{ordered_ab_semigroup_add_imp_le, ordered_cancel_comm_monoid_add}) pp"
  by (transfer, rule drlex_pm_plus_monotone)

end (* theory *)