M: rect set-x! ( rect x -- rect ) over loc>> set-first ;
M: rect set-y! ( rect y -- rect ) over loc>> set-second ;
+: rect-containing ( points -- rect )
+ [ vleast ] [ vgreatest ] bi
+ [ drop ] [ swap v- ] 2bi <rect> ;
+
! Accessing corners
: top-left ( rect -- point ) loc>> ;
: top-right ( rect -- point ) [ loc>> ] [ width 1 - ] bi v+x ;
: bottom-left ( rect -- point ) [ loc>> ] [ height 1 - ] bi v+y ;
: bottom-right ( rect -- point ) [ loc>> ] [ dim>> ] bi v+ { 1 1 } v- ;
+
: vmax ( u v -- w ) [ max ] 2map ;
: vmin ( u v -- w ) [ min ] 2map ;
+: vgreatest ( array -- vmax ) { -1.0/0.0 -1.0/0.0 } [ vmax ] reduce ;
+: vleast ( array -- vmax ) { 1.0/0.0 1.0/0.0 } [ vmin ] reduce ;
+
: v. ( u v -- x ) [ * ] [ + ] 2map-reduce ;
: norm-sq ( v -- x ) [ absq ] [ + ] map-reduce ;
: norm ( v -- x ) norm-sq sqrt ;
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 }
+"The " { $snippet "quadtrees" } " vocabulary implements the quadtree data structure in Factor."
+{ $subsection <quadtree> }
+"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 in-rect }
+{ $subsection prune-quadtree }
"The following words are provided to help write quadtree algorithms:"
{ $subsection descend }
{ $subsection each-quadrant }
-{ $subsection map-quadrant } ;
+{ $subsection map-quadrant }
+"Quadtrees can be used to \"swizzle\" a sequence to improve the locality of spatial data in memory:"
+{ $subsection swizzle } ;
ABOUT: "quadtrees"
-HELP: prune
+HELP: <quadtree>
+{ $values { "bounds" rect } { "quadtree" quadtree } }
+{ $description "Constructs an empty quadtree covering the axis-aligned rectangle indicated by " { $snippet "bounds" } ". All the keys of " { $snippet "quadtree" } " must be two-dimensional vectors lying inside " { $snippet "bounds" } "." } ;
+
+HELP: prune-quadtree
{ $values { "tree" quadtree } }
{ $description "Removes empty nodes from " { $snippet "tree" } "." } ;
{ $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" } "." } ;
+HELP: swizzle
+{ $values { "sequence" sequence } { "quot" quotation } { "sequence'" sequence } }
+{ $description "Swizzles " { $snippet "sequence" } " based on the two-dimensional vector values returned by calling " { $snippet "quot" } " on each element of " { $snippet "sequence" } "." } ;
! (c) 2009 Joe Groff, see BSD license
-USING: assocs kernel tools.test quadtrees math.geometry.rect sorting ;
+USING: accessors assocs kernel tools.test quadtrees math.geometry.rect sorting ;
IN: quadtrees.tests
: unit-bounds ( -- rect ) { -1.0 -1.0 } { 2.0 2.0 } <rect> ;
"d" { 0.75 0.25 } value>>key
{ 0.25 0.25 } delete>>key
- prune
+ prune-quadtree
] unit-test
[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } f f
{ 0.25 0.25 } delete>>key
{ 0.75 0.25 } delete>>key
- prune
+ prune-quadtree
] unit-test
[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } f f
"g" { 0.25 0.25 } value>>key
"h" { 0.75 0.75 } value>>key
- prune
+ prune-quadtree
] unit-test
[ 8 ] [
>alist natural-sort
] unit-test
+TUPLE: pointy-thing center ;
+
+[ {
+ T{ pointy-thing f { 0 0 } }
+ T{ pointy-thing f { 1 0 } }
+ T{ pointy-thing f { 0 1 } }
+ T{ pointy-thing f { 1 1 } }
+ T{ pointy-thing f { 2 0 } }
+ T{ pointy-thing f { 3 0 } }
+ T{ pointy-thing f { 2 1 } }
+ T{ pointy-thing f { 3 1 } }
+ T{ pointy-thing f { 0 2 } }
+ T{ pointy-thing f { 1 2 } }
+ T{ pointy-thing f { 0 3 } }
+ T{ pointy-thing f { 1 3 } }
+ T{ pointy-thing f { 2 2 } }
+ T{ pointy-thing f { 3 2 } }
+ T{ pointy-thing f { 2 3 } }
+ T{ pointy-thing f { 3 3 } }
+} ] [
+ {
+ T{ pointy-thing f { 3 1 } }
+ T{ pointy-thing f { 2 3 } }
+ T{ pointy-thing f { 3 2 } }
+ T{ pointy-thing f { 0 1 } }
+ T{ pointy-thing f { 2 2 } }
+ T{ pointy-thing f { 1 1 } }
+ T{ pointy-thing f { 3 0 } }
+ T{ pointy-thing f { 3 3 } }
+ T{ pointy-thing f { 1 3 } }
+ T{ pointy-thing f { 2 1 } }
+ T{ pointy-thing f { 0 0 } }
+ T{ pointy-thing f { 2 0 } }
+ T{ pointy-thing f { 1 0 } }
+ T{ pointy-thing f { 0 2 } }
+ T{ pointy-thing f { 1 2 } }
+ T{ pointy-thing f { 0 3 } }
+ } [ center>> ] swizzle
+] unit-test
! (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 ;
+combinators.short-circuit arrays fry ;
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 ;
+: <quadtree> ( bounds -- quadtree )
+ quadtree new
+ swap >>bounds
+ t >>leaf? ;
: rect-ll ( rect -- point ) loc>> ;
: rect-lr ( rect -- point ) [ loc>> ] [ width ] bi v+x ;
: 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
+: each-quadrant ( node quot -- )
+ {
+ [ [ ll>> ] [ call ] bi* ]
+ [ [ lr>> ] [ call ] bi* ]
+ [ [ ul>> ] [ call ] bi* ]
+ [ [ ur>> ] [ call ] bi* ]
+ } 2cleave ; inline
: map-quadrant ( node quot: ( child-node -- x ) -- array )
each-quadrant 4array ; inline
[ node-insert ] [ node-insert ] bi ;
: leaf-replaceable? ( pt leaf -- ? ) point>> { [ nip not ] [ = ] } 2|| ;
+
: leaf-insert ( value point leaf -- )
2dup leaf-replaceable?
[ [ (>>point) ] [ (>>value) ] bi ]
PRIVATE>
-: prune ( tree -- tree ) [ (prune) ] keep ;
+: prune-quadtree ( tree -- tree ) [ (prune) ] keep ;
: in-rect ( tree rect -- values )
[ 16 <vector> ] 2dip in-rect* ;
f >>value
drop ;
+: swizzle ( sequence quot -- sequence' )
+ [ dup ] dip map
+ [ zip ] [ rect-containing <quadtree> ] bi
+ [ '[ first2 _ set-at ] each ] [ values ] bi ;
+