code functor to fold through a specified region of the quad tree, without having to allocate an intermediary list or using a closure (which both have runtime costs)

fcore/quad-tree-fold.sml

@@ -0,0 +1,116 @@
+signature QUAD_FOLDER =
+sig
+  type env
+  type state
+
+  val isReachable: state * env * int -> bool
+  val fState: state * env * int -> state
+end
+
+functor MakeQuadFolder(Fn: QUAD_FOLDER) =
+struct
+  open QuadTreeType
+
+  fun foldVec (iX, iY, iW, iH, pos, elements, state, env) =
+    if pos = Vector.length elements then
+      state
+    else
+      let
+        val {itemID, ...} = Vector.sub (elements, pos)
+        val state =
+          if Fn.isReachable (state, env, itemID) then
+            Fn.fState (state, env, itemID)
+          else
+            state
+      in
+        foldVec (iX, iY, iW, iH, pos + 1, elements, state, env)
+      end
+
+  fun foldRegion
+    ( itemX
+    , itemY
+    , itemW
+    , itemH
+    , quadX
+    , quadY
+    , quadW
+    , quadH
+    , env: Fn.env
+    , state: Fn.state
+    , tree: QuadTreeType.t
+    ) =
+    case tree of
+      NODE {topLeft, topRight, bottomLeft, bottomRight, elements} =>
+        let
+          (* fold over intersecting elements in this vector first *)
+          val state = foldVec
+            (itemX, itemY, itemW, itemH, 0, elements, state, env)
+
+          val halfW = quadW div 2
+          val halfH = quadH div 2
+        in
+          (case
+             QuadTree.whichQuadrant
+               (itemX, itemY, itemW, itemH, quadX, quadY, quadW, quadH)
+           of
+             TOP_LEFT =>
+               foldRegion
+                 ( itemX
+                 , itemY
+                 , itemW
+                 , itemH
+                 , quadX
+                 , quadY
+                 , halfW
+                 , halfH
+                 , env
+                 , state
+                 , topLeft
+                 )
+           | TOP_RIGHT =>
+               foldRegion
+                 ( itemX
+                 , itemY
+                 , itemW
+                 , itemH
+                 , quadX + halfW (* middleX *)
+                 , quadY
+                 , halfW
+                 , halfH
+                 , env
+                 , state
+                 , topRight
+                 )
+           | BOTTOM_LEFT =>
+               foldRegion
+                 ( itemX
+                 , itemY
+                 , itemW
+                 , itemH
+                 , quadX
+                 , quadY + halfH (* middleY *)
+                 , halfW
+                 , halfH
+                 , env
+                 , state
+                 , bottomLeft
+                 )
+           | BOTTOM_RIGHT =>
+               foldRegion
+                 ( itemX
+                 , itemY
+                 , itemW
+                 , itemH
+                 , quadX + halfW (* middleX *)
+                 , quadY + halfH (* middleY *)
+                 , halfW
+                 , halfH
+                 , env
+                 , state
+                 , bottomRight
+                 )
+           | PARENT_QUADRANT => state)
+        end
+    | LEAF elements =>
+        foldVec (itemX, itemY, itemW, itemH, 0, elements, state, env)
+end

fcore/quad-tree-type.sml

@@ -0,0 +1,43 @@
+signature QUAD_TREE_TYPE =
+sig
+  type item = {itemID: int, startX: int, startY: int, width: int, height: int}
+
+  datatype t =
+    NODE of
+      { topLeft: t
+      , topRight: t
+      , bottomLeft: t
+      , bottomRight: t
+      , elements: item vector
+      }
+  | LEAF of item vector
+
+  datatype quadrant =
+    TOP_LEFT
+  | TOP_RIGHT
+  | BOTTOM_LEFT
+  | BOTTOM_RIGHT
+  | PARENT_QUADRANT
+end
+
+structure QuadTreeType :> QUAD_TREE_TYPE =
+struct
+  type item = {itemID: int, startX: int, startY: int, width: int, height: int}
+
+  datatype t =
+    NODE of
+      { topLeft: t
+      , topRight: t
+      , bottomLeft: t
+      , bottomRight: t
+      , elements: item vector
+      }
+  | LEAF of item vector
+
+  datatype quadrant =
+    TOP_LEFT
+  | TOP_RIGHT
+  | BOTTOM_LEFT
+  | BOTTOM_RIGHT
+  | PARENT_QUADRANT
+end

fcore/quad-tree.sml

@@ -4,6 +4,10 @@ sig
 
   val empty: t
 
+  val whichQuadrant: int * int * int * int *
+                     int * int * int * int 
+                     -> QuadTreeType.quadrant
+
   datatype collision_side =
     QUERY_ON_LEFT_SIDE
   | QUERY_ON_TOP_SIDE
@@ -42,7 +46,9 @@ end
 
 structure QuadTree: QUAD_TREE =
 struct
-  type item = {itemID: int, startX: int, startY: int, width: int, height: int}
+  open QuadTreeType
+
+  type item = QuadTreeType.item
 
   fun mkItem (id, startX, startY, width, height) : item =
     { itemID = id
@@ -52,15 +58,7 @@ struct
     , height = height
     }
 
-  datatype t =
+  type t = QuadTreeType.t
-    NODE of
-      { topLeft: t
-      , topRight: t
-      , bottomLeft: t
-      , bottomRight: t
-      , elements: item vector
-      }
-  | LEAF of item vector
 
   val empty = LEAF (Vector.fromList [])
 
@@ -79,13 +77,6 @@ struct
     iX >= qX andalso iY >= qY andalso iWidth <= qWidth
     andalso iHeight <= qHeight
 
-  datatype quadrant =
-    TOP_LEFT
-  | TOP_RIGHT
-  | BOTTOM_LEFT
-  | BOTTOM_RIGHT
-  | PARENT_QUADRANT
-
   fun whichQuadrant
     (itemX, itemY, itemWidth, itemHeight, quadX, quadY, quadWidth, quadHeight) =
     let

oms.mlb

@@ -2,7 +2,11 @@ $(SML_LIB)/basis/basis.mlb
 
 (* fcore *)
 fcore/constants.sml
+
+fcore/quad-tree-type.sml
 fcore/quad-tree.sml
+fcore/quad-tree-fold.sml
+
 fcore/bin-search.sml
 
 ann