steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
factor/extra/quadtrees/quadtrees-tests.factor

242 lines
8.6 KiB
Factor
Raw Normal View History

gold-plate quadtrees
2009-02-02 16:16:03 -05:00
! (c) 2009 Joe Groff, see BSD license
Fix conflict
2009-02-05 23:29:15 -05:00
USING: accessors assocs kernel tools.test quadtrees math.rectangles sorting ;
quadtrees vocab
2009-02-02 14:16:03 -05:00
IN: quadtrees.tests
: unit-bounds ( -- rect ) { -1.0 -1.0 } { 2.0 2.0 } <rect> ;
: value>>key ( assoc value key -- assoc )
pick set-at ; inline
: delete>>key ( assoc key -- assoc )
over delete-at ; inline
[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } { 0.0 -0.25 } "a" f f f f t } ]
[
unit-bounds <quadtree>
"a" { 0.0 -0.25 } value>>key
] unit-test
[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } { 0.0 -0.25 } "b" f f f f t } ]
[
unit-bounds <quadtree>
"a" { 0.0 -0.25 } value>>key
"b" { 0.0 -0.25 } value>>key
] unit-test
[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } f f
T{ quadtree f T{ rect f { -1.0 -1.0 } { 1.0 1.0 } } { -0.5 -0.75 } "c" f f f f t }
T{ quadtree f T{ rect f { 0.0 -1.0 } { 1.0 1.0 } } { 0.0 -0.25 } "a" f f f f t }
T{ quadtree f T{ rect f { -1.0 0.0 } { 1.0 1.0 } } f f f f f f t }
T{ quadtree f T{ rect f { 0.0 0.0 } { 1.0 1.0 } } { 0.25 0.25 } "b" f f f f t }
f
} ] [
unit-bounds <quadtree>
"a" { 0.0 -0.25 } value>>key
"b" { 0.25 0.25 } value>>key
"c" { -0.5 -0.75 } value>>key
] unit-test
[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } f f
T{ quadtree f T{ rect f { -1.0 -1.0 } { 1.0 1.0 } } { -0.5 -0.75 } "c" f f f f t }
T{ quadtree f T{ rect f { 0.0 -1.0 } { 1.0 1.0 } } { 0.0 -0.25 } "a" f f f f t }
T{ quadtree f T{ rect f { -1.0 0.0 } { 1.0 1.0 } } f f f f f f t }
T{ quadtree f T{ rect f { 0.0 0.0 } { 1.0 1.0 } } f f
T{ quadtree f T{ rect f { 0.0 0.0 } { 0.5 0.5 } } { 0.25 0.25 } "b" f f f f t }
T{ quadtree f T{ rect f { 0.5 0.0 } { 0.5 0.5 } } { 0.75 0.25 } "d" f f f f t }
T{ quadtree f T{ rect f { 0.0 0.5 } { 0.5 0.5 } } f f f f f f t }
T{ quadtree f T{ rect f { 0.5 0.5 } { 0.5 0.5 } } f f f f f f t }
}
f
} ] [
unit-bounds <quadtree>
"a" { 0.0 -0.25 } value>>key
"b" { 0.25 0.25 } value>>key
"c" { -0.5 -0.75 } value>>key
"d" { 0.75 0.25 } value>>key
] unit-test
[ "b" t ] [
unit-bounds <quadtree>
"a" { 0.0 -0.25 } value>>key
"b" { 0.25 0.25 } value>>key
"c" { -0.5 -0.75 } value>>key
"d" { 0.75 0.25 } value>>key
{ 0.25 0.25 } swap at*
] unit-test
[ f f ] [
unit-bounds <quadtree>
"a" { 0.0 -0.25 } value>>key
"b" { 0.25 0.25 } value>>key
"c" { -0.5 -0.75 } value>>key
"d" { 0.75 0.25 } value>>key
{ 1.0 1.0 } swap at*
] unit-test
[ { "a" "c" } ] [
unit-bounds <quadtree>
"a" { 0.0 -0.25 } value>>key
"b" { 0.25 0.25 } value>>key
"c" { -0.5 -0.75 } value>>key
"d" { 0.75 0.25 } value>>key
{ -0.6 -0.8 } { 0.8 1.0 } <rect> swap in-rect natural-sort
] unit-test
[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } f f
T{ quadtree f T{ rect f { -1.0 -1.0 } { 1.0 1.0 } } { -0.5 -0.75 } "c" f f f f t }
T{ quadtree f T{ rect f { 0.0 -1.0 } { 1.0 1.0 } } { 0.0 -0.25 } "a" f f f f t }
T{ quadtree f T{ rect f { -1.0 0.0 } { 1.0 1.0 } } f f f f f f t }
T{ quadtree f T{ rect f { 0.0 0.0 } { 1.0 1.0 } } { 0.75 0.25 } "d" f f f f t }
f
} ] [
unit-bounds <quadtree>
"a" { 0.0 -0.25 } value>>key
"b" { 0.25 0.25 } value>>key
"c" { -0.5 -0.75 } value>>key
"d" { 0.75 0.25 } value>>key
{ 0.25 0.25 } delete>>key
fill some holes in quadtree docs, rename quadtrees:prune to prune-quadtree to avoid colliding with sets:prune, and kill silly call to boa
2009-02-03 21:09:28 -05:00
prune-quadtree
quadtrees vocab
2009-02-02 14:16:03 -05:00
] unit-test
[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } f f
T{ quadtree f T{ rect f { -1.0 -1.0 } { 1.0 1.0 } } { -0.5 -0.75 } "c" f f f f t }
T{ quadtree f T{ rect f { 0.0 -1.0 } { 1.0 1.0 } } { 0.0 -0.25 } "a" f f f f t }
T{ quadtree f T{ rect f { -1.0 0.0 } { 1.0 1.0 } } f f f f f f t }
T{ quadtree f T{ rect f { 0.0 0.0 } { 1.0 1.0 } } f f f f f f t }
f
} ] [
unit-bounds <quadtree>
"a" { 0.0 -0.25 } value>>key
"b" { 0.25 0.25 } value>>key
"c" { -0.5 -0.75 } value>>key
"d" { 0.75 0.25 } value>>key
{ 0.25 0.25 } delete>>key
{ 0.75 0.25 } delete>>key
fill some holes in quadtree docs, rename quadtrees:prune to prune-quadtree to avoid colliding with sets:prune, and kill silly call to boa
2009-02-03 21:09:28 -05:00
prune-quadtree
quadtrees vocab
2009-02-02 14:16:03 -05:00
] unit-test
[ T{ quadtree f T{ rect f { -1.0 -1.0 } { 2.0 2.0 } } f f
T{ quadtree f T{ rect f { -1.0 -1.0 } { 1.0 1.0 } } f f
T{ quadtree f T{ rect f { -1.0 -1.0 } { 0.5 0.5 } } { -0.75 -0.75 } "b" f f f f t }
T{ quadtree f T{ rect f { -0.5 -1.0 } { 0.5 0.5 } } f f f f f f t }
T{ quadtree f T{ rect f { -1.0 -0.5 } { 0.5 0.5 } } f f f f f f t }
T{ quadtree f T{ rect f { -0.5 -0.5 } { 0.5 0.5 } } { -0.25 -0.25 } "a" f f f f t }
f
}
T{ quadtree f T{ rect f { 0.0 -1.0 } { 1.0 1.0 } } f f
T{ quadtree f T{ rect f { 0.0 -1.0 } { 0.5 0.5 } } f f f f f f t }
T{ quadtree f T{ rect f { 0.5 -1.0 } { 0.5 0.5 } } { 0.75 -0.75 } "f" f f f f t }
T{ quadtree f T{ rect f { 0.0 -0.5 } { 0.5 0.5 } } { 0.25 -0.25 } "e" f f f f t }
T{ quadtree f T{ rect f { 0.5 -0.5 } { 0.5 0.5 } } f f f f f f t }
f
}
T{ quadtree f T{ rect f { -1.0 0.0 } { 1.0 1.0 } } f f
T{ quadtree f T{ rect f { -1.0 0.0 } { 0.5 0.5 } } f f f f f f t }
T{ quadtree f T{ rect f { -0.5 0.0 } { 0.5 0.5 } } { -0.25 0.25 } "c" f f f f t }
T{ quadtree f T{ rect f { -1.0 0.5 } { 0.5 0.5 } } { -0.75 0.75 } "d" f f f f t }
T{ quadtree f T{ rect f { -0.5 0.5 } { 0.5 0.5 } } f f f f f f t }
f
}
T{ quadtree f T{ rect f { 0.0 0.0 } { 1.0 1.0 } } f f
T{ quadtree f T{ rect f { 0.0 0.0 } { 0.5 0.5 } } { 0.25 0.25 } "g" f f f f t }
T{ quadtree f T{ rect f { 0.5 0.0 } { 0.5 0.5 } } f f f f f f t }
T{ quadtree f T{ rect f { 0.0 0.5 } { 0.5 0.5 } } f f f f f f t }
T{ quadtree f T{ rect f { 0.5 0.5 } { 0.5 0.5 } } { 0.75 0.75 } "h" f f f f t }
f
}
f
} ] [
unit-bounds <quadtree>
"a" { -0.25 -0.25 } value>>key
"b" { -0.75 -0.75 } value>>key
"c" { -0.25 0.25 } value>>key
"d" { -0.75 0.75 } value>>key
"e" { 0.25 -0.25 } value>>key
"f" { 0.75 -0.75 } value>>key
"g" { 0.25 0.25 } value>>key
"h" { 0.75 0.75 } value>>key
fill some holes in quadtree docs, rename quadtrees:prune to prune-quadtree to avoid colliding with sets:prune, and kill silly call to boa
2009-02-03 21:09:28 -05:00
prune-quadtree
quadtrees vocab
2009-02-02 14:16:03 -05:00
] unit-test
[ 8 ] [
unit-bounds <quadtree>
"a" { -0.25 -0.25 } value>>key
"b" { -0.75 -0.75 } value>>key
"c" { -0.25 0.25 } value>>key
"d" { -0.75 0.75 } value>>key
"e" { 0.25 -0.25 } value>>key
"f" { 0.75 -0.75 } value>>key
"g" { 0.25 0.25 } value>>key
"h" { 0.75 0.75 } value>>key
assoc-size
] unit-test
add test for quadtree >alist
2009-02-02 14:19:08 -05:00
[ {
{ { -0.75 -0.75 } "b" }
{ { -0.75 0.75 } "d" }
{ { -0.25 -0.25 } "a" }
{ { -0.25 0.25 } "c" }
{ { 0.25 -0.25 } "e" }
{ { 0.25 0.25 } "g" }
{ { 0.75 -0.75 } "f" }
{ { 0.75 0.75 } "h" }
} ] [
quadtrees vocab
2009-02-02 14:16:03 -05:00
unit-bounds <quadtree>
"a" { -0.25 -0.25 } value>>key
"b" { -0.75 -0.75 } value>>key
"c" { -0.25 0.25 } value>>key
"d" { -0.75 0.75 } value>>key
"e" { 0.25 -0.25 } value>>key
"f" { 0.75 -0.75 } value>>key
"g" { 0.25 0.25 } value>>key
"h" { 0.75 0.75 } value>>key
add test for quadtree >alist
2009-02-02 14:19:08 -05:00
>alist natural-sort
quadtrees vocab
2009-02-02 14:16:03 -05:00
] unit-test
swizzle word to swizzle sequences
2009-02-04 20:46:19 -05:00
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