From 82daca7f6f7c5899c2e8b5e0b8531d3121654702 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 2 Feb 2009 15:16:03 -0600
Subject: [PATCH] gold-plate quadtrees

---
 extra/quadtrees/authors.txt            |  1 +
 extra/quadtrees/quadtrees-docs.factor  | 34 ++++++++++++++++++++++
 extra/quadtrees/quadtrees-tests.factor |  1 +
 extra/quadtrees/quadtrees.factor       | 39 +++++++++++++-------------
 extra/quadtrees/summary.txt            |  1 +
 extra/quadtrees/tags.txt               |  2 ++
 6 files changed, 59 insertions(+), 19 deletions(-)
 create mode 100644 extra/quadtrees/authors.txt
 create mode 100644 extra/quadtrees/quadtrees-docs.factor
 create mode 100644 extra/quadtrees/summary.txt
 create mode 100644 extra/quadtrees/tags.txt

diff --git a/extra/quadtrees/authors.txt b/extra/quadtrees/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/quadtrees/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/quadtrees/quadtrees-docs.factor b/extra/quadtrees/quadtrees-docs.factor
new file mode 100644
index 0000000000..f2de89ce3d
--- /dev/null
+++ b/extra/quadtrees/quadtrees-docs.factor
@@ -0,0 +1,34 @@
+USING: arrays assocs help.markup help.syntax math.geometry.rect quadtrees quotations sequences ;
+IN: quadtrees
+
+ARTICLE: "quadtrees" "Quadtrees"
+"The " { $snippet "quadtrees" } " vocabulary implements the quadtree structure in Factor. Quadtrees follow the " { $link "assocs-protocol" } " for insertion, deletion, and querying of exact points, using two-dimensional vectors as keys. Additional words are provided for spatial queries and pruning the tree structure:"
+{ $subsection prune }
+{ $subsection in-rect }
+"The following words are provided to help write quadtree algorithms:"
+{ $subsection descend }
+{ $subsection each-quadrant }
+{ $subsection map-quadrant } ;
+
+ABOUT: "quadtrees"
+
+HELP: prune
+{ $values { "tree" quadtree } }
+{ $description "Removes empty nodes from " { $snippet "tree" } "." } ;
+
+HELP: in-rect
+{ $values { "tree" quadtree } { "rect" rect } { "values" sequence } }
+{ $description "Returns a " { $link sequence } " of values from " { $snippet "tree" } " whose keys lie inside " { $snippet "rect" } "." } ;
+
+HELP: descend
+{ $values { "pt" sequence } { "node" quadtree } { "subnode" quadtree } }
+{ $description "Descends into the subnode of quadtree node " { $snippet "node" } " that contains " { $snippet "pt" } ", leaving " { $snippet "pt" } " on the stack." } ;
+
+HELP: each-quadrant
+{ $values { "node" quadtree } { "quot" quotation } }
+{ $description "Calls " { $snippet "quot" } " with each subnode of " { $snippet "node" } " on the top of the stack in turn." } ;
+
+HELP: map-quadrant
+{ $values { "node" quadtree } { "quot" quotation } { "array" array } }
+{ $description "Calls " { $snippet "quot" } " with each subnode of " { $snippet "node" } " on the top of the stack in turn, collecting the four results into " { $snippet "array" } "." } ;
+
diff --git a/extra/quadtrees/quadtrees-tests.factor b/extra/quadtrees/quadtrees-tests.factor
index 8dd4b53dcb..b96cdd82bf 100644
--- a/extra/quadtrees/quadtrees-tests.factor
+++ b/extra/quadtrees/quadtrees-tests.factor
@@ -1,3 +1,4 @@
+! (c) 2009 Joe Groff, see BSD license
 USING: assocs kernel tools.test quadtrees math.geometry.rect sorting ;
 IN: quadtrees.tests
 
diff --git a/extra/quadtrees/quadtrees.factor b/extra/quadtrees/quadtrees.factor
index a56b94e7d3..60446f4bf8 100644
--- a/extra/quadtrees/quadtrees.factor
+++ b/extra/quadtrees/quadtrees.factor
@@ -1,3 +1,4 @@
+! (c) 2009 Joe Groff, see BSD license
 USING: assocs kernel math.geometry.rect combinators accessors
 math.vectors vectors sequences math math.points math.geometry
 combinators.short-circuit arrays fry locals ;
@@ -14,6 +15,25 @@ TUPLE: quadtree { bounds rect } point value ll lr ul ur leaf? ;
 
 : rect-center ( rect -- point ) [ loc>> ] [ dim>> 0.5 v*n ] bi v+ ; inline
 
+: (quadrant) ( pt node -- quadrant )
+    swap [ first 0.0 < ] [ second 0.0 < ] bi
+    [ [ ll>> ] [ lr>> ] if ]
+    [ [ ul>> ] [ ur>> ] if ] if ;
+
+: quadrant ( pt node -- quadrant )
+    [ bounds>> rect-center v- ] keep (quadrant) ;
+
+: descend ( pt node -- pt subnode )
+    [ drop ] [ quadrant ] 2bi ; inline
+
+:: each-quadrant ( node quot -- )
+    node ll>> quot call
+    node lr>> quot call
+    node ul>> quot call
+    node ur>> quot call ; inline
+: map-quadrant ( node quot: ( child-node -- x ) -- array )
+    each-quadrant 4array ; inline
+
 <PRIVATE
 
 DEFER: (prune)
@@ -35,28 +55,9 @@ DEFER: in-rect*
 : ur-bounds ( rect -- rect' )
     [ [ loc>> ] [ dim>> { 0.5 0.5 } v* ] bi v+ ] [ child-dim ] bi <rect> ;
 
-: (quadrant) ( pt node -- quadrant )
-    swap [ first 0.0 < ] [ second 0.0 < ] bi
-    [ [ ll>> ] [ lr>> ] if ]
-    [ [ ul>> ] [ ur>> ] if ] if ;
-
-: quadrant ( pt node -- quadrant )
-    [ bounds>> rect-center v- ] keep (quadrant) ;
-
-: descend ( pt node -- pt subnode )
-    [ drop ] [ quadrant ] 2bi ; inline
-
 : {quadrants} ( node -- quadrants )
     { [ ll>> ] [ lr>> ] [ ul>> ] [ ur>> ] } cleave 4array ;
 
-:: each-quadrant ( node quot -- array )
-    node ll>> quot call
-    node lr>> quot call
-    node ul>> quot call
-    node ur>> quot call ; inline
-: map-quadrant ( node quot: ( child-node -- x ) -- array )
-    each-quadrant 4array ; inline
-
 : add-subnodes ( node -- node )
     dup bounds>> {
         [ ll-bounds <quadtree> >>ll ]
diff --git a/extra/quadtrees/summary.txt b/extra/quadtrees/summary.txt
new file mode 100644
index 0000000000..dd846a0a97
--- /dev/null
+++ b/extra/quadtrees/summary.txt
@@ -0,0 +1 @@
+Quadtree spatial indices
diff --git a/extra/quadtrees/tags.txt b/extra/quadtrees/tags.txt
new file mode 100644
index 0000000000..c133c6df7e
--- /dev/null
+++ b/extra/quadtrees/tags.txt
@@ -0,0 +1,2 @@
+assocs
+graphics