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' )
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ HELP: interval-key?
|
|||
|
||||
HELP: <interval-map>
|
||||
{ $values { "specification" "an assoc" } { "map" "an interval map" } }
|
||||
{ $description "From a specification, produce an interval tree. The specification is an assoc where the keys are intervals, or pairs of numbers to represent intervals, or individual numbers to represent singleton intervals. The values are the values in the interval map. Construction time is O(n log n)." } ;
|
||||
{ $description "From a specification, produce an interval tree. The specification is an assoc where the keys are intervals, or pairs of numbers to represent intervals, or individual numbers to represent singleton intervals. The values are the values int he interval map. Construction time is O(n log n)." } ;
|
||||
|
||||
ARTICLE: "interval-maps" "Interval maps"
|
||||
"The " { $vocab-link "interval-maps" } " vocabulary implements a data structure, similar to assocs, where a set of closed intervals of keys are associated with values. As such, interval maps do not conform to the assoc protocol, because intervals of floats, for example, can be used, and it is impossible to get a list of keys in between."
|
||||
|
|
|
|||
|
|
@ -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