section \<open>Abstract Dijkstra Algorithm\<close>
theory Dijkstra_Abstract
imports Directed_Graph
begin

subsection \<open>Abstract Algorithm\<close>

type_synonym 'v estimate = "'v \<Rightarrow> enat"
text \<open>We fix a start node and a weighted graph\<close>
locale Dijkstra = WGraph w for w :: "('v) wgraph" +
  fixes s :: 'v
begin

text \<open>Relax all outgoing edges of node \<open>u\<close>\<close>
definition relax_outgoing :: "'v \<Rightarrow> 'v estimate \<Rightarrow> 'v estimate"
  where "relax_outgoing u D \<equiv> \<lambda>v. min (D v) (D u + w (u,v))"

text \<open>Initialization\<close>
definition "initD \<equiv> (\<lambda>_. \<infinity>)(s:=0)"
definition "initS \<equiv> {}"

text \<open>Relaxing will never increase estimates\<close>
lemma relax_mono: "relax_outgoing u D v \<le> D v"
  by (auto simp: relax_outgoing_def)

definition "all_dnodes \<equiv> Set.insert s { v . \<exists>u. w (u,v)\<noteq>\<infinity> }"
definition "unfinished_dnodes S \<equiv> all_dnodes - S "

lemma unfinished_nodes_subset: "unfinished_dnodes S \<subseteq> all_dnodes"
  by (auto simp: unfinished_dnodes_def)

end

subsubsection \<open>Invariant\<close>
text \<open>The invariant is defined as locale\<close>

locale Dijkstra_Invar = Dijkstra w s for w and s :: 'v +
  fixes D :: "'v estimate" and S :: "'v set"
  assumes upper_bound: \<open>\<delta> s u \<le> D u\<close> \<comment> \<open>\<open>D\<close> is a valid estimate\<close>
  assumes s_in_S: \<open>s\<in>S \<or> (D=(\<lambda>_. \<infinity>)(s:=0) \<and> S={})\<close> \<comment> \<open>The start node is
    finished, or we are in initial state\<close>
  assumes S_precise: "u\<in>S \<Longrightarrow> D u = \<delta> s u" \<comment> \<open>Finished nodes have precise
    estimate\<close>
  assumes S_relaxed: \<open>v\<in>S \<Longrightarrow> D u \<le> \<delta> s v + w (v,u)\<close> \<comment> \<open>Outgoing edges of
    finished nodes have been relaxed, using precise distance\<close>
begin

abbreviation (in Dijkstra) "D_invar \<equiv> Dijkstra_Invar w s"

text \<open>The invariant holds for the initial state\<close>

text \<open>Relaxing some edges maintains the upper bound property\<close>
lemma maintain_upper_bound: "\<delta> s u \<le> (relax_outgoing v D) u"
  apply (clarsimp simp: relax_outgoing_def upper_bound split: prod.splits)
  using triangle upper_bound add_right_mono dual_order.trans by blast

text \<open>Relaxing edges will not affect nodes with already precise estimates\<close>
lemma relax_precise_id: "D v = \<delta> s v \<Longrightarrow> relax_outgoing u D v = \<delta> s v"
  using maintain_upper_bound upper_bound relax_mono
  by (metis antisym)

text \<open>In particular, relaxing edges will not affect finished nodes\<close>
lemma relax_finished_id: "v\<in>S \<Longrightarrow> relax_outgoing u D v = D v"
  by (simp add: S_precise relax_precise_id)

text \<open>The least (finite) estimate among all nodes \<open>u\<close> not in \<open>S\<close> is already precise.
  This will allow us to add the node \<open>u\<close> to \<open>S\<close>. \<close>
lemma maintain_S_precise_and_connected:
  assumes UNS: "u\<notin>S"
  assumes MIN: "\<forall>v. v\<notin>S \<longrightarrow> D u \<le> D v"
  shows "D u = \<delta> s u"
  text \<open>We start with a case distinction whether we are in the first
    step of the loop, where we process the start node, or in subsequent steps,
    where the start node has already been finished.\<close>
proof (cases "u=s")
  assume [simp]: "u=s" \<comment> \<open>First step of loop\<close>
  then show ?thesis using \<open>u\<notin>S\<close> s_in_S by simp
next
  assume \<open>u\<noteq>s\<close> \<comment> \<open>Later step of loop\<close>
  text \<open>The start node has already been finished\<close>
  with s_in_S MIN have \<open>s\<in>S\<close> apply clarsimp using infinity_ne_i0 by metis

  show ?thesis
  text \<open>Next, we handle the case that \<open>u\<close> is unreachable.\<close>
  proof (cases \<open>\<delta> s u < \<infinity>\<close>)
    assume "\<not>(\<delta> s u < \<infinity>)" \<comment> \<open>Node is unreachable (infinite distance)\<close>
    text \<open>By the upper-bound property, we get \<open>D u = \<delta> s u = \<infinity>\<close>\<close>
    then show ?thesis using upper_bound[of u] by auto
  next
    assume "\<delta> s u < \<infinity>" \<comment> \<open>Main case: Node has finite distance\<close>

    text \<open>Consider a shortest path from \<open>s\<close> to \<open>u\<close>\<close>
    obtain p where "path s p u" and DSU: "\<delta> s u = sum_list p"
      by (rule obtain_shortest_path)
    text \<open>It goes from inside \<open>S\<close> to outside \<open>S\<close>, so there must be an edge at the border.
      Let \<open>(x,y)\<close> be such an edge, with \<open>x\<in>S\<close> and \<open>y\<notin>S\<close>.\<close>
    from find_leave_edgeE[OF \<open>path s p u\<close> \<open>s\<in>S\<close> \<open>u\<notin>S\<close>] obtain p1 x y p2 where
      [simp]: "p = p1 @ w (x, y) # p2"
      and DECOMP: "x \<in> S" "y \<notin> S" "path s p1 x" "path y p2 u" .
    text \<open>As prefixes of shortest paths are again shortest paths, the shortest
          path to \<open>y\<close> ends with edge \<open>(x,y)\<close> \<close>
    have DSX: "\<delta> s x = sum_list p1" and DSY: "\<delta> s y = \<delta> s x + w (x, y)"
      using shortest_path_prefix[of s p1 x "w (x,y)#p2" u]
        and shortest_path_prefix[of s "p1@[w (x,y)]" y p2 u]
        and \<open>\<delta> s u < \<infinity>\<close> DECOMP
        by (force simp: DSU)+
    text \<open>Upon adding \<open>x\<close> to \<open>S\<close>, this edge has been relaxed with the precise
       estimate for \<open>x\<close>. At this point the estimate for \<open>y\<close> has become
       precise, too\<close>
    with \<open>x\<in>S\<close> have "D y = \<delta> s y"
      by (metis S_relaxed antisym_conv upper_bound)
    moreover text \<open>The shortest path to \<open>y\<close> is a prefix of that to \<open>u\<close>, thus
      it shorter or equal\<close>
    have "\<dots> \<le> \<delta> s u" using DSU by (simp add: DSX DSY)
    moreover text \<open>The estimate for \<open>u\<close> is an upper bound\<close>
    have "\<dots> \<le> D u" using upper_bound by (auto)
    moreover text \<open>\<open>u\<close> was a node with smallest estimate\<close>
    have "\<dots> \<le> D y" using \<open>u\<notin>S\<close> \<open>y\<notin>S\<close> MIN by auto
    ultimately text \<open>This closed a cycle in the inequation chain. Thus, by
      antisymmetry, all items are equal. In particular, \<open>D u = \<delta> s u\<close>, qed.\<close>
    show "D u = \<delta> s u" by simp
  qed
qed

text \<open>A step of Dijkstra's algorithm maintains the invariant.
  More precisely, in a step of Dijkstra's algorithm,
  we pick a node \<open>u\<notin>S\<close> with least finite estimate, relax the outgoing
  edges of \<open>u\<close>, and add \<open>u\<close> to \<open>S\<close>.\<close>
theorem maintain_D_invar:
  assumes UNS: "u\<notin>S"
  assumes UNI: "D u < \<infinity>"
  assumes MIN: "\<forall>v. v\<notin>S \<longrightarrow> D u \<le> D v"
  shows "D_invar (relax_outgoing u D) (Set.insert u S)"
  apply (cases \<open>s\<in>S\<close>)
  subgoal
    apply (unfold_locales)
    subgoal by (simp add: maintain_upper_bound)
    subgoal by simp
    subgoal
      using maintain_S_precise_and_connected[OF UNS MIN] S_precise
      by (auto simp: relax_precise_id)
    subgoal
      using maintain_S_precise_and_connected[OF UNS MIN]
      by (auto simp: relax_outgoing_def S_relaxed min.coboundedI1)
    done
  subgoal
    apply unfold_locales
    using s_in_S UNI distance_direct
    by (auto simp: relax_outgoing_def split: if_splits)
  done

text \<open>When the algorithm is finished, i.e., when there are
  no unfinished nodes with finite estimates left,
  then all estimates are accurate.\<close>
lemma invar_finish_imp_correct:
  assumes F: "\<forall>u. u\<notin>S \<longrightarrow> D u = \<infinity>"
  shows "D u = \<delta> s u"
proof (cases "u\<in>S")
  assume "u\<in>S" text \<open>The estimates of finished nodes are accurate\<close>
  then show ?thesis using S_precise by simp
next
  assume \<open>u\<notin>S\<close> text \<open>\<open>D u\<close> is minimal, and minimal estimates are precise\<close>
  then show ?thesis
    using F maintain_S_precise_and_connected[of u] by auto

qed

text \<open>A step decreases the set of unfinished nodes.\<close>
lemma unfinished_nodes_decr:
  assumes UNS: "u\<notin>S"
  assumes UNI: "D u < \<infinity>"
  shows "unfinished_dnodes (Set.insert u S) \<subset> unfinished_dnodes S"
proof -
  text \<open>There is a path to \<open>u\<close>\<close>
  from UNI have "\<delta> s u < \<infinity>" using upper_bound[of u] leD by fastforce

  text \<open>Thus, \<open>u\<close> is among \<open>all_dnodes\<close>\<close>
  have "u\<in>all_dnodes"
  proof -
    obtain p where "path s p u" "sum_list p < \<infinity>"
      apply (rule obtain_shortest_path[of s u])
      using \<open>\<delta> s u < \<infinity>\<close> by auto
    with \<open>u\<notin>S\<close> show ?thesis
      apply (cases p rule: rev_cases)
      by (auto simp: Dijkstra.all_dnodes_def)
  qed
  text \<open>Which implies the proposition\<close>
  with \<open>u\<notin>S\<close> show ?thesis by (auto simp: unfinished_dnodes_def)
qed

end

subsection \<open>Refinement by Priority Map and Map\<close>
text \<open>
  In a second step, we implement \<open>D\<close> and \<open>S\<close> by a priority map \<open>Q\<close> and a map \<open>V\<close>.
  Both map nodes to finite weights, where \<open>Q\<close> maps unfinished nodes, and \<open>V\<close>
  maps finished nodes.

  Note that this implementation is slightly non-standard:
  In the standard implementation, \<open>Q\<close> contains also unfinished nodes with
  infinite weight.

  We chose this implementation because it avoids enumerating all nodes of
  the graph upon initialization of \<open>Q\<close>.
  However, on relaxing an edge to a node not in \<open>Q\<close>, we require an extra
  lookup to check whether the node is finished.
\<close>

subsubsection \<open>Implementing \<open>enat\<close> by Option\<close>

text \<open>Our maps are functions to \<open>nat option\<close>,which are interpreted as \<open>enat\<close>,
  \<open>None\<close> being \<open>\<infinity>\<close>\<close>

fun enat_of_option :: "nat option \<Rightarrow> enat" where
  "enat_of_option None = \<infinity>"
| "enat_of_option (Some n) = enat n"

lemma enat_of_option_inj[simp]: "enat_of_option x = enat_of_option y \<longleftrightarrow> x=y"
  by (cases x; cases y; simp)

lemma enat_of_option_simps[simp]:
  "enat_of_option x = enat n \<longleftrightarrow> x = Some n"
  "enat_of_option x = \<infinity> \<longleftrightarrow> x = None"
  "enat n = enat_of_option x \<longleftrightarrow> x = Some n"
  "\<infinity> = enat_of_option x \<longleftrightarrow> x = None"
  by (cases x; auto; fail)+

lemma enat_of_option_le_conv:
  "enat_of_option m \<le> enat_of_option n \<longleftrightarrow> (case (m,n) of
      (_,None) \<Rightarrow> True
    | (Some a, Some b) \<Rightarrow> a\<le>b
    | (_, _) \<Rightarrow> False
  )"
  by (auto split: option.split)

subsubsection \<open>Implementing \<open>D,S\<close> by Priority Map and Map\<close>
context Dijkstra begin

text \<open>We define a coupling relation, that connects the concrete with the
  abstract data. \<close>
definition "coupling Q V D S \<equiv>
  D = enat_of_option o (V ++ Q)
\<and> S = dom V
\<and> dom V \<inter> dom Q = {}"

text \<open>Note that our coupling relation is functional.\<close>
(* TODO: Why not use functions instead? *)
lemma coupling_fun: "coupling Q V D S \<Longrightarrow> coupling Q V D' S' \<Longrightarrow> D'=D \<and> S'=S"
  by (auto simp: coupling_def)

text \<open>The concrete version of the invariant.\<close>
definition "D_invar' Q V \<equiv>
  \<exists>D S. coupling Q V D S \<and> D_invar D S"

text \<open>Refinement of \<open>relax-outgoing\<close>\<close>

definition "relax_outgoing' u du V Q v \<equiv>
  case w (u,v) of
    \<infinity> \<Rightarrow> Q v
  | enat d \<Rightarrow> (case Q v of
      None \<Rightarrow> if v\<in>dom V then None else Some (du+d)
    | Some d' \<Rightarrow> Some (min d' (du+d)))
"

