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
new file mode 100644
index 0000000000..b96cdd82bf
--- /dev/null
+++ b/extra/quadtrees/quadtrees-tests.factor
@@ -0,0 +1,202 @@
+! (c) 2009 Joe Groff, see BSD license
+USING: assocs kernel tools.test quadtrees math.geometry.rect sorting ;
+IN: quadtrees.tests
+
+: unit-bounds ( -- rect ) { -1.0 -1.0 } { 2.0 2.0 } <rect> ;
+
+: value>>key ( assoc value key -- assoc )
+    pick set-at ; inline
+: delete>>key ( assoc key -- assoc )
+    over delete-at ; inline
+
+[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } {  0.0  -0.25 } "a" f f f f t } ]
+[
+    unit-bounds <quadtree>
+        "a" {  0.0  -0.25 } value>>key
+] unit-test
+
+[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } {  0.0  -0.25 } "b" f f f f t } ]
+[
+    unit-bounds <quadtree>
+        "a" {  0.0  -0.25 } value>>key
+        "b" {  0.0  -0.25 } value>>key
+] unit-test
+
+[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } f f
+    T{ quadtree f T{ rect f { -1.0 -1.0 } { 1.0 1.0 } } { -0.5  -0.75 } "c" f f f f t }
+    T{ quadtree f T{ rect f {  0.0 -1.0 } { 1.0 1.0 } } {  0.0  -0.25 } "a" f f f f t }
+    T{ quadtree f T{ rect f { -1.0  0.0 } { 1.0 1.0 } } f               f   f f f f t }
+    T{ quadtree f T{ rect f {  0.0  0.0 } { 1.0 1.0 } } {  0.25  0.25 } "b" f f f f t }
+    f 
+} ] [
+    unit-bounds <quadtree>
+        "a" {  0.0  -0.25 } value>>key
+        "b" {  0.25  0.25 } value>>key
+        "c" { -0.5  -0.75 } value>>key
+] unit-test
+
+[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } f f
+    T{ quadtree f T{ rect f { -1.0 -1.0 } { 1.0 1.0 } } { -0.5  -0.75 } "c" f f f f t }
+    T{ quadtree f T{ rect f {  0.0 -1.0 } { 1.0 1.0 } } {  0.0  -0.25 } "a" f f f f t }
+    T{ quadtree f T{ rect f { -1.0  0.0 } { 1.0 1.0 } } f               f   f f f f t }
+    T{ quadtree f T{ rect f {  0.0  0.0 } { 1.0 1.0 } } f f
+        T{ quadtree f T{ rect f {  0.0  0.0 } { 0.5 0.5 } } {  0.25  0.25 } "b" f f f f t }
+        T{ quadtree f T{ rect f {  0.5  0.0 } { 0.5 0.5 } } {  0.75  0.25 } "d" f f f f t }
+        T{ quadtree f T{ rect f {  0.0  0.5 } { 0.5 0.5 } } f               f   f f f f t }
+        T{ quadtree f T{ rect f {  0.5  0.5 } { 0.5 0.5 } } f               f   f f f f t }
+    }
+    f
+} ] [
+    unit-bounds <quadtree>
+        "a" {  0.0  -0.25 } value>>key
+        "b" {  0.25  0.25 } value>>key
+        "c" { -0.5  -0.75 } value>>key
+        "d" {  0.75  0.25 } value>>key
+] unit-test
+
+[ "b" t ] [
+    unit-bounds <quadtree>
+        "a" {  0.0  -0.25 } value>>key
+        "b" {  0.25  0.25 } value>>key
+        "c" { -0.5  -0.75 } value>>key
+        "d" {  0.75  0.25 } value>>key
+
+    {  0.25  0.25 } swap at*
+] unit-test
+
+[ f f ] [
+    unit-bounds <quadtree>
+        "a" {  0.0  -0.25 } value>>key
+        "b" {  0.25  0.25 } value>>key
+        "c" { -0.5  -0.75 } value>>key
+        "d" {  0.75  0.25 } value>>key
+
+    {  1.0   1.0  } swap at*
+] unit-test
+
+[ { "a" "c" } ] [
+    unit-bounds <quadtree>
+        "a" {  0.0  -0.25 } value>>key
+        "b" {  0.25  0.25 } value>>key
+        "c" { -0.5  -0.75 } value>>key
+        "d" {  0.75  0.25 } value>>key
+
+    { -0.6 -0.8 } { 0.8 1.0 } <rect> swap in-rect natural-sort
+] unit-test
+
+[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } f f
+    T{ quadtree f T{ rect f { -1.0 -1.0 } { 1.0 1.0 } } { -0.5  -0.75 } "c" f f f f t }
+    T{ quadtree f T{ rect f {  0.0 -1.0 } { 1.0 1.0 } } {  0.0  -0.25 } "a" f f f f t }
+    T{ quadtree f T{ rect f { -1.0  0.0 } { 1.0 1.0 } } f               f   f f f f t }
+    T{ quadtree f T{ rect f {  0.0  0.0 } { 1.0 1.0 } } {  0.75  0.25 } "d" f f f f t }
+    f
+} ] [
+    unit-bounds <quadtree>
+        "a" {  0.0  -0.25 } value>>key
+        "b" {  0.25  0.25 } value>>key
+        "c" { -0.5  -0.75 } value>>key
+        "d" {  0.75  0.25 } value>>key
+
+        {  0.25  0.25 } delete>>key
+        prune
+] unit-test
+
+[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } f f
+    T{ quadtree f T{ rect f { -1.0 -1.0 } { 1.0 1.0 } } { -0.5  -0.75 } "c" f f f f t }
+    T{ quadtree f T{ rect f {  0.0 -1.0 } { 1.0 1.0 } } {  0.0  -0.25 } "a" f f f f t }
+    T{ quadtree f T{ rect f { -1.0  0.0 } { 1.0 1.0 } } f               f   f f f f t }
+    T{ quadtree f T{ rect f {  0.0  0.0 } { 1.0 1.0 } } f               f   f f f f t }
+    f
+} ] [
+    unit-bounds <quadtree>
+        "a" {  0.0  -0.25 } value>>key
+        "b" {  0.25  0.25 } value>>key
+        "c" { -0.5  -0.75 } value>>key
+        "d" {  0.75  0.25 } value>>key
+
+        {  0.25  0.25 } delete>>key
+        {  0.75  0.25 } delete>>key
+        prune
+] unit-test
+
+[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } f f
+    T{ quadtree f T{ rect f { -1.0 -1.0 } { 1.0 1.0 } } f f
+        T{ quadtree f T{ rect f { -1.0 -1.0 } { 0.5 0.5 } } { -0.75 -0.75 } "b" f f f f t }
+        T{ quadtree f T{ rect f { -0.5 -1.0 } { 0.5 0.5 } } f               f   f f f f t }
+        T{ quadtree f T{ rect f { -1.0 -0.5 } { 0.5 0.5 } } f               f   f f f f t }
+        T{ quadtree f T{ rect f { -0.5 -0.5 } { 0.5 0.5 } } { -0.25 -0.25 } "a" f f f f t }
+        f
+    }
+    T{ quadtree f T{ rect f {  0.0 -1.0 } { 1.0 1.0 } } f f
+        T{ quadtree f T{ rect f {  0.0 -1.0 } { 0.5 0.5 } } f               f   f f f f t }
+        T{ quadtree f T{ rect f {  0.5 -1.0 } { 0.5 0.5 } } {  0.75 -0.75 } "f" f f f f t }
+        T{ quadtree f T{ rect f {  0.0 -0.5 } { 0.5 0.5 } } {  0.25 -0.25 } "e" f f f f t }
+        T{ quadtree f T{ rect f {  0.5 -0.5 } { 0.5 0.5 } } f               f   f f f f t }
+        f
+    }
+    T{ quadtree f T{ rect f { -1.0  0.0 } { 1.0 1.0 } } f f
+        T{ quadtree f T{ rect f { -1.0  0.0 } { 0.5 0.5 } } f               f   f f f f t }
+        T{ quadtree f T{ rect f { -0.5  0.0 } { 0.5 0.5 } } { -0.25  0.25 } "c" f f f f t }
+        T{ quadtree f T{ rect f { -1.0  0.5 } { 0.5 0.5 } } { -0.75  0.75 } "d" f f f f t }
+        T{ quadtree f T{ rect f { -0.5  0.5 } { 0.5 0.5 } } f               f   f f f f t }
+        f
+    }
+    T{ quadtree f T{ rect f {  0.0  0.0 } { 1.0 1.0 } } f f
+        T{ quadtree f T{ rect f {  0.0  0.0 } { 0.5 0.5 } } {  0.25  0.25 } "g" f f f f t }
+        T{ quadtree f T{ rect f {  0.5  0.0 } { 0.5 0.5 } } f               f   f f f f t }
+        T{ quadtree f T{ rect f {  0.0  0.5 } { 0.5 0.5 } } f               f   f f f f t }
+        T{ quadtree f T{ rect f {  0.5  0.5 } { 0.5 0.5 } } {  0.75  0.75 } "h" f f f f t }
+        f
+    }
+    f
+} ] [
+    unit-bounds <quadtree>
+        "a" { -0.25 -0.25 } value>>key
+        "b" { -0.75 -0.75 } value>>key
+        "c" { -0.25  0.25 } value>>key
+        "d" { -0.75  0.75 } value>>key
+        "e" {  0.25 -0.25 } value>>key
+        "f" {  0.75 -0.75 } value>>key
+        "g" {  0.25  0.25 } value>>key
+        "h" {  0.75  0.75 } value>>key
+
+        prune
+] unit-test
+
+[ 8 ] [
+    unit-bounds <quadtree>
+        "a" { -0.25 -0.25 } value>>key
+        "b" { -0.75 -0.75 } value>>key
+        "c" { -0.25  0.25 } value>>key
+        "d" { -0.75  0.75 } value>>key
+        "e" {  0.25 -0.25 } value>>key
+        "f" {  0.75 -0.75 } value>>key
+        "g" {  0.25  0.25 } value>>key
+        "h" {  0.75  0.75 } value>>key
+
+        assoc-size
+] unit-test
+
+[ {
+    { { -0.75 -0.75 } "b" }
+    { { -0.75  0.75 } "d" }
+    { { -0.25 -0.25 } "a" }
+    { { -0.25  0.25 } "c" }
+    { {  0.25 -0.25 } "e" }
+    { {  0.25  0.25 } "g" }
+    { {  0.75 -0.75 } "f" }
+    { {  0.75  0.75 } "h" }
+} ] [
+    unit-bounds <quadtree>
+        "a" { -0.25 -0.25 } value>>key
+        "b" { -0.75 -0.75 } value>>key
+        "c" { -0.25  0.25 } value>>key
+        "d" { -0.75  0.75 } value>>key
+        "e" {  0.25 -0.25 } value>>key
+        "f" {  0.75 -0.75 } value>>key
+        "g" {  0.25  0.25 } value>>key
+        "h" {  0.75  0.75 } value>>key
+
+        >alist natural-sort
+] unit-test
+
diff --git a/extra/quadtrees/quadtrees.factor b/extra/quadtrees/quadtrees.factor
new file mode 100644
index 0000000000..60446f4bf8
--- /dev/null
+++ b/extra/quadtrees/quadtrees.factor
@@ -0,0 +1,188 @@
+! (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 ;
+IN: quadtrees
+
+TUPLE: quadtree { bounds rect } point value ll lr ul ur leaf? ;
+
+: <quadtree> ( bounds -- quadtree ) f f f f f f t quadtree boa ;
+
+: rect-ll ( rect -- point ) loc>> ;
+: rect-lr ( rect -- point ) [ loc>> ] [ width  ] bi v+x ;
+: rect-ul ( rect -- point ) [ loc>> ] [ height ] bi v+y ;
+: rect-ur ( rect -- point ) [ loc>> ] [ dim>>  ] bi v+  ;
+
+: 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)
+DEFER: insert
+DEFER: erase
+DEFER: at-point
+DEFER: quadtree>alist
+DEFER: quadtree-size
+DEFER: node-insert
+DEFER: in-rect*
+
+: child-dim ( rect -- dim/2 ) dim>> 0.5 v*n ; inline
+: ll-bounds ( rect -- rect' )
+    [   loc>>                                  ] [ child-dim ] bi <rect> ;
+: lr-bounds ( rect -- rect' )
+    [ [ loc>> ] [ dim>> { 0.5 0.0 } v* ] bi v+ ] [ child-dim ] bi <rect> ;
+: ul-bounds ( rect -- rect' )
+    [ [ loc>> ] [ dim>> { 0.0 0.5 } v* ] bi v+ ] [ child-dim ] bi <rect> ;
+: ur-bounds ( rect -- rect' )
+    [ [ loc>> ] [ dim>> { 0.5 0.5 } v* ] bi v+ ] [ child-dim ] bi <rect> ;
+
+: {quadrants} ( node -- quadrants )
+    { [ ll>> ] [ lr>> ] [ ul>> ] [ ur>> ] } cleave 4array ;
+
+: add-subnodes ( node -- node )
+    dup bounds>> {
+        [ ll-bounds <quadtree> >>ll ]
+        [ lr-bounds <quadtree> >>lr ]
+        [ ul-bounds <quadtree> >>ul ]
+        [ ur-bounds <quadtree> >>ur ]
+    } cleave
+    f >>leaf? ;
+
+: split-leaf ( value point leaf -- )
+    add-subnodes
+    [ value>> ] [ point>> ] [ ] tri
+    [ node-insert ] [ node-insert ] bi ;
+
+: leaf-replaceable? ( pt leaf -- ? ) point>> { [ nip not ] [ = ] } 2|| ;
+: leaf-insert ( value point leaf -- )
+    2dup leaf-replaceable?
+    [ [ (>>point) ] [ (>>value) ] bi ]
+    [ split-leaf ] if ;
+
+: node-insert ( value point node -- )
+    descend insert ;
+
+: insert ( value point tree -- )
+    dup leaf?>> [ leaf-insert ] [ node-insert ] if ;
+
+: leaf-at-point ( point leaf -- value/f ? )
+    tuck point>> = [ value>> t ] [ drop f f ] if ;
+
+: node-at-point ( point node -- value/f ? )
+    descend at-point ;
+
+: at-point ( point tree -- value/f ? )
+    dup leaf?>> [ leaf-at-point ] [ node-at-point ] if ;
+
+: (node-in-rect*) ( values rect node -- values )
+    2dup bounds>> intersects? [ in-rect* ] [ 2drop ] if ;
+: node-in-rect* ( values rect node -- values )
+    [ (node-in-rect*) ] with each-quadrant ;
+
+: leaf-in-rect* ( values rect leaf -- values ) 
+    tuck { [ nip point>> ] [ point>> swap intersects? ] } 2&&
+    [ value>> over push ] [ drop ] if ;
+
+: in-rect* ( values rect tree -- values )
+    dup leaf?>> [ leaf-in-rect* ] [ node-in-rect* ] if ;
+
+: leaf-erase ( point leaf -- )
+    tuck point>> = [ f >>point f >>value ] when drop ;
+
+: node-erase ( point node -- )
+    descend erase ;
+
+: erase ( point tree -- )
+    dup leaf?>> [ leaf-erase ] [ node-erase ] if ;
+
+: (?leaf) ( quadrant -- {point,value}/f )
+    dup point>> [ swap value>> 2array ] [ drop f ] if* ;
+: ?leaf ( quadrants -- {point,value}/f )
+    [ (?leaf) ] map sift dup length {
+        { 1 [ first ] }
+        { 0 [ drop { f f } ] }
+        [ 2drop f ]
+    } case ;
+
+: collapseable? ( node -- {point,value}/f )
+    {quadrants} { [ [ leaf?>> ] all? ] [ ?leaf ] } 1&& ;
+
+: remove-subnodes ( node -- leaf ) f >>ll f >>lr f >>ul f >>ur t >>leaf? ;
+
+: collapse ( node {point,value} -- )
+    first2 [ >>point ] [ >>value ] bi* remove-subnodes drop ;
+
+: node-prune ( node -- )
+    [ [ (prune) ] each-quadrant ] [ ] [ collapseable? ] tri
+    [ collapse ] [ drop ] if* ;
+
+: (prune) ( tree -- )
+    dup leaf?>> [ drop ] [ node-prune ] if ;
+
+: leaf>alist ( leaf -- alist )
+    dup point>> [ [ point>> ] [ value>> ] bi 2array 1array ] [ drop { } ] if ;
+
+: node>alist ( node -- alist ) [ quadtree>alist ] map-quadrant concat ;
+
+: quadtree>alist ( tree -- assoc )
+    dup leaf?>> [ leaf>alist ] [ node>alist ] if ;
+
+: leaf-size ( leaf -- count )
+    point>> [ 1 ] [ 0 ] if ;
+: node-size ( node -- count )
+    0 swap [ quadtree-size + ] each-quadrant ; 
+    
+: quadtree-size ( tree -- count )
+    dup leaf?>> [ leaf-size ] [ node-size ] if ;
+
+: leaf= ( a b -- ? ) [ [ point>> ] [ value>> ] bi 2array ] bi@ = ;
+
+: node= ( a b -- ? ) [ {quadrants} ] bi@ = ;
+
+: (tree=) ( a b -- ? ) dup leaf?>> [ leaf= ] [ node= ] if ;
+
+: tree= ( a b -- ? )
+    2dup [ leaf?>> ] bi@ = [ (tree=) ] [ 2drop f ] if ;
+
+PRIVATE>
+
+: prune ( tree -- tree ) [ (prune) ] keep ;
+
+: in-rect ( tree rect -- values )
+    [ 16 <vector> ] 2dip in-rect* ;
+
+M: quadtree equal? ( a b -- ? )
+    over quadtree? [ tree= ] [ 2drop f ] if ;
+
+INSTANCE: quadtree assoc
+
+M: quadtree at* ( key assoc -- value/f ? ) at-point ;
+M: quadtree assoc-size ( assoc -- n ) quadtree-size ;
+M: quadtree >alist ( assoc -- alist ) quadtree>alist ;
+M: quadtree set-at ( value key assoc -- ) insert ;
+M: quadtree delete-at ( key assoc -- ) erase ;
+M: quadtree clear-assoc ( assoc -- )
+    t >>leaf?
+    f >>point
+    f >>value
+    drop ;
+
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