switch implementation of heap from being based on heap.sml (heap as described by one of Chris Okasaki's papers) to being based on bin-vec.sml (simple vector storing elements in sorted order); more performant this way for cache reasons
This commit is contained in:
@@ -12,13 +12,16 @@ sig
|
||||
type elem
|
||||
|
||||
val empty: elem vector
|
||||
val isEmpty: elem vector -> bool
|
||||
|
||||
val sub: elem vector * int -> elem
|
||||
val contains: elem * elem vector -> bool
|
||||
val findMin: elem vector -> elem
|
||||
|
||||
val findInsPos: elem * elem vector -> int
|
||||
val insert: elem vector * elem * int -> elem vector
|
||||
val delete: elem vector * elem -> elem vector
|
||||
val deleteMin: elem vector -> elem vector
|
||||
val updateAtIdx: elem vector * elem * int -> elem vector
|
||||
|
||||
val fromList: elem list -> elem vector
|
||||
@@ -30,8 +33,23 @@ struct
|
||||
|
||||
val empty = Vector.fromList []
|
||||
|
||||
fun isEmpty vec = Vector.length vec = 0
|
||||
|
||||
fun deleteMin vec =
|
||||
if Vector.length vec <= 1 then
|
||||
Vector.fromList []
|
||||
else
|
||||
let
|
||||
val len = Vector.length vec - 2
|
||||
val slice = VectorSlice.slice (vec, 1, SOME len)
|
||||
in
|
||||
VectorSlice.vector slice
|
||||
end
|
||||
|
||||
val sub = Vector.sub
|
||||
|
||||
fun findMin vec = Vector.sub (vec, 0)
|
||||
|
||||
fun reverseLinearSearch (pos, findNum, vec) =
|
||||
if pos < 0 then
|
||||
~1
|
||||
@@ -183,3 +201,15 @@ structure ValSet =
|
||||
|
||||
fun g ({distance = a, ...}: elem, {distance = b, ...}: elem) = a > b
|
||||
end)
|
||||
|
||||
structure DistVec =
|
||||
MakeBinVec
|
||||
(struct
|
||||
type elem = {distance: int, id: int, comesFrom: int}
|
||||
|
||||
fun l ({distance = a, ...}: elem, {distance = b, ...}: elem) = a < b
|
||||
|
||||
fun eq ({distance = a, ...}: elem, {distance = b, ...}: elem) = a = b
|
||||
|
||||
fun g ({distance = a, ...}: elem, {distance = b, ...}: elem) = a > b
|
||||
end)
|
||||
|
||||
145
fcore/heap.sml
145
fcore/heap.sml
@@ -1,145 +0,0 @@
|
||||
(* 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
|
||||
|
||||
val default: t
|
||||
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.t
|
||||
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 (prev, []) = root prev
|
||||
| helpFindMin (prev, [t]) = root t
|
||||
| helpFindMin (prev, t :: ts) =
|
||||
let val x = helpFindMin (t, ts)
|
||||
in if Elem.leq (root t, x) then root t else x
|
||||
end
|
||||
|
||||
fun findMin [] = Elem.default
|
||||
| findMin [t] = root t
|
||||
| findMin (t :: ts) = helpFindMin (t, ts)
|
||||
|
||||
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, comesFrom: int}
|
||||
type id = int
|
||||
|
||||
(* default = defaultID returned when queue is empty *)
|
||||
val default = {distance = ~1, id = ~1, comesFrom = ~1}
|
||||
|
||||
fun getID {id, distance = _} = id
|
||||
|
||||
fun leq ({distance = d1, ...}: t, {distance = d2, ...}: t) = d1 <= d2
|
||||
end)
|
||||
@@ -12,7 +12,7 @@ struct
|
||||
, distSoFar: int
|
||||
}
|
||||
|
||||
type state = ValSet.elem vector * DistHeap.t
|
||||
type state = ValSet.elem vector * DistVec.elem vector
|
||||
|
||||
fun isBetween (p1, check, p2) = check >= p1 andalso check <= p2
|
||||
|
||||
@@ -122,11 +122,10 @@ struct
|
||||
else
|
||||
(* key not explored, so add to queue *)
|
||||
let
|
||||
val q =
|
||||
DistHeap.insert
|
||||
( {distance = dist, id = foldPlatID, comesFrom = fromPlatID}
|
||||
, q
|
||||
)
|
||||
val insRecord =
|
||||
{distance = dist, id = foldPlatID, comesFrom = fromPlatID}
|
||||
val insPos = DistVec.findInsPos (insRecord, q)
|
||||
val q = DistVec.insert (q, insRecord, insPos)
|
||||
in
|
||||
(eVals, q)
|
||||
end
|
||||
@@ -134,9 +133,10 @@ struct
|
||||
else
|
||||
(* key not explored, so add to queue *)
|
||||
let
|
||||
val q =
|
||||
DistHeap.insert
|
||||
({distance = dist, id = foldPlatID, comesFrom = fromPlatID}, q)
|
||||
val insRecord =
|
||||
{distance = dist, id = foldPlatID, comesFrom = fromPlatID}
|
||||
val insPos = DistVec.findInsPos (insRecord, q)
|
||||
val q = DistVec.insert (q, insRecord, insPos)
|
||||
in
|
||||
(eVals, q)
|
||||
end
|
||||
@@ -229,17 +229,21 @@ struct
|
||||
end
|
||||
|
||||
fun filterMinDuplicates (q, eKeys) =
|
||||
let
|
||||
val {id = min, ...} = DistHeap.findMin q
|
||||
val pos = IntSet.findInsPos (min, eKeys)
|
||||
in
|
||||
if IntSet.contains (min, eKeys) then
|
||||
let val q = DistHeap.deleteMin q
|
||||
in filterMinDuplicates (q, eKeys)
|
||||
end
|
||||
else
|
||||
q
|
||||
end
|
||||
if DistVec.isEmpty q then
|
||||
q
|
||||
else
|
||||
let
|
||||
val {id = min, ...} = DistVec.findMin q
|
||||
|
||||
val pos = IntSet.findInsPos (min, eKeys)
|
||||
in
|
||||
if IntSet.contains (min, eKeys) then
|
||||
let val q = DistVec.deleteMin q
|
||||
in filterMinDuplicates (q, eKeys)
|
||||
end
|
||||
else
|
||||
q
|
||||
end
|
||||
|
||||
fun helpGetPathList (curID, eID, eKeys, eVals, acc) =
|
||||
if curID = eID then
|
||||
@@ -283,57 +287,51 @@ struct
|
||||
if IntSet.contains (pID, eKeys) then
|
||||
(* return path if we explored pid *)
|
||||
getPathList (pID, eID, eKeys, eVals)
|
||||
else (* continue dijkstra's algorithm *) if DistVec.isEmpty q then
|
||||
(* return empty list to signify that there is no path *)
|
||||
[]
|
||||
else
|
||||
(* continue dijkstra's algorithm *)
|
||||
(* find reachable values from min in quad tree *)
|
||||
let
|
||||
val {distance = distSoFar, id = minID, comesFrom} = DistHeap.findMin q
|
||||
val {distance = distSoFar, id = minID, comesFrom} = DistVec.findMin q
|
||||
val plat = Platform.find (minID, platforms)
|
||||
|
||||
(* add explored *)
|
||||
val insPos = IntSet.findInsPos (minID, eKeys)
|
||||
val eKeys = IntSet.insert (eKeys, minID, insPos)
|
||||
val eVals =
|
||||
ValSet.insert
|
||||
(eVals, {distance = distSoFar, from = comesFrom}, insPos)
|
||||
|
||||
val env =
|
||||
{ platforms = platforms
|
||||
, currentPlat = plat
|
||||
, eKeys = eKeys
|
||||
, distSoFar = distSoFar
|
||||
}
|
||||
|
||||
val state = (eVals, q)
|
||||
|
||||
(* calculate area to fold over quad tree *)
|
||||
val ww = Constants.worldWidth
|
||||
val wh = Constants.worldHeight
|
||||
|
||||
val {x, y, width, ...} = plat
|
||||
val y = y - Constants.jumpLimit
|
||||
val height = wh - y
|
||||
|
||||
(* fold over quad tree, updating any distances
|
||||
* we find the shortest path for *)
|
||||
val (eVals, q) = addPlatforms (0, (eVals, q), env)
|
||||
in
|
||||
if minID = ~1 then
|
||||
(* return empty list to signify that there is no path *)
|
||||
[]
|
||||
else
|
||||
(* find reachable values from min in quad tree *)
|
||||
let
|
||||
val plat = Platform.find (minID, platforms)
|
||||
|
||||
(* add explored *)
|
||||
val insPos = IntSet.findInsPos (minID, eKeys)
|
||||
val eKeys = IntSet.insert (eKeys, minID, insPos)
|
||||
val eVals =
|
||||
ValSet.insert
|
||||
(eVals, {distance = distSoFar, from = comesFrom}, insPos)
|
||||
|
||||
val env =
|
||||
{ platforms = platforms
|
||||
, currentPlat = plat
|
||||
, eKeys = eKeys
|
||||
, distSoFar = distSoFar
|
||||
}
|
||||
|
||||
val state = (eVals, q)
|
||||
|
||||
(* calculate area to fold over quad tree *)
|
||||
val ww = Constants.worldWidth
|
||||
val wh = Constants.worldHeight
|
||||
|
||||
val {x, y, width, ...} = plat
|
||||
val y = y - Constants.jumpLimit
|
||||
val height = wh - y
|
||||
|
||||
(* fold over quad tree, updating any distances
|
||||
* we find the shortest path for *)
|
||||
val (eVals, q) = addPlatforms (0, (eVals, q), env)
|
||||
in
|
||||
loop (pID, eID, platforms, platformTree, q, eKeys, eVals)
|
||||
end
|
||||
loop (pID, eID, platforms, platformTree, q, eKeys, eVals)
|
||||
end
|
||||
end
|
||||
|
||||
fun start (pID, eID, platforms, platformTree) =
|
||||
let
|
||||
(* initialise data structures: the priority queue and the explored map *)
|
||||
val q = DistHeap.empty
|
||||
val q = DistHeap.insert ({distance = 0, id = eID, comesFrom = eID}, q)
|
||||
val q = DistVec.fromList [{distance = 0, id = eID, comesFrom = eID}]
|
||||
|
||||
(* explored keys and values *)
|
||||
val eKeys = IntSet.empty
|
||||
|
||||
Reference in New Issue
Block a user