text \<open>A step preserves the coupling relation.\<close>
lemma (in Dijkstra_Invar) coupling_step:
  assumes C: "coupling Q V D S"
  assumes UNS: "u\<notin>S"
  assumes UNI: "D u = enat du"

  shows "coupling
    ((relax_outgoing' u du V Q)(u:=None)) (V(u\<mapsto>du))
    (relax_outgoing u D) (Set.insert u S)"
  using C unfolding coupling_def
proof (intro ext conjI; elim conjE)
  assume \<alpha>: "D = enat_of_option \<circ> V ++ Q" "S = dom V"
     and DD: "dom V \<inter> dom Q = {}"

  show "Set.insert u S = dom (V(u \<mapsto> du))"
    by (auto simp: \<alpha>)

  have [simp]: "Q u = Some du" "V u = None"
    using DD UNI UNS by (auto simp: \<alpha>)

  from DD
  show "dom (V(u \<mapsto> du)) \<inter> dom ((relax_outgoing' u du V Q)(u := None)) = {}"
    by (auto 0 3
          simp: relax_outgoing'_def dom_def
          split: if_splits enat.splits option.splits)

  fix v

  show "relax_outgoing u D v
    = (enat_of_option \<circ> V(u \<mapsto> du) ++ (relax_outgoing' u du V Q)(u := None)) v"
  proof (cases "v\<in>S")
    case True
    then show ?thesis using DD
      apply (simp add: relax_finished_id)
      by (auto
        simp: relax_outgoing'_def map_add_apply \<alpha> min_def
        split: option.splits enat.splits)
  next
    case False
    then show ?thesis
      by (auto
        simp: relax_outgoing_def relax_outgoing'_def map_add_apply \<alpha> min_def
        split: option.splits enat.splits)
  qed
qed

text \<open>Refinement of initial state\<close>
definition "initQ \<equiv> Map.empty(s\<mapsto>0)"
definition "initV \<equiv> Map.empty"

lemma coupling_init:
  "coupling initQ initV initD initS"
  unfolding coupling_def initD_def initQ_def initS_def initV_def
  by (auto
    simp: coupling_def relax_outgoing_def map_add_apply enat_0
    split: option.split enat.split
    del: ext intro!: ext)

lemma coupling_cond:
  assumes "coupling Q V D S"
  shows "(Q = Map.empty) \<longleftrightarrow> (\<forall>u. u\<notin>S \<longrightarrow> D u = \<infinity>)"
  using assms
  by (fastforce simp add: coupling_def)

text \<open>Termination argument: Refinement of unfinished nodes.\<close>
definition "unfinished_dnodes' V \<equiv> unfinished_dnodes (dom V)"

lemma coupling_unfinished:
  "coupling Q V D S \<Longrightarrow> unfinished_dnodes' V = unfinished_dnodes S"
  by (auto simp: coupling_def unfinished_dnodes'_def unfinished_dnodes_def)

subsubsection \<open>Implementing graph by successor list\<close>

definition "relax_outgoing'' l du V Q = fold (\<lambda>(d,v) Q.
  case Q v of None \<Rightarrow> if v\<in>dom V then Q else Q(v\<mapsto>du+d)
            | Some d' \<Rightarrow> Q(v\<mapsto>min (du+d) d')) l Q"

lemma relax_outgoing''_refine:
  assumes "set l = {(d,v). w (u,v) = enat d}"
  shows "relax_outgoing'' l du V Q = relax_outgoing' u du V Q"
proof
  fix v

  have aux1:
     "relax_outgoing'' l du V Q v
     = (if v\<in>snd`set l then relax_outgoing' u du V Q v else Q v)"
  if "set l \<subseteq> {(d,v). w (u,v) = enat d}"
    using that
    apply (induction l arbitrary: Q v)
    by (auto
      simp: relax_outgoing''_def relax_outgoing'_def image_iff
      split!: if_splits option.splits)

  have aux2:
    "relax_outgoing' u du V Q v = Q v" if "w (u,v) = \<infinity>"
    using that by (auto simp: relax_outgoing'_def)

  show "relax_outgoing'' l du V Q v = relax_outgoing' u du V Q v"
    using aux1
    apply (cases "w (u,v)")
    by (all \<open>force simp: aux2 assms\<close>)
qed

end

end


section \<open>The Pointwise Less-Than Relation Between Two Sets\<close>

theory Nash_Extras
  imports "HOL-Library.Ramsey" "HOL-Library.Countable_Set"

begin

definition less_sets :: "['a::order set, 'a::order set] \<Rightarrow> bool" (infixr "\<lless>" 50)
    where "A \<lless> B \<equiv> \<forall>x\<in>A. \<forall>y\<in>B. x < y"

lemma less_sets_empty[iff]: "S \<lless> {}" "{} \<lless> T"
  by (auto simp: less_sets_def)

lemma less_setsD: "\<lbrakk>A \<lless> B; a \<in> A; b \<in> B\<rbrakk> \<Longrightarrow> a < b"
  by (auto simp: less_sets_def)

lemma less_sets_irrefl [simp]: "A \<lless> A \<longleftrightarrow> A = {}"
  by (auto simp: less_sets_def)

lemma less_sets_trans: "\<lbrakk>A \<lless> B; B \<lless> C; B \<noteq> {}\<rbrakk> \<Longrightarrow> A \<lless> C"
  unfolding less_sets_def using less_trans by blast

lemma less_sets_weaken1: "\<lbrakk>A' \<lless> B; A \<subseteq> A'\<rbrakk> \<Longrightarrow> A \<lless> B"
  by (auto simp: less_sets_def)

lemma less_sets_weaken2: "\<lbrakk>A \<lless> B'; B \<subseteq> B'\<rbrakk> \<Longrightarrow> A \<lless> B"
  by (auto simp: less_sets_def)

lemma less_sets_imp_disjnt: "A \<lless> B \<Longrightarrow> disjnt A B"
  by (auto simp: less_sets_def disjnt_def)

lemma less_sets_UN1: "less_sets (\<Union>\<A>) B \<longleftrightarrow> (\<forall>A\<in>\<A>. A \<lless> B)"
  by (auto simp: less_sets_def)

lemma less_sets_UN2: "less_sets A (\<Union> \<B>) \<longleftrightarrow> (\<forall>B\<in>\<B>. A \<lless> B)"
  by (auto simp: less_sets_def)

lemma less_sets_Un1: "less_sets (A \<union> A') B \<longleftrightarrow> A \<lless> B \<and> A' \<lless> B"
  by (auto simp: less_sets_def)

lemma less_sets_Un2: "less_sets A (B \<union> B') \<longleftrightarrow> A \<lless> B \<and> A \<lless> B'"
  by (auto simp: less_sets_def)

lemma strict_sorted_imp_less_sets:
  "strict_sorted (as @ bs) \<Longrightarrow> (list.set as) \<lless> (list.set bs)"
  by (simp add: less_sets_def sorted_wrt_append)

lemma Sup_nat_less_sets_singleton:
  fixes n::nat
  assumes "Sup T < n" "finite T"
  shows "less_sets T {n}"
  using assms Max_less_iff
  by (auto simp: Sup_nat_def less_sets_def split: if_split_asm)

end


(*  Title:      Depth-First Search
    Author:     Toshiaki Nishihara and Yasuhiko Minamide
    Maintainer: Yasuhiko Minamide <minamide at cs.tsukuba.ac.jp>
*)

section "Depth-First Search"

theory DFS
imports Main "Eval_Base.Eval_Base"
begin

subsection "Definition of Graphs"

typedecl node
type_synonym graph = "(node * node) list"

primrec nexts :: "[graph, node] \<Rightarrow> node list"
where
  "nexts [] n = []"
| "nexts (e#es) n = (if fst e = n then snd e # nexts es n else nexts es n)"

definition nextss :: "[graph, node list] \<Rightarrow> node set"
  where "nextss g xs = set g `` set xs"

lemma nextss_Cons: "nextss g (x#xs) = set (nexts g x) \<union> nextss g xs"
  unfolding nextss_def by (auto simp add:Image_def nexts_set)

definition reachable :: "[graph, node list] \<Rightarrow> node set"
  where "reachable g xs = (set g)\<^sup>* `` set xs"

subsection "Depth-First Search with Stack"

definition nodes_of :: "graph \<Rightarrow> node set"
  where "nodes_of g = set (map fst g @ map snd g)"

lemma [simp]: "finite (nodes_of g - set ys)"
proof(rule finite_subset)
  show "finite (nodes_of g)"
    by (auto simp add: nodes_of_def)
qed (auto)

function
  dfs :: "graph \<Rightarrow> node list \<Rightarrow> node list \<Rightarrow> node list"
where
  dfs_base: "dfs g [] ys = ys"
| dfs_inductive: "dfs g (x#xs) ys = (if List.member ys x then dfs g xs ys
                        else dfs g (nexts g x@xs) (x#ys))"
by pat_completeness auto

termination
apply (relation "inv_image (finite_psubset <*lex*> less_than)
                   (\<lambda>(g,xs,ys). (nodes_of g - set ys, size xs))")
apply auto[1]
apply (simp_all add: finite_psubset_def)
by (case_tac  "x \<in> nodes_of g") (auto simp add: List.member_def)

text \<open>
  \begin{itemize}
  \item The second argument of \isatext{\isastyle{dfs}} is a stack of nodes that will be
  visited.
  \item The third argument of \isatext{\isastyle{dfs}} is a list of nodes that have
  been visited already.
  \end{itemize}
\<close>

subsection "Depth-First Search with Nested-Recursion"

function
  dfs2 :: "graph \<Rightarrow> node list \<Rightarrow> node list \<Rightarrow> node list"
where
  "dfs2 g [] ys = ys"
|  dfs2_inductive:
          "dfs2 g (x#xs) ys = (if List.member ys x then dfs2 g xs ys
                               else dfs2 g xs (dfs2 g (nexts g x) (x#ys)))"
by pat_completeness auto

lemma dfs2_invariant: "dfs2_dom (g, xs, ys) \<Longrightarrow> set ys \<subseteq> set (dfs2 g xs ys)"
apply2 (induct g xs ys rule: dfs2.pinduct) by(force simp add: dfs2.psimps)+

termination dfs2
apply (relation "inv_image (finite_psubset <*lex*> less_than)
                   (\<lambda>(g,xs,ys). (nodes_of g - set ys, size xs))")
apply auto[1]
apply (simp_all add: finite_psubset_def)
apply (case_tac  "x \<in> nodes_of g")
apply (auto simp add: List.member_def)[2]
by (insert dfs2_invariant) force

(*lemma dfs2_induct[induct type]:
  assumes B: "\<And>g ys. P g [] ys" and
  H: "\<And>g x xs ys.
        \<lbrakk>\<not> x mem ys \<longrightarrow> P g xs (dfs2 (g, nexts g x, x # ys));
         \<not> x mem ys \<longrightarrow> P g (nexts g x) (x # ys); x mem ys \<longrightarrow> P g xs ys\<rbrakk>
         \<Longrightarrow> P g (x # xs) ys"
  shows "P u v w"

proof (induct u v w rule: dfs2.induct)
  case 1 show ?case by (rule B)
next
  case (2 g x xs ys)
  show ?case
  proof (rule H)
    show "\<not> x mem ys \<longrightarrow> P g xs (dfs2 (g, nexts g x, x # ys))"
    proof
      assume *: "\<not> x mem ys"
      have "set (x#ys) \<subseteq> set (dfs2 (g, nexts g x, x # ys))"
        by (rule dfs2_inv)
      with 2 * show "P g xs (dfs2 (g, nexts g x, x # ys))"
        by auto
    qed
  qed (rule 2)+
qed
*)

lemma dfs_app: "dfs g (xs@ys) zs = dfs g ys (dfs g xs zs)"
  apply2 (induct g xs zs rule: dfs.induct) by auto

lemma "dfs2 g xs ys = dfs g xs ys"
  apply2 (induct g xs ys rule: dfs2.induct) by(auto simp add: dfs_app)

subsection "Basic Properties"

lemma visit_subset_dfs: "set ys \<subseteq> set (dfs g xs ys)"
  apply2 (induct g xs ys rule: dfs.induct) by auto

lemma next_subset_dfs: "set xs \<subseteq> set (dfs g xs ys)"
proof2(induct g xs ys rule:dfs.induct)
  case(2 g x xs ys)
  show ?case
  proof(cases "x \<in> set ys")
    case True
    have "set ys \<subseteq> set (dfs g xs ys)"
      by (rule visit_subset_dfs)
    with 2 and True show ?thesis
      by (auto simp add: List.member_def)
  next
    case False
    have "set (x#ys) \<subseteq> set (dfs g (nexts g x @ xs) (x#ys))"
      by(rule visit_subset_dfs)
    with 2 and False show ?thesis
      by (auto simp add: List.member_def)
  qed
qed(simp)

lemma nextss_closed_dfs'[rule_format]:
 "nextss g ys \<subseteq> set xs \<union> set ys \<longrightarrow> nextss g (dfs g xs ys) \<subseteq> set (dfs g xs ys)"
  apply2 (induct g xs ys rule:dfs.induct) by(auto simp add:nextss_Cons List.member_def)

lemma nextss_closed_dfs: "nextss g (dfs g xs []) \<subseteq> set (dfs g xs [])"
  by (rule nextss_closed_dfs', simp add: nextss_def)

lemma Image_closed_trancl: assumes "r `` X \<subseteq> X" shows "r\<^sup>* `` X = X"
proof
  show "r\<^sup>* `` X \<subseteq> X"
  proof -
    {
      fix x y
      assume y: "y \<in> X"
      assume "(y,x) \<in> r\<^sup>*"
      then have "x \<in> X"
        apply2 (induct) by(insert assms y, auto simp add: Image_def)
    }
    then show ?thesis unfolding Image_def by auto
  qed
qed auto

lemma reachable_closed_dfs: "reachable g xs \<subseteq> set(dfs g xs [])"
proof -
  have "reachable g xs \<subseteq> reachable g (dfs g xs [])"
    unfolding reachable_def by (rule Image_mono) (auto simp add: next_subset_dfs)
  also have "\<dots> = set(dfs g xs [])"
    unfolding reachable_def
  proof (rule Image_closed_trancl)
    from nextss_closed_dfs
    show "set g `` set (dfs g xs []) \<subseteq> set (dfs g xs [])"
      by (simp add: nextss_def)
  qed
  finally show ?thesis .
qed

lemma reachable_nexts: "reachable g (nexts g x) \<subseteq> reachable g [x]"
  unfolding reachable_def
  by (auto intro: converse_rtrancl_into_rtrancl simp: nexts_set)

lemma reachable_append: "reachable g (xs @ ys) = reachable g xs \<union> reachable g ys"
  unfolding reachable_def by auto

lemma dfs_subset_reachable_visit_nodes: "set (dfs g xs ys) \<subseteq> reachable g xs \<union> set ys"
proof2(induct g xs ys rule: dfs.induct)
  case 1
  then show ?case by simp
next
  case (2 g x xs ys)
  show ?case
  proof (cases "x \<in> set ys")
    case True
    with 2 show "set (dfs g (x#xs) ys) \<subseteq> reachable g (x#xs) \<union> set ys"
      by (auto simp add: reachable_def List.member_def)
  next
    case False
    have "reachable g (nexts g x) \<subseteq> reachable g [x]"
      by (rule reachable_nexts)
    hence a: "reachable g (nexts g x @ xs) \<subseteq> reachable g (x#xs)"
      by(simp add: reachable_append, auto simp add: reachable_def)
    with False 2
    show "set (dfs g (x#xs) ys) \<subseteq> reachable g (x#xs) \<union> set ys"
      by (auto simp add: reachable_def List.member_def)
  qed
qed

subsection "Correctness"

theorem dfs_eq_reachable: "set (dfs g xs []) = reachable g xs"
proof
  have "set (dfs g xs []) \<subseteq> reachable g xs \<union> set []"
    by (rule dfs_subset_reachable_visit_nodes[of g xs "[]"])
 thus "set (dfs g xs []) \<subseteq> reachable g xs"
   by simp
qed(rule reachable_closed_dfs)

theorem "y \<in> set (dfs g [x] []) = ((x,y) \<in> (set g)\<^sup>*)"
  by(simp only:dfs_eq_reachable reachable_def, auto)

subsection "Executable Code"

consts Node :: "int \<Rightarrow> node"

code_datatype Node

instantiation node :: equal
begin

definition equal_node :: "node \<Rightarrow> node \<Rightarrow> bool"
where
  [code del]: "equal_node = HOL.eq"

instance proof
qed (simp add: equal_node_def)

end

declare [[code abort: "HOL.equal :: node \<Rightarrow> node \<Rightarrow> bool"]]

export_code dfs dfs2 in SML file \<open>dfs.ML\<close>

end


(******************************************************************************)
(* Submission: "The Interchange Law: A Principle of Concurrent Programming"   *)
(* Authors: Tony Hoare, Bernard Möller, Georg Struth, and Frank Zeyda         *)
(* File: Machine_Number.thy                                                   *)
(******************************************************************************)
(* LAST REVIEWED: 11 July 2017 *)

section {* Machine Numbers *}

theory Machine_Number
imports Preliminaries
begin

subsection {* Type Class *}

text \<open>
  Machine numbers are introduced via a type class \<open>machine_number\<close>. The class
  extends a linear order by including a constant \<open>max_number\<close> that yields the
  largest representable number.
\<close>

class machine_number = linorder +
  fixes max_number :: "'a"
begin

text \<open>All numbers less or equal to @{const max_number} are within range.\<close>

definition number_range :: "'a set" where
[simp]: "number_range = {x. x \<le> max_number}"
end

text \<open>We can easily prove that @{const number_range} is a non-empty set.\<close>

lemma ex_leq_max_number:
"\<exists>x. x \<le> max_number"
apply (rule_tac x = "max_number" in exI)
apply (rule order_refl)
done

lemma ex_in_number_range:
"\<exists>x. x \<in> number_range"
apply (clarsimp)
apply (rule ex_leq_max_number)
done

subsection {* Type Definition *}

text \<open>The above lemma enables us to introduce a type for representable numbers.\<close>

typedef (overloaded)
  'a::machine_number machine_number = "number_range::'a set"
apply (rule ex_in_number_range)
done

text \<open>The notation \<open>MN(_)\<close> will be used for the abstraction function.\<close>

notation Abs_machine_number ("MN'(_')")

text \<open>The notation \<open>\<lbrakk>_\<rbrakk>\<close> will be used for the representation function.\<close>

notation Rep_machine_number ("\<lbrakk>_\<rbrakk>")

setup_lifting type_definition_machine_number

subsection {* Proof Support *}

lemmas Rep_machine_number_inject_sym = sym [OF Rep_machine_number_inject]

declare Abs_machine_number_inverse
  [simplified number_range_def mem_Collect_eq, simp]

declare Rep_machine_number_inverse
  [simplified number_range_def mem_Collect_eq, simp]

declare Abs_machine_number_inject
  [simplified number_range_def mem_Collect_eq, simp]

declare Rep_machine_number_inject_sym
  [simplified number_range_def mem_Collect_eq, simp]

subsection {* Instantiations *}

subsubsection {* Linear Order *}

instantiation machine_number :: (machine_number) linorder
begin
definition less_eq_machine_number ::
  "'a machine_number \<Rightarrow> 'a machine_number \<Rightarrow> bool" where
[simp]: "less_eq_machine_number x y \<longleftrightarrow> \<lbrakk>x\<rbrakk> \<le> \<lbrakk>y\<rbrakk>"

definition less_machine_number ::
  "'a machine_number \<Rightarrow> 'a machine_number \<Rightarrow> bool" where
[simp]: "less_machine_number x y \<longleftrightarrow> \<lbrakk>x\<rbrakk> < \<lbrakk>y\<rbrakk>"
instance
apply (intro_classes)
apply (unfold less_eq_machine_number_def less_machine_number_def)
-- {* Subgoal 1 *}
apply (transfer')
apply (rule less_le_not_le)
-- {* Subgoal 2 *}
apply (transfer')
apply (rule order_refl)
-- {* Subgoal 3 *}
apply (transfer')
apply (erule order_trans)
apply (assumption)
-- {* Subgoal 4 *}
apply (transfer')
apply (erule antisym)
apply (assumption)
-- {* Subgoal 5 *}
apply (transfer')
apply (rule linear)
done
end

subsubsection {* Arithmetic Operators *}

instantiation machine_number :: ("{machine_number, zero}") zero
begin
definition zero_machine_number :: "'a machine_number" where
[simp]: "zero_machine_number = MN(0)"
instance ..
end

instantiation machine_number :: ("{machine_number, one}") one
begin
definition one_machine_number :: "'a machine_number" where
[simp]: "one_machine_number = MN(1)"
instance ..
end

instantiation machine_number :: ("{machine_number, plus}") plus
begin
definition plus_machine_number :: "'a machine_number binop" where
[simp]: "plus_machine_number x y = MN(\<lbrakk>x\<rbrakk> + \<lbrakk>y\<rbrakk>)"
instance ..
end

instantiation machine_number :: ("{machine_number, minus}") minus
begin
definition minus_machine_number :: "'a machine_number binop" where
[simp]: "minus_machine_number x y = MN(\<lbrakk>x\<rbrakk> - \<lbrakk>y\<rbrakk>)"
instance ..
end

instantiation machine_number :: ("{machine_number, times}") times
begin
definition times_machine_number :: "'a machine_number binop" where
[simp]: "times_machine_number x y = MN(\<lbrakk>x\<rbrakk> * \<lbrakk>y\<rbrakk>)"
instance ..
end

instantiation machine_number :: ("{machine_number, divide}") divide
begin
definition divide_machine_number :: "'a machine_number binop" where
[simp]: "divide_machine_number x y = MN(\<lbrakk>x\<rbrakk> div \<lbrakk>y\<rbrakk>)"
instance ..
end
end


section \<open>Young's Inequality for Increasing Functions\<close>

text \<open>From the following paper:
Cunningham, F., and Nathaniel Grossman. “On Young’s Inequality.”
The American Mathematical Monthly 78, no. 7 (1971): 781–83.
\url{https://doi.org/10.2307/2318018}\<close>

theory Youngs imports
  "HOL-Analysis.Analysis"

begin

subsection \<open>Library Extras: already added to the repository\<close>

text \<open>In fact, strict inequality is required only at a single point within the box.\<close>
lemma integral_less:
  fixes f :: "'n::euclidean_space \<Rightarrow> real"
  assumes cont: "continuous_on (cbox a b) f" "continuous_on (cbox a b) g" and ne: "box a b \<noteq> {}"
    and fg: "\<And>x. x \<in> box a b \<Longrightarrow> f x < g x"
  shows "integral (cbox a b) f < integral (cbox a b) g"
proof -
  obtain int: "f integrable_on (cbox a b)" "g integrable_on (cbox a b)"
    using cont integrable_continuous by blast
  then have "integral (cbox a b) f \<le> integral (cbox a b) g"
    by (metis fg integrable_on_open_interval integral_le integral_open_interval less_eq_real_def)
  moreover have "integral (cbox a b) f \<noteq> integral (cbox a b) g"
  proof (rule ccontr)
    assume "\<not> integral (cbox a b) f \<noteq> integral (cbox a b) g"
    then have 0: "((\<lambda>x. g x - f x) has_integral 0) (cbox a b)"
      by (metis (full_types) cancel_comm_monoid_add_class.diff_cancel has_integral_diff int
                integrable_integral)
    have cgf: "continuous_on (cbox a b) (\<lambda>x. g x - f x)"
      using cont continuous_on_diff by blast
    show False
      using has_integral_0_cbox_imp_0 [OF cgf _ 0] ne box_subset_cbox fg by fastforce
  qed
  ultimately show ?thesis
    by linarith
qed

lemma integral_less_real:
  fixes f :: "real \<Rightarrow> real"
  assumes "continuous_on {a..b} f" "continuous_on {a..b} g" and "{a<..<b} \<noteq> {}"
    and "\<And>x. x \<in> {a<..<b} \<Longrightarrow> f x < g x"
  shows "integral {a..b} f < integral {a..b} g"
  by (metis assms box_real integral_less)

lemma has_integral_UN:
  fixes f :: "'n::euclidean_space \<Rightarrow> 'a::banach"
  assumes "finite I"
    and int: "\<And>i. i \<in> I \<Longrightarrow> (f has_integral (g i)) (\<T> i)"
    and neg: "pairwise (\<lambda>i i'. negligible (\<T> i \<inter> \<T> i')) I"
  shows "(f has_integral (sum g I)) (\<Union>i\<in>I. \<T> i)"
proof -
  let ?\<U> = "((\<lambda>(a,b). \<T> a \<inter> \<T> b) ` {(a,b). a \<in> I \<and> b \<in> I-{a}})"
  have "((\<lambda>x. if x \<in> (\<Union>i\<in>I. \<T> i) then f x else 0) has_integral sum g I) UNIV"
  proof (rule has_integral_spike)
    show "negligible (\<Union>?\<U>)"
    proof (rule negligible_Union)
      have "finite (I \<times> I)"
        by (simp add: \<open>finite I\<close>)
      moreover have "{(a,b). a \<in> I \<and> b \<in> I-{a}} \<subseteq> I \<times> I"
        by auto
      ultimately show "finite ?\<U>"
        by (simp add: finite_subset)
      show "\<And>t. t \<in> ?\<U> \<Longrightarrow> negligible t"
        using neg unfolding pairwise_def by auto
    qed
  next
    show "(if x \<in> (\<Union>i\<in>I. \<T> i) then f x else 0) = (\<Sum>i\<in>I. if x \<in> \<T> i then f x else 0)"
      if "x \<in> UNIV - (\<Union>?\<U>)" for x
    proof clarsimp
      fix i assume i: "i \<in> I" "x \<in> \<T> i"
      then have "\<forall>j\<in>I. x \<in> \<T> j \<longleftrightarrow> j = i"
        using that by blast
      with i show "f x = (\<Sum>i\<in>I. if x \<in> \<T> i then f x else 0)"
        by (simp add: sum.delta[OF \<open>finite I\<close>])
    qed
  next
    show "((\<lambda>x. (\<Sum>i\<in>I. if x \<in> \<T> i then f x else 0)) has_integral sum g I) UNIV"
      using int by (simp add: has_integral_restrict_UNIV has_integral_sum[OF \<open>finite I\<close>])
  qed
  then show ?thesis
    using has_integral_restrict_UNIV by blast
qed

lemma integrable_mono_on_nonneg:
  fixes f :: "real \<Rightarrow> real"
  assumes mon: "mono_on {a..b} f" and 0: "\<And>x. 0 \<le> f x"
  shows "integrable (lebesgue_on {a..b}) f"
proof -
  have "space lborel = space lebesgue" "sets borel \<subseteq> sets lebesgue"
    by force+
  then have fborel: "f \<in> borel_measurable (lebesgue_on {a..b})"
    by (metis mon borel_measurable_mono_on_fnc borel_measurable_subalgebra mono_restrict_space
              space_lborel space_restrict_space)
  then obtain g where g: "incseq g" and simple: "\<And>i. simple_function (lebesgue_on {a..b}) (g i)"
                and bdd: " (\<forall>x. bdd_above (range (\<lambda>i. g i x)))" and nonneg: "\<forall>i x. 0 \<le> g i x"
                and fsup: "f = (SUP i. g i)"
    by (metis borel_measurable_implies_simple_function_sequence_real 0)
  have "f ` {a..b} \<subseteq> {f a..f b}"
    using assms by (auto simp: mono_on_def)
  have g_le_f: "g i x \<le> f x" for i x
  proof -
    have "bdd_above ((\<lambda>h. h x) ` range g)"
      using bdd cSUP_lessD linorder_not_less by fastforce
    then show ?thesis
      by (metis SUP_apply UNIV_I bdd cSUP_upper fsup)
  qed
  then have gfb: "g i x \<le> f b" if "x \<in> {a..b}" for i x
    by (smt (verit, best) mon atLeastAtMost_iff mono_on_def that)
  have g_le: "g i x \<le> g j x" if "i\<le>j"  for i j x
    using g by (simp add: incseq_def le_funD that)
  show "integrable (lebesgue_on {a..b}) ( f)"
  proof (rule integrable_dominated_convergence)
    show "f \<in> borel_measurable (lebesgue_on {a..b})"
      using fborel by blast
    have "\<And>x. (\<lambda>i. g i x) \<longlonglongrightarrow> (SUP h \<in> range g. h  x)"
    proof (rule order_tendstoI)
      show "\<forall>\<^sub>F i in sequentially. y < g i x"
        if "y < (SUP h\<in>range g. h x)" for x y
      proof -
        from that obtain h where h: "h \<in> range g" "y < h x"
          using g_le_f by (subst (asm)less_cSUP_iff) fastforce+
        then show ?thesis
          by (smt (verit, ccfv_SIG) eventually_sequentially g_le imageE)
      qed
      show "\<forall>\<^sub>F i in sequentially. g i x < y"
        if "(SUP h\<in>range g. h x) < y" for x y
        by (smt (verit, best) that Sup_apply g_le_f always_eventually fsup image_cong)
    qed
    then show "AE x in lebesgue_on {a..b}. (\<lambda>i. g i x) \<longlonglongrightarrow> f x"
      by (simp add: fsup)
    fix i
    show "g i \<in> borel_measurable (lebesgue_on {a..b})"
      using borel_measurable_simple_function simple by blast
    show "AE x in lebesgue_on {a..b}. norm (g i x) \<le> f b"
      by (simp add: gfb nonneg Measure_Space.AE_I' [of "{}"])
  qed auto
qed

lemma integrable_mono_on:
  fixes f :: "real \<Rightarrow> real"
  assumes "mono_on {a..b} f"
  shows "integrable (lebesgue_on {a..b}) f"
proof -
  define f' where "f' \<equiv> \<lambda>x. if x \<in> {a..b} then f x - f a else 0"
  have "mono_on {a..b} f'"
    by (smt (verit, best) assms f'_def mono_on_def)
  moreover have 0: "\<And>x. 0 \<le> f' x"
    by (smt (verit, best) assms atLeastAtMost_iff f'_def mono_on_def)
  ultimately have "integrable (lebesgue_on {a..b}) f'"
    using integrable_mono_on_nonneg by presburger
  then have "integrable (lebesgue_on {a..b}) (\<lambda>x. f' x + f a)"
    by force
  moreover have "space lborel = space lebesgue" "sets borel \<subseteq> sets lebesgue"
    by force+
  then have fborel: "f \<in> borel_measurable (lebesgue_on {a..b})"
    using borel_measurable_mono_on_fnc [OF assms]
    by (metis borel_measurable_subalgebra mono_restrict_space space_lborel space_restrict_space)
  ultimately show ?thesis
    by (rule integrable_cong_AE_imp) (auto simp: f'_def)
qed

lemma integrable_on_mono_on:
  fixes f :: "real \<Rightarrow> real"
  assumes "mono_on {a..b} f"
  shows "f integrable_on {a..b}"
  by (simp add: assms integrable_mono_on integrable_on_lebesgue_on)

lemma strict_mono_image_endpoints:
  fixes f :: "'a::linear_continuum_topology \<Rightarrow> 'b::linorder_topology"
  assumes "strict_mono_on {a..b} f" and f: "continuous_on {a..b} f" and "a \<le> b"
  shows "f ` {a..b} = {f a..f b}"
proof
  show "f ` {a..b} \<subseteq> {f a..f b}"
    using assms(1) strict_mono_on_leD by fastforce
  show "{f a..f b} \<subseteq> f ` {a..b}"
    using assms IVT'[OF _ _ _ f] by (force simp: Bex_def)
qed

subsection \<open>Toward Young's inequality\<close>

text \<open>Generalisations of the type of @{term f} are not obvious\<close>
lemma strict_mono_continuous_invD:
  fixes f :: "real \<Rightarrow> real"
  assumes sm: "strict_mono_on {a..} f" and contf: "continuous_on {a..} f"
    and fim: "f ` {a..} = {f a..}" and g: "\<And>x. x \<ge> a \<Longrightarrow> g (f x) = x"
  shows "continuous_on {f a..} g"
proof (clarsimp simp add: continuous_on_eq_continuous_within)
  fix y
  assume "f a \<le> y"
  then obtain u where u: "y+1 = f u" "u \<ge> a"
    by (smt (verit, best) atLeast_iff fim imageE)
  have "continuous_on {f a..y+1} g"
  proof -
    obtain "continuous_on {a..u} f"  "strict_mono_on {a..u} f"
      using contf sm continuous_on_subset by (force simp add: strict_mono_on_def)
    moreover have "continuous_on (f ` {a..u}) g"
      using assms continuous_on_subset
      by (intro continuous_on_inv) fastforce+
    ultimately show ?thesis
      using strict_mono_image_endpoints [of _ _ f]
      by (simp add: strict_mono_image_endpoints u)
  qed
  then have *: "continuous (at y within {f a..y+1}) g"
    by (simp add: \<open>f a \<le> y\<close> continuous_on_imp_continuous_within)
  show "continuous (at y within {f a..}) g"
  proof (clarsimp simp add: continuous_within_topological Ball_def)
    fix B
    assume "open B" and "g y \<in> B"
    with * obtain A where A: "open A" "y \<in> A" and "\<And>x. f a \<le> x \<and> x \<le> y+1 \<Longrightarrow> x \<in> A \<longrightarrow> g x \<in> B"
      by (force simp: continuous_within_topological)
    then have "\<forall>x\<ge>f a. x \<in> A \<inter> ball y 1 \<longrightarrow> g x \<in> B"
      by (smt (verit, ccfv_threshold) IntE dist_norm mem_ball real_norm_def)
    then show "\<exists>A. open A \<and> y \<in> A \<and> (\<forall>x\<ge>f a. x \<in> A \<longrightarrow> g x \<in> B)"
      by (metis Elementary_Metric_Spaces.open_ball Int_iff A centre_in_ball open_Int zero_less_one)
  qed
qed

subsection \<open>Regular divisions\<close>

text \<open>Our lack of the Riemann integral forces us to construct explicitly
the step functions mentioned in the text.\<close>

definition "segment \<equiv> \<lambda>n k. {real k / real n..(1 + k) / real n}"

lemma segment_nonempty: "segment n k \<noteq> {}"
  by (auto simp: segment_def divide_simps)

lemma segment_Suc: "segment n ` {..<Suc k} = insert {k/n..(1 + real k) / n} (segment n ` {..<k})"
  by (simp add: segment_def lessThan_Suc)

lemma Union_segment_image: "\<Union> (segment n ` {..<k}) = (if k=0 then {} else {0..real k/real n})"
proof (induction k)
  case (Suc k)
  then show ?case
    by (simp add: divide_simps segment_Suc Un_commute ivl_disj_un_two_touch split: if_split_asm)
qed (auto simp: segment_def)

definition "segments \<equiv> \<lambda>n. segment n ` {..<n}"

lemma card_segments [simp]: "card (segments n) = n"
  by (simp add: segments_def segment_def card_image divide_right_mono inj_on_def)

lemma segments_0 [simp]: "segments 0 = {}"
  by (simp add: segments_def)

lemma Union_segments: "\<Union> (segments n) = (if n=0 then {} else {0..1})"
  by (simp add: segments_def Union_segment_image)

definition "regular_division \<equiv> \<lambda>a b n. (image ((+) a \<circ> (*) (b-a))) ` (segments n)"

lemma translate_scale_01:
  assumes "a \<le> b"
  shows "(\<lambda>x. a + (b - a) * x) ` {0..1} = {a..b::real}"
  using closed_segment_real_eq [of a b] assms closed_segment_eq_real_ivl by auto

lemma finite_regular_division [simp]: "finite (regular_division a b n)"
  by (simp add: regular_division_def segments_def)

lemma card_regular_division [simp]:
  assumes "a<b"
  shows "card (regular_division a b n) = n"
proof -
  have "inj_on ((`) ((+) a \<circ> (*) (b - a))) (segments n)"
  proof
    fix x y
    assume "((+) a \<circ> (*) (b - a)) ` x = ((+) a \<circ> (*) (b - a)) ` y"
    then have "(+) (-a) ` ((+) a \<circ> (*) (b - a)) ` x = (+) (-a) ` ((+) a \<circ> (*) (b - a)) ` y"
      by simp
    then have "((*) (b - a)) ` x = ((*) (b - a)) ` y"
      by (simp add: image_comp)
    then have "(*) (inverse(b - a)) ` (*) (b - a) ` x = (*) (inverse(b - a)) ` (*) (b - a) ` y"
      by simp
    then show "x = y"
      using assms by (simp add: image_comp mult_ac)
  qed
  then show ?thesis
    by (metis card_image card_segments regular_division_def)
qed

lemma Union_regular_division:
  assumes "a \<le> b"
  shows "\<Union>(regular_division a b n) = (if n=0 then {} else {a..b})"
  using assms
  by (auto simp: regular_division_def Union_segments translate_scale_01 simp flip: image_Union)

lemma regular_division_eqI:
  assumes K: "K = {a + (b-a)*(real k / n) .. a + (b-a)*((1 + real k) / n)}"
    and "a<b" "k < n"
  shows "K \<in> regular_division a b n"
  unfolding regular_division_def segments_def image_comp
proof
  have "K = (\<lambda>x. (b-a) * x + a) ` {real k / real n..(1 + real k) / real n}"
    using K \<open>a<b\<close> by (simp add: image_affinity_atLeastAtMost divide_simps)
  then show "K = ((`) ((+) a \<circ> (*) (b - a)) \<circ> segment n) k"
    by (simp add: segment_def add.commute)
qed (use assms in auto)

lemma regular_divisionE:
  assumes "K \<in> regular_division a b n" "a<b"
  obtains k where "k<n" "K = {a + (b-a)*(real k / n) .. a + (b-a)*((1 + real k) / n)}"
proof -
  have eq: "(\<lambda>x. a + (b - a) * x) = (\<lambda>x. a + x) \<circ> (\<lambda>x. (b - a) * x)"
    by (simp add: o_def)
  obtain k where "k<n" "K = ((\<lambda>x. a+x) \<circ> (\<lambda>x. (b-a) * x)) ` {k/n .. (1 + real k) / n}"
    using assms by (auto simp: regular_division_def segments_def segment_def)
  with that \<open>a<b\<close> show ?thesis
    unfolding image_comp [symmetric]  by auto
qed

lemma regular_division_division_of:
  assumes "a < b" "n>0"
  shows "(regular_division a b n) division_of {a..b}"
proof (rule division_ofI)
  show "finite (regular_division a b n)"
    by (simp add: regular_division_def segments_def)
  show \<section>: "\<Union> (regular_division a b n) = {a..b}"
    using Union_regular_division assms by simp
  fix K
  assume K: "K \<in> regular_division a b n"
  then obtain k where Keq: "K = {a + (b-a)*(k/n) .. a + (b-a)*((1 + real k) / n)}"
    using \<open>a<b\<close> regular_divisionE by meson
  show "K \<subseteq> {a..b}"
    using K Union_regular_division \<open>n>0\<close> by (metis Union_upper \<section>)
  show "K \<noteq> {}"
    using K by (auto simp: regular_division_def segment_nonempty segments_def)
  show "\<exists>a b. K = cbox a b"
    by (metis K \<open>a<b\<close> box_real(2) regular_divisionE)
  fix K'
  assume K': "K' \<in> regular_division a b n" and "K \<noteq> K'"
  then obtain k' where Keq': "K' = {a + (b-a)*(k'/n) .. a + (b-a)*((1 + real k') / n)}"
    using K \<open>a<b\<close> regular_divisionE by meson
  consider "1 + real k \<le> k'" | "1 + real k' \<le> k"
    using Keq Keq' \<open>K \<noteq> K'\<close> by force
  then show "interior K \<inter> interior K' = {}"
  proof cases
    case 1
    then show ?thesis
      by (simp add: Keq Keq' min_def max_def divide_right_mono assms)
  next
    case 2
    then have "interior K' \<inter> interior K = {}"
      by (simp add: Keq Keq' min_def max_def divide_right_mono assms)
    then show ?thesis
      by (simp add: inf_commute)
  qed
qed

subsection \<open>Special cases of Young's inequality\<close>

lemma weighted_nesting_sum:
  fixes g :: "nat \<Rightarrow> 'a::comm_ring_1"
  shows "(\<Sum>k<n. (1 + of_nat k) * (g (Suc k) - g k)) = of_nat n * g n - (\<Sum>i<n. g i)"
  by (induction n) (auto simp: algebra_simps)

theorem Youngs_exact:
  fixes f :: "real \<Rightarrow> real"
  assumes sm: "strict_mono_on {0..} f" and cont: "continuous_on {0..} f" and a: "a\<ge>0"
    and f: "f 0 = 0" "f a = b"
    and g: "\<And>x. \<lbrakk>0 \<le> x; x \<le> a\<rbrakk> \<Longrightarrow> g (f x) = x"
  shows "a*b = integral {0..a} f + integral {0..b} g"
proof (cases "a=0")
  case False
  with \<open>a \<ge> 0\<close> have "a > 0" by linarith
  then have "b \<ge> 0"
    by (smt (verit, best) atLeast_iff f sm strict_mono_onD)
  have sm_0a: "strict_mono_on {0..a} f"
    by (metis atLeastAtMost_iff atLeast_iff sm strict_mono_on_def)
  have cont_0a: "continuous_on {0..a} f"
    using cont continuous_on_subset by fastforce
  with sm_0a have "continuous_on {0..b} g"
    by (metis a atLeastAtMost_iff compact_Icc continuous_on_inv f g strict_mono_image_endpoints)
  then have intgb_g: "g integrable_on {0..b}"
    using integrable_continuous_interval by blast
  have intgb_f: "f integrable_on {0..a}"
    using cont_0a integrable_continuous_real by blast

  have f_iff [simp]: "f x < f y \<longleftrightarrow> x < y" "f x \<le> f y \<longleftrightarrow> x \<le> y"
    if "x \<ge> 0" "y \<ge> 0" for x y
    using that by (smt (verit, best) atLeast_iff sm strict_mono_onD)+
  have fim: "f ` {0..a} = {0..b}"
    by (simp add: \<open>a \<ge> 0\<close> cont_0a strict_mono_image_endpoints strict_mono_on_def f)
  have "uniformly_continuous_on {0..a} f"
    using compact_uniformly_continuous cont_0a by blast
  then obtain del where del_gt0: "\<And>e. e>0 \<Longrightarrow> del e > 0"
        and del:  "\<And>e x x'. \<lbrakk>\<bar>x'-x\<bar> < del e; e>0; x \<in> {0..a}; x' \<in> {0..a}\<rbrakk> \<Longrightarrow> \<bar>f x' - f x\<bar> < e"
    unfolding uniformly_continuous_on_def dist_real_def by metis

  have *: "\<bar>a * b - integral {0..a} f - integral {0..b} g\<bar> < 2*\<epsilon>" if "\<epsilon> > 0" for \<epsilon>
  proof -
    define \<delta> where "\<delta> = min a (del (\<epsilon>/a)) / 2"
    have "\<delta> > 0" "\<delta> \<le> a"
      using \<open>a > 0\<close> \<open>\<epsilon> > 0\<close> del_gt0 by (auto simp: \<delta>_def)
    define n where "n \<equiv> nat\<lfloor>a / \<delta>\<rfloor>"
    define a_seg where "a_seg \<equiv> \<lambda>u::real. u * a/n"
    have "n > 0"
      using  \<open>a > 0\<close> \<open>\<delta> > 0\<close> \<open>\<delta> \<le> a\<close> by (simp add: n_def)
    have a_seg_ge_0 [simp]: "a_seg x \<ge> 0 \<longleftrightarrow> x \<ge> 0"
     and a_seg_le_a [simp]: "a_seg x \<le> a \<longleftrightarrow> x \<le> n" for x
      using \<open>n > 0\<close> \<open>a > 0\<close> by (auto simp: a_seg_def zero_le_mult_iff divide_simps)
    have a_seg_le_iff [simp]: "a_seg x \<le> a_seg y \<longleftrightarrow> x \<le> y"
      and a_seg_less_iff [simp]: "a_seg x < a_seg y \<longleftrightarrow> x < y" for x y
      using \<open>n > 0\<close> \<open>a > 0\<close> by (auto simp: a_seg_def zero_le_mult_iff divide_simps)
    have "strict_mono a_seg"
      by (simp add: strict_mono_def)
    have a_seg_eq_a_iff: "a_seg x = a \<longleftrightarrow> x=n" for x
      using \<open>0 < n\<close> \<open>a > 0\<close> by (simp add: a_seg_def nonzero_divide_eq_eq)
    have fa_eq_b: "f (a_seg n) = b"
      using a_seg_eq_a_iff f by fastforce

    have "a/d < real_of_int \<lfloor>a * 2 / min a d\<rfloor>" if "d>0" for d
      by (smt (verit) \<open>0 < \<delta>\<close> \<open>\<delta> \<le> a\<close> add_divide_distrib divide_less_eq_1_pos floor_eq_iff that)
    then have an_less_del: "a/n < del (\<epsilon>/a)"
      using \<open>a > 0\<close> \<open>\<epsilon> > 0\<close> del_gt0  by (simp add: n_def \<delta>_def field_simps)

    define lower where "lower \<equiv> \<lambda>x. a_seg\<lfloor>(real n * x) / a\<rfloor>"
    define f1 where "f1 \<equiv> f \<circ> lower"
    have f1_lower: "f1 x \<le> f x" if "0 \<le> x" "x \<le> a" for x
    proof -
      have "lower x \<le> x"
        using \<open>n > 0\<close> floor_divide_lower [OF \<open>a > 0\<close>]
        by (auto simp: lower_def a_seg_def field_simps)
      moreover have "lower x \<ge> 0"
        unfolding lower_def using \<open>n > 0\<close> \<open>a \<ge> 0\<close> \<open>0 \<le> x\<close> by force
      ultimately show ?thesis
        using sm strict_mono_on_leD by (fastforce simp add: f1_def)
    qed
    define upper where "upper \<equiv> \<lambda>x. a_seg\<lceil>real n * x / a\<rceil>"
    define f2 where "f2 \<equiv> f \<circ> upper"
    have f2_upper: "f2 x \<ge> f x" if "0 \<le> x" "x \<le> a" for x
    proof -
      have "x \<le> upper x"
        using \<open>n > 0\<close> ceiling_divide_upper [OF \<open>a > 0\<close>] by (simp add: upper_def a_seg_def field_simps)
      then show ?thesis
        using sm strict_mono_on_leD \<open>0 \<le> x\<close> by (force simp: f2_def)
    qed
    let ?\<D> = "regular_division 0 a n"
    have div: "?\<D> division_of {0..a}"
      using \<open>a > 0\<close> \<open>n > 0\<close> regular_division_division_of zero_less_nat_eq by presburger

    have int_f1_D: "(f1 has_integral f(Inf K) * (a/n)) K"
      and int_f2_D: "(f2 has_integral f(Sup K) * (a/n)) K" and less: "\<bar>f(Sup K) - f(Inf K)\<bar> < \<epsilon>/a"
      if "K\<in>?\<D>" for K
    proof -
      from regular_divisionE [OF that] \<open>a > 0\<close>
      obtain k where "k<n" and k: "K = {a_seg(real k)..a_seg(Suc k)}"
        by (auto simp: a_seg_def mult.commute)
      define u where "u \<equiv> a_seg k"
      define v where "v \<equiv> a_seg (Suc k)"
      have "u < v" "0 \<le> u" "0 \<le> v" "u \<le> a" "v \<le> a" and Kuv: "K = {u..v}"
        using \<open>n > 0\<close> \<open>k < n\<close> \<open>a > 0\<close> by (auto simp: k u_def v_def divide_simps)
      have InfK: "Inf K = u" and SupK: "Sup K = v"
        using Kuv \<open>u < v\<close> apply force
        using \<open>n > 0\<close> \<open>a > 0\<close> by (auto simp: divide_right_mono k u_def v_def)
      have f1: "f1 x = f (Inf K)" if "x \<in> K - {v}" for x
      proof -
        have "x \<in> {u..<v}"
          using that Kuv atLeastLessThan_eq_atLeastAtMost_diff by blast
        then have "\<lfloor>real_of_int n * x / a\<rfloor> = int k"
          using \<open>n > 0\<close> \<open>a > 0\<close> by (simp add: field_simps u_def v_def a_seg_def floor_eq_iff)
        then show ?thesis
          by (simp add: InfK f1_def lower_def a_seg_def mult.commute u_def)
      qed
      have "((\<lambda>x. f (Inf K)) has_integral (f (Inf K) * (a/n))) K"
        using has_integral_const_real [of "f (Inf K)" u v]
              \<open>n > 0\<close> \<open>a > 0\<close> by (simp add: Kuv field_simps a_seg_def u_def v_def)
      then show "(f1 has_integral (f (Inf K) * (a/n))) K"
        using has_integral_spike_finite_eq [of "{v}" K "\<lambda>x. f (Inf K)" f1] f1 by simp
      have f2: "f2 x = f (Sup K)" if "x \<in> K - {u}" for x
      proof -
        have "x \<in> {u<..v}"
          using that Kuv greaterThanAtMost_eq_atLeastAtMost_diff by blast
        then have "\<lceil>x * real_of_int n / a\<rceil>  = 1 + int k"
          using \<open>n > 0\<close> \<open>a > 0\<close> by (simp add: field_simps u_def v_def a_seg_def ceiling_eq_iff)
        then show ?thesis
          by (simp add: mult.commute f2_def upper_def a_seg_def SupK v_def)
      qed
      have "((\<lambda>x. f (Sup K)) has_integral (f (Sup K) * (a/n))) K"
        using  \<open>n > 0\<close> \<open>a > 0\<close> has_integral_const_real [of "f (Sup K)" u v]
        by (simp add: Kuv field_simps u_def v_def a_seg_def)
      then show "(f2 has_integral (f (Sup K) * (a/n))) K"
        using has_integral_spike_finite_eq [of "{u}" K "\<lambda>x. f (Sup K)" f2] f2 by simp
      have "\<bar>v - u\<bar> < del (\<epsilon>/a)"
        using \<open>n > 0\<close> \<open>a > 0\<close> by (simp add: v_def u_def a_seg_def field_simps an_less_del)
      then have "\<bar>f v - f u\<bar> < \<epsilon>/a"
        using \<open>\<epsilon> > 0\<close> \<open>a > 0\<close> \<open>0 \<le> u\<close> \<open>u \<le> a\<close> \<open>0 \<le> v\<close> \<open>v \<le> a\<close>
        by (intro del) auto
      then show "\<bar>f(Sup K) - f(Inf K)\<bar> < \<epsilon>/a"
        using InfK SupK by blast
    qed

    have int_21_D: "((\<lambda>x. f2 x - f1 x) has_integral (f(Sup K) - f(Inf K)) * (a/n)) K" if "K\<in>?\<D>" for K
      using that has_integral_diff [OF int_f2_D int_f1_D] by (simp add: algebra_simps)

    have D_ne: "?\<D> \<noteq> {}"
      by (metis \<open>0 < a\<close> \<open>n > 0\<close> card_gt_0_iff card_regular_division)
    have f12: "((\<lambda>x. f2 x - f1 x) has_integral (\<Sum>K\<in>?\<D>. (f(Sup K) - f(Inf K)) * (a/n))) {0..a}"
      by (intro div int_21_D has_integral_combine_division)
    moreover have "(\<Sum>K\<in>?\<D>. (f(Sup K) - f(Inf K)) * (a/n)) < \<epsilon>"
    proof -
      have "(\<Sum>K\<in>?\<D>. (f(Sup K) - f(Inf K)) * (a/n)) \<le> (\<Sum>K\<in>?\<D>. \<bar>f(Sup K) - f(Inf K)\<bar> * (a/n))"
        using \<open>n > 0\<close> \<open>a > 0\<close>
        by (smt (verit) divide_pos_pos of_nat_0_less_iff sum_mono zero_le_mult_iff)
      also have "\<dots> < (\<Sum>K\<in>?\<D>. \<epsilon>/n)"
        using \<open>n > 0\<close> \<open>a > 0\<close> less
        by (intro sum_strict_mono finite_regular_division D_ne) (simp add: field_simps)
      also have "\<dots> = \<epsilon>"
        using \<open>n > 0\<close> \<open>a > 0\<close> by simp
      finally show ?thesis .
    qed
    ultimately have f2_near_f1: "integral {0..a} (\<lambda>x. f2 x - f1 x) < \<epsilon>"
      by (simp add: integral_unique)

    define yidx where "yidx \<equiv> \<lambda>y. LEAST k. y < f (a_seg (Suc k))"
    have fa_yidx_le: "f (a_seg (yidx y)) \<le> y" and yidx_gt: "y < f (a_seg (Suc (yidx y)))"
      if "y \<in> {0..b}" for y
    proof -
      obtain x where x: "f x = y" "x \<in> {0..a}"
        using Topological_Spaces.IVT' [OF _ _ _ cont_0a] assms
        by (metis \<open>y \<in> {0..b}\<close> atLeastAtMost_iff)
      define k where "k \<equiv> nat \<lfloor>x/a * n\<rfloor>"
      have x_lims: "a_seg k \<le> x" "x < a_seg (Suc k)"
        using \<open>n > 0\<close> \<open>0 < a\<close> floor_divide_lower floor_divide_upper [of a "x*n"] x
        by (auto simp: k_def a_seg_def field_simps)
      with that x obtain f_lims: "f (a_seg k) \<le> y" "y < f (a_seg (Suc k))"
        using strict_mono_onD [OF sm] by force
      then have "a_seg (yidx y) \<le> a_seg k"
        by (simp add: Least_le \<open>strict_mono a_seg\<close> strict_mono_less_eq yidx_def)
      then have "f (a_seg (yidx y)) \<le> f (a_seg k)"
        using strict_mono_onD [OF sm] by simp
      then show "f (a_seg (yidx y)) \<le> y"
        using f_lims by linarith
      show "y < f (a_seg (Suc (yidx y)))"
        by (metis LeastI f_lims(2) yidx_def)
    qed

    have yidx_equality: "yidx y = k" if "y \<in> {0..b}" "y \<in> {f (a_seg k)..<f (a_seg (Suc k))}" for y k
    proof (rule antisym)
      show "yidx y \<le> k"
        unfolding yidx_def by (metis atLeastLessThan_iff that(2) Least_le)
      have "(a_seg (real k)) < a_seg (1 + real (yidx y))"
        using yidx_gt [OF that(1)] that(2) strict_mono_onD [OF sm] order_le_less_trans by fastforce
      then have "real k < 1 + real (yidx y)"
        by (simp add: \<open>strict_mono a_seg\<close> strict_mono_less)
      then show "k \<le> yidx y"
        by simp
    qed
    have "yidx b = n"
    proof -
      have "a < (1 + real n) * a / real n"
        using \<open>0 < n\<close> \<open>0 < a\<close> by (simp add: divide_simps)
      then have "b < f (a_seg (1 + real n))"
        using f \<open>a \<ge> 0\<close> a_seg_def sm strict_mono_onD by fastforce
      then show ?thesis
        using \<open>0 \<le> b\<close> by (auto simp: f a_seg_def yidx_equality)
    qed
    moreover have yidx_less_n: "yidx y < n" if "y < b" for y
      by (metis \<open>0 < n\<close> fa_eq_b gr0_conv_Suc less_Suc_eq_le that Least_le yidx_def)
    ultimately have yidx_le_n: "yidx y \<le> n" if "y \<le> b" for y
      by (metis dual_order.order_iff_strict that)

    have zero_to_b_eq: "{0..b} = (\<Union>k<n. {f(a_seg k)..f(a_seg (Suc k))})" (is "?lhs = ?rhs")
    proof
      show "?lhs \<subseteq> ?rhs"
      proof
        fix y assume y: "y \<in> {0..b}"
        have fn: "f (a_seg n) = b"
          using a_seg_eq_a_iff \<open>f a = b\<close> by fastforce
        show "y \<in> ?rhs"
        proof (cases "y=b")
          case True
          with fn \<open>n>0\<close> show ?thesis
            by (rule_tac a="n-1" in UN_I) auto
        next
          case False
          with y show ?thesis
            apply (simp add: subset_iff Bex_def)
            by (metis atLeastAtMost_iff of_nat_Suc order_le_less yidx_gt fa_yidx_le yidx_less_n)
        qed
      qed
      show "?rhs \<subseteq> ?lhs"
        apply clarsimp
        by (smt (verit, best) a_seg_ge_0 a_seg_le_a f f_iff(2) nat_less_real_le of_nat_0_le_iff)
    qed

    define g1 where "g1 \<equiv> \<lambda>y. if y=b then a else a_seg (Suc (yidx y))"
    define g2 where "g2 \<equiv> \<lambda>y. if y=0 then 0 else a_seg (yidx y)"
    have g1: "g1 y \<in> {0..a}" if "y \<in> {0..b}" for y
      using that \<open>a > 0\<close> yidx_less_n [of y] by (auto simp: g1_def a_seg_def divide_simps)
    have g2: "g2 y \<in> {0..a}" if "y \<in> {0..b}" for y
      using that \<open>a > 0\<close> yidx_le_n [of y] by (simp add: g2_def a_seg_def divide_simps)

    have g2_le_g: "g2 y \<le> g y" if "y \<in> {0..b}" for y
    proof -
      have "f (g2 y) \<le> y"
        using \<open>f 0 = 0\<close> g2_def that fa_yidx_le by presburger
      then have "f (g2 y) \<le> f (g y)"
        using that g by (smt (verit, best) atLeastAtMost_iff fim image_iff)
      then show ?thesis
        by (smt (verit, best) atLeastAtMost_iff fim g g2 imageE sm_0a strict_mono_onD that)
    qed
    have g_le_g1: "g y \<le> g1 y" if "y \<in> {0..b}" for y
    proof -
      have "y \<le> f (g1 y)"
        by (smt (verit, best) \<open>f a = b\<close> g1_def that yidx_gt)
      then have "f (g y) \<le> f (g1 y)"
        using that g by (smt (verit, best) atLeastAtMost_iff fim image_iff)
      then show ?thesis
        by (smt (verit, ccfv_threshold) atLeastAtMost_iff f_iff(1) g1 that)
    qed

    define DN where "DN \<equiv> \<lambda>K. nat \<lfloor>Inf K * real n / a\<rfloor>"
    have [simp]: "DN {a * real k / n..a * (1 + real k) / n} = k" for k
      using \<open>n > 0\<close> \<open>a > 0\<close> by (simp add: DN_def divide_simps)
    have DN: "bij_betw DN ?\<D> {..<n}"
    proof (intro bij_betw_imageI)
      show "inj_on DN (regular_division 0 a n)"
      proof
        fix K K'
        assume "K \<in> regular_division 0 a n"
        with \<open>a > 0\<close> obtain k where k: "K = {a * (real k / n) .. a * (1 + real k) / n}"
          by (force elim: regular_divisionE)
        assume "K' \<in> regular_division 0 a n"
        with \<open>a > 0\<close> obtain k' where k': "K' = {a * (real k' / n) .. a * (1 + real k') / n}"
          by (force elim: regular_divisionE)
        assume "DN K = DN K'"
        then show "K = K'" by (simp add: k k')
      qed
      have "\<exists>K\<in>regular_division 0 a n. k = nat \<lfloor>Inf K * real n / a\<rfloor>" if "k < n" for k
        using \<open>n > 0\<close> \<open>a > 0\<close> that
        by (force simp: divide_simps intro: regular_division_eqI [OF refl])
      with \<open>a>0\<close> show "DN ` regular_division 0 a n = {..<n}"
        by (auto simp: DN_def bij_betw_def image_iff frac_le elim!: regular_divisionE)
    qed

    have int_f1: "(f1 has_integral (\<Sum>k<n. f(a_seg k)) * (a/n)) {0..a}"
    proof -
      have "a_seg (real (DN K)) = Inf K" if "K \<in> ?\<D>" for K
        using that \<open>a>0\<close> by (auto simp: DN_def field_simps a_seg_def elim: regular_divisionE)
      then have "(\<Sum>K\<in>?\<D>. f(Inf K) * (a/n)) = (\<Sum>k<n. (f(a_seg k)) * (a/n))"
        by (simp flip: sum.reindex_bij_betw [OF DN])
      moreover have "(f1 has_integral (\<Sum>K\<in>?\<D>. f(Inf K) * (a/n))) {0..a}"
        by (intro div int_f1_D has_integral_combine_division)
      ultimately show ?thesis
        by (metis sum_distrib_right)
    qed
    text \<open>The claim @{term "(f2 has_integral (\<Sum>k<n. f(a_seg(Suc k))) * (a/n)) {0..a}"} can similarly be proved\<close>

    have int_g1_D: "(g1 has_integral a_seg (Suc k) * (f (a_seg (Suc k)) - f (a_seg k)))
                    {f(a_seg k)..f(a_seg (Suc k))}"
     and int_g2_D: "(g2 has_integral a_seg k * (f (a_seg (Suc k)) - f (a_seg k)))
                    {f(a_seg k)..f(a_seg (Suc k))}"
      if "k < n" for k
    proof -
      define u where "u \<equiv> f (a_seg k)"
      define v where "v \<equiv> f (a_seg (Suc k))"
      obtain "u < v" "0 \<le> u" "0 \<le> v"
        unfolding u_def v_def assms
        by (smt (verit, best) a_seg_ge_0 a_seg_le_iff f(1) f_iff(1) of_nat_0_le_iff of_nat_Suc)
      have "u \<le> b" "v \<le> b"
        using \<open>k < n\<close> \<open>a \<ge> 0\<close> by (simp_all add: u_def v_def flip: \<open>f a = b\<close>)
      have yidx_eq: "yidx x = k" if "x \<in> {u..<v}" for x
        using \<open>0 \<le> u\<close> \<open>v \<le> b\<close> that u_def v_def yidx_equality by auto

      have "g1 x = a_seg (Suc k)" if "x \<in> {u..<v}" for x
        using that \<open>v \<le> b\<close> by (simp add: g1_def yidx_eq)
      moreover have "((\<lambda>x. a_seg (Suc k)) has_integral (a_seg (Suc k) * (v-u))) {u..v}"
        using has_integral_const_real \<open>u < v\<close>
        by (metis content_real_if less_eq_real_def mult.commute real_scaleR_def)
      ultimately show "(g1 has_integral (a_seg (Suc k) * (v-u))) {u..v}"
        using has_integral_spike_finite_eq [of "{v}" "{u..v}" "\<lambda>x. a_seg (Suc k)" g1] by simp

      have g2: "g2 x = a_seg k" if "x \<in> {u<..<v}" for x
        using that \<open>0 \<le> u\<close> by (simp add: g2_def yidx_eq)
      moreover have "((\<lambda>x. a_seg k) has_integral (a_seg k * (v-u))) {u..v}"
        using has_integral_const_real \<open>u < v\<close>
        by (metis content_real_if less_eq_real_def mult.commute real_scaleR_def)
      ultimately show "(g2 has_integral (a_seg k * (v-u))) {u..v}"
        using has_integral_spike_finite_eq [of "{u,v}" "{u..v}" "\<lambda>x. a_seg k" g2] by simp
    qed

    have int_g1: "(g1 has_integral (\<Sum>k<n. a_seg (Suc k) * (f (a_seg (Suc k)) - f (a_seg k)))) {0..b}"
    and int_g2: "(g2 has_integral (\<Sum>k<n. a_seg k * (f (a_seg (Suc k)) - f (a_seg k)))) {0..b}"
      unfolding zero_to_b_eq using int_g1_D int_g2_D
      by (auto simp: min_def pairwise_def intro!: has_integral_UN negligible_atLeastAtMostI)

    have "(\<Sum>k<n. a_seg (Suc k) * (f (a_seg (Suc k)) - f (a_seg k)))
        = (\<Sum>k<n. (Suc k) * (f (a_seg (Suc k)) - f (a_seg k))) * (a/n)"
      unfolding a_seg_def sum_distrib_right sum_divide_distrib by (simp add: mult_ac)
    also have "\<dots> = (n * f (a_seg n) - (\<Sum>k<n. f (a_seg k))) * a / n"
      using weighted_nesting_sum [where g = "f o a_seg"] by simp
    also have "\<dots> = a * b - (\<Sum>k<n. f (a_seg k)) * a / n"
      using \<open>n > 0\<close> by (simp add: fa_eq_b field_simps)
    finally have int_g1': "(g1 has_integral a * b - (\<Sum>k<n. f (a_seg k)) * a / n) {0..b}"
      using int_g1 by simp
    text \<open>The claim @{term "(g2 has_integral a * b - (\<Sum>k<n. f (a_seg (Suc k))) * a / n) {0..b}"} can similarly be proved.\<close>

    have a_seg_diff: "a_seg (Suc k) - a_seg k = a/n" for k
      by (simp add: a_seg_def field_split_simps)
    have f_a_seg_diff: "\<bar>f (a_seg (Suc k)) - f (a_seg k)\<bar> < \<epsilon>/a" if "k<n" for k
      using that \<open>a > 0\<close> a_seg_diff an_less_del \<open>\<epsilon> > 0\<close>
      by (intro del) auto

    have "((\<lambda>x. g1 x - g2 x) has_integral (\<Sum>k<n. (f (a_seg (Suc k)) - f (a_seg k)) * (a/n))) {0..b}"
      using has_integral_diff [OF int_g1 int_g2] a_seg_diff
      apply (simp flip: sum_subtractf left_diff_distrib)
      apply (simp add: field_simps)
      done
    moreover have "(\<Sum>k<n. (f (a_seg (Suc k)) - f (a_seg k)) * (a/n)) < \<epsilon>"
    proof -
      have "(\<Sum>k<n. (f (a_seg (Suc k)) - f (a_seg k)) * (a/n))
         \<le> (\<Sum>k<n. \<bar>f (a_seg (Suc k)) - f (a_seg k)\<bar> * (a/n))"
        by simp
      also have "\<dots> < (\<Sum>k<n. (\<epsilon>/a) * (a/n))"
      proof (rule sum_strict_mono)
        fix k assume "k \<in> {..<n}"
        with \<open>n > 0\<close> \<open>a > 0\<close> divide_strict_right_mono f_a_seg_diff pos_less_divide_eq
        show "\<bar>f (a_seg (Suc k)) - f (a_seg k)\<bar> * (a/n) < \<epsilon>/a * (a/n)" by fastforce
      qed (use \<open>n > 0\<close> in auto)
      also have "\<dots> = \<epsilon>"
        using \<open>n > 0\<close> \<open>a > 0\<close> by simp
      finally show ?thesis .
    qed
    ultimately have g2_near_g1: "integral {0..b} (\<lambda>x. g1 x - g2 x) < \<epsilon>"
      by (simp add: integral_unique)

    have ab1: "integral {0..a} f1 + integral {0..b} g1 = a*b"
      using int_f1 int_g1' by (simp add: integral_unique)

    have "integral {0..a} (\<lambda>x. f x - f1 x) \<le> integral {0..a} (\<lambda>x. f2 x - f1 x)"
    proof (rule integral_le)
      show "(\<lambda>x. f x - f1 x) integrable_on {0..a}" "(\<lambda>x. f2 x - f1 x) integrable_on {0..a}"
        using Henstock_Kurzweil_Integration.integrable_diff int_f1 intgb_f f12 by blast+
    qed (auto simp: f2_upper)
    with f2_near_f1 have "integral {0..a} (\<lambda>x. f x - f1 x) < \<epsilon>"
      by simp
    moreover have "integral {0..a} f1 \<le> integral {0..a} f"
      by (intro integral_le has_integral_integral intgb_f has_integral_integrable [OF int_f1])
         (simp add: f1_lower)
    ultimately have f_error: "\<bar>integral {0..a} f - integral {0..a} f1\<bar> < \<epsilon>"
      using Henstock_Kurzweil_Integration.integral_diff int_f1 intgb_f by fastforce

    have "integral {0..b} (\<lambda>x. g1 x - g x) \<le> integral {0..b} (\<lambda>x. g1 x - g2 x)"
    proof (rule integral_le)
      show "(\<lambda>x. g1 x - g x) integrable_on {0..b}" "(\<lambda>x. g1 x - g2 x) integrable_on {0..b}"
        using Henstock_Kurzweil_Integration.integrable_diff int_g1 int_g2 intgb_g by blast+
    qed (auto simp: g2_le_g)
    with g2_near_g1 have "integral {0..b} (\<lambda>x. g1 x - g x) < \<epsilon>"
      by simp
    moreover have "integral {0..b} g \<le> integral {0..b} g1"
      by (intro integral_le has_integral_integral intgb_g has_integral_integrable [OF int_g1])
         (simp add: g_le_g1)
    ultimately have g_error: "\<bar>integral {0..b} g1 - integral {0..b} g\<bar> < \<epsilon>"
      using integral_diff int_g1 intgb_g by fastforce
    show ?thesis
      using f_error g_error ab1 by linarith
  qed
  show ?thesis
    using * [of "\<bar>a * b - integral {0..a} f - integral {0..b} g\<bar> / 2"] by fastforce
qed (use assms in force)

corollary Youngs_strict:
  fixes f :: "real \<Rightarrow> real"
  assumes sm: "strict_mono_on {0..} f" and cont: "continuous_on {0..} f" and "a>0" "b\<ge>0"
    and f: "f 0 = 0" "f a \<noteq> b" and fim: "f ` {0..} = {0..}"
    and g: "\<And>x. 0 \<le> x \<Longrightarrow> g (f x) = x"
  shows "a*b < integral {0..a} f + integral {0..b} g"
proof -
  have f_iff [simp]: "f x < f y \<longleftrightarrow> x < y" "f x \<le> f y \<longleftrightarrow> x \<le> y"
    if "x \<ge> 0" "y \<ge> 0" for x y
    using that by (smt (verit, best) atLeast_iff sm strict_mono_onD)+
  let ?b' = "f a"
  have "?b' \<ge> 0"
    by (smt (verit, best) \<open>0 < a\<close> atLeast_iff f sm strict_mono_onD)
  then have sm_gx: "strict_mono_on {0..} g"
    unfolding strict_mono_on_def
    by (smt (verit, best) atLeast_iff f_iff(1) f_inv_into_f fim g inv_into_into)
  show ?thesis
  proof (cases "?b' < b")
    case True
    have gt_a: "a < g y" if "y \<in> {?b'<..b}" for y
    proof -
      have "a = g ?b'"
        using \<open>a > 0\<close> g by force
      also have "\<dots> < g y"
        using \<open>0 \<le> ?b'\<close> sm_gx strict_mono_onD that by fastforce
      finally show ?thesis .
    qed
    have "continuous_on {0..} g"
      by (metis cont f(1) fim g sm strict_mono_continuous_invD)
    then have contg: "continuous_on {?b'..b} g"
      by (meson Icc_subset_Ici_iff \<open>0 \<le> f a\<close> continuous_on_subset)
    have "mono_on {0..} g"
      by (simp add: sm_gx strict_mono_on_imp_mono_on)
    then have int_g0b: "g integrable_on {0..b}"
      by (simp add: integrable_on_mono_on mono_on_subset)
    then have int_gb'b: "g integrable_on {?b'..b}"
      by (simp add: \<open>0 \<le> ?b'\<close> integrable_on_subinterval)
    have "a * (b - ?b') = integral {?b'..b} (\<lambda>y. a)"
      using True by force
    also have "\<dots> < integral {?b'..b} g"
      using contg True gt_a by (intro integral_less_real) auto
    finally have *: "a * (b - ?b') < integral {?b'..b} g" .
    have "a*b = a * ?b' + a * (b - ?b')"
      by (simp add: algebra_simps)
    also have "\<dots> = integral {0..a} f + integral {0..?b'} g + a * (b - ?b')"
      using Youngs_exact \<open>a > 0\<close> cont \<open>f 0 = 0\<close> g sm by force
    also have "\<dots> < integral {0..a} f + integral {0..?b'} g + integral {?b'..b} g"
      by (simp add: *)
    also have "\<dots> = integral {0..a} f + integral {0..b} g"
      by (smt (verit) Henstock_Kurzweil_Integration.integral_combine True \<open>0 \<le> ?b'\<close> int_g0b)
    finally show ?thesis .
  next
    case False
    with f have "b < ?b'" by force
    obtain a' where "f a' = b" "a' \<ge> 0"
      using fim \<open>b \<ge> 0\<close> by force
    then have "a' < a"
      using \<open>b < f a\<close> \<open>a > 0\<close> by force
    have gt_b: "b < f x" if "x \<in> {a'<..a}" for x
      using \<open>0 \<le> a'\<close> \<open>f a' = b\<close> that by fastforce
    have int_f0a: "f integrable_on {0..a}"
      by (simp add: integrable_on_mono_on mono_on_def)
    then have int_fa'a: "f integrable_on {a'..a}"
      by (simp add: \<open>0 \<le> a'\<close> integrable_on_subinterval)
    have cont_f': "continuous_on {a'..a} f"
      by (meson Icc_subset_Ici_iff \<open>0 \<le> a'\<close> cont continuous_on_subset)
    have "b * (a - a') = integral {a'..a} (\<lambda>x. b)"
      using \<open>a' < a\<close> by simp
    also have "\<dots> < integral {a'..a} f"
      using cont_f' \<open>a' < a\<close> gt_b by (intro integral_less_real) auto
    finally have *: "b * (a - a') < integral {a'..a} f" .
    have "a*b = a' * b + b * (a - a')"
      by (simp add: algebra_simps)
    also have "\<dots> = integral {0..a'} f + integral {0..b} g + b * (a - a')"
      by (simp add: Youngs_exact \<open>0 \<le> a'\<close> \<open>f a' = b\<close> cont f g sm)
    also have "\<dots> < integral {0..a'} f + integral {0..b} g + integral {a'..a} f"
      by (simp add: *)
    also have "\<dots> = integral {0..a} f + integral {0..b} g"
      by (smt (verit) Henstock_Kurzweil_Integration.integral_combine \<open>0 \<le> a'\<close> \<open>a' < a\<close> int_f0a)
    finally show ?thesis .
  qed
qed

corollary Youngs_inequality:
  fixes f :: "real \<Rightarrow> real"
  assumes sm: "strict_mono_on {0..} f" and cont: "continuous_on {0..} f" and "a\<ge>0" "b\<ge>0"
    and f: "f 0 = 0" and fim: "f ` {0..} = {0..}"
    and g: "\<And>x. 0 \<le> x \<Longrightarrow> g (f x) = x"
  shows "a*b \<le> integral {0..a} f + integral {0..b} g"
proof (cases "a=0")
  case True
  have "g x \<ge> 0" if "x \<ge> 0" for x
    by (metis atLeast_iff fim g imageE that)
  then have "0 \<le> integral {0..b} g"
    by (metis Henstock_Kurzweil_Integration.integral_nonneg atLeastAtMost_iff
              not_integrable_integral order_refl)
  then show ?thesis
    by (simp add: True)
next
  case False
  then show ?thesis
    by (smt (verit) assms Youngs_exact Youngs_strict)
qed

end


(* Author: Peter Lammich
           Tobias Nipkow (tuning)
*)

section \<open>Binomial Heap\<close>

theory Binomial_Heap
imports
  "HOL-Library.Pattern_Aliases"
  Complex_Main
  Priority_Queue_Specs
begin

text \<open>
  We formalize the binomial heap presentation from Okasaki's book.
  We show the functional correctness and complexity of all operations.

  The presentation is engineered for simplicity, and most
  proofs are straightforward and automatic.
\<close>

subsection \<open>Binomial Tree and Heap Datatype\<close>

datatype 'a tree = Node (rank: nat) (root: 'a) (children: "'a tree list")

type_synonym 'a heap = "'a tree list"

subsubsection \<open>Multiset of elements\<close>

fun mset_tree :: "'a::linorder tree \<Rightarrow> 'a multiset" where
  "mset_tree (Node _ a ts) = {#a#} + (\<Sum>t\<in>#mset ts. mset_tree t)"

definition mset_heap :: "'a::linorder heap \<Rightarrow> 'a multiset" where
  "mset_heap ts = (\<Sum>t\<in>#mset ts. mset_tree t)"

lemma mset_tree_simp_alt[simp]:
  "mset_tree (Node r a ts) = {#a#} + mset_heap ts"
  unfolding mset_heap_def by auto
declare mset_tree.simps[simp del]

lemma mset_tree_nonempty[simp]: "mset_tree t \<noteq> {#}"
by (cases t) auto

lemma mset_heap_Nil[simp]:
  "mset_heap [] = {#}"
by (auto simp: mset_heap_def)

lemma mset_heap_Cons[simp]: "mset_heap (t#ts) = mset_tree t + mset_heap ts"
by (auto simp: mset_heap_def)

lemma mset_heap_empty_iff[simp]: "mset_heap ts = {#} \<longleftrightarrow> ts=[]"
by (auto simp: mset_heap_def)

lemma root_in_mset[simp]: "root t \<in># mset_tree t"
by (cases t) auto

lemma mset_heap_rev_eq[simp]: "mset_heap (rev ts) = mset_heap ts"
by (auto simp: mset_heap_def)

subsubsection \<open>Invariants\<close>

text \<open>Binomial tree\<close>
fun invar_btree :: "'a::linorder tree \<Rightarrow> bool" where
"invar_btree (Node r x ts) \<longleftrightarrow>
   (\<forall>t\<in>set ts. invar_btree t) \<and> map rank ts = rev [0..<r]"

text \<open>Ordering (heap) invariant\<close>
fun invar_otree :: "'a::linorder tree \<Rightarrow> bool" where
"invar_otree (Node _ x ts) \<longleftrightarrow> (\<forall>t\<in>set ts. invar_otree t \<and> x \<le> root t)"

definition "invar_tree t \<longleftrightarrow> invar_btree t \<and> invar_otree t"

text \<open>Binomial Heap invariant\<close>
definition "invar ts \<longleftrightarrow> (\<forall>t\<in>set ts. invar_tree t) \<and> (sorted_wrt (<) (map rank ts))"

text \<open>The children of a node are a valid heap\<close>
lemma invar_children:
  "invar_tree (Node r v ts) \<Longrightarrow> invar (rev ts)"
  by (auto simp: invar_tree_def invar_def rev_map[symmetric])

subsection \<open>Operations and Their Functional Correctness\<close>

subsubsection \<open>\<open>link\<close>\<close>

context
includes pattern_aliases
begin

fun link :: "('a::linorder) tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
  "link (Node r x\<^sub>1 ts\<^sub>1 =: t\<^sub>1) (Node r' x\<^sub>2 ts\<^sub>2 =: t\<^sub>2) =
    (if x\<^sub>1\<le>x\<^sub>2 then Node (r+1) x\<^sub>1 (t\<^sub>2#ts\<^sub>1) else Node (r+1) x\<^sub>2 (t\<^sub>1#ts\<^sub>2))"

end

lemma invar_link:
  assumes "invar_tree t\<^sub>1"
  assumes "invar_tree t\<^sub>2"
  assumes "rank t\<^sub>1 = rank t\<^sub>2"
  shows "invar_tree (link t\<^sub>1 t\<^sub>2)"
using assms unfolding invar_tree_def
by (cases "(t\<^sub>1, t\<^sub>2)" rule: link.cases) auto

lemma rank_link[simp]: "rank (link t\<^sub>1 t\<^sub>2) = rank t\<^sub>1 + 1"
by (cases "(t\<^sub>1, t\<^sub>2)" rule: link.cases) simp

lemma mset_link[simp]: "mset_tree (link t\<^sub>1 t\<^sub>2) = mset_tree t\<^sub>1 + mset_tree t\<^sub>2"
by (cases "(t\<^sub>1, t\<^sub>2)" rule: link.cases) simp

subsubsection \<open>\<open>ins_tree\<close>\<close>

fun ins_tree :: "'a::linorder tree \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
  "ins_tree t [] = [t]"
| "ins_tree t\<^sub>1 (t\<^sub>2#ts) =
  (if rank t\<^sub>1 < rank t\<^sub>2 then t\<^sub>1#t\<^sub>2#ts else ins_tree (link t\<^sub>1 t\<^sub>2) ts)"

lemma invar_tree0[simp]: "invar_tree (Node 0 x [])"
unfolding invar_tree_def by auto

lemma invar_Cons[simp]:
  "invar (t#ts)
  \<longleftrightarrow> invar_tree t \<and> invar ts \<and> (\<forall>t'\<in>set ts. rank t < rank t')"
by (auto simp: invar_def)

lemma invar_ins_tree:
  assumes "invar_tree t"
  assumes "invar ts"
  assumes "\<forall>t'\<in>set ts. rank t \<le> rank t'"
  shows "invar (ins_tree t ts)"
using assms
by (induction t ts rule: ins_tree.induct) (auto simp: invar_link less_eq_Suc_le[symmetric])

lemma mset_heap_ins_tree[simp]:
  "mset_heap (ins_tree t ts) = mset_tree t + mset_heap ts"
by (induction t ts rule: ins_tree.induct) auto

lemma ins_tree_rank_bound:
  assumes "t' \<in> set (ins_tree t ts)"
  assumes "\<forall>t'\<in>set ts. rank t\<^sub>0 < rank t'"
  assumes "rank t\<^sub>0 < rank t"
  shows "rank t\<^sub>0 < rank t'"
using assms
by (induction t ts rule: ins_tree.induct) (auto split: if_splits)

subsubsection \<open>\<open>insert\<close>\<close>

hide_const (open) insert

definition insert :: "'a::linorder \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
"insert x ts = ins_tree (Node 0 x []) ts"

lemma invar_insert[simp]: "invar t \<Longrightarrow> invar (insert x t)"
by (auto intro!: invar_ins_tree simp: insert_def)

lemma mset_heap_insert[simp]: "mset_heap (insert x t) = {#x#} + mset_heap t"
by(auto simp: insert_def)

subsubsection \<open>\<open>merge\<close>\<close>

context
includes pattern_aliases
begin

fun merge :: "'a::linorder heap \<Rightarrow> 'a heap \<Rightarrow> 'a heap" where
  "merge ts\<^sub>1 [] = ts\<^sub>1"
| "merge [] ts\<^sub>2 = ts\<^sub>2"
| "merge (t\<^sub>1#ts\<^sub>1 =: h\<^sub>1) (t\<^sub>2#ts\<^sub>2 =: h\<^sub>2) = (
    if rank t\<^sub>1 < rank t\<^sub>2 then t\<^sub>1 # merge ts\<^sub>1 h\<^sub>2 else
    if rank t\<^sub>2 < rank t\<^sub>1 then t\<^sub>2 # merge h\<^sub>1 ts\<^sub>2
    else ins_tree (link t\<^sub>1 t\<^sub>2) (merge ts\<^sub>1 ts\<^sub>2)
  )"

end

lemma merge_simp2[simp]: "merge [] ts\<^sub>2 = ts\<^sub>2"
by (cases ts\<^sub>2) auto

lemma merge_rank_bound:
  assumes "t' \<in> set (merge ts\<^sub>1 ts\<^sub>2)"
  assumes "\<forall>t\<^sub>1\<in>set ts\<^sub>1. rank t < rank t\<^sub>1"
  assumes "\<forall>t\<^sub>2\<in>set ts\<^sub>2. rank t < rank t\<^sub>2"
  shows "rank t < rank t'"
using assms
by (induction ts\<^sub>1 ts\<^sub>2 arbitrary: t' rule: merge.induct)
   (auto split: if_splits simp: ins_tree_rank_bound)

lemma invar_merge[simp]:
  assumes "invar ts\<^sub>1"
  assumes "invar ts\<^sub>2"
  shows "invar (merge ts\<^sub>1 ts\<^sub>2)"
using assms
by (induction ts\<^sub>1 ts\<^sub>2 rule: merge.induct)
   (auto 0 3 simp: Suc_le_eq intro!: invar_ins_tree invar_link elim!: merge_rank_bound)

text \<open>Longer, more explicit proof of @{thm [source] invar_merge},
      to illustrate the application of the @{thm [source] merge_rank_bound} lemma.\<close>
lemma
  assumes "invar ts\<^sub>1"
  assumes "invar ts\<^sub>2"
  shows "invar (merge ts\<^sub>1 ts\<^sub>2)"
  using assms
proof (induction ts\<^sub>1 ts\<^sub>2 rule: merge.induct)
  case (3 t\<^sub>1 ts\<^sub>1 t\<^sub>2 ts\<^sub>2)
  \<comment> \<open>Invariants of the parts can be shown automatically\<close>
  from "3.prems" have [simp]:
    "invar_tree t\<^sub>1" "invar_tree t\<^sub>2"
    (*"invar (merge (t\<^sub>1#ts\<^sub>1) ts\<^sub>2)"
    "invar (merge ts\<^sub>1 (t\<^sub>2#ts\<^sub>2))"
    "invar (merge ts\<^sub>1 ts\<^sub>2)"*)
    by auto

  \<comment> \<open>These are the three cases of the @{const merge} function\<close>
  consider (LT) "rank t\<^sub>1 < rank t\<^sub>2"
         | (GT) "rank t\<^sub>1 > rank t\<^sub>2"
         | (EQ) "rank t\<^sub>1 = rank t\<^sub>2"
    using antisym_conv3 by blast
  then show ?case proof cases
    case LT
    \<comment> \<open>@{const merge} takes the first tree from the left heap\<close>
    then have "merge (t\<^sub>1 # ts\<^sub>1) (t\<^sub>2 # ts\<^sub>2) = t\<^sub>1 # merge ts\<^sub>1 (t\<^sub>2 # ts\<^sub>2)" by simp
    also have "invar \<dots>" proof (simp, intro conjI)
      \<comment> \<open>Invariant follows from induction hypothesis\<close>
      show "invar (merge ts\<^sub>1 (t\<^sub>2 # ts\<^sub>2))"
        using LT "3.IH" "3.prems" by simp

      \<comment> \<open>It remains to show that \<open>t\<^sub>1\<close> has smallest rank.\<close>
      show "\<forall>t'\<in>set (merge ts\<^sub>1 (t\<^sub>2 # ts\<^sub>2)). rank t\<^sub>1 < rank t'"
        \<comment> \<open>Which is done by auxiliary lemma @{thm [source] merge_rank_bound}\<close>
        using LT "3.prems" by (force elim!: merge_rank_bound)
    qed
    finally show ?thesis .
  next
    \<comment> \<open>@{const merge} takes the first tree from the right heap\<close>
    case GT
    \<comment> \<open>The proof is anaologous to the \<open>LT\<close> case\<close>
    then show ?thesis using "3.prems" "3.IH" by (force elim!: merge_rank_bound)
  next
    case [simp]: EQ
    \<comment> \<open>@{const merge} links both first trees, and inserts them into the merged remaining heaps\<close>
    have "merge (t\<^sub>1 # ts\<^sub>1) (t\<^sub>2 # ts\<^sub>2) = ins_tree (link t\<^sub>1 t\<^sub>2) (merge ts\<^sub>1 ts\<^sub>2)" by simp
    also have "invar \<dots>" proof (intro invar_ins_tree invar_link)
      \<comment> \<open>Invariant of merged remaining heaps follows by IH\<close>
      show "invar (merge ts\<^sub>1 ts\<^sub>2)"
        using EQ "3.prems" "3.IH" by auto

      \<comment> \<open>For insertion, we have to show that the rank of the linked tree is \<open>\<le>\<close> the
          ranks in the merged remaining heaps\<close>
      show "\<forall>t'\<in>set (merge ts\<^sub>1 ts\<^sub>2). rank (link t\<^sub>1 t\<^sub>2) \<le> rank t'"
      proof -
        \<comment> \<open>Which is, again, done with the help of @{thm [source] merge_rank_bound}\<close>
        have "rank (link t\<^sub>1 t\<^sub>2) = Suc (rank t\<^sub>2)" by simp
        thus ?thesis using "3.prems" by (auto simp: Suc_le_eq elim!: merge_rank_bound)
      qed
    qed simp_all
    finally show ?thesis .
  qed
qed auto

lemma mset_heap_merge[simp]:
  "mset_heap (merge ts\<^sub>1 ts\<^sub>2) = mset_heap ts\<^sub>1 + mset_heap ts\<^sub>2"
by (induction ts\<^sub>1 ts\<^sub>2 rule: merge.induct) auto

subsubsection \<open>\<open>get_min\<close>\<close>

fun get_min :: "'a::linorder heap \<Rightarrow> 'a" where
  "get_min [t] = root t"
| "get_min (t#ts) = min (root t) (get_min ts)"

lemma invar_tree_root_min:
  assumes "invar_tree t"
  assumes "x \<in># mset_tree t"
  shows "root t \<le> x"
using assms unfolding invar_tree_def
by (induction t arbitrary: x rule: mset_tree.induct) (fastforce simp: mset_heap_def)

lemma get_min_mset:
  assumes "ts\<noteq>[]"
  assumes "invar ts"
  assumes "x \<in># mset_heap ts"
  shows "get_min ts \<le> x"
  using assms
apply (induction ts arbitrary: x rule: get_min.induct)
apply (auto
      simp: invar_tree_root_min min_def intro: order_trans;
      meson linear order_trans invar_tree_root_min
      )+
done

lemma get_min_member:
  "ts\<noteq>[] \<Longrightarrow> get_min ts \<in># mset_heap ts"
by (induction ts rule: get_min.induct) (auto simp: min_def)

lemma get_min:
  assumes "mset_heap ts \<noteq> {#}"
  assumes "invar ts"
  shows "get_min ts = Min_mset (mset_heap ts)"
using assms get_min_member get_min_mset
by (auto simp: eq_Min_iff)

subsubsection \<open>\<open>get_min_rest\<close>\<close>

fun get_min_rest :: "'a::linorder heap \<Rightarrow> 'a tree \<times> 'a heap" where
  "get_min_rest [t] = (t,[])"
| "get_min_rest (t#ts) = (let (t',ts') = get_min_rest ts
                     in if root t \<le> root t' then (t,ts) else (t',t#ts'))"

lemma get_min_rest_get_min_same_root:
  assumes "ts\<noteq>[]"
  assumes "get_min_rest ts = (t',ts')"
  shows "root t' = get_min ts"
using assms
by (induction ts arbitrary: t' ts' rule: get_min.induct) (auto simp: min_def split: prod.splits)

lemma mset_get_min_rest:
  assumes "get_min_rest ts = (t',ts')"
  assumes "ts\<noteq>[]"
  shows "mset ts = {#t'#} + mset ts'"
using assms
by (induction ts arbitrary: t' ts' rule: get_min.induct) (auto split: prod.splits if_splits)

lemma set_get_min_rest:
  assumes "get_min_rest ts = (t', ts')"
  assumes "ts\<noteq>[]"
  shows "set ts = Set.insert t' (set ts')"
using mset_get_min_rest[OF assms, THEN arg_cong[where f=set_mset]]
by auto

lemma invar_get_min_rest:
  assumes "get_min_rest ts = (t',ts')"
  assumes "ts\<noteq>[]"
  assumes "invar ts"
  shows "invar_tree t'" and "invar ts'"
proof -
  have "invar_tree t' \<and> invar ts'"
    using assms
    proof (induction ts arbitrary: t' ts' rule: get_min.induct)
      case (2 t v va)
      then show ?case
        apply (clarsimp split: prod.splits if_splits)
        apply (drule set_get_min_rest; fastforce)
        done
    qed auto
  thus "invar_tree t'" and "invar ts'" by auto
qed

subsubsection \<open>\<open>del_min\<close>\<close>

definition del_min :: "'a::linorder heap \<Rightarrow> 'a::linorder heap" where
"del_min ts = (case get_min_rest ts of
   (Node r x ts\<^sub>1, ts\<^sub>2) \<Rightarrow> merge (rev ts\<^sub>1) ts\<^sub>2)"

lemma invar_del_min[simp]:
  assumes "ts \<noteq> []"
  assumes "invar ts"
  shows "invar (del_min ts)"
using assms
unfolding del_min_def
by (auto
      split: prod.split tree.split
      intro!: invar_merge invar_children
      dest: invar_get_min_rest
    )

lemma mset_heap_del_min:
  assumes "ts \<noteq> []"
  shows "mset_heap ts = mset_heap (del_min ts) + {# get_min ts #}"
using assms
unfolding del_min_def
apply (clarsimp split: tree.split prod.split)
apply (frule (1) get_min_rest_get_min_same_root)
apply (frule (1) mset_get_min_rest)
apply (auto simp: mset_heap_def)
done

subsubsection \<open>Instantiating the Priority Queue Locale\<close>

text \<open>Last step of functional correctness proof: combine all the above lemmas
to show that binomial heaps satisfy the specification of priority queues with merge.\<close>

interpretation binheap: Priority_Queue_Merge
  where empty = "[]" and is_empty = "(=) []" and insert = insert
  and get_min = get_min and del_min = del_min and merge = merge
  and invar = invar and mset = mset_heap
proof (unfold_locales, goal_cases)
  case 1 thus ?case by simp
next
  case 2 thus ?case by auto
next
  case 3 thus ?case by auto
next
  case (4 q)
  thus ?case using mset_heap_del_min[of q] get_min[OF _ \<open>invar q\<close>]
    by (auto simp: union_single_eq_diff)
next
  case (5 q) thus ?case using get_min[of q] by auto
next
  case 6 thus ?case by (auto simp add: invar_def)
next
  case 7 thus ?case by simp
next
  case 8 thus ?case by simp
next
  case 9 thus ?case by simp
next
  case 10 thus ?case by simp
qed

subsection \<open>Complexity\<close>

text \<open>The size of a binomial tree is determined by its rank\<close>
lemma size_mset_btree:
  assumes "invar_btree t"
  shows "size (mset_tree t) = 2^rank t"
  using assms
proof (induction t)
  case (Node r v ts)
  hence IH: "size (mset_tree t) = 2^rank t" if "t \<in> set ts" for t
    using that by auto

  from Node have COMPL: "map rank ts = rev [0..<r]" by auto

  have "size (mset_heap ts) = (\<Sum>t\<leftarrow>ts. size (mset_tree t))"
    by (induction ts) auto
  also have "\<dots> = (\<Sum>t\<leftarrow>ts. 2^rank t)" using IH
    by (auto cong: map_cong)
  also have "\<dots> = (\<Sum>r\<leftarrow>map rank ts. 2^r)"
    by (induction ts) auto
  also have "\<dots> = (\<Sum>i\<in>{0..<r}. 2^i)"
    unfolding COMPL
    by (auto simp: rev_map[symmetric] interv_sum_list_conv_sum_set_nat)
  also have "\<dots> = 2^r - 1"
    by (induction r) auto
  finally show ?case
    by (simp)
qed

lemma size_mset_tree:
  assumes "invar_tree t"
  shows "size (mset_tree t) = 2^rank t"
using assms unfolding invar_tree_def
by (simp add: size_mset_btree)

text \<open>The length of a binomial heap is bounded by the number of its elements\<close>
lemma size_mset_heap:
  assumes "invar ts"
  shows "length ts \<le> log 2 (size (mset_heap ts) + 1)"
proof -
  from \<open>invar ts\<close> have
    ASC: "sorted_wrt (<) (map rank ts)" and
    TINV: "\<forall>t\<in>set ts. invar_tree t"
    unfolding invar_def by auto

  have "(2::nat)^length ts = (\<Sum>i\<in>{0..<length ts}. 2^i) + 1"
    by (simp add: sum_power2)
  also have "\<dots> \<le> (\<Sum>t\<leftarrow>ts. 2^rank t) + 1"
    using sorted_wrt_less_sum_mono_lowerbound[OF _ ASC, of "(^) (2::nat)"]
    using power_increasing[where a="2::nat"]
    by (auto simp: o_def)
  also have "\<dots> = (\<Sum>t\<leftarrow>ts. size (mset_tree t)) + 1" using TINV
    by (auto cong: map_cong simp: size_mset_tree)
  also have "\<dots> = size (mset_heap ts) + 1"
    unfolding mset_heap_def by (induction ts) auto
  finally have "2^length ts \<le> size (mset_heap ts) + 1" .
  then show ?thesis using le_log2_of_power by blast
qed

subsubsection \<open>Timing Functions\<close>

text \<open>
  We define timing functions for each operation, and provide
  estimations of their complexity.
\<close>
definition T_link :: "'a::linorder tree \<Rightarrow> 'a tree \<Rightarrow> nat" where
[simp]: "T_link _ _ = 1"

text \<open>This function is non-canonical: we omitted a \<open>+1\<close> in the \<open>else\<close>-part,
  to keep the following analysis simpler and more to the point.
\<close>
fun T_ins_tree :: "'a::linorder tree \<Rightarrow> 'a heap \<Rightarrow> nat" where
  "T_ins_tree t [] = 1"
| "T_ins_tree t\<^sub>1 (t\<^sub>2 # ts) = (
    (if rank t\<^sub>1 < rank t\<^sub>2 then 1
     else T_link t\<^sub>1 t\<^sub>2 + T_ins_tree (link t\<^sub>1 t\<^sub>2) ts)
  )"

definition T_insert :: "'a::linorder \<Rightarrow> 'a heap \<Rightarrow> nat" where
"T_insert x ts = T_ins_tree (Node 0 x []) ts + 1"

lemma T_ins_tree_simple_bound: "T_ins_tree t ts \<le> length ts + 1"
by (induction t ts rule: T_ins_tree.induct) auto

subsubsection \<open>\<open>T_insert\<close>\<close>

lemma T_insert_bound:
  assumes "invar ts"
  shows "T_insert x ts \<le> log 2 (size (mset_heap ts) + 1) + 2"
proof -
  have "real (T_insert x ts) \<le> real (length ts) + 2"
    unfolding T_insert_def using T_ins_tree_simple_bound
    using of_nat_mono by fastforce
  also note size_mset_heap[OF \<open>invar ts\<close>]
  finally show ?thesis by simp
qed

subsubsection \<open>\<open>T_merge\<close>\<close>

context
includes pattern_aliases
begin

fun T_merge :: "'a::linorder heap \<Rightarrow> 'a heap \<Rightarrow> nat" where
  "T_merge ts\<^sub>1 [] = 1"
| "T_merge [] ts\<^sub>2 = 1"
| "T_merge (t\<^sub>1#ts\<^sub>1 =: h\<^sub>1) (t\<^sub>2#ts\<^sub>2 =: h\<^sub>2) = 1 + (
    if rank t\<^sub>1 < rank t\<^sub>2 then T_merge ts\<^sub>1 h\<^sub>2
    else if rank t\<^sub>2 < rank t\<^sub>1 then T_merge h\<^sub>1 ts\<^sub>2
    else T_ins_tree (link t\<^sub>1 t\<^sub>2) (merge ts\<^sub>1 ts\<^sub>2) + T_merge ts\<^sub>1 ts\<^sub>2
  )"

end

text \<open>A crucial idea is to estimate the time in correlation with the
  result length, as each carry reduces the length of the result.\<close>

lemma T_ins_tree_length:
  "T_ins_tree t ts + length (ins_tree t ts) = 2 + length ts"
by (induction t ts rule: ins_tree.induct) auto

lemma T_merge_length:
  "length (merge ts\<^sub>1 ts\<^sub>2) + T_merge ts\<^sub>1 ts\<^sub>2 \<le> 2 * (length ts\<^sub>1 + length ts\<^sub>2) + 1"
by (induction ts\<^sub>1 ts\<^sub>2 rule: T_merge.induct)
   (auto simp: T_ins_tree_length algebra_simps)

text \<open>Finally, we get the desired logarithmic bound\<close>
lemma T_merge_bound:
  fixes ts\<^sub>1 ts\<^sub>2
  defines "n\<^sub>1 \<equiv> size (mset_heap ts\<^sub>1)"
  defines "n\<^sub>2 \<equiv> size (mset_heap ts\<^sub>2)"
  assumes "invar ts\<^sub>1" "invar ts\<^sub>2"
  shows "T_merge ts\<^sub>1 ts\<^sub>2 \<le> 4*log 2 (n\<^sub>1 + n\<^sub>2 + 1) + 1"
proof -
  note n_defs = assms(1,2)

  have "T_merge ts\<^sub>1 ts\<^sub>2 \<le> 2 * real (length ts\<^sub>1) + 2 * real (length ts\<^sub>2) + 1"
    using T_merge_length[of ts\<^sub>1 ts\<^sub>2] by simp
  also note size_mset_heap[OF \<open>invar ts\<^sub>1\<close>]
  also note size_mset_heap[OF \<open>invar ts\<^sub>2\<close>]
  finally have "T_merge ts\<^sub>1 ts\<^sub>2 \<le> 2 * log 2 (n\<^sub>1 + 1) + 2 * log 2 (n\<^sub>2 + 1) + 1"
    unfolding n_defs by (simp add: algebra_simps)
  also have "log 2 (n\<^sub>1 + 1) \<le> log 2 (n\<^sub>1 + n\<^sub>2 + 1)"
    unfolding n_defs by (simp add: algebra_simps)
  also have "log 2 (n\<^sub>2 + 1) \<le> log 2 (n\<^sub>1 + n\<^sub>2 + 1)"
    unfolding n_defs by (simp add: algebra_simps)
  finally show ?thesis by (simp add: algebra_simps)
qed

subsubsection \<open>\<open>T_get_min\<close>\<close>

fun T_get_min :: "'a::linorder heap \<Rightarrow> nat" where
  "T_get_min [t] = 1"
| "T_get_min (t#ts) = 1 + T_get_min ts"

lemma T_get_min_estimate: "ts\<noteq>[] \<Longrightarrow> T_get_min ts = length ts"
by (induction ts rule: T_get_min.induct) auto

lemma T_get_min_bound:
  assumes "invar ts"
  assumes "ts\<noteq>[]"
  shows "T_get_min ts \<le> log 2 (size (mset_heap ts) + 1)"
proof -
  have 1: "T_get_min ts = length ts" using assms T_get_min_estimate by auto
  also note size_mset_heap[OF \<open>invar ts\<close>]
  finally show ?thesis .
qed

subsubsection \<open>\<open>T_del_min\<close>\<close>

fun T_get_min_rest :: "'a::linorder heap \<Rightarrow> nat" where
  "T_get_min_rest [t] = 1"
| "T_get_min_rest (t#ts) = 1 + T_get_min_rest ts"

lemma T_get_min_rest_estimate: "ts\<noteq>[] \<Longrightarrow> T_get_min_rest ts = length ts"
  by (induction ts rule: T_get_min_rest.induct) auto

lemma T_get_min_rest_bound:
  assumes "invar ts"
  assumes "ts\<noteq>[]"
  shows "T_get_min_rest ts \<le> log 2 (size (mset_heap ts) + 1)"
proof -
  have 1: "T_get_min_rest ts = length ts" using assms T_get_min_rest_estimate by auto
  also note size_mset_heap[OF \<open>invar ts\<close>]
  finally show ?thesis .
qed

text\<open>Note that although the definition of function \<^const>\<open>rev\<close> has quadratic complexity,
it can and is implemented (via suitable code lemmas) as a linear time function.
Thus the following definition is justified:\<close>

definition "T_rev xs = length xs + 1"

definition T_del_min :: "'a::linorder heap \<Rightarrow> nat" where
  "T_del_min ts = T_get_min_rest ts + (case get_min_rest ts of (Node _ x ts\<^sub>1, ts\<^sub>2)
                    \<Rightarrow> T_rev ts\<^sub>1 + T_merge (rev ts\<^sub>1) ts\<^sub>2
  ) + 1"

lemma T_del_min_bound:
  fixes ts
  defines "n \<equiv> size (mset_heap ts)"
  assumes "invar ts" and "ts\<noteq>[]"
  shows "T_del_min ts \<le> 6 * log 2 (n+1) + 3"
proof -
  obtain r x ts\<^sub>1 ts\<^sub>2 where GM: "get_min_rest ts = (Node r x ts\<^sub>1, ts\<^sub>2)"
    by (metis surj_pair tree.exhaust_sel)

  have I1: "invar (rev ts\<^sub>1)" and I2: "invar ts\<^sub>2"
    using invar_get_min_rest[OF GM \<open>ts\<noteq>[]\<close> \<open>invar ts\<close>] invar_children
    by auto

  define n\<^sub>1 where "n\<^sub>1 = size (mset_heap ts\<^sub>1)"
  define n\<^sub>2 where "n\<^sub>2 = size (mset_heap ts\<^sub>2)"

  have "n\<^sub>1 \<le> n" "n\<^sub>1 + n\<^sub>2 \<le> n" unfolding n_def n\<^sub>1_def n\<^sub>2_def
    using mset_get_min_rest[OF GM \<open>ts\<noteq>[]\<close>]
    by (auto simp: mset_heap_def)

  have "T_del_min ts = real (T_get_min_rest ts) + real (T_rev ts\<^sub>1) + real (T_merge (rev ts\<^sub>1) ts\<^sub>2) + 1"
    unfolding T_del_min_def GM
    by simp
  also have "T_get_min_rest ts \<le> log 2 (n+1)"
    using T_get_min_rest_bound[OF \<open>invar ts\<close> \<open>ts\<noteq>[]\<close>] unfolding n_def by simp
  also have "T_rev ts\<^sub>1 \<le> 1 + log 2 (n\<^sub>1 + 1)"
    unfolding T_rev_def n\<^sub>1_def using size_mset_heap[OF I1] by simp
  also have "T_merge (rev ts\<^sub>1) ts\<^sub>2 \<le> 4*log 2 (n\<^sub>1 + n\<^sub>2 + 1) + 1"
    unfolding n\<^sub>1_def n\<^sub>2_def using T_merge_bound[OF I1 I2] by (simp add: algebra_simps)
  finally have "T_del_min ts \<le> log 2 (n+1) + log 2 (n\<^sub>1 + 1) + 4*log 2 (real (n\<^sub>1 + n\<^sub>2) + 1) + 3"
    by (simp add: algebra_simps)
  also note \<open>n\<^sub>1 + n\<^sub>2 \<le> n\<close>
  also note \<open>n\<^sub>1 \<le> n\<close>
  finally show ?thesis by (simp add: algebra_simps)
qed

end


theory Exercises2_04
  imports Main
begin

(*---------------- Exercise 2.4----------------*)
(* snoc function -- reverse of cons *)
fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
"snoc Nil a = (Cons a Nil)" |
"snoc (Cons x xs) a = (Cons x (snoc xs a))"

(* reverse function*)
fun reverse :: "'a list \<Rightarrow> 'a list" where
"reverse Nil = Nil" |
"reverse (Cons x xs) = snoc (reverse xs) x"

lemma snoc_reverse : "reverse(snoc xs a) = a # reverse xs"
  apply(induction xs)
   apply(auto)
  done

theorem double_rev : "reverse (reverse xs) = xs"
  apply(induction xs)
   apply(auto)
  apply(simp add: snoc_reverse)
  done

end