Theory Dijkstra_Shortest_Path.Dijkstra

section ‹Dijkstra's Algorithm›
theory Dijkstra
  imports 
  Graph 
  Dijkstra_Misc 
  Collections.Refine_Dflt_ICF
  Weight
begin
text ‹
  This theory defines Dijkstra's algorithm. First, a correct result of 
  Dijkstra's algorithm w.r.t. a graph and a start vertex is specified. 
  Then, the refinement 
  framework is used to specify Dijkstra's Algorithm, prove it correct, and
  finally refine it to datatypes that are closer to an implementation than
  the original specification.
›

subsection "Graph's for Dijkstra's Algorithm"
  text ‹A graph annotated with weights.›
  locale weighted_graph = valid_graph G
    for G :: "('V,'W::weight) graph"

subsection "Specification of Correct Result"
  context weighted_graph
  begin
    text ‹
      A result of Dijkstra's algorithm is correct, if it is a map from nodes 
      v› to the shortest path from the start node v0› to 
      v›. Iff there is no such path, the node is not in the map.
›
    definition is_shortest_path_map :: "'V  ('V  ('V,'W) path)  bool" 
      where
      "is_shortest_path_map v0 res  vV. (case res v of
        None  ¬(p. is_path v0 p v) |
        Some p  is_path v0 p v 
                   (p'. is_path v0 p' v  path_weight p  path_weight p')
      )"
  end

  text ‹
    The following function returns the weight of an optional path,
    where None› is interpreted as infinity.
›
  fun path_weight' where
    "path_weight' None = top" |
    "path_weight' (Some p) = Num (path_weight p)"

subsection "Dijkstra's Algorithm"
  text ‹
    The state in the main loop of the algorithm consists of a workset 
    wl› of vertexes that still need to be explored, and a map 
    res› that contains the current shortest path for each vertex.
›
  type_synonym ('V,'W) state = "('V set) × ('V  ('V,'W) path)"

  text ‹
    The preconditions of Dijkstra's algorithm, i.e., that it operates on a 
    valid and finite graph, and that the start node is a node of the graph,
    are summarized in a locale.
›
  locale Dijkstra = weighted_graph G 
    for G :: "('V,'W::weight) graph"+
    fixes v0 :: 'V
    assumes finite[simp,intro!]: "finite V" "finite E"
    assumes v0_in_V[simp, intro!]: "v0V"
    assumes nonneg_weights[simp, intro]: "(v,w,v')edges G  0w"
  begin

  text ‹Paths have non-negative weights.›
  lemma path_nonneg_weight: "is_path v p v'  0  path_weight p"
    by (induct rule: is_path.induct) auto

  text ‹Invariant of the main loop: 
    \begin{itemize}
      \item The workset only contains nodes of the graph.
      \item If the result set contains a path for a node, it is actually a path,
        and uses only intermediate vertices outside the workset.
      \item For all vertices outside the workset, the result map contains the 
        shortest path.
      \item For all vertices in the workset, the result map contains the
        shortest path among all paths that only use intermediate vertices outside
        the workset.
    \end{itemize}
›
  definition "dinvar σ  let (wl,res)=σ in
    wl  V 
    (vV. p. res v = Some p  is_path v0 p v  int_vertices p  V-wl) 
    (vV-wl. p. is_path v0 p v 
        path_weight' (res v)  path_weight' (Some p)) 
    (vwl. p. is_path v0 p v  int_vertices p  V-wl
        path_weight' (res v)  path_weight' (Some p)
    )
    "

  text ‹Sanity check: The invariant is strong enough to imply correctness 
    of result.›
  lemma invar_imp_correct: "dinvar ({},res)  is_shortest_path_map v0 res"
    unfolding dinvar_def is_shortest_path_map_def
    by (auto simp: infty_unbox split: option.split)

  text ‹
    The initial workset contains all vertices. The initial result maps
    v0› to the empty path, and all other vertices to None›.
›
  definition dinit :: "('V,'W) state nres" where
    "dinit  SPEC ( λ(wl,res) . 
        wl=V  res v0 = Some []  (vV-{v0}. res v = None))"

  text ‹
    The initial state satisfies the invariant.
›
  lemma dinit_invar: "dinit  SPEC dinvar"
    unfolding dinit_def
    apply (intro refine_vcg)
    apply (force simp: dinvar_def split: option.split)
    done

  text ‹
    In each iteration, the main loop of the algorithm pops a minimal node from
    the workset, and then updates the result map accordingly.
›

  text ‹
    Pop a minimal node from the workset. The node is minimal in the sense that
    the length of the current path for that node is minimal.
