diff --git a/basis/math/geometry/rect/rect.factor b/basis/math/geometry/rect/rect.factor index a7cefceae8..08cfbbcc46 100644 --- a/basis/math/geometry/rect/rect.factor +++ b/basis/math/geometry/rect/rect.factor @@ -60,9 +60,14 @@ M: rect set-height! ( rect height -- rect ) over dim>> set-second ; 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 ; + ! 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- ; + diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index a6967a7218..4d9a0916b5 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -19,6 +19,9 @@ IN: math.vectors : 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 ; diff --git a/extra/quadtrees/quadtrees-docs.factor b/extra/quadtrees/quadtrees-docs.factor index f2de89ce3d..7b0d3772a0 100644 --- a/extra/quadtrees/quadtrees-docs.factor +++ b/extra/quadtrees/quadtrees-docs.factor @@ -2,17 +2,25 @@ USING: arrays assocs help.markup help.syntax math.geometry.rect quadtrees quotat 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 } +"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: +{ $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" } "." } ; @@ -32,3 +40,6 @@ 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" } "." } ; +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" } "." } ; diff --git a/extra/quadtrees/quadtrees-tests.factor b/extra/quadtrees/quadtrees-tests.factor index b96cdd82bf..7a17c1fb44 100644 --- a/extra/quadtrees/quadtrees-tests.factor +++ b/extra/quadtrees/quadtrees-tests.factor @@ -1,5 +1,5 @@ ! (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 } ; @@ -98,7 +98,7 @@ IN: quadtrees.tests "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 @@ -116,7 +116,7 @@ IN: quadtrees.tests { 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 @@ -160,7 +160,7 @@ IN: quadtrees.tests "g" { 0.25 0.25 } value>>key "h" { 0.75 0.75 } value>>key - prune + prune-quadtree ] unit-test [ 8 ] [ @@ -200,3 +200,42 @@ IN: quadtrees.tests >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 diff --git a/extra/quadtrees/quadtrees.factor b/extra/quadtrees/quadtrees.factor index 60446f4bf8..d9bdbe4aeb 100644 --- a/extra/quadtrees/quadtrees.factor +++ b/extra/quadtrees/quadtrees.factor @@ -1,12 +1,15 @@ ! (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? ; -: ( bounds -- quadtree ) f f f f f f t quadtree boa ; +: ( bounds -- quadtree ) + quadtree new + swap >>bounds + t >>leaf? ; : rect-ll ( rect -- point ) loc>> ; : rect-lr ( rect -- point ) [ loc>> ] [ width ] bi v+x ; @@ -26,11 +29,13 @@ TUPLE: quadtree { bounds rect } point value ll lr ul ur leaf? ; : 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 @@ -73,6 +78,7 @@ DEFER: in-rect* [ node-insert ] [ node-insert ] bi ; : leaf-replaceable? ( pt leaf -- ? ) point>> { [ nip not ] [ = ] } 2|| ; + : leaf-insert ( value point leaf -- ) 2dup leaf-replaceable? [ [ (>>point) ] [ (>>value) ] bi ] @@ -165,7 +171,7 @@ DEFER: in-rect* PRIVATE> -: prune ( tree -- tree ) [ (prune) ] keep ; +: prune-quadtree ( tree -- tree ) [ (prune) ] keep ; : in-rect ( tree rect -- values ) [ 16 ] 2dip in-rect* ; @@ -186,3 +192,8 @@ M: quadtree clear-assoc ( assoc -- ) f >>value drop ; +: swizzle ( sequence quot -- sequence' ) + [ dup ] dip map + [ zip ] [ rect-containing ] bi + [ '[ first2 _ set-at ] each ] [ values ] bi ; +