From b684db297a07b3d8258e4c9b7d4184fa8068a2ef Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Feb 2009 03:46:10 -0600 Subject: [PATCH 01/11] Use [ max ] map-reduce instead of map supremum; would be nice to find a good name for this and put it in sequences vocab --- basis/alien/structs/structs.factor | 6 +++--- .../tree/normalization/introductions/introductions.factor | 4 ++-- basis/stack-checker/branches/branches.factor | 4 ++-- basis/tools/disassembler/udis/udis.factor | 5 +++-- extra/project-euler/008/008.factor | 4 ++-- extra/project-euler/011/011.factor | 4 ++-- extra/project-euler/056/056.factor | 2 +- extra/sequences/modified/modified.factor | 5 +++-- extra/tetris/tetromino/tetromino.factor | 6 +++--- 9 files changed, 21 insertions(+), 19 deletions(-) diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index a3c616cda2..42923fb28b 100644 --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays generic hashtables kernel kernel.private math namespaces parser sequences strings words libc fry -alien.c-types alien.structs.fields cpu.architecture ; +alien.c-types alien.structs.fields cpu.architecture math.order ; IN: alien.structs TUPLE: struct-type size align fields ; @@ -47,7 +47,7 @@ M: struct-type stack-size [ first2 ] with with map ; : compute-struct-align ( types -- n ) - [ c-type-align ] map supremum ; + [ c-type-align ] [ max ] map-reduce ; : define-struct ( name vocab fields -- ) [ @@ -59,5 +59,5 @@ M: struct-type stack-size : define-union ( name members -- ) [ expand-constants ] map - [ [ heap-size ] map supremum ] keep + [ [ heap-size ] [ max ] map-reduce ] keep compute-struct-align f (define-struct) ; diff --git a/basis/compiler/tree/normalization/introductions/introductions.factor b/basis/compiler/tree/normalization/introductions/introductions.factor index 9e96dc0472..743b8c56da 100644 --- a/basis/compiler/tree/normalization/introductions/introductions.factor +++ b/basis/compiler/tree/normalization/introductions/introductions.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces sequences accessors math kernel -compiler.tree ; +compiler.tree math.order ; IN: compiler.tree.normalization.introductions SYMBOL: introductions @@ -25,7 +25,7 @@ M: #introduce count-introductions* M: #branch count-introductions* children>> - [ count-introductions ] map supremum + [ count-introductions ] [ max ] map-reduce introductions+ ; M: #recursive count-introductions* diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index 2eb4fb46a9..690af39c28 100755 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry vectors sequences assocs math accessors kernel +USING: fry vectors sequences assocs math math.order accessors kernel combinators quotations namespaces grouping stack-checker.state stack-checker.backend stack-checker.errors stack-checker.visitor stack-checker.values stack-checker.recursive-state ; @@ -16,7 +16,7 @@ SYMBOL: +bottom+ : pad-with-bottom ( seq -- newseq ) dup empty? [ - dup [ length ] map supremum + dup [ length ] [ max ] map-reduce '[ _ +bottom+ pad-head ] map ] unless ; diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index cb52b1d5db..cfa2483c7e 100644 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.disassembler namespaces combinators alien alien.syntax alien.c-types lexer parser kernel -sequences layouts math math.parser system make fry arrays ; +sequences layouts math math.order +math.parser system make fry arrays ; IN: tools.disassembler.udis << @@ -56,7 +57,7 @@ SINGLETON: udis-disassembler : buf/len ( from to -- buf len ) [ drop ] [ swap - ] 2bi ; : format-disassembly ( lines -- lines' ) - dup [ second length ] map supremum + dup [ second length ] [ max ] map-reduce '[ [ [ first >hex cell 2 * CHAR: 0 pad-head % ": " % ] diff --git a/extra/project-euler/008/008.factor b/extra/project-euler/008/008.factor index 24ccbb443a..1e8dade646 100644 --- a/extra/project-euler/008/008.factor +++ b/extra/project-euler/008/008.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: grouping math.parser sequences ; +USING: grouping math.order math.parser sequences ; IN: project-euler.008 ! http://projecteuler.net/index.php?section=problems&id=8 @@ -64,7 +64,7 @@ IN: project-euler.008 PRIVATE> : euler008 ( -- answer ) - source-008 5 clump [ string>digits product ] map supremum ; + source-008 5 clump [ string>digits product ] [ max ] map-reduce ; ! [ euler008 ] 100 ave-time ! 2 ms ave run time - 0.79 SD (100 trials) diff --git a/extra/project-euler/011/011.factor b/extra/project-euler/011/011.factor index 0940695726..122eec2c2e 100644 --- a/extra/project-euler/011/011.factor +++ b/extra/project-euler/011/011.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: grouping kernel make sequences ; +USING: grouping kernel make math.order sequences ; IN: project-euler.011 ! http://projecteuler.net/index.php?section=problems&id=11 @@ -88,7 +88,7 @@ IN: project-euler.011 : max-product ( matrix width -- n ) [ clump ] curry map concat - [ product ] map supremum ; inline + [ product ] [ max ] map-reduce ; inline PRIVATE> diff --git a/extra/project-euler/056/056.factor b/extra/project-euler/056/056.factor index 34626b796d..4e7bbdc0df 100644 --- a/extra/project-euler/056/056.factor +++ b/extra/project-euler/056/056.factor @@ -23,7 +23,7 @@ IN: project-euler.056 : euler056 ( -- answer ) 90 100 [a,b) dup cartesian-product - [ first2 ^ number>digits sum ] map supremum ; + [ first2 ^ number>digits sum ] [ max ] map-reduce ; ! [ euler056 ] 100 ave-time ! 22 ms ave run time - 2.13 SD (100 trials) diff --git a/extra/sequences/modified/modified.factor b/extra/sequences/modified/modified.factor index 3e4c1b1bdc..d552f2dc77 100644 --- a/extra/sequences/modified/modified.factor +++ b/extra/sequences/modified/modified.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel math sequences sequences.private shuffle ; +USING: accessors arrays kernel math math.order +sequences sequences.private shuffle ; IN: sequences.modified TUPLE: modified ; @@ -50,7 +51,7 @@ M: offset modified-set-nth ( elt n seq -- ) TUPLE: summed < modified seqs ; C: summed -M: summed length seqs>> [ length ] map supremum ; +M: summed length seqs>> [ length ] [ max ] map-reduce ; Date: Mon, 2 Feb 2009 03:47:45 -0600 Subject: [PATCH 02/11] Refactor basis/wrap to have a more flexible API --- basis/wrap/wrap-tests.factor | 48 +++++++++++++++++++++++++ basis/wrap/wrap.factor | 66 ++++++++++++++++++++++++---------- basis/xml/writer/writer.factor | 2 +- 3 files changed, 96 insertions(+), 20 deletions(-) create mode 100644 basis/wrap/wrap-tests.factor diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/wrap-tests.factor new file mode 100644 index 0000000000..b2d18761e2 --- /dev/null +++ b/basis/wrap/wrap-tests.factor @@ -0,0 +1,48 @@ +IN: wrap.tests +USING: tools.test wrap multiline sequences ; + +[ + { + { + T{ word f 1 10 f } + T{ word f 2 10 f } + T{ word f 3 2 t } + } + { + T{ word f 4 10 f } + T{ word f 5 10 f } + } + } +] [ + { + T{ word f 1 10 f } + T{ word f 2 10 f } + T{ word f 3 2 t } + T{ word f 4 10 f } + T{ word f 5 10 f } + } 35 wrap [ { } like ] map +] unit-test + +[ + <" This is a +long piece +of text +that we +wish to +word wrap."> +] [ + <" This is a long piece of text that we wish to word wrap."> 10 + wrap-string +] unit-test + +[ + <" This is a + long piece + of text + that we + wish to + word wrap."> +] [ + <" This is a long piece of text that we wish to word wrap."> 12 + " " wrap-indented-string +] unit-test \ No newline at end of file diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index 87a870d75d..8e4e2753a8 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -1,32 +1,60 @@ -USING: sequences kernel namespaces make splitting math math.order ; +USING: sequences kernel namespaces make splitting +math math.order fry assocs accessors ; IN: wrap -! Very stupid word wrapping/line breaking -! This will be replaced by a Unicode-aware method, -! which works with variable-width fonts +! Word wrapping/line breaking -- not Unicode-aware + +TUPLE: word key width break? ; + +C: word + +> not [ width get > ] [ drop f ] if ; -: (split-chunk) ( words -- ) - -1 over [ length + 1+ dup width get > ] find drop nip - [ 1 max cut-slice swap , (split-chunk) ] [ , ] if* ; +: find-optimal-break ( words -- n ) + [ 0 ] dip [ [ width>> + dup ] keep break-here? ] find drop nip ; -: split-chunk ( words -- lines ) - [ (split-chunk) ] { } make ; +: (wrap) ( words -- ) + dup find-optimal-break + [ 1 max cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if* ; -: join-spaces ( words-seqs -- lines ) - [ [ " " join ] map ] map concat ; +: intersperse ( seq elt -- seq' ) + [ '[ _ , ] [ , ] interleave ] { } make ; -: broken-lines ( string width -- lines ) +: split-lines ( string -- words-lines ) + string-lines [ + " \t" split harvest + [ dup length f ] map + " " 1 t intersperse + ] map ; + +: join-words ( wrapped-lines -- lines ) + [ + [ break?>> ] + [ trim-head-slice ] + [ trim-tail-slice ] bi + [ key>> ] map concat + ] map ; + +: join-lines ( strings -- string ) + "\n" join ; + +PRIVATE> + +: wrap ( words width -- lines ) width [ - line-chunks [ split-chunk ] map join-spaces + [ (wrap) ] { } make ] with-variable ; -: line-break ( string width -- newstring ) - broken-lines "\n" join ; +: wrap-lines ( lines width -- newlines ) + [ split-lines ] dip '[ _ wrap join-words ] map concat ; -: indented-break ( string width indent -- newstring ) - [ length - broken-lines ] keep [ prepend ] curry map "\n" join ; +: wrap-string ( string width -- newstring ) + wrap-lines join-lines ; + +: wrap-indented-string ( string width indent -- newstring ) + [ length - wrap-lines ] keep '[ _ prepend ] map join-lines ; diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index 146e67e70f..a713790973 100755 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -69,7 +69,7 @@ M: string write-xml escape-string xml-pprint? get [ dup [ blank? ] all? [ drop "" ] - [ nl 80 indent-string indented-break ] if + [ nl 80 indent-string wrap-indented-string ] if ] when write ; : write-tag ( tag -- ) From bb2452c86e3e14b77675acbebae84eca6ed39c2d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Feb 2009 05:47:29 -0600 Subject: [PATCH 03/11] Fix biassocs docs --- basis/biassocs/biassocs-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/biassocs/biassocs-docs.factor b/basis/biassocs/biassocs-docs.factor index 31258a7ddc..b55af5b902 100644 --- a/basis/biassocs/biassocs-docs.factor +++ b/basis/biassocs/biassocs-docs.factor @@ -23,7 +23,7 @@ HELP: >biassoc ARTICLE: "biassocs" "Bidirectional assocs" "A " { $emphasis "bidirectional assoc" } " combines a pair of assocs to form a data structure where both normal assoc opeartions (eg, " { $link at } "), as well as " { $link "assocs-values" } " (eg, " { $link value-at } ") run in sub-linear time." $nl -"Bidirectional assocs implement the entire " { $link "assoc-protocol" } " with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with." +"Bidirectional assocs implement the entire " { $link "assocs-protocol" } " with the exception of " { $link delete-at } ". Duplicate values are allowed, however value lookups with " { $link value-at } " only return the first key that a given value was stored with." $nl "The class of biassocs:" { $subsection biassoc } From 25f8eeab6f5adcc6736176aa2cf56b6916bc76e5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Feb 2009 05:49:21 -0600 Subject: [PATCH 04/11] Fix io.encodings.japanese on case-sensitive file sysems --- basis/io/encodings/japanese/{CP932.TXT => CP932.txt} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename basis/io/encodings/japanese/{CP932.TXT => CP932.txt} (100%) diff --git a/basis/io/encodings/japanese/CP932.TXT b/basis/io/encodings/japanese/CP932.txt similarity index 100% rename from basis/io/encodings/japanese/CP932.TXT rename to basis/io/encodings/japanese/CP932.txt From e88812b76a14bc47c296fda86709ae5a631a6240 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 2 Feb 2009 06:04:29 -0600 Subject: [PATCH 05/11] map infimum => [ min ] map-reduce --- basis/compiler/tree/normalization/normalization.factor | 4 ++-- extra/project-euler/044/044.factor | 5 +++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index 3f1e9e2667..ee7bf8672e 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry namespaces sequences math accessors kernel arrays +USING: fry namespaces sequences math math.order accessors kernel arrays combinators compiler.utilities assocs stack-checker.backend stack-checker.branches @@ -54,7 +54,7 @@ M: #branch normalize* ] map unzip swap ] change-children swap [ remaining-introductions set ] - [ [ length ] map infimum introduction-stack [ swap head ] change ] + [ [ length ] [ min ] map-reduce introduction-stack [ swap head ] change ] bi ; : eliminate-phi-introductions ( introductions seq terminated -- seq' ) diff --git a/extra/project-euler/044/044.factor b/extra/project-euler/044/044.factor index e7b1959023..46b20253ee 100644 --- a/extra/project-euler/044/044.factor +++ b/extra/project-euler/044/044.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions math.ranges project-euler.common sequences ; +USING: kernel math math.functions math.ranges math.order +project-euler.common sequences ; IN: project-euler.044 ! http://projecteuler.net/index.php?section=problems&id=44 @@ -37,7 +38,7 @@ PRIVATE> : euler044 ( -- answer ) 2500 [1,b] [ nth-pentagonal ] map dup cartesian-product - [ first2 sum-and-diff? ] filter [ first2 - abs ] map infimum ; + [ first2 sum-and-diff? ] filter [ first2 - abs ] [ min ] map-reduce ; ! [ euler044 ] 10 ave-time ! 4996 ms ave run time - 87.46 SD (10 trials) From d32d436154f1fd40887460a32c65f85eb402b73b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 2 Feb 2009 13:16:03 -0600 Subject: [PATCH 06/11] 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 07/11] 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 08/11] 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 09/11] 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 From 475f89645d9217e9a721dc22fb300659776c5843 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 2 Feb 2009 15:51:42 -0600 Subject: [PATCH 10/11] fix load error --- extra/project-euler/056/056.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/project-euler/056/056.factor b/extra/project-euler/056/056.factor index 4e7bbdc0df..e2d95e27c1 100644 --- a/extra/project-euler/056/056.factor +++ b/extra/project-euler/056/056.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math.functions math.ranges project-euler.common sequences ; +USING: kernel math.functions math.ranges project-euler.common +sequences math.order ; IN: project-euler.056 ! http://projecteuler.net/index.php?section=problems&id=56 From 7644d51e3bfe37878d817c25728d35be02cf70b9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 2 Feb 2009 16:03:03 -0600 Subject: [PATCH 11/11] assocs -> collections in quadtree tags to be consistent --- extra/quadtrees/tags.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/quadtrees/tags.txt b/extra/quadtrees/tags.txt index c133c6df7e..216000f731 100644 --- a/extra/quadtrees/tags.txt +++ b/extra/quadtrees/tags.txt @@ -1,2 +1,2 @@ -assocs +collections graphics