›
  definition pop_min :: "('V,'W) state  ('V × ('V,'W) state) nres" where
    "pop_min σ  do {
      let (wl,res)=σ;
      ASSERT (wl{}); 
      v  RES (least_map (path_weight'  res) wl);
      RETURN (v,(wl-{v},res))
    }"


  text ‹
    Updating the result according to a node v› is done by checking, 
    for each successor node, whether the path over v› is shorter than 
    the path currently stored into the result map.
›
  inductive update_spec :: "'V  ('V,'W) state  ('V,'W) state  bool"
    where
    " v'V. 
      res' v'  least_map path_weight' (
        { res v' }  { Some (p@[(v,w,v')]) | p w. res v = Some p  (v,w,v')E }
      )
       update_spec v (wl,res) (wl,res')"

  text ‹
    In order to ease the refinement proof, we will assert the following 
    precondition for updating.
›
  definition update_pre :: "'V  ('V,'W) state  bool" where
    "update_pre v σ  let (wl,res)=σ in vV 
       (v'V-wl. v'v  (p. is_path v0 p v' 
           path_weight' (res v')  path_weight' (Some p)))
       (v'V. p. res v' = Some p  is_path v0 p v')"

  definition update :: "'V  ('V,'W) state  ('V,'W) state nres" where 
    "update v σ  do {ASSERT (update_pre v σ); SPEC (update_spec v σ)}"

  text ‹Finally, we define Dijkstra's algorithm:›
  definition dijkstra where
    "dijkstra  do {
       σ0dinit; 
       (_,res)  WHILETdinvar(λ(wl,_). wl{}) 
            (λσ. 
              do { (v,σ')  pop_min σ; update v σ' }
            )
            σ0;
       RETURN res }
    "

  text ‹The following theorem states (total) correctness of Dijkstra's 
    algorithm.›

  theorem dijkstra_correct: "dijkstra  SPEC (is_shortest_path_map v0)"
    unfolding dijkstra_def
    unfolding dinit_def
    unfolding pop_min_def update_def [abs_def]
    thm refine_vcg

    apply (refine_rcg
      WHILEIT_rule[where R="inv_image {(x,y). x<y} (card  fst)"]
      refine_vcg 
    )

    (* TODO/FIXME: Should we built in such massaging of the goal into 
        refine_rcg ?*)
    supply [[simproc del: defined_all]]
    apply (simp_all split: prod.split_asm)
    apply (tactic ALLGOALS ((REPEAT_DETERM o Hypsubst.bound_hyp_subst_tac @{context})
      THEN' asm_full_simp_tac @{context}
      ))

  proof -
    fix wl res v
    assume INV: "dinvar (wl,res)"
    and LM: "vleast_map (path_weight'  res) wl"
    hence "vV" unfolding dinvar_def by (auto dest: least_map_elemD)
    moreover
    from INV have " v'V - (wl-{v}). v'  v  
      (p. is_path v0 p v'  path_weight' (res v')  Num (path_weight p))"
      by (auto simp: dinvar_def)
    moreover from INV have "v'V. p. res v'=Some p  is_path v0 p v'"
      by (auto simp: dinvar_def)
    ultimately show "update_pre v (wl-{v},res)" by (auto simp: update_pre_def)
  next
    fix res
    assume "dinvar ({}, res)"
    thus "is_shortest_path_map v0 res"
      by (rule invar_imp_correct)
  next
    show "wf (inv_image {(x, y). x < y} (card  fst))" 
      by (blast intro: wf_less)
  next
    fix wl res v σ''
    assume 
      LM: "vleast_map (path_weight'  res) wl" and 
      UD: "update_spec v (wl-{v},res) σ''" and
      INV: "dinvar (wl,res)" 

    from LM have "vwl" by (auto dest: least_map_elemD)
    moreover from UD have "fst σ'' = wl-{v}" by (auto elim: update_spec.cases)
    moreover from INV have "finite wl" 
      unfolding dinvar_def by (auto dest: finite_subset)
    ultimately show "card (fst σ'') < card wl" 
      apply simp
      by (metis card_gt_0_iff diff_Suc_less empty_iff)
  next
    fix a and res :: "'V  ('V,'W) path"
    assume "a = V  res v0 = Some []  (vV-{v0}. res v = None)"
    thus "dinvar (V,res)"
      by (force simp: dinvar_def split: option.split)
  next
    fix wl res
    assume INV: "dinvar (wl,res)"
    hence  
      WL_SUBSET: "wl  V" and
      PATH_VALID: "vV. p. res v = Some p 
         is_path v0 p v  int_vertices p  V - wl" and
      NWL_MIN: "vV - wl. p. is_path v0 p v 
         path_weight' (res v)  Num (path_weight p)" and
      WL_MIN: "vwl. p. is_path v0 p v  int_vertices p  V - wl 
         path_weight' (res v)  Num (path_weight p)"
      unfolding dinvar_def by auto

    fix v σ''
    assume V_LEAST: "vleast_map (path_weight' o res) wl" 
      and "update_spec v (wl-{v},res) σ''"
    then obtain res' where
      [simp]: "σ''=(wl-{v},res')"
      and CONSIDERED_NEW_PATHS: "v'V. res' v'  least_map path_weight' 
        (insert (res v') 
              ({ Some (p@[(v,w,v')]) | p w. res v = Some p  (v,w,v')E }))"
      by (auto elim!: update_spec.cases)
      
    from V_LEAST have V_MEM: "vwl" by (blast intro: least_map_elemD)

    show "dinvar σ''"
      apply (unfold dinvar_def, simp)
      apply (intro conjI)
    proof -
      from WL_SUBSET show "wl-{v}  V" by auto

      show "vaV. p. res' va = Some p 
         is_path v0 p va  int_vertices p  V - (wl - {v})"
      proof (intro ballI conjI impI allI)
        fix v' p
        assume V'_MEM: "v'V" and [simp]: "res' v' = Some p"
        txt ‹The new paths that we have added are valid and only use 
          intermediate vertices outside the workset. 
          
          This proof works as follows: A path @{term "res' v'"} is either
          the old path, or has been assembled as a path over node @{term v}.
          In the former case the proposition follows straightforwardly from the
          invariant for the old state. In the latter case we get, by the invariant
          for the old state, that the path over node @{term v} is valid. 
          Then, we observe that appending an edge to a valid path yields a valid 
          path again. Also, adding @{term v} as intermediate node is legal, as we 
          just removed @{term v} from the workset.
›
        with CONSIDERED_NEW_PATHS have "res' v'  (insert (res v') 
          ({ Some (p@[(v,w,v')]) | p w. res v = Some p  (v,w,v')E }))"
          by (rule_tac least_map_elemD) blast
        moreover {
          assume [symmetric,simp]: "res' v' = res v'"
          from V'_MEM PATH_VALID have 
            "is_path v0 p v'" 
            "int_vertices p  V - (wl-{v})"
            by force+
        } moreover {
          fix pv w
          assume "res' v' = Some (pv@[(v,w,v')])" 
            and [simp]: "res v = Some pv" 
            and EDGE: "(v,w,v')E"
          hence [simp]: "p = pv@[(v,w,v')]" by simp
          
          from bspec[OF PATH_VALID rev_subsetD[OF V_MEM WL_SUBSET]] have 
            PATHV: "is_path v0 pv v" and IVV: "int_vertices pv  V - wl" by auto
          hence 
            "is_path v0 p v'" 
            "int_vertices p  V - (wl-{v})"
            by (auto simp: EDGE V'_MEM)
        } 
        ultimately show 
          "is_path v0 p v'" 
          "int_vertices p  V - (wl-{v})"
          by blast+
      qed

      txt ‹
        We show that already the {\em original} result stores the minimal 
        path for all vertices not in the {\em new} workset. 
        For vertices also not in the original workset, this follows 
        straightforwardly from the invariant.
        
        For the vertex v›, that has been removed from the
        workset, we split a path p'› to v› at the point
        u› where it first enters the original workset.  

        As we chose v› to be the vertex in the workset with the
        minimal weight, its weight is less than the current weight of
        u›.  As the vertices of the prefix of p'› up to
        u› are not in the workset, the current weight of
        u› is less than the weight of the prefix of p'›, and thus less than the weight of p'›. 
        Together, the current weight of v› is less than the weight of
        p'›.›
      have RES_MIN: "vV - (wl - {v}). p. is_path v0 p v 
         path_weight' (res v)  Num (path_weight p)"
      proof (intro ballI allI impI)
        fix v' p'
        assume NOT_IN_WL: "v'  V - (wl - {v})" 
          and PATH: "is_path v0 p' v'"
        hence [simp, intro!]: "v'V" by auto

        show "path_weight' (res v')  Num (path_weight p')"
        proof (cases "v' = v")
          assume NE[simp]: "v'v"
          from bspec[OF NWL_MIN, of v'] NOT_IN_WL PATH show
            "path_weight' (res v')  Num (path_weight p')" by auto
        next
          assume EQ[simp]: "v'=v"
          
          from path_split_set'[OF PATH, of wl] V_MEM obtain p1 p2 u where
            [simp]: "p'=p1@p2" 
              and P1: "is_path v0 p1 u" 
              and P2: "is_path u p2 v'" 
              and P1V: "int_vertices p1  -wl" 
              and [simp]: "uwl"
            by auto
          
          from least_map_leD[OF V_LEAST]
          have "path_weight' (res v')  path_weight' (res u)"by auto
          also from bspec[OF WL_MIN, of u] P1 P1V int_vertices_subset[OF P1]
          have "path_weight' (res u)  Num (path_weight p1)" by auto
          also have "  Num (path_weight p')" 
            using path_nonneg_weight[OF P2]
            apply (auto simp: infty_unbox )
            by (metis add_0_right add_left_mono)
          finally show ?thesis .
        qed
      qed
        
      txt ‹With the previous statement, we easily show the
        third part of the invariant, as the new paths are not longer than the
        old ones.
›
      show "vV - (wl - {v}). p. is_path v0 p v 
         path_weight' (res' v)  Num (path_weight p)"
      proof (intro allI ballI impI)
        fix v' p
        assume NOT_IN_WL: "v'  V - (wl - {v})" 
          and PATH: "is_path v0 p v'"
        hence [simp, intro!]: "v'V" by auto
        from bspec[OF CONSIDERED_NEW_PATHS, of v']
        have "path_weight' (res' v')  path_weight' (res v')"
          by (auto dest: least_map_leD)
        also from bspec[OF RES_MIN NOT_IN_WL] PATH 
        have "path_weight' (res v')  Num (path_weight p)" by blast
        finally show "path_weight' (res' v')  Num (path_weight p)" .
      qed

      txt ‹
        Finally, we have to show that for nodes on the worklist,
        the stored paths are not longer than any path using only nodes not
        on the worklist. Compared to the situation before the step, those
        path may also use the node v›.
›
      show "vawl - {v}. p. 
        is_path v0 p va  int_vertices p  V - (wl - {v}) 
         path_weight' (res' va)  Num (path_weight p)"
      proof (intro allI impI ballI, elim conjE)
        fix v' p
        assume IWS: "v'wl - {v}" 
          and PATH: "is_path v0 p v'" 
          and VERTICES: "int_vertices p  V - (wl - {v})"
        from IWS WL_SUBSET have [simp, intro!]: "v'V" by auto
        
        {
          txt ‹
            If the path is empty, the proposition follows easily from the
            invariant for the original states, as no intermediate nodes are 
            used at all.
›
          assume [simp]: "p=[]"
          from bspec[OF CONSIDERED_NEW_PATHS, of v'] have
            "path_weight' (res' v')  path_weight' (res v')"
            using IWS WL_SUBSET by (auto dest: least_map_leD)
          also have "int_vertices p  V-wl" by auto
          with WL_MIN IWS PATH 
          have "path_weight' (res v')  Num (path_weight p)"
            by (auto simp del: path_weight_empty)
          finally have "path_weight' (res' v')  Num (path_weight p)" .
        } moreover {
          fix p1 u w
          assume [simp]: "p = p1@[(u,w,v')]"
          txt ‹If the path is not empty, we pick the last but one vertex, and
            call it @{term u}.›
          from PATH have PATH1: "is_path v0 p1 u" and EDGE: "(u,w,v')E" by auto
          from VERTICES have NIV: "uV - (wl-{v})" by simp
          hence U_MEM[simp]: "uV" by auto

          txt ‹From @{thm [source] RES_MIN}, we know that @{term "res u"} holds
            the shortest path to @{term u}. Thus p› is longer than the 
            path that is constructed by replacing the prefix of @{term p} by 
            {term "res u"}›
          from NIV RES_MIN PATH1 
          have G: "Num (path_weight p1)  path_weight' (res u)" by simp
          then obtain pu where [simp]: "res u = Some pu" 
            by (cases "res u") (auto simp: infty_unbox)
          from G have "Num (path_weight p)  path_weight' (res u) + Num w"
            by (auto simp: infty_unbox add_right_mono)
          also 
          have "path_weight' (res u) + Num w  path_weight' (res' v')"
            txt ‹
              The remaining argument depends on wether @{term u} 
              equals @{term v}. 
              In the case @{term "uv"}, all vertices of @{term "res u"} are
              outside the original workset. Thus, appending the edge 
              @{term "(u,w,v')"} to @{term "res u"} yields a path to @{term v}
              over intermediate nodes only outside the workset. By the invariant
              for the original state, @{term "res v'"} is shorter than this path.
              As a step does not replace paths by longer ones, also 
              @{term "res' v'"} is shorter.

              In the case @{term "u=v"}, the step has
              considered the path to v'› over v›, and thus the
              result path is not longer.
›
          proof (cases "u=v")
            assume "uv"
            with NIV have NIV': "uV-wl" by auto
            from bspec[OF PATH_VALID U_MEM] NIV'
            have "is_path v0 pu u" and VU: "int_vertices (pu@[(u,w,v')])  V-wl" 
              by auto
            with EDGE have PV': "is_path v0 (pu@[(u,w,v')]) v'" by auto
            with bspec[OF WL_MIN, of v'] IWS VU have 
              "path_weight' (res v')  Num (path_weight (pu@[(u,w,v')]))"
              by blast
            hence "path_weight' (res u) + Num w  path_weight' (res v')"
              by (auto simp: infty_unbox)
            also from CONSIDERED_NEW_PATHS have 
              "path_weight' (res v')  path_weight' (res' v')"
              by (auto dest: least_map_leD)
            finally (order_trans[rotated]) show ?thesis .
          next
            assume [symmetric,simp]: "u=v"
            from CONSIDERED_NEW_PATHS EDGE have 
              "path_weight' (res' v')  path_weight' (Some (pu@[(v,w,v')]))"
              by (rule_tac least_map_leD) auto
            thus ?thesis by (auto simp: infty_unbox)
          qed
          finally (order_trans[rotated]) have 
            "path_weight' (res' v')  Num (path_weight p)" .
        } ultimately show "path_weight' (res' v')  Num (path_weight p)"
          using PATH apply (cases p rule: rev_cases) by auto
      qed
    qed
  qed

  subsection ‹Structural Refinement of Update›
  text ‹
    Now that we have proved correct the initial version of the algorithm, we start
    refinement towards an efficient implementation.
›

  text ‹
    First, the update function is refined to iterate over each successor of the
    selected node, and update the result on demand.
›
  definition uinvar 
    :: "'V  'V set  _  ('W×'V) set  ('V,'W) state  bool" where
    "uinvar v wl res it σ  let (wl',res')=σ in wl'=wl 
     (v'V. 
      res' v'  least_map path_weight' (
        { res v' }  { Some (p@[(v,w,v')]) | p w. res v = Some p 
           (w,v')  succ G v - it }
      ))
     (v'V. p. res' v' = Some p  is_path v0 p v')
     res' v = res v
    "

  definition update' :: "'V  ('V,'W) state  ('V,'W) state nres" where 
    "update' v σ  do {
      ASSERT (update_pre v σ);
      let (wl,res) = σ;
      let wv = path_weight' (res v);
      let pv = res v;
      FOREACH⇗uinvar v wl res(succ G v) (λ(w',v') (wl,res). 
        if (wv + Num w' < path_weight' (res v')) then do {
            ASSERT (v'wl  pvNone); 
            RETURN (wl,res(v'  the pv@[(v,w',v')]))
        } else RETURN (wl,res)
      ) (wl,res)}"

  lemma update'_refines:
    assumes "v'=v" and "σ'=σ"
    shows "update' v' σ'  Id (update v σ)"
    apply (simp only: assms)
    unfolding update'_def update_def
    apply (refine_rcg refine_vcg)

    (*apply (intro refine_vcg conjI)*)
    apply (simp_all only: singleton_iff)
  proof -
    fix wl res
    assume "update_pre v (wl,res)"
    thus "uinvar v wl res (succ G v) (wl,res)"
      by (simp add: uinvar_def update_pre_def)
  next

    fix wl res it wl' res' v' w'
    assume PRE: "update_pre v (wl,res)"
    assume INV: "uinvar v wl res it (wl',res')"
    assume MEM: "(w',v')it" 
    assume IT_SS: "it succ G v"
    assume LESS: "path_weight' (res v) + Num w' < path_weight' (res' v')"

    from PRE have [simp, intro!]: "vV" by (simp add: update_pre_def)

    from MEM IT_SS have [simp,intro!]: "v'V" using succ_subset
      by auto

    from LESS obtain pv where [simp]: "res v = Some pv"
      by (cases "res v") auto

    thus "res v  None" by simp

    have [simp]: "wl'=wl" and [simp]: "res' v = res v" 
      using INV unfolding uinvar_def by auto

    from MEM IT_SS have EDGE[simp]: "(v,w',v')E" 
      unfolding succ_def by auto
    with INV have [simp]: "is_path v0 pv v"
      unfolding uinvar_def by auto

    have "0w'" by (rule nonneg_weights[OF EDGE])
    hence [simp]: "v'v" using LESS
      by auto
    hence [simp]: "vv'" by blast

    show [simp]: "v'wl'" proof (rule ccontr)
      assume [simp]: "v'wl'"
      hence [simp]: "v'V-wl" and [simp]: "v'wl" by auto
      note LESS
      also
      from INV have "path_weight' (res' v')  path_weight' (res v')"
        unfolding uinvar_def by (auto dest: least_map_leD)      
      also
      from PRE have PW: "p. is_path v0 p v'  
        path_weight' (res v')  path_weight' (Some p)"
        unfolding update_pre_def 
        by auto
      have P: "is_path v0 (pv@[(v,w',v')]) v'" by simp
      from PW[OF P] have 
        "path_weight' (res v')  Num (path_weight (pv@[(v,w',v')]))"
        by auto
      finally show False by (simp add: infty_unbox)
    qed

    show "uinvar v wl res (it-{(w',v')}) (wl',res'(v'the (res v)@[(v,w',v')]))"
    proof -
      have "(res'(v'the (res v)@[(v,w',v')])) v = res' v" by simp
      moreover {
        fix v'' assume VMEM: "v''V"
        have "(res'(v'the (res v)@[(v,w',v')])) v''  least_map path_weight' (
          { res v'' }  { Some (p@[(v,w,v'')]) | p w. res v = Some p 
           (w,v'')  succ G v - (it - {(w',v')}) }
          )  (p. (res'(v'the (res v)@[(v,w',v')])) v'' = Some p 
                 is_path v0 p v'')"
        proof (cases "v''=v'")
          case [simp]: False
          have "{ Some (p@[(v,w,v'')]) | p w. res v = Some p 
           (w,v'')  succ G v - (it - {(w',v')}) } = 
            { Some (p@[(v,w,v'')]) | p w. res v = Some p 
           (w,v'')  succ G v - it }"
            by auto
          with INV VMEM show ?thesis unfolding uinvar_def 
            by simp
        next
          case [simp]: True
          have EQ: "{ res v'' }  { Some (p@[(v,w,v'')]) | p w. res v = Some p 
           (w,v'')  succ G v - (it - {(w',v')}) } =
          insert (Some (pv@[(v,w',v')])) (
            { res v'' }  { Some (p@[(v,w,v'')]) | p w. res v = Some p 
           (w,v'')  succ G v - it })"
            using MEM IT_SS
            by auto
          show ?thesis
            apply (subst EQ)
            apply simp
            apply (rule least_map_insert_min)
            apply (rule ballI)
          proof -
            fix r'
            assume A: 
              "r'  insert (res v') 
               {Some (pv @ [(v, w, v')]) |w. (w, v')  succ G v  (w, v')  it}"

            from LESS have 
              "path_weight' (Some (pv @ [(v, w', v')])) < path_weight' (res' v')"
              by (auto simp: infty_unbox)
            also from INV[unfolded uinvar_def] have 
              "res' v'  least_map path_weight' (
                insert (res v') 
                {Some (pv @ [(v, w, v')]) |w. (w, v')  succ G v  (w, v')  it}
              )"
              by auto
            with A have "path_weight' (res' v')  path_weight' r'"
              by (auto dest: least_map_leD)
            finally show 
              "path_weight' (Some (pv @ [(v, w', v')]))  path_weight' r'"
              by simp
          qed
        qed
      }
      ultimately show ?thesis
        unfolding uinvar_def Let_def 
        by auto
    qed
  next
    fix wl res it w' v' wl' res'
    assume INV: "uinvar v wl res it (wl',res')"
    and NLESS: "¬ path_weight' (res v) + Num w' < path_weight' (res' v')"
    and IN_IT: "(w',v')it"
    and IT_SS: "it  succ G v"

    from IN_IT IT_SS have [simp, intro!]: "(w',v')succ G v" by auto
    hence [simp,intro!]: "v'V" using succ_subset
      by auto

    show "uinvar v wl res (it - {(w',v')}) (wl',res')"
    proof (cases "res v")
      case [simp]: None
      from INV show ?thesis
        unfolding uinvar_def by auto
    next
      case [simp]: (Some p)
      {
        fix v''
        assume [simp, intro!]: "v''V"
        have "res' v''  least_map path_weight' (
          { res v'' }  { Some (p@[(v,w,v'')]) | p w. res v = Some p 
           (w,v'')  succ G v - (it - {(w',v')}) }
          )" (is "_  least_map path_weight' ?S")
        proof (cases "v''=v'")
          case False with INV show ?thesis
            unfolding uinvar_def by auto
        next
          case [simp]: True
          
          have EQ: "?S = insert (Some (p@[(v,w',v')])) (
            { res v' }  { Some (p@[(v,w,v'')]) | p w. res v = Some p 
                             (w,v'')  succ G v - it }
            )"
            by auto
          from NLESS have 
            "path_weight' (res' v')  path_weight' (Some (p@[(v,w',v')]))"
            by (auto simp: infty_unbox)
          thus ?thesis
            apply (subst EQ)
            apply (rule least_map_insert_nmin)
            using INV unfolding uinvar_def apply auto []
            apply simp
            done
        qed
      } with INV
      show ?thesis
        unfolding uinvar_def by auto
    qed
  next
    fix wl res σ'

    assume "uinvar v wl res {} σ'" 
    thus "update_spec v (wl,res) σ'"
      unfolding uinvar_def
      apply (cases σ')
      apply (auto intro: update_spec.intros simp: succ_def)
      done
  next
    show "finite (succ G v)" by simp
  qed

  text ‹We integrate the new update function into the main algorithm:›
  definition dijkstra' where
    "dijkstra'  do {
      σ0  dinit; 
      (_,res)  WHILETdinvar(λ(wl,_). wl{}) 
            (λσ. do {(v,σ')  pop_min σ; update' v σ'})
            σ0;
      RETURN res
    }"


  lemma dijkstra'_refines: "dijkstra'  Id dijkstra"
  proof -
    note [refine] = update'_refines
    have [refine]: "σ σ'. σ=σ'  pop_min σ  Id (pop_min σ')" by simp
    show ?thesis
      unfolding dijkstra_def dijkstra'_def
      apply (refine_rcg)
      apply simp_all
      done
  qed
end

subsection ‹Refinement to Cached Weights›
text ‹
  Next, we refine the data types of the workset and the result map.
  The workset becomes a map from nodes to their current weights.
  The result map stores, in addition to the shortest path, also the
  weight of the shortest path. Moreover, we store the shortest paths
  in reversed order, which makes appending new edges more effcient.

  These refinements allow to implement the workset as a priority queue,
  and save recomputation of the path weights in the inner loop of the
  algorithm.
›

type_synonym ('V,'W) mwl = "('V  'W infty)"
type_synonym ('V,'W) mres = "('V  (('V,'W) path × 'W))"
type_synonym ('V,'W) mstate = "('V,'W) mwl × ('V,'W) mres"

text ‹
  Map a path with cached weight to one without cached weight.
›
fun mpath' :: "(('V,'W) path × 'W) option  ('V,'W) path" where
  "mpath' None = None" |
  "mpath' (Some (p,w)) = Some p"

fun mpath_weight' :: "(('V,'W) path × 'W) option  ('W::weight) infty" where
  "mpath_weight' None = top" |
  "mpath_weight' (Some (p,w)) = Num w"

context Dijkstra
begin
  definition αw::"('V,'W) mwl  'V set" where "αw  dom"
  definition αr::"('V,'W) mres  'V  ('V,'W) path" where 
    "αr  λres v. case res v of None  None | Some (p,w)  Some (rev p)"
  definition αs:: "('V,'W) mstate  ('V,'W) state" where
    "αs  map_prod αw αr"

  text ‹Additional invariants for the new state. They guarantee that
    the cached weights are consistent.›
  definition res_invarm :: "('V  (('V,'W) path×'W))  bool" where
    "res_invarm res  (v. case res v of 
        None  True | 
        Some (p,w)  w = path_weight (rev p))"
  definition dinvarm :: "('V,'W) mstate  bool" where
    "dinvarm σ  let (wl,res) = σ in
      (vdom wl. the (wl v) = mpath_weight' (res v))  res_invarm res
    "
  lemma mpath_weight'_correct: "dinvarm (wl,res) 
    mpath_weight' (res v) = path_weight' (αr res v)
    "
    unfolding dinvarm_def res_invarm_def αr_def
    by (auto split: option.split option.split_asm)

  lemma mpath'_correct: "dinvarm (wl,res) 
    mpath' (res v) = map_option rev (αr res v)"
    unfolding dinvarm_def αr_def
    by (auto split: option.split option.split_asm)

  lemma wl_weight_correct:
    assumes INV: "dinvarm (wl,res)" 
    assumes WLV: "wl v = Some w" 
    shows "path_weight' (αr res v) = w"
  proof -
    from INV WLV have "w = mpath_weight' (res v)"
      unfolding dinvarm_def by force
    also from mpath_weight'_correct[OF INV] have 
      " = path_weight' (αr res v)" .
    finally show ?thesis by simp
  qed

  text ‹The initial state is constructed using an iterator:›
  definition mdinit :: "('V,'W) mstate nres" where
    "mdinit  do {
      wl  FOREACH V (λv wl. RETURN (wl(vInfty))) Map.empty;
      RETURN (wl(v0Num 0),[v0  ([],0)])
    }"

  lemma mdinit_refines: "mdinit  (build_rel αs dinvarm) dinit"
    unfolding mdinit_def dinit_def
    apply (rule build_rel_SPEC)
    apply (intro FOREACH_rule[where I="λit wl. (vV-it. wl v = Some Infty)  
      dom wl = V-it"]
           refine_vcg)
    apply (auto 
      simp: αs_def αw_def αr_def dinvarm_def res_invarm_def infty_unbox
      split: if_split_asm
    )
    done

  text ‹The new pop function:›
  definition 
    mpop_min :: "('V,'W) mstate  ('V × 'W infty × ('V,'W) mstate) nres" 
    where
    "mpop_min σ  do {
      let (wl,res) = σ; 
      (v,w,wl')prio_pop_min wl;
      RETURN (v,w,(wl',res))
    }"
    
  lemma mpop_min_refines:
    " (σ,σ')  build_rel αs dinvarm   
      mpop_min σ  
       (build_rel 
          (λ(v,w,σ). (v,αs σ)) 
          (λ(v,w,σ). dinvarm σ  w = mpath_weight' (snd σ v)))
      (pop_min σ')"
    ― ‹The two algorithms are structurally different, so we use the
      nofail/inres method to prove refinement.›
    unfolding mpop_min_def pop_min_def prio_pop_min_def

    apply (rule pw_ref_I)
    apply rule
    apply (auto simp add: refine_pw_simps αs_def αw_def refine_rel_defs
      split: prod.split prod.split_asm)

    apply (auto simp: dinvarm_def) []

    apply (auto simp: mpath_weight'_correct wl_weight_correct) []

    apply (auto 
      simp: wl_weight_correct 
      intro!: least_map.intros
    ) []
    apply (metis restrict_map_eq(2))

    done

  text ‹The new update function:›
  definition "uinvarm v wl res it σ  
    uinvar v wl res it (αs σ)  dinvarm σ"

  definition mupdate :: "'V  'W infty  ('V,'W) mstate  ('V,'W) mstate nres"
   where 
    "mupdate v wv σ  do {
      ASSERT (update_pre v (αs σ)  wv=mpath_weight' (snd σ v));
      let (wl,res) = σ;
      let pv = mpath' (res v);
      FOREACH⇗uinvarm v (αw wl) (αr res)(succ G v) (λ(w',v') (wl,res). 
        if (wv + Num w' < mpath_weight' (res v')) then do {
          ASSERT (v'dom wl  pv  None);
          ASSERT (wv  Infty);
          RETURN (wl(v'wv + Num w'),
                    res(v'  ((v,w',v')#the pv,val wv + w') ))
        } else RETURN (wl,res)
        ) (wl,res)
    }"

  lemma mupdate_refines: 
    assumes SREF: "(σ,σ')build_rel αs dinvarm"
    assumes WV: "wv = mpath_weight' (snd σ v)"
    assumes VV': "v'=v"
    shows "mupdate v wv σ  (build_rel αs dinvarm) (update' v' σ')"
  proof (simp only: VV')
    {
      txt ‹Show that IF-condition is a refinement:›
      fix wl res wl' res' it w' v'
      assume "uinvarm v (αw wl) (αr res) it (wl',res')" 
        and "dinvarm (wl,res)"
      hence "mpath_weight' (res v) + Num w' < mpath_weight' (res' v') 
        path_weight' (αr res v) + Num w' < path_weight' (αr res' v')"
        unfolding uinvarm_def
        by (auto simp add: mpath_weight'_correct)
    } note COND_refine=this

    {
      txt ‹THEN-case:›
      fix wl res wl' res' it w' v'
      assume UINV: "uinvarm v (αw wl) (αr res) it (wl',res')"
        and DINV: "dinvarm (wl,res)"
        and "mpath_weight' (res v) + Num w' < mpath_weight' (res' v')"
        and "path_weight' (αr res v) + Num w' < path_weight' (αr res' v')"
        and V'MEM: "v'αw wl'"
        and NN: "αr res v  None"
    
      from NN obtain pv wv where
        ARV: "αr res v = Some (rev pv)" and
        RV: "res v = Some (pv,wv)" 
        unfolding αr_def by (auto split: option.split_asm)

      with DINV have [simp]: "wv = path_weight (rev pv)"
        unfolding dinvarm_def res_invarm_def by (auto split: option.split_asm)
      
      note [simp] = ARV RV

      from V'MEM NN have "v'dom wl'" (is "?G1") 
        and "mpath' (res v)  None" (is "?G2") 
        unfolding αw_def αr_def by (auto split: option.split_asm)
    
      hence "x. αw wl' = αw (wl'(v'x))" by (auto simp: αw_def)
      moreover have "mpath' (res v) = map_option rev (αr res v)" using DINV 
        by (simp add: mpath'_correct)
      ultimately have
        "αw wl' = αw (wl'(v'  mpath_weight' (res v) + Num w')) 
         (αr res')(v'  the (αr res v)@[(v, w', v')]) 
           = αr (res'(v'  ((v, w', v')#the (mpath' (res v)), 
                 val (mpath_weight' (res v)) + w')))" (is ?G3)
        by (auto simp add: αr_def intro!: ext)
      have
        "(dinvarm (wl'(v'mpath_weight' (res v) + Num w'),
                           res'(v'  ((v,w',v') # the (mpath' (res v)),
                                       val (mpath_weight' (res v)) + w'
                                      ))))" (is ?G4)
        using UINV unfolding uinvarm_def dinvarm_def res_invarm_def
        by (auto simp: infty_unbox split: option.split option.split_asm)
      note ?G1 ?G2 ?G3 ?G4
    } note THEN_refine=this


    note [refine2] = inj_on_id

    note [simp] = refine_rel_defs

    show "mupdate v wv σ  (build_rel αs dinvarm) (update' v σ')" 
      using SREF WV
      unfolding mupdate_def update'_def
      apply -

      apply (refine_rcg)

      apply simp_all [3]
      apply (simp add: αs_def uinvarm_def)
      apply (simp_all add: αs_def COND_refine THEN_refine(1-2)) [3]
      apply (rule ccontr,simp)
      using THEN_refine(3,4)
      apply (auto simp: αs_def) []
      txt ‹The ELSE-case is trivial:›
      apply simp
      done
  qed

  text ‹Finally, we assemble the refined algorithm:›
  definition mdijkstra where
    "mdijkstra  do {
      σ0  mdinit; 
      (_,res)  WHILETdinvarm(λ(wl,_). dom wl{}) 
            (λσ. do { (v,wv,σ')  mpop_min σ; mupdate v wv σ' } )
            σ0;
      RETURN res
    }"

  lemma mdijkstra_refines: "mdijkstra  (build_rel αr res_invarm) dijkstra'"
  proof -
    note [refine] = mdinit_refines mpop_min_refines mupdate_refines
    show ?thesis
      unfolding mdijkstra_def dijkstra'_def
      apply (refine_rcg)
      apply (simp_all split: prod.split
        add: αs_def αw_def dinvarm_def refine_rel_defs)
      done
  qed

end

end