Trying to fix a bad merge...
Revert "Merge branch 'master' of git://factorcode.org/git/factor" This reverts commitdb4da639739bd, reversing changes made to346a61f497.
slava
parent
da639739bd
commit
e29f18a2f4
|
|
@ -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 <field-spec> ] 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) ;
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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*
|
||||
|
|
|
|||
|
|
@ -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' )
|
||||
|
|
|
|||
|
|
@ -1,14 +0,0 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.syntax help.markup ;
|
||||
IN: io.encodings.chinese
|
||||
|
||||
ARTICLE: "io.encodings.chinese" "Chinese text encodings"
|
||||
"The " { $vocab-link "io.encodings.chinese" } " vocabulary implements encodings used for Chinese text besides the standard UTF encodings for Unicode strings."
|
||||
{ $subsection gb18030 } ;
|
||||
|
||||
ABOUT: "io.encodings.chinese"
|
||||
|
||||
HELP: gb18030
|
||||
{ $class-description "The encoding descriptor for GB 18030, a Chinese national standard for text encoding. GB 18030 consists of a unique encoding for each Unicode code point, and for this reason has been described as a UTF. It is backwards compatible with the earlier encodings GB 2312 and GBK." }
|
||||
{ $see-also "encodings-introduction" } ;
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.encodings.chinese io.encodings.string strings tools.test arrays ;
|
||||
IN: io.encodings.chinese.tests
|
||||
|
||||
[ "hello" ] [ "hello" gb18030 encode >string ] unit-test
|
||||
[ "hello" ] [ "hello" gb18030 decode ] unit-test
|
||||
[ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } ]
|
||||
[ B{ HEX: B7 HEX: B8 } gb18030 encode ] unit-test
|
||||
[ { HEX: B7 HEX: B8 } ]
|
||||
[ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } gb18030 decode >array ] unit-test
|
||||
[ { HEX: B7 CHAR: replacement-character } ]
|
||||
[ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 } gb18030 decode >array ] unit-test
|
||||
[ { HEX: B7 CHAR: replacement-character } ]
|
||||
[ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 } gb18030 decode >array ] unit-test
|
||||
[ { HEX: B7 CHAR: replacement-character } ]
|
||||
[ B{ HEX: A1 HEX: A4 HEX: 81 } gb18030 decode >array ] unit-test
|
||||
[ { HEX: B7 } ]
|
||||
[ B{ HEX: A1 HEX: A4 } gb18030 decode >array ] unit-test
|
||||
[ { CHAR: replacement-character } ]
|
||||
[ B{ HEX: A1 } gb18030 decode >array ] unit-test
|
||||
[ { HEX: 44D7 HEX: 464B } ]
|
||||
[ B{ HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 }
|
||||
gb18030 decode >array ] unit-test
|
||||
[ { HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 } ]
|
||||
[ { HEX: 44D7 HEX: 464B } gb18030 encode >array ] unit-test
|
||||
|
|
@ -1,133 +0,0 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: xml xml.data kernel io io.encodings interval-maps splitting fry
|
||||
math.parser sequences combinators assocs locals accessors math
|
||||
arrays values io.encodings.ascii ascii io.files biassocs math.order
|
||||
combinators.short-circuit io.binary ;
|
||||
IN: io.encodings.chinese
|
||||
|
||||
SINGLETON: gb18030
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! GB to mean GB18030 is a terrible abuse of notation
|
||||
|
||||
! Resource file from:
|
||||
! http://source.icu-project.org/repos/icu/data/trunk/charset/data/xml/gb-18030-2000.xml
|
||||
|
||||
TUPLE: range ufirst ulast bfirst blast ;
|
||||
|
||||
: b>byte-array ( string -- byte-array )
|
||||
" " split [ hex> ] B{ } map-as ;
|
||||
|
||||
: add-range ( contained ranges -- )
|
||||
[
|
||||
{
|
||||
[ "uFirst" attr hex> ]
|
||||
[ "uLast" attr hex> ]
|
||||
[ "bFirst" attr b>byte-array ]
|
||||
[ "bLast" attr b>byte-array ]
|
||||
} cleave range boa
|
||||
] dip push ;
|
||||
|
||||
: add-mapping ( contained mapping -- )
|
||||
[
|
||||
[ "b" attr b>byte-array ]
|
||||
[ "u" attr hex> ] bi
|
||||
] dip set-at ;
|
||||
|
||||
: xml>gb-data ( stream -- mapping ranges )
|
||||
[let | mapping [ H{ } clone ] ranges [ V{ } clone ] |
|
||||
[
|
||||
dup contained? [
|
||||
dup name>> main>> {
|
||||
{ "range" [ ranges add-range ] }
|
||||
{ "a" [ mapping add-mapping ] }
|
||||
[ 2drop ]
|
||||
} case
|
||||
] [ drop ] if
|
||||
] each-element mapping ranges
|
||||
] ;
|
||||
|
||||
! Algorithms from:
|
||||
! http://www-128.ibm.com/developerworks/library/u-china.html
|
||||
|
||||
: linear ( bytes -- num )
|
||||
! This hard-codes bMin and bMax
|
||||
reverse first4
|
||||
10 * + 126 * + 10 * + ;
|
||||
|
||||
: unlinear ( num -- bytes )
|
||||
B{ HEX: 81 HEX: 30 HEX: 81 HEX: 30 } linear -
|
||||
10 /mod swap [ HEX: 30 + ] dip
|
||||
126 /mod swap [ HEX: 81 + ] dip
|
||||
10 /mod swap [ HEX: 30 + ] dip
|
||||
HEX: 81 +
|
||||
B{ } 4sequence reverse ;
|
||||
|
||||
: >interval-map-by ( start-quot end-quot value-quot seq -- interval-map )
|
||||
'[ _ [ @ 2array ] _ tri ] { } map>assoc <interval-map> ; inline
|
||||
|
||||
: ranges-u>gb ( ranges -- interval-map )
|
||||
[ ufirst>> ] [ ulast>> ] [ ] >interval-map-by ;
|
||||
|
||||
: ranges-gb>u ( ranges -- interval-map )
|
||||
[ bfirst>> linear ] [ blast>> linear ] [ ] >interval-map-by ;
|
||||
|
||||
VALUE: gb>u
|
||||
VALUE: u>gb
|
||||
VALUE: mapping
|
||||
|
||||
"resource:basis/io/encodings/chinese/gb-18030-2000.xml"
|
||||
ascii <file-reader> xml>gb-data
|
||||
[ ranges-u>gb to: u>gb ] [ ranges-gb>u to: gb>u ] bi
|
||||
>biassoc to: mapping
|
||||
|
||||
: lookup-range ( char -- byte-array )
|
||||
dup u>gb interval-at [
|
||||
[ ufirst>> - ] [ bfirst>> linear ] bi + unlinear
|
||||
] [ encode-error ] if* ;
|
||||
|
||||
M: gb18030 encode-char ( char stream encoding -- )
|
||||
drop [
|
||||
dup mapping at
|
||||
[ ] [ lookup-range ] ?if
|
||||
] dip stream-write ;
|
||||
|
||||
: second-byte? ( ch -- ? ) ! of a double-byte character
|
||||
{ [ HEX: 40 HEX: 7E between? ] [ HEX: 80 HEX: fe between? ] } 1|| ;
|
||||
|
||||
: quad-1/3? ( ch -- ? ) HEX: 81 HEX: fe between? ;
|
||||
|
||||
: quad-2/4? ( ch -- ? ) HEX: 30 HEX: 39 between? ;
|
||||
|
||||
: last-bytes? ( byte-array -- ? )
|
||||
{ [ length 2 = ] [ first quad-1/3? ] [ second quad-2/4? ] } 1&& ;
|
||||
|
||||
: decode-quad ( byte-array -- char )
|
||||
dup mapping value-at [ ] [
|
||||
linear dup gb>u interval-at [
|
||||
[ bfirst>> linear - ] [ ufirst>> ] bi +
|
||||
] [ drop replacement-char ] if*
|
||||
] ?if ;
|
||||
|
||||
: four-byte ( stream byte1 byte2 -- char )
|
||||
rot 2 swap stream-read dup last-bytes?
|
||||
[ first2 B{ } 4sequence decode-quad ]
|
||||
[ 3drop replacement-char ] if ;
|
||||
|
||||
: two-byte ( stream byte -- char )
|
||||
over stream-read1 {
|
||||
{ [ dup not ] [ 3drop replacement-char ] }
|
||||
{ [ dup second-byte? ] [ B{ } 2sequence mapping value-at nip ] }
|
||||
{ [ dup quad-2/4? ] [ four-byte ] }
|
||||
[ 3drop replacement-char ]
|
||||
} cond ;
|
||||
|
||||
M: gb18030 decode-char ( stream encoding -- char )
|
||||
drop dup stream-read1 {
|
||||
{ [ dup not ] [ 2drop f ] }
|
||||
{ [ dup ascii? ] [ nip 1array B{ } like mapping value-at ] }
|
||||
{ [ dup quad-1/3? ] [ two-byte ] }
|
||||
[ 2drop replacement-char ]
|
||||
} cond ;
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -2,8 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel strings values io.files assocs
|
||||
splitting sequences io namespaces sets io.encodings.8-bit
|
||||
io.encodings.ascii io.encodings.utf8 io.encodings.utf16
|
||||
io.encodings.chinese io.encodings.japanese ;
|
||||
io.encodings.ascii io.encodings.utf8 io.encodings.utf16 ;
|
||||
IN: io.encodings.iana
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -25,9 +24,6 @@ VALUE: n>e-table
|
|||
{ latin/hebrew "ISO-8859-8" }
|
||||
{ latin5 "ISO-8859-9" }
|
||||
{ latin6 "ISO-8859-10" }
|
||||
{ shift-jis "Shift_JIS" }
|
||||
{ windows-31j "Windows-31J" }
|
||||
{ gb18030 "GB18030" }
|
||||
} ;
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: help.markup help.syntax ;
|
|||
IN: io.encodings.japanese
|
||||
|
||||
ARTICLE: "io.encodings.japanese" "Japanese text encodings"
|
||||
"The " { $vocab-link "io.encodings.japanese" } " vocabulary implements Japanese-specific text encodings. Several encodings are used for Japanese text besides the standard UTF encodings for Unicode strings. These are mostly based on the character set defined in the JIS X 208 standard. Current coverage of encodings is incomplete."
|
||||
"Several encodings are used for Japanese text besides the standard UTF encodings for Unicode strings. These are mostly based on the character set defined in the JIS X 208 standard. Current coverage of encodings is incomplete."
|
||||
{ $subsection shift-jis }
|
||||
{ $subsection windows-31j } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ VALUE: windows-31j
|
|||
TUPLE: jis assoc ;
|
||||
|
||||
: <jis> ( assoc -- jis )
|
||||
[ nip ] assoc-filter
|
||||
[ nip ] assoc-filter H{ } assoc-like
|
||||
>biassoc jis boa ;
|
||||
|
||||
: ch>jis ( ch tuple -- jis ) assoc>> value-at [ encode-error ] unless* ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <alien> ] [ 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 % ": " % ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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> word
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: width
|
||||
|
||||
: line-chunks ( string -- words-lines )
|
||||
"\n" split [ " \t" split harvest ] map ;
|
||||
: break-here? ( column word -- ? )
|
||||
break?>> 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 <word> ] map
|
||||
" " 1 t <word> 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 ;
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -83,8 +83,6 @@ ARTICLE: "encodings-descriptors" "Encoding descriptors"
|
|||
"Legacy encodings:"
|
||||
{ $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }
|
||||
{ $vocab-subsection "ASCII" "io.encodings.ascii" }
|
||||
{ $vocab-subsection "Japanese encodings" "io.encodings.chinese" }
|
||||
{ $vocab-subsection "Chinese encodings" "io.encodings.japanese" }
|
||||
{ $see-also "encodings-introduction" } ;
|
||||
|
||||
ARTICLE: "encodings-protocol" "Encoding protocol"
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -23,7 +24,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)
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
||||
|
|
@ -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" } "." } ;
|
||||
|
||||
|
|
@ -0,0 +1,202 @@
|
|||
! (c) 2009 Joe Groff, see BSD license
|
||||
USING: assocs kernel tools.test quadtrees math.geometry.rect sorting ;
|
||||
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
|
||||
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 <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
|
||||
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 <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
|
||||
|
||||
prune
|
||||
] 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
|
||||
|
||||
[ {
|
||||
{ { -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 <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
|
||||
|
||||
>alist natural-sort
|
||||
] unit-test
|
||||
|
||||
|
|
@ -0,0 +1,188 @@
|
|||
! (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 ;
|
||||
IN: quadtrees
|
||||
|
||||
TUPLE: quadtree { bounds rect } point value ll lr ul ur leaf? ;
|
||||
|
||||
: <quadtree> ( 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
|
||||
|
||||
: (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
|
||||
|
||||
<PRIVATE
|
||||
|
||||
DEFER: (prune)
|
||||
DEFER: insert
|
||||
DEFER: erase
|
||||
DEFER: at-point
|
||||
DEFER: quadtree>alist
|
||||
DEFER: quadtree-size
|
||||
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 <rect> ;
|
||||
: lr-bounds ( rect -- rect' )
|
||||
[ [ loc>> ] [ dim>> { 0.5 0.0 } v* ] bi v+ ] [ child-dim ] bi <rect> ;
|
||||
: ul-bounds ( rect -- rect' )
|
||||
[ [ loc>> ] [ dim>> { 0.0 0.5 } v* ] bi v+ ] [ child-dim ] bi <rect> ;
|
||||
: ur-bounds ( rect -- rect' )
|
||||
[ [ loc>> ] [ dim>> { 0.5 0.5 } v* ] bi v+ ] [ child-dim ] bi <rect> ;
|
||||
|
||||
: {quadrants} ( node -- quadrants )
|
||||
{ [ ll>> ] [ lr>> ] [ ul>> ] [ ur>> ] } cleave 4array ;
|
||||
|
||||
: add-subnodes ( node -- node )
|
||||
dup bounds>> {
|
||||
[ ll-bounds <quadtree> >>ll ]
|
||||
[ lr-bounds <quadtree> >>lr ]
|
||||
[ ul-bounds <quadtree> >>ul ]
|
||||
[ ur-bounds <quadtree> >>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-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@ = ;
|
||||
|
||||
: (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 <vector> ] 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-size ;
|
||||
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 ;
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
Quadtree spatial indices
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
collections
|
||||
graphics
|
||||
|
|
@ -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> summed
|
||||
|
||||
M: summed length seqs>> [ length ] map supremum ;
|
||||
M: summed length seqs>> [ length ] [ max ] map-reduce ;
|
||||
|
||||
<PRIVATE
|
||||
: ?+ ( x/f y/f -- sum )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays namespaces sequences math math.vectors
|
||||
colors random ;
|
||||
USING: kernel arrays namespaces sequences math math.order
|
||||
math.vectors colors random ;
|
||||
IN: tetris.tetromino
|
||||
|
||||
TUPLE: tetromino states colour ;
|
||||
|
|
@ -104,7 +104,7 @@ SYMBOL: tetrominoes
|
|||
tetrominoes get random ;
|
||||
|
||||
: blocks-max ( blocks quot -- max )
|
||||
map [ 1+ ] map supremum ; inline
|
||||
map [ 1+ ] [ max ] map-reduce ; inline
|
||||
|
||||
: blocks-width ( blocks -- width )
|
||||
[ first ] blocks-max ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue