diff --git a/fcore/bin-vec.sml b/fcore/bin-vec.sml index ee87bcf..e884950 100644 --- a/fcore/bin-vec.sml +++ b/fcore/bin-vec.sml @@ -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) diff --git a/fcore/heap.sml b/fcore/heap.sml deleted file mode 100644 index 917a770..0000000 --- a/fcore/heap.sml +++ /dev/null @@ -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) diff --git a/fcore/path-finding.sml b/fcore/path-finding.sml index 749098a..7161bc1 100644 --- a/fcore/path-finding.sml +++ b/fcore/path-finding.sml @@ -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 diff --git a/oms.mlb b/oms.mlb index ac072ef..d8547de 100644 --- a/oms.mlb +++ b/oms.mlb @@ -2,7 +2,6 @@ $(SML_LIB)/basis/basis.mlb (* fcore *) fcore/constants.sml -fcore/heap.sml fcore/quad-tree-type.sml fcore/quad-tree.sml