steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

swizzle word to swizzle sequences

db4
Joe Groff 2009-02-04 19:46:19 -06:00
parent 6babe4bf3f
commit ccdd8999e1
4 changed files with 62 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
basis/math/geometry/rect/rect.factor
View File

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

3
basis/math/vectors/vectors.factor
View File

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

41
extra/quadtrees/quadtrees-tests.factor
View File

@ -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

20
extra/quadtrees/quadtrees.factor
View File

@ -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 -- )
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
@ -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 ;