From d32d436154f1fd40887460a32c65f85eb402b73b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 2 Feb 2009 13:16:03 -0600 Subject: [PATCH 1/4] quadtrees vocab --- extra/quadtrees/quadtrees-tests.factor | 193 +++++++++++++++++++++++++ extra/quadtrees/quadtrees.factor | 178 +++++++++++++++++++++++ 2 files changed, 371 insertions(+) create mode 100644 extra/quadtrees/quadtrees-tests.factor create mode 100644 extra/quadtrees/quadtrees.factor diff --git a/extra/quadtrees/quadtrees-tests.factor b/extra/quadtrees/quadtrees-tests.factor new file mode 100644 index 0000000000..e1b885ccc0 --- /dev/null +++ b/extra/quadtrees/quadtrees-tests.factor @@ -0,0 +1,193 @@ +USING: assocs kernel tools.test quadtrees math.geometry.rect sorting ; +IN: quadtrees.tests + +: unit-bounds ( -- rect ) { -1.0 -1.0 } { 2.0 2.0 } ; + +: 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 + "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 + "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 + "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 + "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 + "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 + "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 + "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 } 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 + "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 + prune +] 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 + "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 + prune +] 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 + "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 + + prune +] unit-test + +[ 8 ] [ + unit-bounds + "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 + +[ 8 ] [ + unit-bounds + "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 + + diff --git a/extra/quadtrees/quadtrees.factor b/extra/quadtrees/quadtrees.factor new file mode 100644 index 0000000000..66b3c2f15d --- /dev/null +++ b/extra/quadtrees/quadtrees.factor @@ -0,0 +1,178 @@ +USING: assocs kernel math.geometry.rect combinators accessors +math.vectors vectors sequences math math.points math.geometry +combinators.short-circuit arrays fry locals ; +IN: quadtrees + +TUPLE: quadtree { bounds rect } point value ll lr ul ur leaf? ; + +: ( bounds -- quadtree ) f f f f f f t quadtree boa ; + +: 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-center ( rect -- point ) [ loc>> ] [ dim>> 0.5 v*n ] bi v+ ; inline + +alist +DEFER: node-insert +DEFER: in-rect* + +: child-dim ( rect -- dim/2 ) dim>> 0.5 v*n ; inline +: ll-bounds ( rect -- rect' ) + [ loc>> ] [ child-dim ] bi ; +: lr-bounds ( rect -- rect' ) + [ [ loc>> ] [ dim>> { 0.5 0.0 } v* ] bi v+ ] [ child-dim ] bi ; +: ul-bounds ( rect -- rect' ) + [ [ loc>> ] [ dim>> { 0.0 0.5 } v* ] bi v+ ] [ child-dim ] bi ; +: ur-bounds ( rect -- rect' ) + [ [ loc>> ] [ dim>> { 0.5 0.5 } v* ] bi v+ ] [ child-dim ] bi ; + +: (quadrant) ( pt node -- quadrant ) + swap [ first 0.0 < ] [ second 0.0 < ] bi + [ [ ll>> ] [ lr>> ] if ] + [ [ ul>> ] [ ur>> ] if ] if ; + +: quadrant ( pt node -- quadrant ) + [ bounds>> rect-center v- ] keep (quadrant) ; + +: descend ( pt node -- pt subnode ) + [ drop ] [ quadrant ] 2bi ; inline + +: {quadrants} ( node -- quadrants ) + { [ ll>> ] [ lr>> ] [ ul>> ] [ ur>> ] } cleave 4array ; + +:: each-quadrant ( node quot -- array ) + node ll>> quot call + node lr>> quot call + node ul>> quot call + node ur>> quot call ; inline +: map-quadrant ( node quot: ( child-node -- x ) -- array ) + each-quadrant 4array ; inline + +: add-subnodes ( node -- node ) + dup bounds>> { + [ ll-bounds >>ll ] + [ lr-bounds >>lr ] + [ ul-bounds >>ul ] + [ ur-bounds >>ur ] + } cleave + f >>leaf? ; + +: split-leaf ( value point leaf -- ) + add-subnodes + [ value>> ] [ point>> ] [ ] tri + [ node-insert ] [ node-insert ] bi ; + +: leaf-replaceable? ( pt leaf -- ? ) point>> { [ nip not ] [ = ] } 2|| ; +: leaf-insert ( value point leaf -- ) + 2dup leaf-replaceable? + [ [ (>>point) ] [ (>>value) ] bi ] + [ split-leaf ] if ; + +: node-insert ( value point node -- ) + descend insert ; + +: 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 ; + +: node-at-point ( point node -- value/f ? ) + descend at-point ; + +: at-point ( point tree -- value/f ? ) + dup leaf?>> [ leaf-at-point ] [ node-at-point ] if ; + +: (node-in-rect*) ( values rect node -- values ) + 2dup bounds>> intersects? [ 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 ; + +: 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 ; + +: node-erase ( point node -- ) + descend erase ; + +: erase ( point tree -- ) + dup leaf?>> [ leaf-erase ] [ node-erase ] if ; + +: (?leaf) ( quadrant -- {point,value}/f ) + dup point>> [ swap value>> 2array ] [ drop f ] if* ; +: ?leaf ( quadrants -- {point,value}/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&& ; + +: remove-subnodes ( node -- leaf ) f >>ll f >>lr f >>ul f >>ur t >>leaf? ; + +: collapse ( node {point,value} -- ) + first2 [ >>point ] [ >>value ] bi* remove-subnodes drop ; + +: node-prune ( node -- ) + [ [ (prune) ] each-quadrant ] [ ] [ collapseable? ] tri + [ collapse ] [ drop ] if* ; + +: (prune) ( tree -- ) + dup leaf?>> [ drop ] [ node-prune ] if ; + +: leaf>alist ( leaf -- alist ) + dup point>> [ [ point>> ] [ value>> ] bi 2array 1array ] [ drop { } ] if ; + +: node>alist ( node -- alist ) [ quadtree>alist ] map-quadrant concat ; + +: quadtree>alist ( tree -- assoc ) + dup leaf?>> [ leaf>alist ] [ node>alist ] if ; + +: leaf= ( a b -- ? ) [ [ point>> ] [ value>> ] bi 2array ] bi@ = ; + +: node= ( a b -- ? ) [ {quadrants} ] bi@ = ; + +: (tree=) ( a b -- ? ) dup leaf?>> [ leaf= ] [ node= ] if ; + +: tree= ( a b -- ? ) + 2dup [ leaf?>> ] bi@ = [ (tree=) ] [ 2drop f ] if ; + +PRIVATE> + +: prune ( tree -- tree ) [ (prune) ] keep ; + +: in-rect ( tree rect -- values ) + [ 16 ] 2dip in-rect* ; + +M: quadtree equal? ( a b -- ? ) + over quadtree? [ tree= ] [ 2drop f ] if ; + +INSTANCE: quadtree assoc + +M: quadtree at* ( key assoc -- value/f ? ) at-point ; +M: quadtree assoc-size ( assoc -- n ) quadtree>alist length ; ! XXX implement proper +M: quadtree >alist ( assoc -- alist ) quadtree>alist ; +M: quadtree set-at ( value key assoc -- ) insert ; +M: quadtree delete-at ( key assoc -- ) erase ; +M: quadtree clear-assoc ( assoc -- ) + t >>leaf? + f >>point + f >>value + drop ; + From cffb6340019c2301802d28cbe49ba3516b3dee67 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 2 Feb 2009 13:19:08 -0600 Subject: [PATCH 2/4] add test for quadtree >alist --- extra/quadtrees/quadtrees-tests.factor | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/extra/quadtrees/quadtrees-tests.factor b/extra/quadtrees/quadtrees-tests.factor index e1b885ccc0..715adc0729 100644 --- a/extra/quadtrees/quadtrees-tests.factor +++ b/extra/quadtrees/quadtrees-tests.factor @@ -176,7 +176,16 @@ IN: quadtrees.tests assoc-size ] unit-test -[ 8 ] [ +[ { + { { -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" } +} ] [ unit-bounds "a" { -0.25 -0.25 } value>>key "b" { -0.75 -0.75 } value>>key @@ -187,7 +196,7 @@ IN: quadtrees.tests "g" { 0.25 0.25 } value>>key "h" { 0.75 0.75 } value>>key - assoc-size + >alist natural-sort ] unit-test From b2d0daa68d7fba36a45e12fcd584fc64294f6776 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 2 Feb 2009 14:25:29 -0600 Subject: [PATCH 3/4] non-retarded implementation of quadtree assoc-size --- extra/quadtrees/quadtrees-tests.factor | 1 - extra/quadtrees/quadtrees.factor | 11 ++++++++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/extra/quadtrees/quadtrees-tests.factor b/extra/quadtrees/quadtrees-tests.factor index 715adc0729..8dd4b53dcb 100644 --- a/extra/quadtrees/quadtrees-tests.factor +++ b/extra/quadtrees/quadtrees-tests.factor @@ -199,4 +199,3 @@ IN: quadtrees.tests >alist natural-sort ] unit-test - diff --git a/extra/quadtrees/quadtrees.factor b/extra/quadtrees/quadtrees.factor index 66b3c2f15d..a56b94e7d3 100644 --- a/extra/quadtrees/quadtrees.factor +++ b/extra/quadtrees/quadtrees.factor @@ -21,6 +21,7 @@ DEFER: insert DEFER: erase DEFER: at-point DEFER: quadtree>alist +DEFER: quadtree-size DEFER: node-insert DEFER: in-rect* @@ -144,6 +145,14 @@ DEFER: in-rect* : quadtree>alist ( tree -- assoc ) dup leaf?>> [ leaf>alist ] [ node>alist ] if ; +: leaf-size ( leaf -- count ) + point>> [ 1 ] [ 0 ] if ; +: node-size ( node -- count ) + 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@ = ; : node= ( a b -- ? ) [ {quadrants} ] bi@ = ; @@ -166,7 +175,7 @@ M: quadtree equal? ( a b -- ? ) INSTANCE: quadtree assoc M: quadtree at* ( key assoc -- value/f ? ) at-point ; -M: quadtree assoc-size ( assoc -- n ) quadtree>alist length ; ! XXX implement proper +M: quadtree assoc-size ( assoc -- n ) quadtree-size ; M: quadtree >alist ( assoc -- alist ) quadtree>alist ; M: quadtree set-at ( value key assoc -- ) insert ; M: quadtree delete-at ( key assoc -- ) erase ; From 82daca7f6f7c5899c2e8b5e0b8531d3121654702 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 2 Feb 2009 15:16:03 -0600 Subject: [PATCH 4/4] gold-plate quadtrees --- extra/quadtrees/authors.txt | 1 + extra/quadtrees/quadtrees-docs.factor | 34 ++++++++++++++++++++++ extra/quadtrees/quadtrees-tests.factor | 1 + extra/quadtrees/quadtrees.factor | 39 +++++++++++++------------- extra/quadtrees/summary.txt | 1 + extra/quadtrees/tags.txt | 2 ++ 6 files changed, 59 insertions(+), 19 deletions(-) create mode 100644 extra/quadtrees/authors.txt create mode 100644 extra/quadtrees/quadtrees-docs.factor create mode 100644 extra/quadtrees/summary.txt create mode 100644 extra/quadtrees/tags.txt diff --git a/extra/quadtrees/authors.txt b/extra/quadtrees/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/quadtrees/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/quadtrees/quadtrees-docs.factor b/extra/quadtrees/quadtrees-docs.factor new file mode 100644 index 0000000000..f2de89ce3d --- /dev/null +++ b/extra/quadtrees/quadtrees-docs.factor @@ -0,0 +1,34 @@ +USING: arrays assocs help.markup help.syntax math.geometry.rect quadtrees quotations sequences ; +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 } +{ $subsection in-rect } +"The following words are provided to help write quadtree algorithms:" +{ $subsection descend } +{ $subsection each-quadrant } +{ $subsection map-quadrant } ; + +ABOUT: "quadtrees" + +HELP: prune +{ $values { "tree" quadtree } } +{ $description "Removes empty nodes from " { $snippet "tree" } "." } ; + +HELP: in-rect +{ $values { "tree" quadtree } { "rect" rect } { "values" sequence } } +{ $description "Returns a " { $link sequence } " of values from " { $snippet "tree" } " whose keys lie inside " { $snippet "rect" } "." } ; + +HELP: descend +{ $values { "pt" sequence } { "node" quadtree } { "subnode" quadtree } } +{ $description "Descends into the subnode of quadtree node " { $snippet "node" } " that contains " { $snippet "pt" } ", leaving " { $snippet "pt" } " on the stack." } ; + +HELP: each-quadrant +{ $values { "node" quadtree } { "quot" quotation } } +{ $description "Calls " { $snippet "quot" } " with each subnode of " { $snippet "node" } " on the top of the stack in turn." } ; + +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" } "." } ; + diff --git a/extra/quadtrees/quadtrees-tests.factor b/extra/quadtrees/quadtrees-tests.factor index 8dd4b53dcb..b96cdd82bf 100644 --- a/extra/quadtrees/quadtrees-tests.factor +++ b/extra/quadtrees/quadtrees-tests.factor @@ -1,3 +1,4 @@ +! (c) 2009 Joe Groff, see BSD license USING: assocs kernel tools.test quadtrees math.geometry.rect sorting ; IN: quadtrees.tests diff --git a/extra/quadtrees/quadtrees.factor b/extra/quadtrees/quadtrees.factor index a56b94e7d3..60446f4bf8 100644 --- a/extra/quadtrees/quadtrees.factor +++ b/extra/quadtrees/quadtrees.factor @@ -1,3 +1,4 @@ +! (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 ; @@ -14,6 +15,25 @@ TUPLE: quadtree { bounds rect } point value ll lr ul ur leaf? ; : rect-center ( rect -- point ) [ loc>> ] [ dim>> 0.5 v*n ] bi v+ ; inline +: (quadrant) ( pt node -- quadrant ) + swap [ first 0.0 < ] [ second 0.0 < ] bi + [ [ ll>> ] [ lr>> ] if ] + [ [ ul>> ] [ ur>> ] if ] if ; + +: quadrant ( pt node -- quadrant ) + [ bounds>> rect-center v- ] keep (quadrant) ; + +: 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 +: map-quadrant ( node quot: ( child-node -- x ) -- array ) + each-quadrant 4array ; inline + > ] [ dim>> { 0.5 0.5 } v* ] bi v+ ] [ child-dim ] bi ; -: (quadrant) ( pt node -- quadrant ) - swap [ first 0.0 < ] [ second 0.0 < ] bi - [ [ ll>> ] [ lr>> ] if ] - [ [ ul>> ] [ ur>> ] if ] if ; - -: quadrant ( pt node -- quadrant ) - [ bounds>> rect-center v- ] keep (quadrant) ; - -: descend ( pt node -- pt subnode ) - [ drop ] [ quadrant ] 2bi ; inline - : {quadrants} ( node -- quadrants ) { [ ll>> ] [ lr>> ] [ ul>> ] [ ur>> ] } cleave 4array ; -:: each-quadrant ( node quot -- array ) - node ll>> quot call - node lr>> quot call - node ul>> quot call - node ur>> quot call ; inline -: map-quadrant ( node quot: ( child-node -- x ) -- array ) - each-quadrant 4array ; inline - : add-subnodes ( node -- node ) dup bounds>> { [ ll-bounds >>ll ] diff --git a/extra/quadtrees/summary.txt b/extra/quadtrees/summary.txt new file mode 100644 index 0000000000..dd846a0a97 --- /dev/null +++ b/extra/quadtrees/summary.txt @@ -0,0 +1 @@ +Quadtree spatial indices diff --git a/extra/quadtrees/tags.txt b/extra/quadtrees/tags.txt new file mode 100644 index 0000000000..c133c6df7e --- /dev/null +++ b/extra/quadtrees/tags.txt @@ -0,0 +1,2 @@ +assocs +graphics