implement functor to fold over quad tree

fcore/quad-tree-fold.sml

@@ -1 +1,57 @@
+signature QUAD_FOLDER =
+sig
+  type env
+  type state
 
+  val fold: int * env * state -> state
+end
+
+signature MAKE_QUAD_TREE_FOLD =
+sig
+  structure Fn: QUAD_FOLDER
+
+  val foldRegion: int * int * int * int * 
+                  Fn.env * Fn.state * QuadTreeType.t
+                  -> Fn.state
+end
+
+functor MakeQuadTreeFold(Fn: QUAD_FOLDER): MAKE_QUAD_TREE_FOLD =
+struct
+  structure Fn = Fn
+
+  open QuadTreeType
+
+  fun foldRegionVec (rx, ry, rw, rh, env, state, pos, elements) =
+    if pos = Vector.length elements then
+      state
+    else
+      let
+        val item = Vector.sub (elements, pos)
+        val state =
+          if isCollidingItem (rx, ry, rw, rh, ~1, item) then
+            Fn.fold (#itemID item, env, state)
+          else
+            state
+      in
+        foldRegionVec (rx, ry, rh, rh, env, state, pos + 1, elements)
+      end
+
+  fun foldRegion (rx, ry, rw, rh, env, state, tree) =
+    case tree of
+      NODE {topLeft, topRight, bottomLeft, bottomRight, x, y, w, h} =>
+        if isCollidingPlus (rx, ry, rw, rh, x, y, w, h) then
+          let
+            val state = foldRegion (rx, ry, rw, rh, env, state, topLeft)
+            val state = foldRegion (rx, ry, rw, rh, env, state, topRight)
+            val state = foldRegion (rx, ry, rw, rh, env, state, bottomLeft)
+          in
+            foldRegion (rx, ry, rw, rh, env, state, bottomRight)
+          end
+        else
+          state
+    | LEAF {items, x, y, w, h} =>
+        if isCollidingPlus (rx, ry, rw, rh, x, y, w, h) then
+          foldRegionVec (rx, ry, rw, rh, env, state, 0, items)
+        else
+          state
+end

fcore/quad-tree-type.sml

@@ -15,17 +15,33 @@ sig
       }
   | LEAF of {items: item vector, x: int, y: int, w: int, h: int}
 
-  val isColliding: int * int * int * int * int * int * int * int -> bool
+  val isColliding: int * int * int * int *
+                   int * int * int * int
+                   -> bool
 
-  val isCollidingPlus: int * int * int * int * int * int * int * int -> bool
+  val isCollidingPlus: int * int * int * int *
+                       int * int * int * int
+                       -> bool
 
-  val visitTopLeft: int * int * int * int * int * int * int * int -> bool
+  val isCollidingItem: int * int * int * int * 
+                       int * item 
+                       -> bool
 
-  val visitTopRight: int * int * int * int * int * int * int * int -> bool
+  val visitTopLeft: int * int * int * int *
+                    int * int * int * int
+                    -> bool
 
-  val visitBottomLeft: int * int * int * int * int * int * int * int -> bool
+  val visitTopRight: int * int * int * int *
+                     int * int * int * int
+                     -> bool
 
-  val visitBottomRight: int * int * int * int * int * int * int * int -> bool
+  val visitBottomLeft: int * int * int * int *
+                       int * int * int * int
+                       -> bool
+
+  val visitBottomRight: int * int * int * int *
+                        int * int * int * int
+                        -> bool
 end
 
 structure QuadTreeType :> QUAD_TREE_TYPE =
@@ -58,6 +74,20 @@ struct
       isColliding (ix, iy, ifx, ify, cx, cy, cfx, cfy)
     end
 
+  fun isCollidingItem (iX, iY, iW, iH, itemID, checkWith: item) =
+    let
+      val
+        { itemID = checkID
+        , startX = cX
+        , startY = cY
+        , width = cW
+        , height = cH
+        , ...
+        } = checkWith
+    in
+      isCollidingPlus (iX, iY, iW, iH, cX, cY, cW, cH) andalso itemID <> checkID
+    end
+
   fun visitTopLeft (iX, iY, iW, iH, qX, qY, qW, qH) =
     let
       val hw = qW div 2

fcore/quad-tree.sml

@@ -189,21 +189,6 @@ struct
           (* bounds of new item don't fit inside leaf so return old tree *)
           tree
 
-  fun isColliding (iX, iY, iW, iH, itemID, checkWith: item) =
-    let
-      val
-        { itemID = checkID
-        , startX = cX
-        , startY = cY
-        , width = cW
-        , height = cH
-        , ...
-        } = checkWith
-    in
-      iX < cX + cW andalso iX + iW > cX andalso iY < cY + cH
-      andalso iY + iH > cY andalso itemID <> checkID
-    end
-
   fun getCollisionsVec (iX, iY, iW, iH, itemID, pos, elements, acc) =
     if pos = Vector.length elements then
       acc
@@ -211,8 +196,10 @@ struct
       let
         val item = Vector.sub (elements, pos)
         val acc =
-          if isColliding (iX, iY, iW, iH, itemID, item) then #itemID item :: acc
-          else acc
+          if isCollidingItem (iX, iY, iW, iH, itemID, item) then
+            #itemID item :: acc
+          else
+            acc
       in
         getCollisionsVec (iX, iY, iW, iH, itemID, pos + 1, elements, acc)
       end
@@ -270,7 +257,7 @@ struct
       let
         val item = Vector.sub (elements, pos)
       in
-        isColliding (iX, iY, iW, iH, itemID, item)
+        isCollidingItem (iX, iY, iW, iH, itemID, item)
         orelse hasCollisionAtVec (iX, iY, iW, iH, itemID, pos + 1, elements)
       end
 
@@ -297,7 +284,7 @@ struct
       let
         val item = Vector.sub (elements, pos)
       in
-        if isColliding (iX, iY, iW, iH, ~1, item) then #itemID item
+        if isCollidingItem (iX, iY, iW, iH, ~1, item) then #itemID item
         else getItemIDVec (iX, iY, iW, iH, pos + 1, elements)
       end