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.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays generic hashtables kernel kernel.private
|
USING: accessors arrays generic hashtables kernel kernel.private
|
||||||
math namespaces parser sequences strings words libc fry
|
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
|
IN: alien.structs
|
||||||
|
|
||||||
TUPLE: struct-type size align fields ;
|
TUPLE: struct-type size align fields ;
|
||||||
|
|
@ -47,7 +47,7 @@ M: struct-type stack-size
|
||||||
[ first2 <field-spec> ] with with map ;
|
[ first2 <field-spec> ] with with map ;
|
||||||
|
|
||||||
: compute-struct-align ( types -- n )
|
: compute-struct-align ( types -- n )
|
||||||
[ c-type-align ] map supremum ;
|
[ c-type-align ] [ max ] map-reduce ;
|
||||||
|
|
||||||
: define-struct ( name vocab fields -- )
|
: define-struct ( name vocab fields -- )
|
||||||
[
|
[
|
||||||
|
|
@ -59,5 +59,5 @@ M: struct-type stack-size
|
||||||
|
|
||||||
: define-union ( name members -- )
|
: define-union ( name members -- )
|
||||||
[ expand-constants ] map
|
[ expand-constants ] map
|
||||||
[ [ heap-size ] map supremum ] keep
|
[ [ heap-size ] [ max ] map-reduce ] keep
|
||||||
compute-struct-align f (define-struct) ;
|
compute-struct-align f (define-struct) ;
|
||||||
|
|
|
||||||
|
|
@ -23,7 +23,7 @@ HELP: >biassoc
|
||||||
ARTICLE: "biassocs" "Bidirectional assocs"
|
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."
|
"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
|
$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
|
$nl
|
||||||
"The class of biassocs:"
|
"The class of biassocs:"
|
||||||
{ $subsection biassoc }
|
{ $subsection biassoc }
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: namespaces sequences accessors math kernel
|
USING: namespaces sequences accessors math kernel
|
||||||
compiler.tree ;
|
compiler.tree math.order ;
|
||||||
IN: compiler.tree.normalization.introductions
|
IN: compiler.tree.normalization.introductions
|
||||||
|
|
||||||
SYMBOL: introductions
|
SYMBOL: introductions
|
||||||
|
|
@ -25,7 +25,7 @@ M: #introduce count-introductions*
|
||||||
|
|
||||||
M: #branch count-introductions*
|
M: #branch count-introductions*
|
||||||
children>>
|
children>>
|
||||||
[ count-introductions ] map supremum
|
[ count-introductions ] [ max ] map-reduce
|
||||||
introductions+ ;
|
introductions+ ;
|
||||||
|
|
||||||
M: #recursive count-introductions*
|
M: #recursive count-introductions*
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
combinators compiler.utilities assocs
|
||||||
stack-checker.backend
|
stack-checker.backend
|
||||||
stack-checker.branches
|
stack-checker.branches
|
||||||
|
|
@ -54,7 +54,7 @@ M: #branch normalize*
|
||||||
] map unzip swap
|
] map unzip swap
|
||||||
] change-children swap
|
] change-children swap
|
||||||
[ remaining-introductions set ]
|
[ remaining-introductions set ]
|
||||||
[ [ length ] map infimum introduction-stack [ swap head ] change ]
|
[ [ length ] [ min ] map-reduce introduction-stack [ swap head ] change ]
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
: eliminate-phi-introductions ( introductions seq terminated -- seq' )
|
: eliminate-phi-introductions ( introductions seq terminated -- seq' )
|
||||||
|
|
|
||||||
|
|
@ -15,7 +15,7 @@ HELP: interval-key?
|
||||||
|
|
||||||
HELP: <interval-map>
|
HELP: <interval-map>
|
||||||
{ $values { "specification" "an assoc" } { "map" "an 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"
|
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."
|
"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.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel strings values io.files assocs
|
USING: kernel strings values io.files assocs
|
||||||
splitting sequences io namespaces sets io.encodings.8-bit
|
splitting sequences io namespaces sets io.encodings.8-bit
|
||||||
io.encodings.ascii io.encodings.utf8 io.encodings.utf16
|
io.encodings.ascii io.encodings.utf8 io.encodings.utf16 ;
|
||||||
io.encodings.chinese io.encodings.japanese ;
|
|
||||||
IN: io.encodings.iana
|
IN: io.encodings.iana
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
@ -25,9 +24,6 @@ VALUE: n>e-table
|
||||||
{ latin/hebrew "ISO-8859-8" }
|
{ latin/hebrew "ISO-8859-8" }
|
||||||
{ latin5 "ISO-8859-9" }
|
{ latin5 "ISO-8859-9" }
|
||||||
{ latin6 "ISO-8859-10" }
|
{ latin6 "ISO-8859-10" }
|
||||||
{ shift-jis "Shift_JIS" }
|
|
||||||
{ windows-31j "Windows-31J" }
|
|
||||||
{ gb18030 "GB18030" }
|
|
||||||
} ;
|
} ;
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -4,7 +4,7 @@ USING: help.markup help.syntax ;
|
||||||
IN: io.encodings.japanese
|
IN: io.encodings.japanese
|
||||||
|
|
||||||
ARTICLE: "io.encodings.japanese" "Japanese text encodings"
|
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 shift-jis }
|
||||||
{ $subsection windows-31j } ;
|
{ $subsection windows-31j } ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -15,7 +15,7 @@ VALUE: windows-31j
|
||||||
TUPLE: jis assoc ;
|
TUPLE: jis assoc ;
|
||||||
|
|
||||||
: <jis> ( assoc -- jis )
|
: <jis> ( assoc -- jis )
|
||||||
[ nip ] assoc-filter
|
[ nip ] assoc-filter H{ } assoc-like
|
||||||
>biassoc jis boa ;
|
>biassoc jis boa ;
|
||||||
|
|
||||||
: ch>jis ( ch tuple -- jis ) assoc>> value-at [ encode-error ] unless* ;
|
: ch>jis ( ch tuple -- jis ) assoc>> value-at [ encode-error ] unless* ;
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
combinators quotations namespaces grouping stack-checker.state
|
||||||
stack-checker.backend stack-checker.errors stack-checker.visitor
|
stack-checker.backend stack-checker.errors stack-checker.visitor
|
||||||
stack-checker.values stack-checker.recursive-state ;
|
stack-checker.values stack-checker.recursive-state ;
|
||||||
|
|
@ -16,7 +16,7 @@ SYMBOL: +bottom+
|
||||||
|
|
||||||
: pad-with-bottom ( seq -- newseq )
|
: pad-with-bottom ( seq -- newseq )
|
||||||
dup empty? [
|
dup empty? [
|
||||||
dup [ length ] map supremum
|
dup [ length ] [ max ] map-reduce
|
||||||
'[ _ +bottom+ pad-head ] map
|
'[ _ +bottom+ pad-head ] map
|
||||||
] unless ;
|
] unless ;
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,8 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: tools.disassembler namespaces combinators
|
USING: tools.disassembler namespaces combinators
|
||||||
alien alien.syntax alien.c-types lexer parser kernel
|
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
|
IN: tools.disassembler.udis
|
||||||
|
|
||||||
<<
|
<<
|
||||||
|
|
@ -56,7 +57,7 @@ SINGLETON: udis-disassembler
|
||||||
: buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
|
: buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
|
||||||
|
|
||||||
: format-disassembly ( lines -- lines' )
|
: format-disassembly ( lines -- lines' )
|
||||||
dup [ second length ] map supremum
|
dup [ second length ] [ max ] map-reduce
|
||||||
'[
|
'[
|
||||||
[
|
[
|
||||||
[ first >hex cell 2 * CHAR: 0 pad-head % ": " % ]
|
[ 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
|
IN: wrap
|
||||||
|
|
||||||
! Very stupid word wrapping/line breaking
|
! Word wrapping/line breaking -- not Unicode-aware
|
||||||
! This will be replaced by a Unicode-aware method,
|
|
||||||
! which works with variable-width fonts
|
TUPLE: word key width break? ;
|
||||||
|
|
||||||
|
C: <word> word
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
SYMBOL: width
|
SYMBOL: width
|
||||||
|
|
||||||
: line-chunks ( string -- words-lines )
|
: break-here? ( column word -- ? )
|
||||||
"\n" split [ " \t" split harvest ] map ;
|
break?>> not [ width get > ] [ drop f ] if ;
|
||||||
|
|
||||||
: (split-chunk) ( words -- )
|
: find-optimal-break ( words -- n )
|
||||||
-1 over [ length + 1+ dup width get > ] find drop nip
|
[ 0 ] dip [ [ width>> + dup ] keep break-here? ] find drop nip ;
|
||||||
[ 1 max cut-slice swap , (split-chunk) ] [ , ] if* ;
|
|
||||||
|
|
||||||
: split-chunk ( words -- lines )
|
: (wrap) ( words -- )
|
||||||
[ (split-chunk) ] { } make ;
|
dup find-optimal-break
|
||||||
|
[ 1 max cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if* ;
|
||||||
|
|
||||||
: join-spaces ( words-seqs -- lines )
|
: intersperse ( seq elt -- seq' )
|
||||||
[ [ " " join ] map ] map concat ;
|
[ '[ _ , ] [ , ] 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 [
|
width [
|
||||||
line-chunks [ split-chunk ] map join-spaces
|
[ (wrap) ] { } make
|
||||||
] with-variable ;
|
] with-variable ;
|
||||||
|
|
||||||
: line-break ( string width -- newstring )
|
: wrap-lines ( lines width -- newlines )
|
||||||
broken-lines "\n" join ;
|
[ split-lines ] dip '[ _ wrap join-words ] map concat ;
|
||||||
|
|
||||||
: indented-break ( string width indent -- newstring )
|
: wrap-string ( string width -- newstring )
|
||||||
[ length - broken-lines ] keep [ prepend ] curry map "\n" join ;
|
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 [
|
escape-string xml-pprint? get [
|
||||||
dup [ blank? ] all?
|
dup [ blank? ] all?
|
||||||
[ drop "" ]
|
[ drop "" ]
|
||||||
[ nl 80 indent-string indented-break ] if
|
[ nl 80 indent-string wrap-indented-string ] if
|
||||||
] when write ;
|
] when write ;
|
||||||
|
|
||||||
: write-tag ( tag -- )
|
: write-tag ( tag -- )
|
||||||
|
|
|
||||||
|
|
@ -83,8 +83,6 @@ ARTICLE: "encodings-descriptors" "Encoding descriptors"
|
||||||
"Legacy encodings:"
|
"Legacy encodings:"
|
||||||
{ $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }
|
{ $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }
|
||||||
{ $vocab-subsection "ASCII" "io.encodings.ascii" }
|
{ $vocab-subsection "ASCII" "io.encodings.ascii" }
|
||||||
{ $vocab-subsection "Japanese encodings" "io.encodings.chinese" }
|
|
||||||
{ $vocab-subsection "Chinese encodings" "io.encodings.japanese" }
|
|
||||||
{ $see-also "encodings-introduction" } ;
|
{ $see-also "encodings-introduction" } ;
|
||||||
|
|
||||||
ARTICLE: "encodings-protocol" "Encoding protocol"
|
ARTICLE: "encodings-protocol" "Encoding protocol"
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (c) 2007, 2008 Aaron Schaefer.
|
! Copyright (c) 2007, 2008 Aaron Schaefer.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: project-euler.008
|
||||||
|
|
||||||
! http://projecteuler.net/index.php?section=problems&id=8
|
! http://projecteuler.net/index.php?section=problems&id=8
|
||||||
|
|
@ -64,7 +64,7 @@ IN: project-euler.008
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: euler008 ( -- answer )
|
: 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
|
! [ euler008 ] 100 ave-time
|
||||||
! 2 ms ave run time - 0.79 SD (100 trials)
|
! 2 ms ave run time - 0.79 SD (100 trials)
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (c) 2007, 2008 Aaron Schaefer.
|
! Copyright (c) 2007, 2008 Aaron Schaefer.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: project-euler.011
|
||||||
|
|
||||||
! http://projecteuler.net/index.php?section=problems&id=11
|
! http://projecteuler.net/index.php?section=problems&id=11
|
||||||
|
|
@ -88,7 +88,7 @@ IN: project-euler.011
|
||||||
|
|
||||||
: max-product ( matrix width -- n )
|
: max-product ( matrix width -- n )
|
||||||
[ clump ] curry map concat
|
[ clump ] curry map concat
|
||||||
[ product ] map supremum ; inline
|
[ product ] [ max ] map-reduce ; inline
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,7 @@
|
||||||
! Copyright (c) 2008 Aaron Schaefer.
|
! Copyright (c) 2008 Aaron Schaefer.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: project-euler.044
|
||||||
|
|
||||||
! http://projecteuler.net/index.php?section=problems&id=44
|
! http://projecteuler.net/index.php?section=problems&id=44
|
||||||
|
|
@ -37,7 +38,7 @@ PRIVATE>
|
||||||
|
|
||||||
: euler044 ( -- answer )
|
: euler044 ( -- answer )
|
||||||
2500 [1,b] [ nth-pentagonal ] map dup cartesian-product
|
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
|
! [ euler044 ] 10 ave-time
|
||||||
! 4996 ms ave run time - 87.46 SD (10 trials)
|
! 4996 ms ave run time - 87.46 SD (10 trials)
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,7 @@
|
||||||
! Copyright (c) 2008 Aaron Schaefer.
|
! Copyright (c) 2008 Aaron Schaefer.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: project-euler.056
|
||||||
|
|
||||||
! http://projecteuler.net/index.php?section=problems&id=56
|
! http://projecteuler.net/index.php?section=problems&id=56
|
||||||
|
|
@ -23,7 +24,7 @@ IN: project-euler.056
|
||||||
|
|
||||||
: euler056 ( -- answer )
|
: euler056 ( -- answer )
|
||||||
90 100 [a,b) dup cartesian-product
|
90 100 [a,b) dup cartesian-product
|
||||||
[ first2 ^ number>digits sum ] map supremum ;
|
[ first2 ^ number>digits sum ] [ max ] map-reduce ;
|
||||||
|
|
||||||
! [ euler056 ] 100 ave-time
|
! [ euler056 ] 100 ave-time
|
||||||
! 22 ms ave run time - 2.13 SD (100 trials)
|
! 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
|
! Copyright (C) 2008 Alex Chapman
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
IN: sequences.modified
|
||||||
|
|
||||||
TUPLE: modified ;
|
TUPLE: modified ;
|
||||||
|
|
@ -50,7 +51,7 @@ M: offset modified-set-nth ( elt n seq -- )
|
||||||
TUPLE: summed < modified seqs ;
|
TUPLE: summed < modified seqs ;
|
||||||
C: <summed> summed
|
C: <summed> summed
|
||||||
|
|
||||||
M: summed length seqs>> [ length ] map supremum ;
|
M: summed length seqs>> [ length ] [ max ] map-reduce ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
: ?+ ( x/f y/f -- sum )
|
: ?+ ( x/f y/f -- sum )
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2006, 2007, 2008 Alex Chapman
|
! Copyright (C) 2006, 2007, 2008 Alex Chapman
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel arrays namespaces sequences math math.vectors
|
USING: kernel arrays namespaces sequences math math.order
|
||||||
colors random ;
|
math.vectors colors random ;
|
||||||
IN: tetris.tetromino
|
IN: tetris.tetromino
|
||||||
|
|
||||||
TUPLE: tetromino states colour ;
|
TUPLE: tetromino states colour ;
|
||||||
|
|
@ -104,7 +104,7 @@ SYMBOL: tetrominoes
|
||||||
tetrominoes get random ;
|
tetrominoes get random ;
|
||||||
|
|
||||||
: blocks-max ( blocks quot -- max )
|
: blocks-max ( blocks quot -- max )
|
||||||
map [ 1+ ] map supremum ; inline
|
map [ 1+ ] [ max ] map-reduce ; inline
|
||||||
|
|
||||||
: blocks-width ( blocks -- width )
|
: blocks-width ( blocks -- width )
|
||||||
[ first ] blocks-max ;
|
[ first ] blocks-max ;
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue