Merge branch 'master' of git://factorcode.org/git/factor

.gitignore

@@ -11,6 +11,7 @@ Factor/factor
 *.image
 *.dylib
 factor
+factor.com
 *#*#
 .DS_Store
 .gdb_history

Makefile

@@ -17,12 +17,12 @@ else
 	CFLAGS += -O3 $(SITE_CFLAGS)
 endif
 
+ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
+
 ifdef CONFIG
 	include $(CONFIG)
 endif
 
-ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
-
 DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/alien.o \
 	vm/bignum.o \
@@ -129,15 +129,7 @@ solaris-x86-32:
 solaris-x86-64:
 	$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64
 
-freetype6.dll:
+winnt-x86-32:
-	wget http://factorcode.org/dlls/freetype6.dll
-	chmod 755 freetype6.dll
-
-zlib1.dll:
-	wget http://factorcode.org/dlls/zlib1.dll
-	chmod 755 zlib1.dll
-
-winnt-x86-32: freetype6.dll zlib1.dll
 	$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
 	$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
 
@@ -158,7 +150,7 @@ macosx.app: factor
 		-change libfactor.dylib \
 		@executable_path/../Frameworks/libfactor.dylib \
 		Factor.app/Contents/MacOS/factor
-        
+
 factor: $(DLL_OBJS) $(EXE_OBJS)
 	$(LINKER) $(ENGINE) $(DLL_OBJS)
 	$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
@@ -167,7 +159,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
 factor-console: $(DLL_OBJS) $(EXE_OBJS)
 	$(LINKER) $(ENGINE) $(DLL_OBJS)
 	$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
