swizzle word to swizzle sequences

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 <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- ;
+

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 ;

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 } <rect> ;
@@ -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

extra/quadtrees/quadtrees.factor

@@ -1,7 +1,7 @@
 ! (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? ;
@@ -29,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 -- )
+: each-quadrant ( node quot -- )
-    node ll>> quot call
+    {
-    node lr>> quot call
+        [ [ ll>> ] [ call ] bi* ] 
-    node ul>> quot call
+        [ [ lr>> ] [ call ] bi* ] 
-    node ur>> quot call ; inline
+        [ [ ul>> ] [ call ] bi* ] 
+        [ [ ur>> ] [ call ] bi* ] 
+    } 2cleave ; inline
 : map-quadrant ( node quot: ( child-node -- x ) -- array )
     each-quadrant 4array ; inline
 
@@ -76,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 ]
@@ -189,3 +192,8 @@ 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 ;
+