implement heap which stores distance for later use with Dijkstra's algorithm

fcore/heap.sml

@@ -0,0 +1,153 @@
+(* implementation based on Chris Okasaki's paper describing SkewBinomialQueues
+ * from the following PDF, based on figure 6 and figure 7.
+ * https://www.brics.dk/RS/96/37/BRICS-RS-96-37.pdf
+ *
+ * Differences: 
+ * - No exception is raised as we return a default value
+ *   in the case of findMin when queue is empty 
+ *   and we return the empty queue when queue is empty
+ *   in the case of deleteMin.
+ * - Use foldDeleteMin function to eliminate 
+ *   runtime cost of closure/defunctionalisation
+ * *)
+signature ORDERED =
+sig
+  type t
+  type id
+
+  val default: id
+  val getID: t -> id
+  val leq: t * t -> bool
+end
+
+signature PRIORITY_QUEUE =
+sig
+  structure Elem: ORDERED
+
+  type t
+  val empty: t
+  val isEmpty: t -> bool
+  val insert: Elem.t * t -> t
+  val findMin: t -> Elem.id
+  val deleteMin: t -> t
+end
+
+functor MakeSkewHeap(E: ORDERED): PRIORITY_QUEUE =
+struct
+  structure Elem = E
+
+  type rank = int
+
+  datatype tree = NODE of Elem.t * rank * tree list
+  type t = tree list
+
+  fun root (NODE (x, _, _)) = x
+
+  fun rank (NODE (_, r, _)) = r
+
+  fun link (t1, t2) =
+    case (t1, t2) of
+      (NODE (x1, r1, c1), NODE (x2, r2, c2)) =>
+        if Elem.leq (x1, x2) then NODE (x1, r1 + 1, t2 :: c1)
+        else NODE (x2, r2 + 1, t1 :: c2)
+
+  fun skewLink (t0, t1, t2) =
+    case (t0, t1, t2) of
+      (NODE (x0, r0, _), NODE (x1, r1, c1), NODE (x2, r2, c2)) =>
+        if Elem.leq (x1, x0) andalso Elem.leq (x1, x2) then
+          NODE (x1, r1 + 1, t0 :: t2 :: c1)
+        else if Elem.leq (x2, x0) andalso Elem.leq (x2, x1) then
+          NODE (x2, r2 + 1, t0 :: t1 :: c2)
+        else
+          NODE (x0, r1 + 1, [t1, t2])
+
+  fun ins (t, t' :: ts) =
+        if rank t < rank t' then t :: t' :: ts else ins (link (t, t'), ts)
+    | ins (t, []) = [t]
+
+  val empty = []
+
+  fun isEmpty [] = true
+    | isEmpty _ = false
+
+  fun insert (x, ts as t1 :: t2 :: rest) =
+        if rank t1 = rank t2 then skewLink (NODE (x, 0, []), t1, t2) :: rest
+        else NODE (x, 0, []) :: ts
+    | insert (x, ts) =
+        NODE (x, 0, []) :: ts
+
+  fun helpFindMin (t, ts) =
+    case ts of
+      [x] => root x
+    | x :: tl =>
+        let val x = helpFindMin (x, tl)
+        in if Elem.leq (root t, x) then root t else x
+        end
+    | [] => root t
+
+  fun findMin [t] =
+        Elem.getID (root t)
+    | findMin (t :: ts) =
+        let val x = helpFindMin (t, ts)
+        in if Elem.leq (root t, x) then Elem.getID (root t) else Elem.getID x
+        end
+    | findMin [] = Elem.default
+
+  fun getMin (prevT, t) =
+    case t of
+      [t] => (t, [])
+    | t :: ts =>
+        let val (t', ts') = getMin (t, ts)
+        in if Elem.leq (root t, root t') then (t, ts) else (t', t :: ts')
+        end
+    | [] => (prevT, [])
+
+  fun split (ts, xs, []) = (ts, xs)
+    | split (ts, xs, t :: c) =
+        if rank t = 0 then split (ts, root t :: xs, c)
+        else split (t :: ts, xs, c)
+
+  fun unify [] = []
+    | unify (t :: ts) = ins (t, ts)
+
+  fun meldUniq ([], ts) = ts
+    | meldUniq (ts, []) = ts
+    | meldUniq (t1 :: ts1, t2 :: ts2) =
+        if rank t1 < rank t2 then t1 :: meldUniq (ts1, t2 :: ts2)
+        else if rank t2 < rank t1 then t2 :: meldUniq (t1 :: ts1, ts2)
+        else ins (link (t1, t2), meldUniq (ts1, ts2))
+
+  fun meld (ts, ts') =
+    meldUniq (unify ts, unify ts')
+
+  fun foldDeleteMin (lst, state) =
+    case lst of
+      [] => state
+    | hd :: tl =>
+        let val state = insert (hd, state)
+        in foldDeleteMin (tl, state)
+        end
+
+  fun deleteMin [] = raise Empty
+    | deleteMin (ts as hd :: tl) =
+        let
+          val (NODE (x, r, c), ts) = getMin (hd, tl)
+          val (ts', xs') = split ([], [], c)
+        in
+          foldDeleteMin (xs', meld (ts, ts'))
+        end
+end
+
+structure DistHeap =
+  MakeSkewHeap
+    (struct
+       type t = {distance: int, id: int}
+       type id = int
+
+       (* default = defaultID returned when queue is empty *)
+       val default = ~1
+
+       fun getID {id, distance = _} = id
+
+       fun leq ({distance = d1, ...}: t, {distance = d2, ...}: t) = d1 <= d2
+     end)

oms.mlb

@@ -2,6 +2,7 @@ $(SML_LIB)/basis/basis.mlb
 
 (* fcore *)
 fcore/constants.sml
+fcore/heap.sml
 
 fcore/quad-tree-type.sml
 fcore/quad-tree.sml