-		$(CFLAGS) $(CFLAGS_CONSOLE) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
+		$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
 
 clean:
 	rm -f vm/*.o

basis/alien/structs/structs.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays generic hashtables kernel kernel.private
 math namespaces parser sequences strings words libc fry
-alien.c-types alien.structs.fields cpu.architecture ;
+alien.c-types alien.structs.fields cpu.architecture math.order ;
 IN: alien.structs
 
 TUPLE: struct-type size align fields ;
@@ -47,7 +47,7 @@ M: struct-type stack-size
     [ first2 <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) ;

basis/biassocs/biassocs-docs.factor

@@ -16,13 +16,22 @@ HELP: once-at
 { $values { "value" object } { "key" object } { "assoc" assoc } }
 { $description "If the assoc does not contain the given key, adds the key/value pair to the assoc, otherwise does nothing." } ;
 
+HELP: >biassoc
+{ $values { "assoc" assoc } { "biassoc" biassoc } }
+{ $description "Costructs a new biassoc with the same key/value pairs as the given assoc." } ;
+
 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 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 }
 { $subsection biassoc? }
+"Creating new biassocs:"
 { $subsection <biassoc> }
-{ $subsection <bihash> } ;
+{ $subsection <bihash> }
+"Converting existing assocs to biassocs:"
+{ $subsection >biassoc } ;
 
 ABOUT: "biassocs"

basis/biassocs/biassocs-tests.factor

@@ -20,3 +20,13 @@ USING: biassocs assocs namespaces tools.test ;
 [ 2 ] [ 1 "h" get value-at ] unit-test
 
 [ 2 ] [ "h" get assoc-size ] unit-test
+
+H{ { "a" "A" } { "b" "B" } } "a" set
+
+[ ] [ "a" get >biassoc "b" set ] unit-test
+
+[ t ] [ "b" get biassoc? ] unit-test
+
+[ "A" ] [ "a" "b" get at ] unit-test
+
+[ "a" ] [ "A" "b" get value-at ] unit-test

basis/biassocs/biassocs.factor

@@ -1,6 +1,6 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs accessors summary ;
+USING: kernel assocs accessors summary hashtables ;
 IN: biassocs
 
 TUPLE: biassoc from to ;
@@ -37,4 +37,10 @@ M: biassoc >alist
 M: biassoc clear-assoc
     [ from>> clear-assoc ] [ to>> clear-assoc ] bi ;
 
+M: biassoc new-assoc
+    drop [ <hashtable> ] [ <hashtable> ] bi biassoc boa ;
+
 INSTANCE: biassoc assoc
+
+: >biassoc ( assoc -- biassoc )
+    T{ biassoc } assoc-clone-like ;

basis/compiler/tree/normalization/introductions/introductions.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces sequences accessors math kernel
-compiler.tree ;
+compiler.tree math.order ;
 IN: compiler.tree.normalization.introductions
 
 SYMBOL: introductions
@@ -25,7 +25,7 @@ M: #introduce count-introductions*
 
 M: #branch count-introductions*
     children>>
-    [ count-introductions ] map supremum
+    [ count-introductions ] [ max ] map-reduce
     introductions+ ;
 
 M: #recursive count-introductions*

basis/compiler/tree/normalization/normalization.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry namespaces sequences math accessors kernel arrays
+USING: fry namespaces sequences math math.order accessors kernel arrays
 combinators compiler.utilities assocs
 stack-checker.backend
 stack-checker.branches
@@ -54,7 +54,7 @@ M: #branch normalize*
         ] map unzip swap
     ] change-children swap
     [ remaining-introductions set ]
-    [ [ length ] map infimum introduction-stack [ swap head ] change ]
+    [ [ length ] [ min ] map-reduce introduction-stack [ swap head ] change ]
     bi ;
 
 : eliminate-phi-introductions ( introductions seq terminated -- seq' )

basis/generalizations/generalizations-docs.factor

@@ -139,15 +139,6 @@ HELP: -nrot
     }
 } ;
 
-HELP: nrev
-{ $values { "n" integer } }
-{ $description "A generalization of " { $link spin } " that reverses any number of items at the top of the stack."
-}
-{ $examples
-  { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrev .s" "4\n3\n2\n1" }
-  "The " { $link spin } " word is equivalent to " { $snippet "3 nrev" } "."
-} ;
-
 HELP: ndip
 { $values { "quot" quotation } { "n" integer } }
 { $description "A generalization of " { $link dip } " that can work " 
@@ -327,7 +318,6 @@ $nl
 { $subsection nnip }
 { $subsection ndrop }
 { $subsection ntuck }
-{ $subsection nrev }
 { $subsection mnswap }
 "Generalized combinators:"
 { $subsection ndip }

basis/generalizations/generalizations.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
 ! Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences sequences.private math math.ranges
+USING: kernel sequences sequences.private math combinators
-combinators macros quotations fry macros locals ;
+macros quotations fry ;
 IN: generalizations
 
 <<
@@ -51,9 +51,6 @@ MACRO: nnip ( n -- )
 MACRO: ntuck ( n -- )
     2 + '[ dup _ -nrot ] ;
 
-MACRO: nrev ( n -- )
-    1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;
-
 MACRO: ndip ( quot n -- )
     [ '[ _ dip ] ] times ;
 

basis/http/http.factor

@@ -3,17 +3,11 @@
 USING: accessors kernel combinators math namespaces make assocs
 sequences splitting sorting sets strings vectors hashtables
 quotations arrays byte-arrays math.parser calendar
-calendar.format present urls
+calendar.format present urls fry
-
 io io.encodings io.encodings.iana io.encodings.binary
 io.encodings.8-bit io.crlf
-
 unicode.case unicode.categories
-
 http.parsers ;
-
-EXCLUDE: fry => , ;
-
 IN: http
 
 : (read-header) ( -- alist )
@@ -217,5 +211,7 @@ TUPLE: post-data data params content-type content-encoding ;
     " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
 
 : parse-content-type ( content-type -- type encoding )
-    ";" split1 parse-content-type-attributes "charset" swap at
+    ";" split1
-    name>encoding over "text/" head? latin1 binary ? or ;
+    parse-content-type-attributes "charset" swap at
+    [ name>encoding ]
+    [ dup "text/" head? latin1 binary ? ] if* ;

basis/http/server/server-tests.factor

@@ -1,6 +1,21 @@
-USING: http http.server math sequences continuations tools.test ;
+USING: http http.server math sequences continuations tools.test
+io.encodings.utf8 io.encodings.binary accessors ;
 IN: http.server.tests
 
 [ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
 
 \ make-http-error must-infer
+
+[ "text/plain; charset=UTF-8" ] [
+    <response>
+        "text/plain" >>content-type
+        utf8 >>content-charset
+    unparse-content-type
+] unit-test
+
+[ "text/xml" ] [
+    <response>
+        "text/xml" >>content-type
+        binary >>content-charset
+    unparse-content-type
+] unit-test

basis/http/server/server.factor

@@ -97,10 +97,8 @@ GENERIC: write-full-response ( request response -- )
     tri ;
 
 : unparse-content-type ( request -- content-type )
-    [ content-type>> "application/octet-stream" or ]
+    [ content-type>> "application/octet-stream" or ] [ content-charset>> ] bi
-    [ content-charset>> encoding>name ]
+    dup binary eq? [ drop ] [ encoding>name "; charset=" glue ] if ;
-    bi
-    [ "; charset=" glue ] when* ;
 
 : ensure-domain ( cookie -- cookie )
     [

basis/io/encodings/8-bit/8-bit.factor

@@ -3,31 +3,33 @@
 USING: math.parser arrays io.encodings sequences kernel assocs
 hashtables io.encodings.ascii generic parser classes.tuple words
 words.symbol io io.files splitting namespaces math
-compiler.units accessors ;
+compiler.units accessors classes.singleton classes.mixin
+io.encodings.iana ;
 IN: io.encodings.8-bit
 
 <PRIVATE
 
 : mappings {
-    { "latin1" "8859-1" }
+    ! encoding-name iana-name file-name
-    { "latin2" "8859-2" }
+    { "latin1" "ISO_8859-1:1987" "8859-1" }
-    { "latin3" "8859-3" }
+    { "latin2" "ISO_8859-2:1987" "8859-2" }
-    { "latin4" "8859-4" }
+    { "latin3" "ISO_8859-3:1988" "8859-3" }
-    { "latin/cyrillic" "8859-5" }
+    { "latin4" "ISO_8859-4:1988" "8859-4" }
-    { "latin/arabic" "8859-6" }
+    { "latin/cyrillic" "ISO_8859-5:1988" "8859-5" }
-    { "latin/greek" "8859-7" }
+    { "latin/arabic" "ISO_8859-6:1987" "8859-6" }
-    { "latin/hebrew" "8859-8" }
+    { "latin/greek" "ISO_8859-7:1987" "8859-7" }
-    { "latin5" "8859-9" }
+    { "latin/hebrew" "ISO_8859-8:1988" "8859-8" }
-    { "latin6" "8859-10" }
+    { "latin5" "ISO_8859-9:1989" "8859-9" }
-    { "latin/thai" "8859-11" }
+    { "latin6" "ISO-8859-10" "8859-10" }
-    { "latin7" "8859-13" }
+    { "latin/thai" "TIS-620" "8859-11" }
-    { "latin8" "8859-14" }
+    { "latin7" "ISO-8859-13" "8859-13" }
-    { "latin9" "8859-15" }
+    { "latin8" "ISO-8859-14" "8859-14" }
-    { "latin10" "8859-16" }
+    { "latin9" "ISO-8859-15" "8859-15" }
-    { "koi8-r" "KOI8-R" }
+    { "latin10" "ISO-8859-16" "8859-16" }
-    { "windows-1252" "CP1252" }
+    { "koi8-r" "KOI8-R" "KOI8-R" }
-    { "ebcdic" "CP037" }
+    { "windows-1252" "windows-1252" "CP1252" }
-    { "mac-roman" "ROMAN" }
+    { "ebcdic" "IBM037" "CP037" }
+    { "mac-roman" "macintosh" "ROMAN" }
 } ;
 
 : encoding-file ( file-name -- stream )
@@ -45,7 +47,7 @@ IN: io.encodings.8-bit
 : ch>byte ( assoc -- newassoc )
     [ swap ] assoc-map >hashtable ;
 
-: parse-file ( path -- byte>ch ch>byte )
+: parse-file ( stream -- byte>ch ch>byte )
     lines process-contents
     [ byte>ch ] [ ch>byte ] bi ;
 
@@ -65,8 +67,7 @@ M: 8-bit encode-char encode>> encode-8-bit ;
 
 M: 8-bit decode-char decode>> decode-8-bit ;
 
-PREDICATE: 8-bit-encoding < word
+MIXIN: 8-bit-encoding
-    8-bit-encodings get-global key? ;
 
 M: 8-bit-encoding <encoder>
     8-bit-encodings get-global at <encoder> ;
@@ -74,15 +75,21 @@ M: 8-bit-encoding <encoder>
 M: 8-bit-encoding <decoder>
     8-bit-encodings get-global at <decoder> ;
 
+: create-encoding ( name -- word )
+    "io.encodings.8-bit" create
+    [ define-singleton-class ]
+    [ 8-bit-encoding add-mixin-instance ]
+    [ ] tri ;
+
 PRIVATE>
 
 [
     mappings [
-        [ "io.encodings.8-bit" create ]
+        first3
+        [ create-encoding ]
+        [ dupd register-encoding ]
         [ encoding-file parse-file 8-bit boa ]
-        bi*
+        tri*
-    ] assoc-map
+    ] H{ } map>assoc
-    [ keys [ define-symbol ] each ]
+    8-bit-encodings set-global
-    [ 8-bit-encodings set-global ]
-    bi
 ] with-compilation-unit

basis/io/encodings/ascii/ascii.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.encodings kernel math io.encodings.private ;
+USING: io io.encodings kernel math io.encodings.private io.encodings.iana ;
 IN: io.encodings.ascii
 
 <PRIVATE
@@ -20,3 +20,5 @@ M: ascii encode-char
 
 M: ascii decode-char
     128 decode-if< ;
+
+ascii "ANSI_X3.4-1968" register-encoding

basis/io/encodings/chinese/chinese-docs.factor

@@ -0,0 +1,14 @@
+! 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" } ;

basis/io/encodings/chinese/chinese-tests.factor

@@ -0,0 +1,26 @@
+! 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

basis/io/encodings/chinese/chinese.factor

@@ -0,0 +1,135 @@
+! 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
+byte-arrays values io.encodings.ascii ascii io.files biassocs
+math.order combinators.short-circuit io.binary io.encodings.iana ;
+IN: io.encodings.chinese
+
+SINGLETON: gb18030
+
+gb18030 "GB18030" register-encoding
+
+<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
+
+! 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 * + ; foldable
+
+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 linear ]
+            [ "bLast" attr b>byte-array linear ]
+        } 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 
+    ] ;
+
+: unlinear ( num -- bytes )
+    B{ HEX: 81 HEX: 30 HEX: 81 HEX: 30 } linear -
+    10 /mod HEX: 30 + swap
+    126 /mod HEX: 81 + swap
+    10 /mod HEX: 30 + swap
+    HEX: 81 +
+    4byte-array dup reverse-here ;
+
+: >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>> ] [ blast>> ] [ ] >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>> ] 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>> - ] [ ufirst>> ] bi +
+        ] [ drop replacement-char ] if*
+    ] ?if ;
+
+: four-byte ( stream byte1 byte2 -- char )
+    rot 2 swap stream-read dup last-bytes?
+    [ first2 4byte-array decode-quad ]
+    [ 3drop replacement-char ] if ;
+
+: two-byte ( stream byte -- char )
+    over stream-read1 {
+        { [ dup not ] [ 3drop replacement-char ] }
+        { [ dup second-byte? ] [ 2byte-array 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 1byte-array mapping value-at ] }
+        { [ dup quad-1/3? ] [ two-byte ] }
+        [ 2drop replacement-char ]
+    } cond ;

basis/io/encodings/iana/iana-docs.factor

@@ -1,12 +1,35 @@
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup strings ;
 IN: io.encodings.iana
 
+ABOUT: "io.encodings.iana"
+
+ARTICLE: "io.encodings.iana" "IANA-registered encoding names"
+"The " { $vocab-link "io.encodings.iana" } " vocabulary provides words for accessing the names of encodings and the encoding descriptors corresponding to names." $nl
+"Most text encodings in common use have been registered with IANA. There is a standard set of names for each encoding. Simple conversion functions:" 
+{ $subsection name>encoding }
+{ $subsection encoding>name }
+"To let a new encoding be used with the above words, use the following:"
+{ $subsection register-encoding }
+"Exceptions when encodings or names are not found:"
+{ $subsection missing-encoding }
+{ $subsection missing-name } ;
+
+HELP: missing-encoding
+{ $error-description "The error called from " { $link name>encoding } " when there is no encoding descriptor registered corresponding to the given name." } ;
+
+HELP: missing-name
+{ $error-description "The error called from " { $link encoding>name } " when there is no name registered corresponding to the given encoding." } ;
+
 HELP: name>encoding
 { $values { "name" "an encoding name" } { "encoding" "an encoding descriptor" } }
-{ "Given an IANA-registered encoding name, find the encoding descriptor that represents it, or " { $code f } " if it is not found (either not implemented in Factor or not registered)." } ;
+{ $description "Given an IANA-registered encoding name, find the encoding descriptor that represents it, or " { $code f } " if it is not found (either not implemented in Factor or not registered)." } ;
 
 HELP: encoding>name
 { $values { "encoding" "an encoding descriptor" } { "name" "an encoding name" } }
-{ "Given an encoding descriptor, return the preferred IANA name." } ;
+{ $description "Given an encoding descriptor, return the preferred IANA name." } ;
 
 { name>encoding encoding>name } related-words
+
+HELP: register-encoding
+{ $values { "descriptor" "an encoding descriptor" } { "name" string } }
+{ $description "Registers an encoding descriptor with the given name, available for lookup through " { $link name>encoding } " and " { $link encoding>name } ". IANA-registered aliases are automatically included. The name given must be the first name in the " { $snippet "resources:basis/io/encodings/iana/character-sets" } " file." } ;

basis/io/encodings/iana/iana-tests.factor

@@ -1,5 +1,28 @@
-USING: io.encodings.iana io.encodings.ascii tools.test ;
+USING: io.encodings.iana io.encodings.iana.private
+io.encodings.utf8 tools.test assocs namespaces ;
+IN: io.encodings.iana.tests
 
-[ ascii ] [ "US-ASCII" name>encoding ] unit-test
+[ utf8 ] [ "UTF-8" name>encoding ] unit-test
-[ ascii ] [ "ASCII" name>encoding ] unit-test
+[ utf8 ] [ "utf8" name>encoding ] unit-test
-[ "US-ASCII" ] [ ascii encoding>name ] unit-test
+[ "UTF-8" ] [ utf8 encoding>name ] unit-test
+
+! We will never implement EBCDIC-FI-SE-A
+SINGLETON: ebcdic-fisea
+ebcdic-fisea "EBCDIC-FI-SE-A" register-encoding
+[ ebcdic-fisea ] [ "EBCDIC-FI-SE-A" name>encoding ] unit-test
+[ ebcdic-fisea ] [ "csEBCDICFISEA" name>encoding ] unit-test
+[ "EBCDIC-FI-SE-A" ] [ ebcdic-fisea encoding>name ] unit-test
+
+! Clean up after myself
+[ ] [
+    "EBCDIC-FI-SE-A" n>e-table get delete-at
+    "csEBCDICFISEA" n>e-table get delete-at
+    ebcdic-fisea e>n-table get delete-at
+] unit-test
+[ "EBCDIC-FI-SE-A" name>encoding ] must-fail
+[ "csEBCDICFISEA" name>encoding ] must-fail
+[ ebcdic-fisea encoding>name ] must-fail
+
+[ ebcdic-fisea "foobar" register-encoding ] must-fail
+[ "foobar" name>encoding ] must-fail
+[ ebcdic-fisea encoding>name ] must-fail

basis/io/encodings/iana/iana.factor

@@ -1,37 +1,24 @@
 ! Copyright (C) 2008 Daniel Ehrenberg
 ! 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
+splitting sequences io namespaces sets io.encodings.utf8 ;
-io.encodings.ascii io.encodings.utf8 io.encodings.utf16  ;
 IN: io.encodings.iana
 
 <PRIVATE
-VALUE: n>e-table
+SYMBOL: n>e-table
-
+SYMBOL: e>n-table
-: e>n-table H{
+SYMBOL: aliases
-    { ascii "US-ASCII" }
-    { utf8 "UTF-8" }
-    { utf16 "UTF-16" }
-    { utf16be "UTF-16BE" }
-    { utf16le "UTF-16LE" }
-    { latin1 "ISO-8859-1" }
-    { latin2 "ISO-8859-2" }
-    { latin3 "ISO-8859-3" }
-    { latin4 "ISO-8859-4" }
-    { latin/cyrillic "ISO-8859-5" }
-    { latin/arabic "ISO-8859-6" }
-    { latin/greek "ISO-8859-7" }
-    { latin/hebrew "ISO-8859-8" }
-    { latin5 "ISO-8859-9" }
-    { latin6 "ISO-8859-10" }
-} ;
 PRIVATE>
 
+ERROR: missing-encoding name ;
+
 : name>encoding ( name -- encoding )
-    n>e-table at ;
+    dup n>e-table get-global at [ ] [ missing-encoding ] ?if ;
+
+ERROR: missing-name encoding ;
 
 : encoding>name ( encoding -- name )
-    e>n-table at ;
+    dup e>n-table get-global at [ ] [ missing-name ] ?if ;
 
 <PRIVATE
 : parse-iana ( stream -- synonym-set )
@@ -39,24 +26,33 @@ PRIVATE>
         [ " " split ] map
         [ first { "Name:" "Alias:" } member? ] filter
         [ second ] map { "None" } diff
-    ] map ;
+    ] map harvest ;
 
-: more-aliases ( -- assoc )
+: make-aliases ( stream -- n>e )
+    parse-iana [ [ first ] [ ] bi ] H{ } map>assoc ;
+
+: initial-n>e ( -- assoc )
     H{
         { "UTF8" utf8 }
         { "utf8" utf8 }
         { "utf-8" utf8 }
-    } ;
+        { "UTF-8" utf8 }
+    } clone ;
+
+: initial-e>n ( -- assoc )
+    H{ { utf8 "UTF-8" } } clone ;
 
-: make-n>e ( stream -- n>e )
-    parse-iana [ [
-        dup [
-            e>n-table value-at
-            [ swap [ set ] with each ]
-            [ drop ] if*
-        ] with each
-    ] each ] H{ } make-assoc more-aliases assoc-union ;
 PRIVATE>
 
 "resource:basis/io/encodings/iana/character-sets"
-ascii <file-reader> make-n>e to: n>e-table
+utf8 <file-reader> make-aliases aliases set-global
+
+n>e-table global [ initial-n>e or ] change-at
+e>n-table global [ initial-e>n or ] change-at
+
+: register-encoding ( descriptor name -- )
+    [
+        aliases get at [
+            [ n>e-table get-global set-at ] with each
+        ] [ "Bad encoding registration" throw ] if*
+    ] [ swap e>n-table get-global set-at ] 2bi ;

basis/io/encodings/japanese/authors.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

basis/io/encodings/japanese/japanese-docs.factor

@@ -0,0 +1,19 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: io.encodings.japanese
+
+ARTICLE: "io.encodings.japanese" "Japanese 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."
+{ $subsection shift-jis }
+{ $subsection windows-31j } ;
+
+ABOUT: "io.encodings.japanese"
+
+HELP: windows-31j
+{ $class-description "The encoding descriptor Windows-31J, which is sometimes informally called Shift JIS. This is based on Code Page 932." }
+{ $see-also "encodings-introduction" shift-jis } ;
+
+HELP: shift-jis
+{ $class-description "The encoding descriptor for Shift JIS, or JIS X 208:1997 Appendix 1. Microsoft extensions are not included." }
+{ $see-also "encodings-introduction" windows-31j } ;

basis/io/encodings/japanese/japanese-tests.factor

@@ -0,0 +1,17 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.japanese tools.test io.encodings.string arrays strings ;
+IN: io.encodings.japanese.tests
+
+[ { CHAR: replacement-character } ] [ { 141 } shift-jis decode >array ] unit-test
+[ "" ] [ "" shift-jis decode >string ] unit-test
+[ "" ] [ "" shift-jis encode >string ] unit-test
+[ { CHAR: replacement-character } shift-jis encode ] must-fail
+[ "ab¥ｨ" ] [ { CHAR: a CHAR: b HEX: 5C HEX: A8 } shift-jis decode ] unit-test
+[ { CHAR: a CHAR: b HEX: 5C HEX: A8 } ] [ "ab¥ｨ" shift-jis encode >array ] unit-test
+[ "ab\\ｨ" ] [ { CHAR: a CHAR: b HEX: 5C HEX: A8 } windows-31j decode ] unit-test
+[ { CHAR: a CHAR: b HEX: 5C HEX: A8 } ] [ "ab\\ｨ" windows-31j encode >array ] unit-test
+[ "\u000081\u0000c8" ] [ CHAR: logical-and 1string windows-31j encode >string ] unit-test
+[ "\u000081\u0000c8" ] [ CHAR: logical-and 1string shift-jis encode >string ] unit-test
+[ { CHAR: logical-and } ] [ "\u000081\u0000c8" windows-31j decode >array ] unit-test
+[ { CHAR: logical-and } ] [ "\u000081\u0000c8" shift-jis decode >array ] unit-test

basis/io/encodings/japanese/japanese.factor

@@ -0,0 +1,75 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel io io.files combinators.short-circuit
+math.order values assocs io.encodings io.binary fry strings math
+io.encodings.ascii arrays byte-arrays accessors splitting
+math.parser biassocs io.encodings.iana ;
+IN: io.encodings.japanese
+
+SINGLETON: shift-jis
+
+shift-jis "Shift_JIS" register-encoding
+
+SINGLETON: windows-31j
+
+windows-31j "Windows-31J" register-encoding
+
+<PRIVATE
+
+VALUE: shift-jis-table
+
+M: shift-jis <encoder> drop shift-jis-table <encoder> ;
+M: shift-jis <decoder> drop shift-jis-table <decoder> ;
+
+VALUE: windows-31j-table
+
+M: windows-31j <encoder> drop windows-31j-table <encoder> ;
+M: windows-31j <decoder> drop windows-31j-table <decoder> ;
+
+TUPLE: jis assoc ;
+
+: <jis> ( assoc -- jis )
+    [ nip ] assoc-filter
+    >biassoc jis boa ;
+
+: ch>jis ( ch tuple -- jis ) assoc>> value-at [ encode-error ] unless* ;
+: jis>ch ( jis tuple -- string ) assoc>> at replacement-char or ;
+
+: process-jis ( lines -- assoc )
+    [ "#" split1 drop ] map harvest [
+        "\t" split 2 head
+        [ 2 short tail hex> ] map
+    ] map ;
+
+: make-jis ( filename -- jis )
+    ascii file-lines process-jis <jis> ;
+
+"resource:basis/io/encodings/japanese/CP932.txt"
+make-jis to: windows-31j-table
+
+"resource:basis/io/encodings/japanese/sjis-0208-1997-std.txt"
+make-jis to: shift-jis-table
+
+: small? ( char -- ? )
+    ! ASCII range or single-byte halfwidth katakana
+    { [ 0 HEX: 7F between? ] [ HEX: A1 HEX: DF between? ] } 1|| ;
+
+: write-halfword ( stream halfword -- )
+    h>b/b swap 2byte-array swap stream-write ;
+
+M: jis encode-char
+    swapd ch>jis
+    dup small?
+    [ swap stream-write1 ]
+    [ write-halfword ] if ;
+
+M: jis decode-char
+    swap dup stream-read1 [
+        dup small? [ nip swap jis>ch ] [
+            swap stream-read1
+            [ 2array be> swap jis>ch ]
+            [ 2drop replacement-char ] if*
+        ] if
+    ] [ 2drop f ] if* ;
+
+PRIVATE>

basis/io/encodings/japanese/summary.txt

@@ -0,0 +1 @@
+Japanese text encodings

basis/io/encodings/japanese/tags.txt

@@ -0,0 +1 @@
+text

basis/io/encodings/utf16/utf16-docs.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax io.encodings strings ;
 IN: io.encodings.utf16
 

basis/io/encodings/utf16/utf16-tests.factor

@@ -1,6 +1,7 @@
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel tools.test io.encodings.utf16 arrays sbufs
 io.streams.byte-array sequences io.encodings io
-bootstrap.unicode
 io.encodings.string alien.c-types alien.strings accessors classes ;
 IN: io.encodings.utf16.tests
 
@@ -15,7 +16,6 @@ IN: io.encodings.utf16.tests
 [ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
 [ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test
 [ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test
-[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
 
 [ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test
 

basis/io/encodings/utf16/utf16.factor

@@ -1,15 +1,21 @@
-! Copyright (C) 2006, 2008 Daniel Ehrenberg.
+! Copyright (C) 2006, 2009 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel sequences sbufs vectors namespaces io.binary
-io.encodings combinators splitting io byte-arrays ;
+io.encodings combinators splitting io byte-arrays io.encodings.iana ;
 IN: io.encodings.utf16
 
 SINGLETON: utf16be
 
+utf16be "UTF-16BE" register-encoding
+
 SINGLETON: utf16le
 
+utf16le "UTF-16LE" register-encoding
+
 SINGLETON: utf16
 
+utf16 "UTF-16" register-encoding
+
 ERROR: missing-bom ;
 
 <PRIVATE
@@ -101,13 +107,9 @@ M: utf16le encode-char ( char stream encoding -- )
 
 ! UTF-16
 
-: bom-le B{ HEX: ff HEX: fe } ; inline
+CONSTANT: bom-le B{ HEX: ff HEX: fe }
 
-: bom-be B{ HEX: fe HEX: ff } ; inline
+CONSTANT: bom-be B{ HEX: fe HEX: ff }
-
-: start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
-
-: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
 
 : bom>le/be ( bom -- le/be )
     dup bom-le sequence= [ drop utf16le ] [

basis/io/encodings/utf32/authors.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

basis/io/encodings/utf32/summary.txt

@@ -0,0 +1 @@
+UTF32 encoding/decoding

basis/io/encodings/utf32/tags.txt

@@ -0,0 +1 @@
+text

basis/io/encodings/utf32/utf32-docs.factor

@@ -0,0 +1,27 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.encodings strings ;
+IN: io.encodings.utf32
+
+ARTICLE: "io.encodings.utf32" "UTF-32 encoding"
+"The UTF-32 encoding is a fixed-width encoding. Unicode code points are encoded as 4 byte sequences. There are three encoding descriptor classes for working with UTF-32, depending on endianness or the presence of a BOM:"
+{ $subsection utf32 }
+{ $subsection utf32le }
+{ $subsection utf32be } ;
+
+ABOUT: "io.encodings.utf32"
+
+HELP: utf32le
+{ $class-description "The encoding descriptor for UTF-32LE, that is, UTF-32 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: utf32be
+{ $class-description "The encoding descriptor for UTF-32BE, that is, UTF-32 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: utf32
+{ $class-description "The encoding descriptor for UTF-32, that is, UTF-32 with a byte order mark. This is the most useful for general input and output in UTF-32. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+{ utf32 utf32le utf32be } related-words
+

basis/io/encodings/utf32/utf32-tests.factor

@@ -0,0 +1,30 @@
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel tools.test io.encodings.utf32 arrays sbufs
+io.streams.byte-array sequences io.encodings io
+io.encodings.string alien.c-types alien.strings accessors classes ;
+IN: io.encodings.utf32.tests
+
+[ { CHAR: x } ] [ { 0 0 0 CHAR: x } utf32be decode >array ] unit-test
+[ { HEX: 1D11E } ] [ { 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 1 HEX: D1 } utf32be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 1 } utf32be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 } utf32be decode >array ] unit-test
+[ { } ] [ { } utf32be decode >array ] unit-test
+
+[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } utf32be encode >array ] unit-test
+
+[ { CHAR: x } ] [ { CHAR: x 0 0 0 } utf32le decode >array ] unit-test
+[ { HEX: 1d11e } ] [ { HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 } utf32le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { HEX: 1e } utf32le decode >array ] unit-test
+[ { } ] [ { } utf32le decode >array ] unit-test
+
+[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32le encode >array ] unit-test
+
+[ { CHAR: x } ] [ { HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test
+[ { CHAR: x } ] [ { 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test
+
+[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32 encode >array ] unit-test
+

basis/io/encodings/utf32/utf32.factor

@@ -0,0 +1,62 @@
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math kernel io.encodings combinators io io.encodings.utf16
+sequences io.binary io.encodings.iana ;
+IN: io.encodings.utf32
+
+SINGLETON: utf32be
+
+utf32be "UTF-32BE" register-encoding
+
+SINGLETON: utf32le
+
+utf32le "UTF-32LE" register-encoding
+
+SINGLETON: utf32
+
+utf32 "UTF-32" register-encoding
+
+<PRIVATE
+
+! Decoding
+
+: char> ( stream encoding quot -- ch )
+    nip swap 4 swap stream-read dup length {
+        { 0 [ 2drop f ] }
+        { 4 [ swap call ] }
+        [ 3drop replacement-char ]
+    } case ; inline
+
+M: utf32be decode-char
+    [ be> ] char> ;
+
+M: utf32le decode-char
+    [ le> ] char> ;
+
+! Encoding
+
+: >char ( char stream encoding quot -- )
+    nip 4 swap curry dip stream-write ; inline
+
+M: utf32be encode-char
+    [ >be ] >char ;
+
+M: utf32le encode-char
+    [ >le ] >char ;
+
+! UTF-32
+
+CONSTANT: bom-le B{ HEX: ff HEX: fe 0 0 }
+
+CONSTANT: bom-be B{ 0 0 HEX: fe HEX: ff }
+
+: bom>le/be ( bom -- le/be )
+    dup bom-le sequence= [ drop utf32le ] [
+        bom-be sequence= [ utf32be ] [ missing-bom ] if
+    ] if ;
+
+M: utf32 <decoder> ( stream utf32 -- decoder )
+    drop 4 over stream-read bom>le/be <decoder> ;
+
+M: utf32 <encoder> ( stream utf32 -- encoder )
+    drop bom-le over stream-write utf32le <encoder> ;

basis/io/launcher/windows/nt/nt-tests.factor

@@ -1,7 +1,7 @@
 USING: io.launcher tools.test calendar accessors environment
 namespaces kernel system arrays io io.files io.encodings.ascii
 sequences parser assocs hashtables math continuations eval
-io.files.temp io.directories io.pathnames ;
+io.files.temp io.directories io.pathnames splitting ;
 IN: io.launcher.windows.nt.tests
 
 [ ] [
@@ -23,9 +23,12 @@ IN: io.launcher.windows.nt.tests
 
 [ f ] [ "notepad" get process-running? ] unit-test
 
+: console-vm ( -- path )
+    vm ".exe" ?tail [ ".com" append ] when ;
+
 [ ] [
     <process>
-        vm "-quiet" "-run=hello-world" 3array >>command
+        console-vm "-quiet" "-run=hello-world" 3array >>command
         "out.txt" temp-file >>stdout
     try-process
 ] unit-test
@@ -36,7 +39,7 @@ IN: io.launcher.windows.nt.tests
 
 [ ] [
     <process>
-        vm "-run=listener" 2array >>command
+        console-vm "-run=listener" 2array >>command
         +closed+ >>stdin
     try-process
 ] unit-test
@@ -47,7 +50,7 @@ IN: io.launcher.windows.nt.tests
 [ ] [
     launcher-test-path [
         <process>
-            vm "-script" "stderr.factor" 3array >>command
+            console-vm "-script" "stderr.factor" 3array >>command
             "out.txt" temp-file >>stdout
             "err.txt" temp-file >>stderr
         try-process
@@ -65,7 +68,7 @@ IN: io.launcher.windows.nt.tests
 [ ] [
     launcher-test-path [
         <process>
-            vm "-script" "stderr.factor" 3array >>command
+            console-vm "-script" "stderr.factor" 3array >>command
             "out.txt" temp-file >>stdout
             +stdout+ >>stderr
         try-process
@@ -79,7 +82,7 @@ IN: io.launcher.windows.nt.tests
 [ "output" ] [
     launcher-test-path [
         <process>
-            vm "-script" "stderr.factor" 3array >>command
+            console-vm "-script" "stderr.factor" 3array >>command
             "err2.txt" temp-file >>stderr
         ascii <process-reader> lines first
     ] with-directory
@@ -92,7 +95,7 @@ IN: io.launcher.windows.nt.tests
 [ t ] [
     launcher-test-path [
         <process>
-            vm "-script" "env.factor" 3array >>command
+            console-vm "-script" "env.factor" 3array >>command
         ascii <process-reader> contents
     ] with-directory eval
 
@@ -102,7 +105,7 @@ IN: io.launcher.windows.nt.tests
 [ t ] [
     launcher-test-path [
         <process>
-            vm "-script" "env.factor" 3array >>command
+            console-vm "-script" "env.factor" 3array >>command
             +replace-environment+ >>environment-mode
             os-envs >>environment
         ascii <process-reader> contents
@@ -114,7 +117,7 @@ IN: io.launcher.windows.nt.tests
 [ "B" ] [
     launcher-test-path [
         <process>
-            vm "-script" "env.factor" 3array >>command
+            console-vm "-script" "env.factor" 3array >>command
             { { "A" "B" } } >>environment
         ascii <process-reader> contents
     ] with-directory eval
@@ -125,7 +128,7 @@ IN: io.launcher.windows.nt.tests
 [ f ] [
     launcher-test-path [
         <process>
-            vm "-script" "env.factor" 3array >>command
+            console-vm "-script" "env.factor" 3array >>command
             { { "USERPROFILE" "XXX" } } >>environment
             +prepend-environment+ >>environment-mode
         ascii <process-reader> contents
@@ -151,7 +154,7 @@ IN: io.launcher.windows.nt.tests
     2 [
         launcher-test-path [
             <process>
-                vm "-script" "append.factor" 3array >>command
+                console-vm "-script" "append.factor" 3array >>command
                 "append-test" temp-file <appender> >>stdout
             try-process
         ] with-directory

basis/math/geometry/rect/rect.factor

@@ -60,9 +60,14 @@ M: rect set-height! ( rect height -- rect ) over dim>> set-second ;
 M: rect set-x! ( rect x -- rect ) over loc>> set-first  ;
 M: rect set-y! ( rect y -- rect ) over loc>> set-second ;
 
+: rect-containing ( points -- rect )
+    [ vleast ] [ vgreatest ] bi
+    [ drop ] [ swap v- ] 2bi <rect> ;
+
 ! Accessing corners
 
 : top-left     ( rect -- point ) loc>> ;
 : top-right    ( rect -- point ) [ loc>> ] [ width  1 - ] bi v+x ;
 : bottom-left  ( rect -- point ) [ loc>> ] [ height 1 - ] bi v+y ;
 : bottom-right ( rect -- point ) [ loc>> ] [ dim>> ] bi v+ { 1 1 } v- ;
+

basis/math/vectors/vectors.factor

@@ -19,6 +19,9 @@ IN: math.vectors
 : vmax ( u v -- w ) [ max ] 2map ;
 : vmin ( u v -- w ) [ min ] 2map ;
 
+: vgreatest ( array -- vmax ) { -1.0/0.0 -1.0/0.0 } [ vmax ] reduce ; 
+: vleast    ( array -- vmax ) {  1.0/0.0  1.0/0.0 } [ vmin ] reduce ; 
+
 : v. ( u v -- x ) [ * ] [ + ] 2map-reduce ;
 : norm-sq ( v -- x ) [ absq ] [ + ] map-reduce ;
 : norm ( v -- x ) norm-sq sqrt ;

basis/memoize/memoize.factor

@@ -35,7 +35,7 @@ M: too-many-arguments summary
     drop "There must be no more than 4 input and 4 output arguments" ;
 
 : check-memoized ( word -- )
-    dup #in 4 > swap #out 4 > or [ too-many-arguments ] when ;
+    [ #in ] [ #out ] bi [ 4 > ] either? [ too-many-arguments ] when ;
 
 : define-memoized ( word quot -- )
     over check-memoized

basis/stack-checker/branches/branches.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry vectors sequences assocs math accessors kernel
+USING: fry vectors sequences assocs math math.order accessors kernel
 combinators quotations namespaces grouping stack-checker.state
 stack-checker.backend stack-checker.errors stack-checker.visitor
 stack-checker.values stack-checker.recursive-state ;
@@ -16,7 +16,7 @@ SYMBOL: +bottom+
 
 : pad-with-bottom ( seq -- newseq )
     dup empty? [
-        dup [ length ] map supremum
+        dup [ length ] [ max ] map-reduce
         '[ _ +bottom+ pad-head ] map
     ] unless ;
 

basis/stack-checker/transforms/transforms.factor

@@ -70,7 +70,7 @@ IN: stack-checker.transforms
     [
         [ no-case ]
     ] [
-        dup peek quotation? [
+        dup peek callable? [
             dup peek swap but-last
         ] [
             [ no-case ] swap

basis/tools/disassembler/udis/udis.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.disassembler namespaces combinators
 alien alien.syntax alien.c-types lexer parser kernel
-sequences layouts math math.parser system make fry arrays ;
+sequences layouts math math.order
+math.parser system make fry arrays ;
 IN: tools.disassembler.udis
 
 <<
@@ -56,7 +57,7 @@ SINGLETON: udis-disassembler
 : buf/len ( from to -- buf len ) [ drop <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 % ": " % ]

basis/wrap/authors.txt

@@ -1 +1,2 @@
 Daniel Ehrenberg
+Slava Pestov

basis/wrap/wrap-docs.factor

@@ -0,0 +1,41 @@
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup strings math kernel ;
+IN: wrap
+
+ABOUT: "wrap"
+
+ARTICLE: "wrap" "Word wrapping"
+"The " { $vocab-link "wrap" } " vocabulary implements word wrapping. There is support for simple string wrapping, with the following words:"
+{ $subsection wrap-lines }
+{ $subsection wrap-string }
+{ $subsection wrap-indented-string }
+"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called words."
+{ $subsection wrap }
+{ $subsection word }
+{ $subsection <word> } ;
+
+HELP: wrap-lines
+{ $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } }
+{ $description "Given a string, divides it into a sequence of lines where each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ;
+
+HELP: wrap-string
+{ $values { "string" string } { "width" integer } { "newstring" string } }
+{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ;
+
+HELP: wrap-indented-string
+{ $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } }
+{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ;
+
+HELP: wrap
+{ $values { "words" { "a sequence of " { $instance word } "s" } } { "width" integer } { "lines" "a sequence of sequences of words" } }
+{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given width. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ;
+
+HELP: word
+{ $class-description "A word, for the purposes of " { $vocab-link "wrap" } ", is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Words can be created with " { $link <word> } "." }
+{ $see-also wrap } ;
+
+HELP: <word>
+{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "word" word } }
+{ $description "Creates a " { $link word } " object with the given parameters." }
+{ $see-also wrap } ;

basis/wrap/wrap-tests.factor

@@ -0,0 +1,82 @@
+! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test wrap multiline sequences ;
+IN: wrap.tests
+    
+[
+    {
+        {
+            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
+
+[
+    {
+        {
+            T{ word f 1 10 f }
+            T{ word f 2 10 f }
+            T{ word f 3 9 t }
+            T{ word f 3 9 t }
+            T{ word f 3 9 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 9 t }
+        T{ word f 3 9 t }
+        T{ word f 3 9 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
+
+[ "this text\nhas lots of\nspaces" ]
+[ "this text        has lots of       spaces" 12 wrap-string ] unit-test
+
+[ "hello\nhow\nare\nyou\ntoday?" ]
+[ "hello how are you today?" 3 wrap-string ] unit-test

basis/wrap/wrap.factor

@@ -1,32 +1,73 @@
-USING: sequences kernel namespaces make splitting math math.order ;
+! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel namespaces make splitting
+math math.order fry assocs accessors ;
 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
 
-: 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 -- )
+: walk ( n words -- n )
-    -1 over [ length + 1+ dup width get > ] find drop nip
+    ! If on a break, take the rest of the breaks
-    [ 1 max cut-slice swap , (split-chunk) ] [ , ] if* ;
+    ! If not on a break, go back until you hit a break
+    2dup bounds-check? [
+        2dup nth break?>>
+        [ [ break?>> not ] find-from drop ]
+        [ [ break?>> ] find-last-from drop 1+ ] if
+   ] [ drop ] if ;
 
-: split-chunk ( words -- lines )
+: find-optimal-break ( words -- n )
-    [ (split-chunk) ] { } make ;
+    [ 0 ] keep
+    [ [ width>> + dup ] keep break-here? ] find drop nip
+    [ 1 max swap walk ] [ drop f ] if* ;
 
-: join-spaces ( words-seqs -- lines )
+: (wrap) ( words -- )
-    [ [ " " join ] map ] map concat ;
+    [
+        dup find-optimal-break
+        [ cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if*
+    ] unless-empty ;
 
-: broken-lines ( string width -- lines )
+: intersperse ( seq elt -- seq' )
+    [ '[ _ , ] [ , ] interleave ] { } make ;
+
+: 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-slice
+        [ 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 )
+: 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 ;

basis/xml/tests/encodings.factor

@@ -1,4 +1,5 @@
-USING: xml xml.data xml.utilities tools.test accessors kernel ;
+USING: xml xml.data xml.utilities tools.test accessors kernel
+io.encodings.8-bit ;
 
 [ "\u000131" ] [ "resource:basis/xml/tests/latin5.xml" file>xml children>string ] unit-test
 [ "\u0000e9" ] [ "resource:basis/xml/tests/latin1.xml" file>xml children>string ] unit-test
@@ -11,4 +12,4 @@ USING: xml xml.data xml.utilities tools.test accessors kernel ;
 [ "\u0000e9" ] [ "resource:basis/xml/tests/utf16le-bom.xml" file>xml children>string ] unit-test
 [ "\u0000e9" ] [ "resource:basis/xml/tests/prologless.xml" file>xml children>string ] unit-test
 [ "e" ] [ "resource:basis/xml/tests/ascii.xml" file>xml children>string ] unit-test
-[ "\u0000e9" "x" ] [ "resource:basis/xml/tests/unitag.xml" file>xml [ name>> main>> ] [ children>string ] bi ] unit-test
+[ "\u0000e9" "x" ] [ "resource:basis/xml/tests/unitag.xml" file>xml [ name>> main>> ] [ children>string ] bi ] unit-test

basis/xml/writer/writer.factor

@@ -69,7 +69,7 @@ M: string write-xml
     escape-string xml-pprint? get [
         dup [ blank? ] all?
         [ drop "" ]
-        [ nl 80 indent-string indented-break ] if
+        [ nl 80 indent-string wrap-indented-string ] if
     ] when write ;
 
 : write-tag ( tag -- )

build-support/factor.sh

@@ -236,7 +236,7 @@ find_word_size() {
 
 set_factor_binary() {
     case $OS in
-        winnt) FACTOR_BINARY=factor-console.exe;;
+        winnt) FACTOR_BINARY=factor.com;;
         *) FACTOR_BINARY=factor;;
     esac
 }
@@ -295,6 +295,9 @@ set_build_info() {
     elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then
         MAKE_IMAGE_TARGET=winnt-x86.64
         MAKE_TARGET=winnt-x86-64
+    elif [[ $OS == winnt && $ARCH == x86 && $WORD == 32 ]] ; then
+        MAKE_IMAGE_TARGET=winnt-x86.32
+        MAKE_TARGET=winnt-x86-32
     elif [[ $ARCH == x86 && $WORD == 64 ]] ; then
         MAKE_IMAGE_TARGET=unix-x86.64
         MAKE_TARGET=$OS-x86-64

core/byte-arrays/byte-arrays-tests.factor

@@ -9,3 +9,5 @@ USING: tools.test byte-arrays sequences kernel ;
 [ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test
 
 [ -10 B{ } resize-byte-array ] must-fail
+
+[ B{ 123 } ] [ 123 1byte-array ] unit-test

core/byte-arrays/byte-arrays.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel kernel.private alien.accessors sequences
 sequences.private math ;
@@ -19,7 +19,7 @@ M: byte-array resize
 
 INSTANCE: byte-array sequence
 
-: 1byte-array ( x -- byte-array ) 1 <byte-array> [ set-first ] keep ; inline
+: 1byte-array ( x -- byte-array ) B{ } 1sequence ; inline
 
 : 2byte-array ( x y -- byte-array ) B{ } 2sequence ; inline
 

core/combinators/combinators-tests.factor

@@ -1,6 +1,6 @@
 USING: alien strings kernel math tools.test io prettyprint
 namespaces combinators words classes sequences accessors 
-math.functions ;
+math.functions arrays ;
 IN: combinators.tests
 
 ! Compiled
@@ -314,3 +314,13 @@ IN: combinators.tests
 \ test-case-7 must-infer
 
 [ "plus" ] [ \ + test-case-7 ] unit-test
+
+! Some corner cases (no pun intended)
+DEFER: corner-case-1
+
+<< \ corner-case-1 2 [ + ] curry 1array [ case ] curry (( a -- b )) define-declared >>
+
+[ t ] [ \ corner-case-1 optimized>> ] unit-test
+[ 4 ] [ 2 corner-case-1 ] unit-test
+
+[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test

core/combinators/combinators.factor

@@ -59,13 +59,13 @@ ERROR: no-case ;
             ] [
                 dup wrapper? [ wrapped>> ] when
             ] if =
-        ] [ quotation? ] if
+        ] [ callable? ] if
     ] find nip ;
 
 : case ( obj assoc -- )
     case-find {
         { [ dup array? ] [ nip second call ] }
-        { [ dup quotation? ] [ call ] }
+        { [ dup callable? ] [ call ] }
         { [ dup not ] [ no-case ] }
     } cond ;
 

core/continuations/continuations-docs.factor

@@ -246,8 +246,8 @@ HELP: retry
 { $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." }
 { $examples
     "Try to get a 0 as a random number:"
-    { $unchecked-example "USING: continuations math prettyprint ;"
+    { $unchecked-example "USING: continuations math prettyprint random ;"
-        "[ 5 random 0 = ] 5 retry t"
+        "[ 5 random 0 = ] 5 retry"
         "t"
     }
 } ;

core/io/binary/binary-tests.factor

@@ -10,3 +10,7 @@ IN: io.binary.tests
 [ 1234 ] [ 1234 4 >le le> ] unit-test
 
 [ fixnum ] [ B{ 0 0 0 0 0 0 0 0 0 0 } be> class ] unit-test
+
+[ HEX: 56780000 HEX: 12340000 ] [ HEX: 1234000056780000 d>w/w ] unit-test
+[ HEX: 5678 HEX: 1234 ] [ HEX: 12345678 w>h/h ] unit-test
+[ HEX: 34 HEX: 12 ] [ HEX: 1234 h>b/b ] unit-test

core/io/binary/binary.factor

@@ -14,13 +14,13 @@ IN: io.binary
 : >be ( x n -- byte-array ) >le dup reverse-here ;
 
 : d>w/w ( d -- w1 w2 )
-    dup HEX: ffffffff bitand
+    [ HEX: ffffffff bitand ]
-    swap -32 shift HEX: ffffffff bitand ;
+    [ -32 shift HEX: ffffffff bitand ] bi ;
 
 : w>h/h ( w -- h1 h2 )
-    dup HEX: ffff bitand
+    [ HEX: ffff bitand ]
-    swap -16 shift HEX: ffff bitand ;
+    [ -16 shift HEX: ffff bitand ] bi ;
 
 : h>b/b ( h -- b1 b2 )
-    dup mask-byte
+    [ mask-byte ]
-    swap -8 shift mask-byte ;
+    [ -8 shift mask-byte ] bi ;

core/io/encodings/encodings-docs.factor

@@ -78,6 +78,7 @@ ARTICLE: "encodings-descriptors" "Encoding descriptors"
 { $subsection "io.encodings.binary" }
 { $subsection "io.encodings.utf8" }
 { $subsection "io.encodings.utf16" }
+{ $vocab-subsection "UTF-32 encoding" "io.encodings.utf32" }
 { $vocab-subsection "Strict encodings" "io.encodings.strict" }
 "Legacy encodings:"
 { $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }

core/sequences/sequences-docs.factor

@@ -207,6 +207,10 @@ HELP: first4-unsafe
 { $values { "seq" sequence } { "first" "the first element" } { "second" "the second element" } { "third" "the third element" } { "fourth" "the fourth element" } }
 { $contract "Unsafe variant of " { $link first4 } " that does not perform bounds checks." } ;
 
+HELP: 1sequence
+{ $values { "obj" object } { "exemplar" sequence } { "seq" sequence } }
+{ $description "Creates a one-element sequence of the same type as " { $snippet "exemplar" } "." } ;
+
 HELP: 2sequence
 { $values { "obj1" object } { "obj2" object } { "exemplar" sequence } { "seq" sequence } }
 { $description "Creates a two-element sequence of the same type as " { $snippet "exemplar" } "." } ;

core/sequences/sequences.factor

@@ -137,9 +137,12 @@ INSTANCE: iota immutable-sequence
 
 : from-end ( seq n -- seq n' ) [ dup length ] dip - ; inline
 
+: (1sequence) ( obj seq -- seq )
+    [ 0 swap set-nth-unsafe ] keep ; inline
+
 : (2sequence) ( obj1 obj2 seq -- seq )
     [ 1 swap set-nth-unsafe ] keep
-    [ 0 swap set-nth-unsafe ] keep ; inline
+    (1sequence) ; inline
 
 : (3sequence) ( obj1 obj2 obj3 seq -- seq )
     [ 2 swap set-nth-unsafe ] keep
@@ -151,6 +154,9 @@ INSTANCE: iota immutable-sequence
 
 PRIVATE>
 
+: 1sequence ( obj exemplar -- seq )
+    1 swap [ (1sequence) ] new-like ; inline
+
 : 2sequence ( obj1 obj2 exemplar -- seq )
     2 swap [ (2sequence) ] new-like ; inline
 

core/vectors/vectors-tests.factor

@@ -97,3 +97,5 @@ IN: vectors.tests
 [ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test
 
 [ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test
+
+[ V{ "lulz" } ] [ "lulz" 1vector ] unit-test

core/vectors/vectors.factor

@@ -40,7 +40,7 @@ M: sequence new-resizable drop <vector> ;
 
 INSTANCE: vector growable
 
-: 1vector ( x -- vector ) 1array >vector ;
+: 1vector ( x -- vector ) V{ } 1sequence ;
 
 : ?push ( elt seq/f -- seq )
     [ 1 <vector> ] unless* [ push ] keep ;

extra/project-euler/008/008.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2007, 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: grouping math.parser sequences ;
+USING: grouping math.order math.parser sequences ;
 IN: project-euler.008
 
 ! http://projecteuler.net/index.php?section=problems&id=8
@@ -64,7 +64,7 @@ IN: project-euler.008
 PRIVATE>
 
 : euler008 ( -- answer )
-    source-008 5 clump [ string>digits product ] map supremum ;
+    source-008 5 clump [ string>digits product ] [ max ] map-reduce ;
 
 ! [ euler008 ] 100 ave-time
 ! 2 ms ave run time - 0.79 SD (100 trials)

extra/project-euler/011/011.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2007, 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: grouping kernel make sequences ;
+USING: grouping kernel make math.order sequences ;
 IN: project-euler.011
 
 ! http://projecteuler.net/index.php?section=problems&id=11
@@ -88,7 +88,7 @@ IN: project-euler.011
 
 : max-product ( matrix width -- n )
     [ clump ] curry map concat
-    [ product ] map supremum ; inline
+    [ product ] [ max ] map-reduce ; inline
 
 PRIVATE>
 

extra/project-euler/044/044.factor

@@ -1,6 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.ranges project-euler.common sequences ;
+USING: kernel math math.functions math.ranges math.order
+project-euler.common sequences ;
 IN: project-euler.044
 
 ! http://projecteuler.net/index.php?section=problems&id=44
@@ -37,7 +38,7 @@ PRIVATE>
 
 : euler044 ( -- answer )
     2500 [1,b] [ nth-pentagonal ] map dup cartesian-product
-    [ first2 sum-and-diff? ] filter [ first2 - abs ] map infimum ;
+    [ first2 sum-and-diff? ] filter [ first2 - abs ] [ min ] map-reduce ;
 
 ! [ euler044 ] 10 ave-time
 ! 4996 ms ave run time - 87.46 SD (10 trials)

extra/project-euler/056/056.factor

@@ -1,6 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.functions math.ranges project-euler.common sequences ;
+USING: kernel math.functions math.ranges project-euler.common
+sequences math.order ;
 IN: project-euler.056
 
 ! http://projecteuler.net/index.php?section=problems&id=56
@@ -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)

extra/quadtrees/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/quadtrees/quadtrees-docs.factor

@@ -0,0 +1,45 @@
+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 data structure in Factor."
+{ $subsection <quadtree> }
+"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 in-rect }
+{ $subsection prune-quadtree }
+"The following words are provided to help write quadtree algorithms:"
+{ $subsection descend }
+{ $subsection each-quadrant }
+{ $subsection map-quadrant }
+"Quadtrees can be used to \"swizzle\" a sequence to improve the locality of spatial data in memory:"
+{ $subsection swizzle } ;
+
+ABOUT: "quadtrees"
+
+HELP: <quadtree>
+{ $values { "bounds" rect } { "quadtree" quadtree } }
+{ $description "Constructs an empty quadtree covering the axis-aligned rectangle indicated by " { $snippet "bounds" } ". All the keys of " { $snippet "quadtree" } " must be two-dimensional vectors lying inside " { $snippet "bounds" } "." } ;
+
+HELP: prune-quadtree
+{ $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" } "." } ;
+
+HELP: swizzle
+{ $values { "sequence" sequence } { "quot" quotation } { "sequence'" sequence } }
+{ $description "Swizzles " { $snippet "sequence" } " based on the two-dimensional vector values returned by calling " { $snippet "quot" } " on each element of " { $snippet "sequence" } "." } ;

extra/quadtrees/quadtrees-tests.factor

@@ -0,0 +1,241 @@
+! (c) 2009 Joe Groff, see BSD license
+USING: accessors 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-quadtree
+] 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-quadtree
+] 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-quadtree
+] 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
+
+TUPLE: pointy-thing center ;
+
+[ {
+    T{ pointy-thing f { 0 0 } }
+    T{ pointy-thing f { 1 0 } }
+    T{ pointy-thing f { 0 1 } }
+    T{ pointy-thing f { 1 1 } }
+    T{ pointy-thing f { 2 0 } }
+    T{ pointy-thing f { 3 0 } }
+    T{ pointy-thing f { 2 1 } }
+    T{ pointy-thing f { 3 1 } }
+    T{ pointy-thing f { 0 2 } }
+    T{ pointy-thing f { 1 2 } }
+    T{ pointy-thing f { 0 3 } }
+    T{ pointy-thing f { 1 3 } }
+    T{ pointy-thing f { 2 2 } }
+    T{ pointy-thing f { 3 2 } }
+    T{ pointy-thing f { 2 3 } }
+    T{ pointy-thing f { 3 3 } }
+} ] [
+    {
+        T{ pointy-thing f { 3 1 } }
+        T{ pointy-thing f { 2 3 } }
+        T{ pointy-thing f { 3 2 } }
+        T{ pointy-thing f { 0 1 } }
+        T{ pointy-thing f { 2 2 } }
+        T{ pointy-thing f { 1 1 } }
+        T{ pointy-thing f { 3 0 } }
+        T{ pointy-thing f { 3 3 } }
+        T{ pointy-thing f { 1 3 } }
+        T{ pointy-thing f { 2 1 } }
+        T{ pointy-thing f { 0 0 } }
+        T{ pointy-thing f { 2 0 } }
+        T{ pointy-thing f { 1 0 } }
+        T{ pointy-thing f { 0 2 } }
+        T{ pointy-thing f { 1 2 } }
+        T{ pointy-thing f { 0 3 } }
+    } [ center>> ] swizzle
+] unit-test

extra/quadtrees/quadtrees.factor

@@ -0,0 +1,199 @@
+! (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 ;
+IN: quadtrees
+
+TUPLE: quadtree { bounds rect } point value ll lr ul ur leaf? ;
+
+: <quadtree> ( bounds -- quadtree )
+    quadtree new
+        swap >>bounds
+        t >>leaf? ;
+
+: 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 -- )
+    {
+        [ [ ll>> ] [ call ] bi* ] 
+        [ [ lr>> ] [ call ] bi* ] 
+        [ [ ul>> ] [ call ] bi* ] 
+        [ [ ur>> ] [ call ] bi* ] 
+    } 2cleave ; 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-quadtree ( 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 ;
+
+: swizzle ( sequence quot -- sequence' )
+    [ dup ] dip map
+    [ zip ] [ rect-containing <quadtree> ] bi
+    [ '[ first2 _ set-at ] each ] [ values ] bi ;
+

extra/quadtrees/summary.txt

@@ -0,0 +1 @@
+Quadtree spatial indices

extra/quadtrees/tags.txt

@@ -0,0 +1,2 @@
+collections
+graphics

extra/reports/noise/noise.factor

@@ -53,7 +53,6 @@ IN: reports.noise
         { nipd 3 }
         { nkeep 5 }
         { npick 6 }
-        { nrev 5 }
         { nrot 5 }
         { nslip 5 }
         { ntuck 6 }

extra/sequences/modified/modified.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel math sequences sequences.private shuffle ;
+USING: accessors arrays kernel math math.order
+sequences sequences.private shuffle ;
 IN: sequences.modified
 
 TUPLE: modified ;
@@ -50,7 +51,7 @@ M: offset modified-set-nth ( elt n seq -- )
 TUPLE: summed < modified seqs ;
 C: <summed> summed
 
-M: summed length seqs>> [ length ] map supremum ;
+M: summed length seqs>> [ length ] [ max ] map-reduce ;
 
 <PRIVATE
 : ?+ ( x/f y/f -- sum )

extra/tetris/tetromino/tetromino.factor

@@ -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
+USING: kernel arrays namespaces sequences math math.order
-colors random ;
+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 ;

vm/Config.windows

@@ -2,6 +2,7 @@ CFLAGS += -DWINDOWS -mno-cygwin
 LIBS = -lm
 PLAF_DLL_OBJS += vm/os-windows.o
 EXE_EXTENSION=.exe
+CONSOLE_EXTENSION=.com
 DLL_EXTENSION=.dll
 LINKER = $(CC) -shared -mno-cygwin -o 
 LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX)

vm/Config.windows.nt

@@ -6,4 +6,5 @@ PLAF_EXE_OBJS += vm/resources.o
 PLAF_EXE_OBJS += vm/main-windows-nt.o
 CFLAGS += -mwindows
 CFLAGS_CONSOLE += -mconsole
+CONSOLE_EXTENSION = .com
 include vm/Config.windows

vm/Config.windows.nt.x86.32

@@ -1,3 +1,4 @@
+DLL_PATH=http://factorcode.org/dlls
 WINDRES=windres
 include vm/Config.windows.nt
 include vm/Config.x86.32

vm/Config.windows.nt.x86.64

@@ -1,3 +1,5 @@
+#error "lol"
+DLL_PATH=http://factorcode.org/dlls/64
 CC=$(WIN64_PATH)-gcc.exe
 WINDRES=$(WIN64_PATH)-windres.exe
 include vm/Config.windows.nt

vm/os-windows.c

@@ -109,17 +109,6 @@ const F_CHAR *default_image_path(void)
 	snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path); 
 	temp_path[sizeof(temp_path) - 1] = 0;
 
-	if(!windows_stat(temp_path)) {
-		unsigned int len = wcslen(full_path);
-		F_CHAR magic[] = L"-console";
-		unsigned int magic_len = wcslen(magic);
-
-		if(!wcsncmp(full_path + len - magic_len, magic, MIN(len, magic_len)))
-			full_path[len - magic_len] = 0;
-		snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path); 
-		temp_path[sizeof(temp_path) - 1] = 0;
-	}
-
 	return safe_strdup(temp_path);
 }