factor: trim using lists

[factor.git] / extra / quadtrees / quadtrees.factor

diff --git a/extra/quadtrees/quadtrees.factor b/extra/quadtrees/quadtrees.factor
index 383a0907e7ff708ed826fa5c66e11e1780a0cb0d..2d23015f23503ffa9d58ab0996007feb5f860bc7 100644 (file)
--- a/extra/quadtrees/quadtrees.factor
+++ b/extra/quadtrees/quadtrees.factor
@@ -1,17 +1,19 @@
 ! (c) 2009 Joe Groff, see BSD license
 USING: assocs kernel math.rectangles combinators accessors
-math.vectors vectors sequences math math.points math.geometry
-combinators.short-circuit arrays fry locals ;
+math.vectors vectors sequences math combinators.short-circuit arrays ;
 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 ;
-: rect-ul ( rect -- point ) [ loc>> ] [ height ] bi v+y ;
-: rect-ur ( rect -- point ) [ loc>> ] [ dim>>  ] bi v+  ;
+: rect-lr ( rect -- point ) [ loc>> ] [ dim>> { 1 0 } v* ] bi v+ ;
+: rect-ul ( rect -- point ) [ loc>> ] [ dim>> { 0 1 } v* ] bi v+ ;
+: rect-ur ( rect -- point ) [ loc>> ] [ dim>>  ] bi v+ ;
 
 : rect-center ( rect -- point ) [ loc>> ] [ dim>> 0.5 v*n ] bi v+ ; inline
 
@@ -26,11 +28,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
 
@@ -55,7 +59,7 @@ DEFER: in-rect*
 : ur-bounds ( rect -- rect' )
     [ [ loc>> ] [ dim>> { 0.5 0.5 } v* ] bi v+ ] [ child-dim ] bi <rect> ;
 
-: {quadrants} ( node -- quadrants )
+: node>quadrants ( node -- quadrants )
     { [ ll>> ] [ lr>> ] [ ul>> ] [ ur>> ] } cleave 4array ;
 
 : add-subnodes ( node -- node )
@@ -73,9 +77,10 @@ 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 ]
+    [ [ point<< ] [ value<< ] bi ]
     [ split-leaf ] if ;
 
 : node-insert ( value point node -- )
@@ -84,8 +89,9 @@ DEFER: in-rect*
 : 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 ;
+:: leaf-at-point ( point leaf -- value/f ? )
+    point leaf point>> =
+    [ leaf value>> t ] [ f f ] if ;
 
 : node-at-point ( point node -- value/f ? )
     descend at-point ;
@@ -94,19 +100,19 @@ DEFER: in-rect*
     dup leaf?>> [ leaf-at-point ] [ node-at-point ] if ;
 
 : (node-in-rect*) ( values rect node -- values )
-    2dup bounds>> intersects? [ in-rect* ] [ 2drop ] if ;
+    2dup bounds>> contains-rect? [ 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 ;
+:: leaf-in-rect* ( values rect leaf -- values )
+    { [ leaf point>> ] [ leaf point>> rect contains-point? ] } 0&&
+    [ values leaf value>> suffix! ] [ values ] 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 ;
+:: leaf-erase ( point leaf -- )
+    point leaf point>> = [ leaf f >>point f >>value drop ] when ;
 
 : node-erase ( point node -- )
     descend erase ;
@@ -114,17 +120,17 @@ DEFER: in-rect*
 : erase ( point tree -- )
     dup leaf?>> [ leaf-erase ] [ node-erase ] if ;
 
-: (?leaf) ( quadrant -- {point,value}/f )
+: (?leaf) ( quadrant -- pair/f )
     dup point>> [ swap value>> 2array ] [ drop f ] if* ;
-: ?leaf ( quadrants -- {point,value}/f )
+: ?leaf ( quadrants -- pair/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&& ;
+: collapseable? ( node -- pair/f )
+    node>quadrants { [ [ leaf?>> ] all? ] [ ?leaf ] } 1&& ;
 
 : remove-subnodes ( node -- leaf ) f >>ll f >>lr f >>ul f >>ur t >>leaf? ;
 
@@ -149,23 +155,23 @@ DEFER: in-rect*
 : leaf-size ( leaf -- count )
     point>> [ 1 ] [ 0 ] if ;
 : node-size ( node -- count )
-    0 swap [ quadtree-size + ] each-quadrant ; 
-    
+    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@ = ;
+: leaf= ( a b -- ? ) [ [ point>> ] [ value>> ] bi 2array ] same? ;
 
-: node= ( a b -- ? ) [ {quadrants} ] bi@ = ;
+: node= ( a b -- ? ) [ node>quadrants ] same? ;
 
 : (tree=) ( a b -- ? ) dup leaf?>> [ leaf= ] [ node= ] if ;
 
 : tree= ( a b -- ? )
-    2dup [ leaf?>> ] bi@ = [ (tree=) ] [ 2drop f ] if ;
+    2dup [ leaf?>> ] same? [ (tree=) ] [ 2drop f ] if ;
 
 PRIVATE>
 
-: prune ( tree -- tree ) [ (prune) ] keep ;
+: prune-quadtree ( tree -- tree ) [ (prune) ] keep ;
 
 : in-rect ( tree rect -- values )
     [ 16 <vector> ] 2dip in-rect* ;
@@ -186,3 +192,7 @@ M: quadtree clear-assoc ( assoc -- )
     f >>value
     drop ;
 
+: swizzle ( sequence quot -- sequence' )
+    [ dup ] dip map
+    [ zip ] [ rect-containing <quadtree> ] bi
+    [ '[ first2 _ set-at ] each ] [ values ] bi ; inline