Fix conflicts

core/bootstrap/primitives.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: bootstrap.primitives
 USING: alien arrays byte-arrays generic hashtables
@@ -476,7 +476,7 @@ builtins get num-tags get tail f union-class define-class
     { "float<=" "math.private" }
     { "float>" "math.private" }
     { "float>=" "math.private" }
-    { "<word>" "words.private" }
+    { "<word>" "words" }
     { "word-xt" "words" }
     { "drop" "kernel" }
     { "2drop" "kernel" }

core/heaps/heaps.factor

@@ -6,7 +6,6 @@ IN: heaps
 MIXIN: priority-queue
 
 GENERIC: heap-push ( value key heap -- )
-GENERIC: heap-push-all ( assoc heap -- )
 GENERIC: heap-peek ( heap -- value key )
 GENERIC: heap-pop* ( heap -- )
 GENERIC: heap-pop ( heap -- value key )
@@ -107,7 +106,7 @@ M: priority-queue heap-push ( value key heap -- )
     [ heap-data ] keep
     up-heap ;
 
-M: priority-queue heap-push-all ( assoc heap -- )
+: heap-push-all ( assoc heap -- )
     [ swapd heap-push ] curry assoc-each ;
 
 M: priority-queue heap-peek ( heap -- value key )

core/io/crc32/crc32.factor

@@ -23,4 +23,4 @@ IN: io.crc32
 : crc32 ( seq -- n )
     >r HEX: ffffffff dup r> [ (crc32) ] each bitxor ;
 
-: file-crc32 ( path -- n ) <file-reader> contents crc32 ;
+: file-crc32 ( path -- n ) file-contents crc32 ;

core/io/files/files-tests.factor

@@ -23,11 +23,11 @@ USING: tools.test io.files io threads kernel ;
 ] unit-test
 
 [ "Hello world.\nHello appender.\n" ] [
-    "test-foo.txt" resource-path <file-reader> contents
+    "test-foo.txt" resource-path file-contents
 ] unit-test
 
 [ "Hello appender.\n" ] [
-    "test-bar.txt" resource-path <file-reader> contents
+    "test-bar.txt" resource-path file-contents
 ] unit-test
 
 [ ] [ "test-foo.txt" resource-path delete-file ] unit-test

core/io/files/files.factor

@@ -3,7 +3,7 @@
 IN: io.files
 USING: io.backend io.files.private io hashtables kernel math
 memory namespaces sequences strings assocs arrays definitions
-system combinators splitting ;
+system combinators splitting sbufs ;
 
 HOOK: <file-reader> io-backend ( path -- stream )
 
@@ -157,3 +157,8 @@ HOOK: binary-roots io-backend ( -- seq )
 PRIVATE>
 
 : walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;
+
+: file-lines ( path -- seq ) <file-reader> lines ;
+
+: file-contents ( path -- str )
+    dup <file-reader> swap file-length <sbuf> [ stream-copy ] keep >string ;

core/io/io.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2003, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: hashtables generic kernel math namespaces sequences strings
+    continuations assocs io.styles sbufs ;
 IN: io
-USING: hashtables generic kernel math namespaces
-sequences strings continuations assocs io.styles sbufs ;
 
 GENERIC: stream-close ( stream -- )
 GENERIC: set-timeout ( n stream -- )

core/source-files/source-files.factor

@@ -68,7 +68,7 @@ uses definitions ;
 : reset-checksums ( -- )
     source-files get [
         swap ?resource-path dup exists?
-        [ <file-reader> contents record-checksum ] [ 2drop ] if
+        [ file-contents record-checksum ] [ 2drop ] if
     ] assoc-each ;
 
 M: pathname where pathname-string 1 2array ;

extra/assoc-heaps/assoc-heaps-tests.factor

@@ -44,3 +44,12 @@ T{
     T{ max-heap T{ heap f V{ { 1 2 } { 0 1 } } } }
 } heap-pop
 ] unit-test
+
+[
+T{
+    assoc-heap
+    f
+    H{ { 1 2 } { 3 4 } }
+    T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } } } }
+}
+] [ H{ { 1 2 } { 3 4 } } H{ } clone <assoc-min-heap> [ heap-push-all ] keep ] unit-test

extra/assoc-heaps/assoc-heaps.factor

@@ -40,9 +40,6 @@ M: assoc-heap heap-peek ( assoc-heap -- value key )
 M: assoc-heap heap-push ( value key assoc-heap -- )
     set-at ;
 
-M: assoc-heap heap-push-all ( assoc assoc-heap -- )
-    swap [ rot set-at ] curry* each ;
-
 M: assoc-heap heap-pop ( assoc-heap -- value key )
     dup assoc-heap-heap heap-pop swap
     rot dupd assoc-heap-assoc delete-at ;

extra/combinators/lib/lib.factor

@@ -72,9 +72,9 @@ MACRO: nfirst ( n -- )
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ;
+: sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ; inline
 
-: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ;
+: count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
 
 : all-unique? ( seq -- ? ) [ prune ] keep [ length ] 2apply = ;
 
@@ -161,3 +161,8 @@ MACRO: map-call-with2 ( quots -- )
   r> length [ narray ] curry append ;
 
 MACRO: map-exec-with ( words -- ) [ 1quotation ] map [ map-call-with ] curry ;
+
+MACRO: construct-slots ( assoc tuple-class -- tuple ) 
+    [ construct-empty ] curry swap [
+        [ dip ] curry swap 1quotation [ keep ] curry compose
+    ] { } assoc>map concat compose ;

extra/cryptlib/cryptlib-tests.factor

@@ -151,8 +151,8 @@ tools.test io io.files continuations alien.c-types splitting generic.math ;
 [
     ! envelope
     CRYPT_FORMAT_CRYPTLIB [
-        "extra/cryptlib/test/large_data.txt" resource-path <file-reader>
+        "extra/cryptlib/test/large_data.txt" resource-path
-        contents set-pop-buffer
+        file-contents set-pop-buffer
         envelope-handle CRYPT_ATTRIBUTE_BUFFERSIZE
         get-pop-buffer alien>char-string length 10000 + set-attribute
         envelope-handle CRYPT_ENVINFO_DATASIZE
@@ -192,7 +192,7 @@ tools.test io io.files continuations alien.c-types splitting generic.math ;
     CRYPT_FORMAT_CRYPTLIB [
         envelope-handle CRYPT_ENVINFO_PASSWORD "password" set-attribute-string
         "extra/cryptlib/test/large_data.txt" resource-path
-        <file-reader> contents set-pop-buffer
+        file-contents set-pop-buffer
         envelope-handle CRYPT_ATTRIBUTE_BUFFERSIZE
         get-pop-buffer alien>char-string length 10000 + set-attribute
         envelope-handle CRYPT_ENVINFO_DATASIZE

extra/delegate/delegate.factor

@@ -39,11 +39,13 @@ M: tuple-class group-words
 
 PROTOCOL: sequence-protocol
     clone clone-like like new new-resizable nth nth-unsafe
-    set-nth set-nth-unsafe length immutable set-length lengthen ;
+    set-nth set-nth-unsafe length set-length lengthen ;
 
 PROTOCOL: assoc-protocol
-    at* assoc-size >alist assoc-find set-at
+    at* assoc-size >alist set-at assoc-clone-like
     delete-at clear-assoc new-assoc assoc-like ;
+    ! assoc-find excluded because GENERIC# 1
+    ! everything should work, just slower (with >alist)
 
 PROTOCOL: stream-protocol
     stream-close stream-read1 stream-read stream-read-until

extra/faq/faq.factor

@@ -8,7 +8,7 @@ IN: faq
 : find-after ( seq quot -- elem after )
     over >r find r> rot 1+ tail ; inline
 
-: tag-named? ( tag name -- ? )
+: tag-named*? ( tag name -- ? )
     assure-name swap tag-named? ;
 
 ! Questions
@@ -16,8 +16,8 @@ TUPLE: q/a question answer ;
 C: <q/a> q/a
 
 : li>q/a ( li -- q/a )
-    [ "br" tag-named? not ] subset
+    [ "br" tag-named*? not ] subset
-    [ "strong" tag-named? ] find-after
+    [ "strong" tag-named*? ] find-after
     >r tag-children r> <q/a> ;
 
 : q/a>li ( q/a -- li )

extra/html/elements/elements.factor

@@ -4,7 +4,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: io kernel namespaces prettyprint quotations
-sequences strings words ;
+sequences strings words xml.writer ;
 
 IN: html.elements
 
@@ -123,7 +123,7 @@ SYMBOL: html
     " " write-html
     write-html
     "='" write-html
-    write
+    escape-quoted-string write
     "'" write-html ;
 
 : define-attribute-word ( name -- )

extra/html/html.factor

@@ -142,7 +142,7 @@ M: html-block-stream stream-close ( quot style stream -- )
     table-style " border-collapse: collapse;" append =style ;
 
 : do-escaping ( string style -- string )
-    html swap at [ chars>entities ] unless ;
+    html swap at [ escape-string ] unless ;
 
 PRIVATE>
 
@@ -151,13 +151,13 @@ M: html-stream stream-write1 ( char stream -- )
     >r 1string r> stream-write ;
 
 M: html-stream stream-write ( str stream -- )
-    >r chars>entities r> delegate stream-write ;
+    >r escape-string r> delegate stream-write ;
 
 M: html-stream make-span-stream ( style stream -- stream' )
     html-span-stream <html-sub-stream> ;
 
 M: html-stream stream-format ( str style stream -- )
-    >r html over at [ >r chars>entities r> ] unless r>
+    >r html over at [ >r escape-string r> ] unless r>
     format-html-span ;
 
 M: html-stream make-block-stream ( style stream -- stream' )

extra/html/parser/analyzer/analyzer.factor

@@ -81,11 +81,11 @@ IN: html.parser.analyzer
     ! ] if ;
 
 
-! clear "/Users/erg/web/fark.html" <file-reader> contents parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map
+! clear "/Users/erg/web/fark.html" file-contents parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map
 ! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map
 
-! clear "/Users/erg/web/hostels.html" <file-reader> contents parse-html "Currency" "name" pick find-first-attribute-key-value
+! clear "/Users/erg/web/hostels.html" file-contents parse-html "Currency" "name" pick find-first-attribute-key-value
 
-! clear "/Users/erg/web/hostels.html" <file-reader> contents parse-html
+! clear "/Users/erg/web/hostels.html" file-contents parse-html
 ! "Currency" "name" pick find-first-attribute-key-value
 ! pick find-between remove-blank-text

extra/http/server/templating/templating-tests.factor

@@ -1,18 +1,14 @@
-USING: io io.files io.streams.string http.server.templating 
+USING: io io.files io.streams.string http.server.templating kernel tools.test
-kernel tools.test sequences ;
+    sequences ;
 IN: temporary
 
 : test-template ( path -- ? )
     "extra/http/server/templating/test/" swap append
-    
     [
         ".fhtml" append resource-path
         [ run-template-file ] string-out
     ] keep
-
+    ".html" append resource-path file-contents = ;
-    ".html" append resource-path
-    <file-reader> contents
-    = ;
 
 [ t ] [ "example" test-template ] unit-test
 [ t ] [ "bug" test-template ] unit-test

extra/http/server/templating/templating.factor

@@ -82,7 +82,7 @@ DEFER: <% delimiter
             templating-vocab use+
             dup source-file file set ! so that reload works properly
             [
-                ?resource-path <file-reader> contents
+                ?resource-path file-contents
                 [ eval-template ] [ html-error. drop ] recover
             ] keep
         ] with-scope

extra/icfp/2006/2006.factor

@@ -1,9 +1,7 @@
 ! Copyright (C) 2007 Gavin Harrison
 ! See http://factorcode.org/license.txt for BSD license.
-
+USING: kernel math sequences kernel.private namespaces arrays io io.files
-USING: kernel math sequences kernel.private namespaces arrays
+    splitting io.binary math.functions vectors quotations combinators.private ;
-io io.files splitting io.binary math.functions vectors
-quotations combinators.private ;
 IN: icfp.2006
 
 SYMBOL: regs
@@ -129,7 +127,7 @@ SYMBOL: open-arrays
     [ run-op exec-loop ] unless ;
 
 : load-platters ( path -- )
-    <file-reader> contents 4 group [ be> ] map
+    file-contents 4 group [ be> ] map
     0 arrays get set-nth ;
 
 : init ( path -- )

extra/io/mmap/mmap-tests.factor

@@ -1,11 +1,9 @@
-USING: io io.mmap io.files kernel tools.test continuations
+USING: io io.mmap io.files kernel tools.test continuations sequences ;
-sequences ;
 IN: temporary
 
 [ "mmap-test-file.txt" resource-path delete-file ] catch drop
 [ ] [ "mmap-test-file.txt" resource-path <file-writer> [ "12345" write ] with-stream ] unit-test
 [ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
 [ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test
-[ "22345" ] [ "mmap-test-file.txt" resource-path <file-reader> contents ] unit-test
+[ "22345" ] [ "mmap-test-file.txt" resource-path file-contents ] unit-test
 [ "mmap-test-file.txt" resource-path delete-file ] catch drop
-

extra/lazy-lists/lazy-lists-docs.factor

@@ -4,70 +4,64 @@
 USING: help.markup help.syntax sequences strings ;
 IN: lazy-lists 
 
+{ car cons cdr nil nil? list? uncons } related-words
+
 HELP: cons 
 { $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } }
-{ $description "Constructs a cons cell." }
+{ $description "Constructs a cons cell." } ;
-{ $see-also cons car cdr nil nil? list? } ;
 
 HELP: car
 { $values { "cons" "a cons object" } { "car" "the first item in the list" } }
-{ $description "Returns the first item in the list." } 
+{ $description "Returns the first item in the list." } ;
-{ $see-also cons cdr nil nil? list? } ;
 
 HELP: cdr
 { $values { "cons" "a cons object" } { "cdr" "a cons object" } }
-{ $description "Returns the tail of the list." } 
+{ $description "Returns the tail of the list." } ;
-{ $see-also cons car nil nil? list? } ;
 
 HELP: nil 
 { $values { "cons" "An empty cons" } }
-{ $description "Returns a representation of an empty list" } 
+{ $description "Returns a representation of an empty list" } ;
-{ $see-also cons car cdr nil? list? } ;
 
 HELP: nil? 
 { $values { "cons" "a cons object" } { "?" "a boolean" } }
-{ $description "Return true if the cons object is the nil cons." } 
+{ $description "Return true if the cons object is the nil cons." } ;
-{ $see-also cons car cdr nil list? } ;
 
 HELP: list? 
 { $values { "object" "an object" } { "?" "a boolean" } }
-{ $description "Returns true if the object conforms to the list protocol." } 
+{ $description "Returns true if the object conforms to the list protocol." } ;
-{ $see-also cons car cdr nil } ;
+
+{ 1list 2list 3list } related-words
 
 HELP: 1list
 { $values { "obj" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 1 element." } 
+{ $description "Create a list with 1 element." } ;
-{ $see-also 2list 3list } ;
 
 HELP: 2list
 { $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 2 elements." } 
+{ $description "Create a list with 2 elements." } ;
-{ $see-also 1list 3list } ;
 
 HELP: 3list
 { $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 3 elements." } 
+{ $description "Create a list with 3 elements." } ;
-{ $see-also 1list 2list } ;
 
 HELP: lazy-cons
 { $values { "car" "a quotation with stack effect ( -- X )" } { "cdr" "a quotation with stack effect ( -- cons )" } { "promise" "the resulting cons object" } }
 { $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." } 
 { $see-also cons car cdr nil nil? } ;
 
+{ 1lazy-list 2lazy-list 3lazy-list } related-words
+
 HELP: 1lazy-list
 { $values { "a" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } 
+{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } ;
-{ $see-also 2lazy-list 3lazy-list } ;
 
 HELP: 2lazy-list
 { $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } 
+{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
-{ $see-also 1lazy-list 3lazy-list } ;
 
 HELP: 3lazy-list
 { $values { "a" "a quotation with stack effect ( -- X )" } { "b" "a quotation with stack effect ( -- X )" } { "c" "a quotation with stack effect ( -- X )" } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } 
+{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
-{ $see-also 1lazy-list 2lazy-list } ;
 
 HELP: <memoized-cons>
 { $values { "cons" "a cons object" } { "memoized-cons" "the resulting memoized-cons object" } }
@@ -86,43 +80,41 @@ HELP: llength
 
 HELP: uncons
 { $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
-{ $description "Put the head and tail of the list on the stack." } 
+{ $description "Put the head and tail of the list on the stack." } ;
-{ $see-also cons car cdr } ;
+
+{ leach lreduce lmap lmap-with ltake lsubset lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lreduce lwhile luntil } related-words
 
 HELP: leach
 { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- )" } }
-{ $description "Call the quotation for each item in the list." } 
+{ $description "Call the quotation for each item in the list." } ;
-{ $see-also lmap lmap-with ltake lsubset lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ;
+
+HELP: lreduce
+{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" "a quotation with stack effect ( prev elt -- next )" } { "result" "the final result" } }
+{ $description "Combines successive elements of the list using a binary operation, and outputs the final result." } ;
 
 HELP: lmap
 { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj -- X )" } { "result" "resulting cons object" } }
-{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } 
+{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-{ $see-also leach ltake lsubset lappend lmap-with  lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ;
 
 HELP: lmap-with
 { $values { "value" "an object" } { "list" "a cons object" } { "quot" "a quotation with stack effect ( obj elt -- X )" } { "result" "resulting cons object" } }
-{ $description "Variant of " { $link lmap } " which pushes a retained object on each invocation of the quotation." } 
+{ $description "Variant of " { $link lmap } " which pushes a retained object on each invocation of the quotation." } ;
-{ $see-also leach ltake lsubset lappend lmap lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ;
 
 HELP: ltake
 { $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } 
+{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-{ $see-also leach lmap lmap-with lsubset lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ;
 
 HELP: lsubset
 { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( -- X )" } { "result" "resulting cons object" } }
-{ $description "Perform a similar functionality to that of the " { $link subset } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-subset> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } 
+{ $description "Perform a similar functionality to that of the " { $link subset } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-subset> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-{ $see-also leach lmap lmap-with ltake lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ;
 
 HELP: lwhile
 { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." }
+{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-{ $see-also luntil } ;
 
 HELP: luntil
 { $values { "list" "a cons object" } { "quot" "a quotation with stack effect ( X -- bool )" } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." }
+{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-{ $see-also lwhile } ;
 
 HELP: list>vector
 { $values { "list" "a cons object" } { "vector" "the list converted to a vector" } }
@@ -136,18 +128,15 @@ HELP: list>array
 
 HELP: lappend
 { $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } }
-{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } 
+{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
-{ $see-also leach lmap lmap-with ltake lsubset lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ;
 
 HELP: lfrom-by
 { $values { "n" "an integer" } { "quot" "a quotation with stack effect ( -- int )" } { "list" "a lazy list of integers" } }
-{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } 
+{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
-{ $see-also leach lmap lmap-with ltake lsubset lfrom lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ;
 
 HELP: lfrom
 { $values { "n" "an integer" } { "list" "a lazy list of integers" } }
-{ $description "Return an infinite lazy list of incrementing integers starting from n." } 
+{ $description "Return an infinite lazy list of incrementing integers starting from n." } ;
-{ $see-also leach lmap lmap-with ltake lsubset lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ;
 
 HELP: seq>list
 { $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } }
@@ -161,39 +150,33 @@ HELP: >list
 
 HELP: lconcat
 { $values { "list" "a list of lists" } { "result" "a list" } }
-{ $description "Concatenates a list of lists together into one list." } 
+{ $description "Concatenates a list of lists together into one list." } ;
-{ $see-also leach lmap lmap-with ltake lsubset lcartesian-product lcartesian-product* lfrom-by lcomp lcomp* lmerge } ;
 
 HELP: lcartesian-product
 { $values { "list1" "a list" } { "list2" "a list" } { "result" "list of cartesian products" } }
-{ $description "Given two lists, return a list containing the cartesian product of those lists." } 
+{ $description "Given two lists, return a list containing the cartesian product of those lists." } ;
-{ $see-also leach lmap lmap-with lconcat ltake lsubset lfrom-by lcartesian-product* lcomp lcomp* lmerge } ;
 
 HELP: lcartesian-product*
 { $values { "lists" "a list of lists" } { "result" "list of cartesian products" } }
-{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } 
+{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ;
-{ $see-also leach lmap lmap-with lconcat ltake lsubset lfrom-by lcartesian-product lcomp lcomp* lmerge } ;
 
 HELP: lcomp
 { $values { "list" "a list of lists" } { "quot" "a quotation with stack effect ( seq -- X )" } { "result" "the resulting list" } }
-{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } 
+{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
-{ $see-also leach lmap lmap-with lconcat ltake lsubset lfrom-by lcartesian-product lcomp* lmerge } ;
 
 HELP: lcomp*
 { $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" "a quotation with stack effect ( seq -- X )" } { "list" "the resulting list" } { "result" "a list" } }
 { $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
 { $examples
   { $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
-}
+} ;
-{ $see-also leach lmap lmap-with lconcat ltake lsubset lfrom-by lcartesian-product lcomp lmerge } ;
 
 HELP: lmerge
 { $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } }
 { $description "Return the result of merging the two lists in a lazy manner." } 
 { $examples
   { $example "USE: lazy-lists" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
-}
+} ;
-{ $see-also leach lmap lmap-with lconcat ltake lsubset lfrom-by lcartesian-product lcomp } ;
 
 HELP: lcontents
 { $values { "stream" "a stream" } { "result" string } }

extra/lazy-lists/lazy-lists.factor

@@ -102,6 +102,9 @@ M: lazy-cons list? ( object -- bool )
 : leach ( list quot -- )
   swap dup nil? [ 2drop ] [ uncons swapd over 2slip leach ] if ; inline
 
+: lreduce ( list identity quot -- result )
+  swapd leach ; inline
+
 TUPLE: memoized-cons original car cdr nil? ;
 
 : not-memoized ( -- obj )
@@ -211,17 +214,17 @@ TUPLE: lazy-until cons quot ;
 C: <lazy-until> lazy-until
 
 : luntil ( list quot -- result )
-  <lazy-until> ;
+  over nil? [ drop ] [ <lazy-until> ] if ;
 
 M: lazy-until car ( lazy-until -- car )
    lazy-until-cons car ;
 
 M: lazy-until cdr ( lazy-until -- cdr )
-   [ lazy-until-cons uncons ] keep lazy-until-quot
+   [ lazy-until-cons uncons swap ] keep lazy-until-quot tuck call
-   rot over call [ 2drop nil ] [ luntil ] if ;
+   [ 2drop nil ] [ luntil ] if ;
 
 M: lazy-until nil? ( lazy-until -- bool )
-   lazy-until-cons nil? ;
+   drop f ;
 
 M: lazy-until list? ( lazy-until -- bool )
    drop t ;
@@ -231,19 +234,16 @@ TUPLE: lazy-while cons quot ;
 C: <lazy-while> lazy-while
 
 : lwhile ( list quot -- result )
-  <lazy-while>
+  over nil? [ drop ] [ <lazy-while> ] if ;
-;
 
 M: lazy-while car ( lazy-while -- car )
    lazy-while-cons car ;
 
 M: lazy-while cdr ( lazy-while -- cdr )
-   dup lazy-while-cons cdr dup nil?
+   [ lazy-while-cons cdr ] keep lazy-while-quot lwhile ;
-   [ 2drop nil ] [ swap lazy-while-quot lwhile ] if ;
 
 M: lazy-while nil? ( lazy-while -- bool )
-   dup lazy-while-cons nil?
+   [ car ] keep lazy-while-quot call not ;
-   [ nip ] [ [ car ] keep lazy-while-quot call not ] if* ;
 
 M: lazy-while list? ( lazy-while -- bool )
    drop t ;
@@ -313,11 +313,7 @@ M: lazy-append cdr ( lazy-append -- cdr )
   lazy-append-list2 lappend ;
 
 M: lazy-append nil? ( lazy-append -- bool )
-  dup lazy-append-list1 nil? [
+   drop f ;
-    lazy-append-list2 nil?
-  ] [
-    drop f
-  ] if ;
 
 M: lazy-append list? ( object -- bool )
   drop t ;

extra/macros/macros.factor

@@ -2,18 +2,18 @@
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: parser kernel sequences words effects inference.transforms
-       combinators assocs definitions quotations namespaces ;
+combinators assocs definitions quotations namespaces memoize ;
 
 IN: macros
 
-: (:)
+: (:) ( -- word definition effect-in )
     CREATE dup reset-generic parse-definition
     over "declared-effect" word-prop effect-in length ;
 
-: (MACRO:)
+: (MACRO:) ( word definition effect-in -- )
-    >r
+    >r 2dup "macro" set-word-prop
-    2dup "macro" set-word-prop
+    2dup over "declared-effect" word-prop memoize-quot
-    2dup [ call ] append define
+    [ call ] append define
     r> define-transform ;
 
 : MACRO:

extra/mad/api/api.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Adam Wendt.
 ! See http://factorcode.org/license.txt for BSD license.
-!
+USING: alien alien.c-types byte-arrays io io.binary io.files kernel mad
-USING: alien alien.c-types byte-arrays io io.binary io.files kernel mad namespaces prettyprint sbufs sequences tools.interpreter vars ;
+    namespaces prettyprint sbufs sequences tools.interpreter vars ;
 IN: mad.api
 
 VARS: buffer-start buffer-length output-callback-var ;
@@ -80,11 +80,8 @@ VARS: buffer-start buffer-length output-callback-var ;
 : make-decoder ( -- decoder )
   "mad_decoder" malloc-object ;
 
-: file-contents ( path -- string )
-  dup <file-reader> swap file-length <sbuf> [ stream-copy ] keep >byte-array ;
-
 : malloc-file-contents ( path -- alien )
-  file-contents malloc-byte-array ;
+  file-contents >byte-array malloc-byte-array ;
 
 : mad-run ( -- int )
   make-decoder [ mad-init ] keep MAD_DECODER_MODE_SYNC mad_decoder_run ;
@@ -98,4 +95,3 @@ VARS: buffer-start buffer-length output-callback-var ;
 : mad-test ( -- results )
   [ output-stdout ] >output-callback-var
   "/home/adam/download/mp3/Misc/wutbf.mp3" decode-mp3 ;
-

extra/math/algebra/algebra-docs.factor

@@ -0,0 +1,6 @@
+USING: help.markup help.syntax ;
+IN: math.algebra
+
+HELP: chinese-remainder
+{ $values { "aseq" "a sequence of integers" } { "nseq" "a sequence of positive integers" } { "x" "an integer" } }
+{ $description "If " { $snippet "nseq" } " integers are pairwise coprimes, " { $snippet "x" } " is the smallest positive integer congruent to each element in " { $snippet "aseq" } " modulo the corresponding element in " { $snippet "nseq" } "." } ;

extra/math/algebra/algebra-tests.factor

@@ -0,0 +1,3 @@
+USING: math.algebra tools.test ;
+
+{ 11 } [ { 2 3 1 } { 3 4 5 } chinese-remainder ] unit-test

extra/math/algebra/algebra.factor

@@ -0,0 +1,8 @@
+! Copyright (c) 2007 Samuel Tardieu
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions sequences ;
+IN: math.algebra
+
+: chinese-remainder ( aseq nseq -- x )
+  dup product
+  [ [ over / [ swap gcd drop ] keep * * ] curry 2map sum ] keep rem ; foldable

extra/math/algebra/authors.txt

@@ -0,0 +1 @@
+Samuel Tardieu

extra/math/algebra/summary.txt

@@ -0,0 +1 @@
+Various algebra-related words

extra/math/erato/erato.factor

@@ -1,6 +1,7 @@
 ! Copyright (c) 2007 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: bit-arrays kernel lazy-lists math math.functions math.ranges sequences ;
+USING: bit-arrays kernel lazy-lists math math.functions math.primes.list
+       math.ranges sequences ;
 IN: math.erato
 
 <PRIVATE
@@ -35,4 +36,8 @@ TUPLE: erato limit bits latest ;
 PRIVATE>
 
 : lerato ( n -- lazy-list )
-  <erato> 2 [ drop next-prime ] curry* lfrom-by [ ] lwhile ;
+  dup 1000003 < [
+    0 primes-under-million seq>list swap [ <= ] curry lwhile
+  ] [
+    <erato> 2 [ drop next-prime ] curry* lfrom-by [ ] lwhile
+  ] if ;

extra/math/primes/authors.txt

@@ -0,0 +1 @@
+Samuel Tardieu

extra/math/primes/factors/authors.txt

@@ -0,0 +1 @@
+Samuel Tardieu

extra/math/primes/factors/factors-docs.factor

@@ -0,0 +1,20 @@
+USING: help.markup help.syntax ;
+IN: math.primes.factors
+
+{ factors count-factors unique-factors } related-words
+
+HELP: factors
+{ $values { "n" "a positive integer" } { "seq" "a sequence" } }
+{ $description { "Factorize an integer and return an ordered list of factors, possibly repeated." } } ;
+
+HELP: count-factors
+{ $values { "n" "a positive integer" } { "seq" "a sequence" } }
+{ $description { "Return a sequence of pairs representing each factor in the number and its corresponding power." } } ;
+
+HELP: unique-factors
+{ $values { "n" "a positive integer" } { "seq" "a sequence" } }
+{ $description { "Return an ordered list of unique prime factors." } } ;
+
+HELP: totient
+{ $values { "n" "a positive integer" } { "t" "an integer" } }
+{ $description { "Return the number of integers between 1 and " { $snippet "n-1" } " relatively prime to " { $snippet "n" } "." } } ;

extra/math/primes/factors/factors-tests.factor

@@ -0,0 +1,6 @@
+USING: math.primes.factors tools.test ;
+
+{ { 999983 999983 1000003 } } [ 999969000187000867 factors ] unit-test
+{ { { 999983 2 } { 1000003 1 } } } [ 999969000187000867 count-factors ] unit-test
+{ { 999983 1000003 } } [ 999969000187000867 unique-factors ] unit-test
+{ 999967000236000612 } [ 999969000187000867 totient ] unit-test

extra/math/primes/factors/factors.factor

@@ -0,0 +1,41 @@
+! Copyright (C) 2007 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel lazy-lists math math.primes namespaces sequences ;
+IN: math.primes.factors
+
+<PRIVATE
+
+: (factor) ( n d -- n' )
+  2dup mod zero? [ [ / ] keep dup , (factor) ] [ drop ] if ;
+
+: (count) ( n d -- n' )
+  [ (factor) ] { } make
+  dup empty? [ drop ] [ [ first ] keep length 2array , ] if ;
+
+: (unique) ( n d -- n' )
+  [ (factor) ] { } make
+  dup empty? [ drop ] [ first , ] if ;
+
+: (factors) ( quot list n -- )
+  dup 1 > [ swap uncons >r pick call r> swap (factors) ] [ 3drop ] if ;
+
+: (decompose) ( n quot -- seq )
+  [ lprimes rot (factors) ] { } make ;
+
+PRIVATE>
+
+: factors ( n -- seq )
+  [ (factor) ] (decompose) ; foldable
+
+: count-factors ( n -- seq )
+  [ (count) ] (decompose) ; foldable
+
+: unique-factors ( n -- seq )
+  [ (unique) ] (decompose) ; foldable
+
+: totient ( n -- t )
+  dup 2 < [
+    drop 0
+  ] [
+   [ unique-factors dup 1 [ 1- * ] reduce swap product / ] keep *
+  ] if ; foldable

extra/math/primes/factors/summary.txt

@@ -0,0 +1 @@
+Prime factors decomposition

extra/math/primes/primes-docs.factor

@@ -0,0 +1,30 @@
+USING: help.markup help.syntax ;
+IN: math.primes
+
+{ next-prime prime? } related-words
+
+HELP: next-prime
+{ $values { "n" "a positive integer" } { "p" "a prime number" } }
+{ $description "Return the next prime number greater than " { $snippet "n" } "." } ;
+
+HELP: prime?
+{ $values { "n" "an integer" } { "?" "a boolean" } }
+{ $description "Test if an integer is a prime number." } ;
+
+{ lprimes lprimes-from primes-upto primes-between } related-words
+
+HELP: lprimes
+{ $values { "list" "a lazy list" } }
+{ $description "Return a sorted list containing all the prime numbers." } ;
+
+HELP: lprimes-from
+{ $values { "n" "an integer" } { "list" "a lazy list" } }
+{ $description "Return a sorted list containing all the prime numbers greater or equal to " { $snippet "n" } "." } ;
+
+HELP: primes-upto
+{ $values { "n" "an integer" } { "seq" "a sequence" } }
+{ $description "Return a sequence containing all the prime numbers smaller or equal to " { $snippet "n" } "." } ;
+
+HELP: primes-between
+{ $values { "low" "an integer" } { "high" "an integer" } { "seq" "a sequence" } }
+{ $description "Return a sequence containing all the prime numbers between " { $snippet "low" } " and " { $snippet "high" } "." } ;

extra/math/primes/primes-tests.factor

@@ -0,0 +1,10 @@
+USING: arrays math.primes tools.test lazy-lists ;
+
+{ 1237 } [ 1234 next-prime ] unit-test
+{ f t } [ 1234 prime? 1237 prime? ] unit-test
+{ { 2 3 5 7 11 13 17 19 23 29 } } [ 10 lprimes ltake list>array ] unit-test
+{ { 101 103 107 109 113 } } [ 5 100 lprimes-from ltake list>array ] unit-test
+{ { 1000117 1000121 } } [ 2 1000100 lprimes-from ltake list>array ] unit-test
+{ { 999983 1000003 } } [ 2 999982 lprimes-from ltake list>array ] unit-test
+{ { 2 3 5 7 } } [ 10 primes-upto >array ] unit-test
+{ { 999983 1000003 } } [ 999982 1000010 primes-between >array ] unit-test

extra/math/primes/primes.factor

@@ -0,0 +1,49 @@
+! Copyright (C) 2007 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators kernel lazy-lists math math.functions math.miller-rabin
+       math.primes.list math.ranges sequences sorting ;
+IN: math.primes
+
+<PRIVATE
+
+: find-prime-miller-rabin ( n -- p )
+  dup miller-rabin [ 2 + find-prime-miller-rabin ] unless ; foldable
+
+PRIVATE>
+
+: next-prime ( n -- p )
+  dup 999983 < [
+    primes-under-million [ [ <=> ] binsearch 1+ ] keep nth
+  ] [
+    next-odd find-prime-miller-rabin
+  ] if ; foldable
+
+: prime? ( n -- ? )
+  dup 1000000 < [
+    dup primes-under-million [ <=> ] binsearch* =
+  ] [
+    miller-rabin
+  ] if ; foldable
+
+: lprimes ( -- list )
+  0 primes-under-million seq>list
+  1000003 [ 2 + find-prime-miller-rabin ] lfrom-by
+  lappend ;
+
+: lprimes-from ( n -- list )
+  dup 3 < [ drop lprimes ] [  1- next-prime [ next-prime ] lfrom-by ] if ;
+
+: primes-upto ( n -- seq )
+  {
+    { [ dup 2 < ] [ drop { } ] }
+    { [ dup 1000003 < ]
+      [ primes-under-million [ [ <=> ] binsearch 1+ 0 swap ] keep <slice> ] }
+    { [ t ]
+      [ primes-under-million 1000003 lprimes-from
+        rot [ <= ] curry lwhile list>array append ] }
+  } cond ; foldable
+
+: primes-between ( low high -- seq )
+  primes-upto
+  >r 1- next-prime r>
+  [ [ <=> ] binsearch ] keep [ length ] keep <slice> ; foldable

extra/math/primes/summary.txt

@@ -0,0 +1,2 @@
+Prime numbers test and generation
+

extra/math/text/authors.txt

@@ -0,0 +1 @@
+Aaron Schaefer

extra/math/text/summary.txt

@@ -0,0 +1 @@
+Convert integers to text

extra/math/text/text-docs.factor

@@ -0,0 +1,7 @@
+USING: help.markup help.syntax math strings ;
+IN: math.text
+
+HELP: number>text
+{ $values { "n" integer } { "str" string } }
+{ $description "Converts an integer to a text string representation in English, including appropriate punctuation and conjunctions." }
+{ $examples { $example "12345 number>text ." "\"Twelve Thousand, Three Hundred and Forty-Five\"" } } ;

extra/math/text/text-tests.factor

@@ -0,0 +1,15 @@
+USING: math.functions math.text tools.test ;
+IN: temporary
+
+[ "Zero" ] [ 0 number>text ] unit-test
+[ "Twenty-One" ] [ 21 number>text ] unit-test
+[ "One Hundred" ] [ 100 number>text ] unit-test
+[ "One Hundred and One" ] [ 101 number>text ] unit-test
+[ "One Thousand and One" ] [ 1001 number>text ] unit-test
+[ "One Thousand, One Hundred and One" ] [ 1101 number>text ] unit-test
+[ "One Million, One Thousand and One" ] [ 1001001 number>text ] unit-test
+[ "One Million, One Thousand, One Hundred and One" ] [ 1001101 number>text ] unit-test
+[ "One Million, One Hundred and Eleven Thousand, One Hundred and Eleven" ] [ 1111111 number>text ] unit-test
+[ "One Duotrigintillion" ] [ 10 99 ^ number>text ] unit-test
+
+[ "Negative One Hundred and Twenty-Three" ] [ -123 number>text ] unit-test

extra/math/text/text.factor

@@ -0,0 +1,103 @@
+! Copyright (c) 2007 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.lib kernel math math.functions math.parser namespaces
+    sequences splitting sequences.lib ;
+IN: math.text
+
+<PRIVATE
+
+: small-numbers ( n -- str )
+    { "Zero" "One" "Two" "Three" "Four" "Five" "Six" "Seven" "Eight" "Nine"
+    "Ten" "Eleven" "Twelve" "Thirteen" "Fourteen" "Fifteen" "Sixteen"
+    "Seventeen" "Eighteen" "Nineteen" } nth ;
+
+: tens ( n -- str )
+    { "" "" "Twenty" "Thirty" "Forty" "Fifty" "Sixty" "Seventy" "Eighty" "Ninety" } nth ;
+
+: scale-numbers ( n -- str )  ! up to 10^99
+    { "" "Thousand" "Million" "Billion" "Trillion" "Quadrillion" "Quintillion"
+    "Sextillion" "Septillion" "Octillion" "Nonillion" "Decillion" "Undecillion"
+    "Duodecillion" "Tredecillion" "Quattuordecillion" "Quindecillion"
+    "Sexdecillion" "Septendecillion" "Octodecillion" "Novemdecillion"
+    "Vigintillion" "Unvigintillion" "Duovigintillion" "Trevigintillion"
+    "Quattuorvigintillion" "Quinvigintillion" "Sexvigintillion"
+    "Septvigintillion" "Octovigintillion" "Novemvigintillion" "Trigintillion"
+    "Untrigintillion" "Duotrigintillion" } nth ;
+
+SYMBOL: and-needed?
+: set-conjunction ( seq -- )
+    first {
+        [ dup 100 < ]
+        [ dup 0 > ]
+    } && and-needed? set drop ;
+
+: negative-text ( n -- str )
+    0 < "Negative " "" ? ;
+
+: 3digit-groups ( n -- seq )
+    number>string <reversed> 3 <groups>
+    [ reverse 10 string>integer ] map ;
+
+: hundreds-place ( n -- str )
+    100 /mod swap dup zero? [
+        2drop ""
+    ] [
+        small-numbers " Hundred" append
+        swap zero? [ " and " append ] unless
+    ] if ;
+
+: tens-place ( n -- str )
+    100 mod dup 20 >= [
+        10 /mod >r tens r>
+        dup zero? [ drop ] [ "-" swap small-numbers 3append ] if
+    ] [
+        dup zero? [ drop "" ] [ small-numbers ] if
+    ] if ;
+
+: 3digits>text ( n -- str )
+    dup hundreds-place swap tens-place append ;
+
+: text-with-scale ( index seq -- str )
+    dupd nth 3digits>text swap
+    scale-numbers dup empty? [
+        drop
+    ] [
+        " " swap 3append
+    ] if ;
+
+: append-with-conjunction ( str1 str2 -- newstr )
+    over length zero? [
+        nip
+    ] [
+        and-needed? get " and " ", " ? rot 3append
+        and-needed? off
+    ] if ;
+
+: (recombine) ( str index seq -- newstr seq )
+    2dup nth zero? [
+        nip
+    ] [
+        [ text-with-scale ] keep
+        -rot append-with-conjunction swap
+    ] if ;
+
+: recombine ( seq -- str )
+    dup singleton? [
+        first 3digits>text
+    ] [
+        dup set-conjunction "" swap
+        dup length [ swap (recombine) ] each drop
+    ] if ;
+
+: (number>text) ( n -- str )
+    dup negative-text swap abs 3digit-groups recombine append ;
+
+PRIVATE>
+
+: number>text ( n -- str )
+    dup zero? [
+        small-numbers
+    ] [
+        [ (number>text) ] with-scope
+    ] if ;
+

extra/memoize/memoize.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel hashtables sequences arrays words namespaces
-parser math assocs effects definitions ;
+parser math assocs effects definitions quotations ;
 IN: memoize
 
 : packer ( n -- quot )
@@ -46,3 +46,7 @@ PREDICATE: compound memoized "memoize" word-prop ;
 
 M: memoized definer drop \ MEMO: \ ; ;
 M: memoized definition "memo-quot" word-prop ;
+
+: memoize-quot ( quot effect -- memo-quot )
+    gensym swap dupd "declared-effect" set-word-prop
+    dup rot define-memoized 1quotation ;

extra/project-euler/003/003.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2007 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math project-euler.common sequences ;
+USING: math.primes.factors sequences ;
 IN: project-euler.003
 
 ! http://projecteuler.net/index.php?section=problems&id=3
@@ -17,12 +17,12 @@ IN: project-euler.003
 ! --------
 
 : largest-prime-factor ( n -- factor )
-    prime-factors supremum ;
+  factors supremum ;
 
 : euler003 ( -- answer )
   317584931803 largest-prime-factor ;
 
-! [ euler003 ] 100 ave-time
+! [ euler003 ] time
-! 404 ms run / 9 ms GC ave time - 100 trials
+! 2 ms run / 0 ms GC time
 
 MAIN: euler003

extra/project-euler/007/007.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2007 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.miller-rabin ;
+USING: lazy-lists math math.primes ;
 IN: project-euler.007
 
 ! http://projecteuler.net/index.php?section=problems&id=7
@@ -18,12 +18,12 @@ IN: project-euler.007
 ! --------
 
 : nth-prime ( n -- n )
-    2 swap 1- [ next-prime ] times ;
+  1 - lprimes lnth ;
 
 : euler007 ( -- answer )
   10001 nth-prime ;
 
 ! [ euler007 ] time
-! 19230 ms run / 487 ms GC time
+! 22 ms run / 0 ms GC time
 
 MAIN: euler007

extra/project-euler/010/010.factor

@@ -1,7 +1,6 @@
 ! Copyright (c) 2007 Aaron Schaefer, Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel lazy-lists math math.erato math.functions math.ranges
+USING: kernel math.primes sequences ;
-       namespaces sequences ;
 IN: project-euler.010
 
 ! http://projecteuler.net/index.php?section=problems&id=10
@@ -17,15 +16,10 @@ IN: project-euler.010
 ! SOLUTION
 ! --------
 
-! Sieve of Eratosthenes and lazy summing
-
 : euler010 ( -- answer )
-    0 1000000 lerato [ + ] leach ;
+    1000000 primes-upto sum ;
 
-! TODO: solution is still too slow for 1000000, probably due to seq-diff
+! [ euler010 ] 100 ave-time
-! calling member? for each number that we want to remove
+! 14 ms run / 0 ms GC ave time - 100 trials
-
-! [ euler010 ] time
-! 765 ms run / 7 ms GC time
 
 MAIN: euler010

extra/project-euler/011/011.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2007 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces project-euler.common sequences ;
+USING: kernel namespaces project-euler.common sequences splitting ;
 IN: project-euler.011
 
 ! http://projecteuler.net/index.php?section=problems&id=11
@@ -45,40 +45,40 @@ IN: project-euler.011
 
 : horizontal ( -- matrix )
     {
-        { 08 02 22 97 38 15 00 40 00 75 04 05 07 78 52 12 50 77 91 08 }
+      08 02 22 97 38 15 00 40 00 75 04 05 07 78 52 12 50 77 91 08
-        { 49 49 99 40 17 81 18 57 60 87 17 40 98 43 69 48 04 56 62 00 }
+      49 49 99 40 17 81 18 57 60 87 17 40 98 43 69 48 04 56 62 00
-        { 81 49 31 73 55 79 14 29 93 71 40 67 53 88 30 03 49 13 36 65 }
+      81 49 31 73 55 79 14 29 93 71 40 67 53 88 30 03 49 13 36 65
-        { 52 70 95 23 04 60 11 42 69 24 68 56 01 32 56 71 37 02 36 91 }
+      52 70 95 23 04 60 11 42 69 24 68 56 01 32 56 71 37 02 36 91
-        { 22 31 16 71 51 67 63 89 41 92 36 54 22 40 40 28 66 33 13 80 }
+      22 31 16 71 51 67 63 89 41 92 36 54 22 40 40 28 66 33 13 80
-        { 24 47 32 60 99 03 45 02 44 75 33 53 78 36 84 20 35 17 12 50 }
+      24 47 32 60 99 03 45 02 44 75 33 53 78 36 84 20 35 17 12 50
-        { 32 98 81 28 64 23 67 10 26 38 40 67 59 54 70 66 18 38 64 70 }
+      32 98 81 28 64 23 67 10 26 38 40 67 59 54 70 66 18 38 64 70
-        { 67 26 20 68 02 62 12 20 95 63 94 39 63 08 40 91 66 49 94 21 }
+      67 26 20 68 02 62 12 20 95 63 94 39 63 08 40 91 66 49 94 21
-        { 24 55 58 05 66 73 99 26 97 17 78 78 96 83 14 88 34 89 63 72 }
+      24 55 58 05 66 73 99 26 97 17 78 78 96 83 14 88 34 89 63 72
-        { 21 36 23 09 75 00 76 44 20 45 35 14 00 61 33 97 34 31 33 95 }
+      21 36 23 09 75 00 76 44 20 45 35 14 00 61 33 97 34 31 33 95
-        { 78 17 53 28 22 75 31 67 15 94 03 80 04 62 16 14 09 53 56 92 }
+      78 17 53 28 22 75 31 67 15 94 03 80 04 62 16 14 09 53 56 92
-        { 16 39 05 42 96 35 31 47 55 58 88 24 00 17 54 24 36 29 85 57 }
+      16 39 05 42 96 35 31 47 55 58 88 24 00 17 54 24 36 29 85 57
-        { 86 56 00 48 35 71 89 07 05 44 44 37 44 60 21 58 51 54 17 58 }
+      86 56 00 48 35 71 89 07 05 44 44 37 44 60 21 58 51 54 17 58
-        { 19 80 81 68 05 94 47 69 28 73 92 13 86 52 17 77 04 89 55 40 }
+      19 80 81 68 05 94 47 69 28 73 92 13 86 52 17 77 04 89 55 40
-        { 04 52 08 83 97 35 99 16 07 97 57 32 16 26 26 79 33 27 98 66 }
+      04 52 08 83 97 35 99 16 07 97 57 32 16 26 26 79 33 27 98 66
-        { 88 36 68 87 57 62 20 72 03 46 33 67 46 55 12 32 63 93 53 69 }
+      88 36 68 87 57 62 20 72 03 46 33 67 46 55 12 32 63 93 53 69
-        { 04 42 16 73 38 25 39 11 24 94 72 18 08 46 29 32 40 62 76 36 }
+      04 42 16 73 38 25 39 11 24 94 72 18 08 46 29 32 40 62 76 36
-        { 20 69 36 41 72 30 23 88 34 62 99 69 82 67 59 85 74 04 36 16 }
+      20 69 36 41 72 30 23 88 34 62 99 69 82 67 59 85 74 04 36 16
-        { 20 73 35 29 78 31 90 01 74 31 49 71 48 86 81 16 23 57 05 54 }
+      20 73 35 29 78 31 90 01 74 31 49 71 48 86 81 16 23 57 05 54
-        { 01 70 54 71 83 51 54 69 16 92 33 48 61 43 52 01 89 19 67 48 }
+      01 70 54 71 83 51 54 69 16 92 33 48 61 43 52 01 89 19 67 48
-    } ;
+    } 20 group ;
 
 : vertical ( -- matrix )
     horizontal flip ;
 
 : pad-front ( matrix -- matrix )
     [
-        length [ 0 <repetition> ] each
+        length [ 0 <repetition> ] map
-    ] keep [ append ] map ;
+    ] keep [ append ] 2map ;
 
 : pad-back ( matrix -- matrix )
     <reversed> [
-        length [ 0 <repetition> ] each
+        length [ 0 <repetition> ] map
-    ] keep [ <reversed> append ] map ;
+    ] keep [ <reversed> append ] 2map ;
 
 : diagonal/ ( -- matrix )
     horizontal reverse pad-front pad-back flip ;
@@ -98,9 +98,6 @@ PRIVATE>
         [ call 4 max-product , ] each
     ] { } make supremum ;
 
-! TODO: solution works but doesn't completely compile due to the creation of
-! the diagonal matrices, there must be a cleaner way to generate those
-
 ! [ euler011 ] 100 ave-time
 ! 4 ms run / 0 ms GC ave time - 100 trials
 

extra/project-euler/016/016.factor

@@ -1,6 +1,6 @@
 ! Copyright (c) 2007 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.functions math.parser sequences ;
+USING: kernel math.functions math.parser project-euler.common sequences ;
 IN: project-euler.016
 
 ! http://projecteuler.net/index.php?section=problems&id=16
@@ -16,9 +16,6 @@ IN: project-euler.016
 ! SOLUTION
 ! --------
 
-: number>digits ( n -- seq )
-    number>string string>digits ;
-
 : euler016 ( -- answer )
     2 1000 ^ number>digits sum ;
 

extra/project-euler/017/017.factor

@@ -1,6 +1,7 @@
-! Copyright (c) 2007 Samuel Tardieu.
+! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces sequences strings ;
+USING: combinators.lib kernel math math.ranges math.text namespaces sequences
+    strings ;
 IN: project-euler.017
 
 ! http://projecteuler.net/index.php?section=problems&id=17
@@ -18,6 +19,7 @@ IN: project-euler.017
 ! forty-two) contains 23 letters and 115 (one hundred and fifteen) contains
 ! 20 letters.
 
+
 ! SOLUTION
 ! --------
 
@@ -38,18 +40,18 @@ IN: project-euler.017
 DEFER: make-english
 
 : maybe-add ( n sep -- )
-  over 0 = [ 2drop ] [ % make-english ] if ;
+  over zero? [ 2drop ] [ % make-english ] if ;
 
 : 0-99 ( n -- )
   dup 20 < [ units ] [ 10 /mod swap tenths "-" maybe-add ] if ;
 
 : 0-999 ( n -- )
   100 /mod swap
-  dup 0 = [ drop 0-99 ] [ units " hundred" % " and " maybe-add ] if ;
+  dup zero? [ drop 0-99 ] [ units " hundred" % " and " maybe-add ] if ;
 
 : make-english ( n -- )
   1000 /mod swap
-  dup 0 = [ drop 0-999 ] [ 0-999 " thousand" % " and " maybe-add ] if ;
+  dup zero? [ drop 0-999 ] [ 0-999 " thousand" % " and " maybe-add ] if ;
 
 PRIVATE>
 
@@ -57,9 +59,19 @@ PRIVATE>
   [ make-english ] "" make ;
 
 : euler017 ( -- answer )
-  1000 [ 1 + >english [ letter? ] subset length ] map sum ;
+  1000 [1,b] [ >english [ letter? ] subset length ] map sum ;
 
 ! [ euler017 ] 100 ave-time
 ! 9 ms run / 0 ms GC ave time - 100 trials
 
+
+! ALTERNATE SOLUTIONS
+! -------------------
+
+: euler017a ( -- answer )
+    1000 [1,b] SBUF" " clone [ number>text over push-all ] reduce [ Letter? ] count ;
+
+! [ euler017a ] 100 ave-time
+! 14 ms run / 1 ms GC ave time - 100 trials
+
 MAIN: euler017

extra/project-euler/018/018.factor

@@ -0,0 +1,121 @@
+! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math project-euler.common sequences ;
+IN: project-euler.018
+
+! http://projecteuler.net/index.php?section=problems&id=18
+
+! DESCRIPTION
+! -----------
+
+! By starting at the top of the triangle below and moving to adjacent numbers
+! on the row below, the maximum total from top to bottom is 23.
+
+!        3
+!       7 5
+!      2 4 6
+!     8 5 9 3
+
+! That is, 3 + 7 + 4 + 9 = 23.
+
+! Find the maximum total from top to bottom of the triangle below:
+
+!                                 75
+!                               95  64
+!                             17  47  82
+!                           18  35  87  10
+!                         20  04  82  47  65
+!                       19  01  23  75  03  34
+!                     88  02  77  73  07  63  67
+!                   99  65  04  28  06  16  70  92
+!                 41  41  26  56  83  40  80  70  33
+!               41  48  72  33  47  32  37  16  94  29
+!             53  71  44  65  25  43  91  52  97  51  14
+!           70  11  33  28  77  73  17  78  39  68  17  57
+!         91  71  52  38  17  14  91  43  58  50  27  29  48
+!       63  66  04  68  89  53  67  30  73  16  69  87  40  31
+!     04  62  98  27  23  09  70  98  73  93  38  53  60  04  23
+
+! NOTE: As there are only 16384 routes, it is possible to solve this problem by
+! trying every route. However, Problem 67, is the same challenge with a
+! triangle containing one-hundred rows; it cannot be solved by brute force, and
+! requires a clever method! ;o)
+
+
+! SOLUTION
+! --------
+
+! Propagate from bottom to top the longest cumulative path. This is very
+! efficient and will be reused in problem 67.
+
+<PRIVATE
+
+: pyramid ( -- seq )
+  {
+                         75
+                        95 64
+                      17 47 82
+                     18 35 87 10
+                   20 04 82 47 65
+                  19 01 23 75 03 34
+                88 02 77 73 07 63 67
+               99 65 04 28 06 16 70 92
+             41 41 26 56 83 40 80 70 33
+            41 48 72 33 47 32 37 16 94 29
+          53 71 44 65 25 43 91 52 97 51 14
+         70 11 33 28 77 73 17 78 39 68 17 57
+       91 71 52 38 17 14 91 43 58 50 27 29 48
+      63 66 04 68 89 53 67 30 73 16 69 87 40 31
+    04 62 98 27 23 09 70 98 73 93 38 53 60 04 23
+  }
+  15 [ 1+ cut swap ] map nip ;
+
+PRIVATE>
+
+! Propagate one row into the upper one
+: propagate ( bottom top -- newtop )
+    [ over 1 tail rot first2 max rot + ] map nip ;
+
+! Not strictly needed, but it is nice to be able to dump the pyramid after
+! the propagation
+: propagate-all ( pyramid -- newpyramid )
+    reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap add ;
+
+: euler018 ( -- answer )
+    pyramid propagate-all first first ;
+
+! [ euler018 ] 100 ave-time
+! 0 ms run / 0 ms GC ave time - 100 trials
+
+
+! ALTERNATE SOLUTIONS
+! -------------------
+
+<PRIVATE
+
+: source-018a ( -- triangle )
+    { { 75 }
+      { 95 64 }
+      { 17 47 82 }
+      { 18 35 87 10 }
+      { 20 04 82 47 65 }
+      { 19 01 23 75 03 34 }
+      { 88 02 77 73 07 63 67 }
+      { 99 65 04 28 06 16 70 92 }
+      { 41 41 26 56 83 40 80 70 33 }
+      { 41 48 72 33 47 32 37 16 94 29 }
+      { 53 71 44 65 25 43 91 52 97 51 14 }
+      { 70 11 33 28 77 73 17 78 39 68 17 57 }
+      { 91 71 52 38 17 14 91 43 58 50 27 29 48 }
+      { 63 66 04 68 89 53 67 30 73 16 69 87 40 31 }
+      { 04 62 98 27 23 09 70 98 73 93 38 53 60 04 23 } } ;
+
+PRIVATE>
+
+: euler018a ( -- answer )
+    source-018a max-path ;
+
+! [ euler018a ] 100 ave-time
+! 0 ms run / 0 ms GC ave time - 100 trials
+
+MAIN: euler018

extra/project-euler/019/019.factor

@@ -0,0 +1,70 @@
+! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar combinators combinators.lib kernel math math.ranges namespaces
+    sequences ;
+IN: project-euler.019
+
+! http://projecteuler.net/index.php?section=problems&id=19
+
+! DESCRIPTION
+! -----------
+
+! You are given the following information, but you may prefer to do some
+! research for yourself.
+
+!     * 1 Jan 1900 was a Monday.
+!     * Thirty days has September, April, June and November.  All the rest have
+!       thirty-one, Saving February alone, Which has twenty-eight, rain or
+!       shine.  And on leap years, twenty-nine.
+!     * A leap year occurs on any year evenly divisible by 4, but not on a
+!       century unless it is divisible by 400.
+
+! How many Sundays fell on the first of the month during the twentieth century
+! (1 Jan 1901 to 31 Dec 2000)?
+
+
+! SOLUTION
+! --------
+
+! Use Zeller congruence, which is implemented in the "calendar" module
+! already, as "zeller-congruence ( year month day -- n )" where n is
+! the day of the week (Sunday is 0).
+
+: euler019 ( -- count )
+  1901 2000 [a,b] [ 12 [1,b] [ 1 zeller-congruence ] 1 map-withn ] map concat
+  [ 0 = ] subset length ;
+
+! [ euler019 ] 100 ave-time
+! 1 ms run / 0 ms GC ave time - 100 trials
+
+
+! ALTERNATE SOLUTIONS
+! -------------------
+
+<PRIVATE
+
+: start-date ( -- timestamp )
+    1901 1 1 0 0 0 0 make-timestamp ;
+
+: end-date ( -- timestamp )
+    2000 12 31 0 0 0 0 make-timestamp ;
+
+: (first-days) ( end-date start-date -- )
+    2dup timestamp- 0 >= [
+        dup day-of-week , 1 +month (first-days)
+    ] [
+        2drop
+    ] if ;
+
+: first-days ( start-date end-date -- seq )
+    [ swap (first-days) ] { } make ;
+
+PRIVATE>
+
+: euler019a ( -- answer )
+    start-date end-date first-days [ zero? ] count ;
+
+! [ euler019a ] 100 ave-time
+! 131 ms run / 3 ms GC ave time - 100 trials
+
+MAIN: euler019

extra/project-euler/020/020.factor

@@ -0,0 +1,25 @@
+! Copyright (c) 2007 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math.combinatorics math.parser project-euler.common sequences ;
+IN: project-euler.020
+
+! http://projecteuler.net/index.php?section=problems&id=20
+
+! DESCRIPTION
+! -----------
+
+! n! means n * (n - 1) * ... * 3 * 2 * 1
+
+! Find the sum of the digits in the number 100!
+
+
+! SOLUTION
+! --------
+
+: euler020 ( -- answer )
+    100 factorial number>digits sum ;
+
+! [ euler020 ] 100 ave-time
+! 0 ms run / 0 ms GC ave time - 100 trials
+
+MAIN: euler020

extra/project-euler/021/021.factor

@@ -0,0 +1,38 @@
+! Copyright (c) 2007 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.lib kernel math math.functions math.ranges namespaces
+    project-euler.common sequences ;
+IN: project-euler.021
+
+! http://projecteuler.net/index.php?section=problems&id=21
+
+! DESCRIPTION
+! -----------
+
+! Let d(n) be defined as the sum of proper divisors of n (numbers less than n
+! which divide evenly into n).
+
+! If d(a) = b and d(b) = a, where a != b, then a and b are an amicable pair and
+! each of a and b are called amicable numbers.
+
+! For example, the proper divisors of 220 are 1, 2, 4, 5, 10, 11, 20, 22, 44,
+! 55 and 110; therefore d(220) = 284. The proper divisors of 284 are 1, 2, 4,
+! 71 and 142; so d(284) = 220.
+
+! Evaluate the sum of all the amicable numbers under 10000.
+
+
+! SOLUTION
+! --------
+
+: amicable? ( n -- ? )
+    dup sum-proper-divisors
+    { [ 2dup = not ] [ 2dup sum-proper-divisors = ] } && 2nip ;
+
+: euler021 ( -- answer )
+    10000 [1,b] [ dup amicable? [ drop 0 ] unless ] sigma ;
+
+! [ euler021 ] 100 ave-time
+! 328 ms run / 10 ms GC ave time - 100 trials
+
+MAIN: euler021

extra/project-euler/022/022.factor

@@ -0,0 +1,60 @@
+! Copyright (c) 2007 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.lib io io.files kernel math math.parser namespaces sequences
+    sorting splitting strings system vocabs ;
+IN: project-euler.022
+
+! http://projecteuler.net/index.php?section=problems&id=22
+
+! DESCRIPTION
+! -----------
+
+! Using names.txt (right click and 'Save Link/Target As...'), a 46K text file
+! containing over five-thousand first names, begin by sorting it into
+! alphabetical order. Then working out the alphabetical value for each name,
+! multiply this value by its alphabetical position in the list to obtain a name
+! score.
+
+! For example, when the list is sorted into alphabetical order, COLIN, which is
+! worth 3 + 15 + 12 + 9 + 14 = 53, is the 938th name in the list. So, COLIN
+! would obtain a score of 938 * 53 = 49714.
+
+! What is the total of all the name scores in the file?
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: (source-022) ( -- path )
+    [
+        "project-euler.022" vocab-root ?resource-path %
+        os "windows" = [
+            "\\project-euler\\022\\names.txt" %
+        ] [
+            "/project-euler/022/names.txt" %
+        ] if
+    ] "" make ;
+
+: source-022 ( -- seq )
+    (source-022) file-contents [ quotable? ] subset "," split ;
+
+: alpha-value ( str -- n )
+    string>digits [ 9 - ] sigma ;
+
+: name-scores ( seq -- seq )
+    dup length [ 1+ swap alpha-value * ] 2map ;
+
+PRIVATE>
+
+: euler022 ( -- answer )
+    source-022 natural-sort name-scores sum ;
+
+! [ euler022 ] 100 ave-time
+! 59 ms run / 1 ms GC ave time - 100 trials
+
+! source-022 [ natural-sort name-scores sum ] curry 100 ave-time
+! 45 ms run / 1 ms GC ave time - 100 trials
+
+MAIN: euler022

extra/project-euler/067/067.factor

@@ -0,0 +1,82 @@
+! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.files kernel math.parser namespaces project-euler.018
+    project-euler.common sequences splitting system vocabs ;
+IN: project-euler.067
+
+! http://projecteuler.net/index.php?section=problems&id=67
+
+! DESCRIPTION
+! -----------
+
+! By starting at the top of the triangle below and moving to adjacent numbers
+! on the row below, the maximum total from top to bottom is 23.
+
+!        3
+!       7 5
+!      2 4 6
+!     8 5 9 3
+
+! That is, 3 + 7 + 4 + 9 = 23.
+
+! Find the maximum total from top to bottom in triangle.txt (right click and
+! 'Save Link/Target As...'), a 15K text file containing a triangle with
+! one-hundred rows.
+
+! NOTE: This is a much more difficult version of Problem 18. It is not possible
+! to try every route to solve this problem, as there are 2^99 altogether! If you
+! could check one trillion (10^12) routes every second it would take over twenty
+! billion years to check them all. There is an efficient algorithm to solve it. ;o)
+
+
+! SOLUTION
+! --------
+
+! Propagate from bottom to top the longest cumulative path as is done in
+! problem 18.
+
+<PRIVATE
+
+: pyramid ( -- seq )
+    "resource:extra/project-euler/067/triangle.txt" ?resource-path
+    <file-reader> lines [ " " split [ string>number ] map ] map ;
+
+PRIVATE>
+
+: euler067 ( -- answer )
+    pyramid propagate-all first first ;
+
+! [ euler067 ] 100 ave-time
+! 18 ms run / 0 ms GC time
+
+
+! ALTERNATE SOLUTIONS
+! -------------------
+
+<PRIVATE
+
+: (source-067a) ( -- path )
+    [
+        "project-euler.067" vocab-root ?resource-path %
+        os "windows" = [
+            "\\project-euler\\067\\triangle.txt" %
+        ] [
+            "/project-euler/067/triangle.txt" %
+        ] if
+    ] "" make ;
+
+: source-067a ( -- triangle )
+    (source-067a) <file-reader> lines [ " " split [ string>number ] map ] map ;
+
+PRIVATE>
+
+: euler067a ( -- answer )
+    source-067a max-path ;
+
+! [ euler067a ] 100 ave-time
+! 15 ms run / 0 ms GC ave time - 100 trials
+
+! source-067a [ max-path ] curry 100 ave-time
+! 3 ms run / 0 ms GC ave time - 100 trials
+
+MAIN: euler067a

extra/project-euler/067/triangle.txt

@@ -0,0 +1,100 @@
+59
+73 41
+52 40 09
+26 53 06 34
+10 51 87 86 81
+61 95 66 57 25 68
+90 81 80 38 92 67 73
+30 28 51 76 81 18 75 44
+84 14 95 87 62 81 17 78 58
+21 46 71 58 02 79 62 39 31 09
+56 34 35 53 78 31 81 18 90 93 15
+78 53 04 21 84 93 32 13 97 11 37 51
+45 03 81 79 05 18 78 86 13 30 63 99 95
+39 87 96 28 03 38 42 17 82 87 58 07 22 57
+06 17 51 17 07 93 09 07 75 97 95 78 87 08 53
+67 66 59 60 88 99 94 65 55 77 55 34 27 53 78 28
+76 40 41 04 87 16 09 42 75 69 23 97 30 60 10 79 87
+12 10 44 26 21 36 32 84 98 60 13 12 36 16 63 31 91 35
+70 39 06 05 55 27 38 48 28 22 34 35 62 62 15 14 94 89 86
+66 56 68 84 96 21 34 34 34 81 62 40 65 54 62 05 98 03 02 60
+38 89 46 37 99 54 34 53 36 14 70 26 02 90 45 13 31 61 83 73 47
+36 10 63 96 60 49 41 05 37 42 14 58 84 93 96 17 09 43 05 43 06 59
+66 57 87 57 61 28 37 51 84 73 79 15 39 95 88 87 43 39 11 86 77 74 18
+54 42 05 79 30 49 99 73 46 37 50 02 45 09 54 52 27 95 27 65 19 45 26 45
+71 39 17 78 76 29 52 90 18 99 78 19 35 62 71 19 23 65 93 85 49 33 75 09 02
+33 24 47 61 60 55 32 88 57 55 91 54 46 57 07 77 98 52 80 99 24 25 46 78 79 05
+92 09 13 55 10 67 26 78 76 82 63 49 51 31 24 68 05 57 07 54 69 21 67 43 17 63 12
+24 59 06 08 98 74 66 26 61 60 13 03 09 09 24 30 71 08 88 70 72 70 29 90 11 82 41 34
+66 82 67 04 36 60 92 77 91 85 62 49 59 61 30 90 29 94 26 41 89 04 53 22 83 41 09 74 90
+48 28 26 37 28 52 77 26 51 32 18 98 79 36 62 13 17 08 19 54 89 29 73 68 42 14 08 16 70 37
+37 60 69 70 72 71 09 59 13 60 38 13 57 36 09 30 43 89 30 39 15 02 44 73 05 73 26 63 56 86 12
+55 55 85 50 62 99 84 77 28 85 03 21 27 22 19 26 82 69 54 04 13 07 85 14 01 15 70 59 89 95 10 19
+04 09 31 92 91 38 92 86 98 75 21 05 64 42 62 84 36 20 73 42 21 23 22 51 51 79 25 45 85 53 03 43 22
+75 63 02 49 14 12 89 14 60 78 92 16 44 82 38 30 72 11 46 52 90 27 08 65 78 03 85 41 57 79 39 52 33 48
+78 27 56 56 39 13 19 43 86 72 58 95 39 07 04 34 21 98 39 15 39 84 89 69 84 46 37 57 59 35 59 50 26 15 93
+42 89 36 27 78 91 24 11 17 41 05 94 07 69 51 96 03 96 47 90 90 45 91 20 50 56 10 32 36 49 04 53 85 92 25 65
+52 09 61 30 61 97 66 21 96 92 98 90 06 34 96 60 32 69 68 33 75 84 18 31 71 50 84 63 03 03 19 11 28 42 75 45 45
+61 31 61 68 96 34 49 39 05 71 76 59 62 67 06 47 96 99 34 21 32 47 52 07 71 60 42 72 94 56 82 83 84 40 94 87 82 46
+01 20 60 14 17 38 26 78 66 81 45 95 18 51 98 81 48 16 53 88 37 52 69 95 72 93 22 34 98 20 54 27 73 61 56 63 60 34 63
+93 42 94 83 47 61 27 51 79 79 45 01 44 73 31 70 83 42 88 25 53 51 30 15 65 94 80 44 61 84 12 77 02 62 02 65 94 42 14 94
+32 73 09 67 68 29 74 98 10 19 85 48 38 31 85 67 53 93 93 77 47 67 39 72 94 53 18 43 77 40 78 32 29 59 24 06 02 83 50 60 66
+32 01 44 30 16 51 15 81 98 15 10 62 86 79 50 62 45 60 70 38 31 85 65 61 64 06 69 84 14 22 56 43 09 48 66 69 83 91 60 40 36 61
+92 48 22 99 15 95 64 43 01 16 94 02 99 19 17 69 11 58 97 56 89 31 77 45 67 96 12 73 08 20 36 47 81 44 50 64 68 85 40 81 85 52 09
+91 35 92 45 32 84 62 15 19 64 21 66 06 01 52 80 62 59 12 25 88 28 91 50 40 16 22 99 92 79 87 51 21 77 74 77 07 42 38 42 74 83 02 05
+46 19 77 66 24 18 05 32 02 84 31 99 92 58 96 72 91 36 62 99 55 29 53 42 12 37 26 58 89 50 66 19 82 75 12 48 24 87 91 85 02 07 03 76 86
+99 98 84 93 07 17 33 61 92 20 66 60 24 66 40 30 67 05 37 29 24 96 03 27 70 62 13 04 45 47 59 88 43 20 66 15 46 92 30 04 71 66 78 70 53 99
+67 60 38 06 88 04 17 72 10 99 71 07 42 25 54 05 26 64 91 50 45 71 06 30 67 48 69 82 08 56 80 67 18 46 66 63 01 20 08 80 47 07 91 16 03 79 87
+18 54 78 49 80 48 77 40 68 23 60 88 58 80 33 57 11 69 55 53 64 02 94 49 60 92 16 35 81 21 82 96 25 24 96 18 02 05 49 03 50 77 06 32 84 27 18 38
+68 01 50 04 03 21 42 94 53 24 89 05 92 26 52 36 68 11 85 01 04 42 02 45 15 06 50 04 53 73 25 74 81 88 98 21 67 84 79 97 99 20 95 04 40 46 02 58 87
+94 10 02 78 88 52 21 03 88 60 06 53 49 71 20 91 12 65 07 49 21 22 11 41 58 99 36 16 09 48 17 24 52 36 23 15 72 16 84 56 02 99 43 76 81 71 29 39 49 17
+64 39 59 84 86 16 17 66 03 09 43 06 64 18 63 29 68 06 23 07 87 14 26 35 17 12 98 41 53 64 78 18 98 27 28 84 80 67 75 62 10 11 76 90 54 10 05 54 41 39 66
+43 83 18 37 32 31 52 29 95 47 08 76 35 11 04 53 35 43 34 10 52 57 12 36 20 39 40 55 78 44 07 31 38 26 08 15 56 88 86 01 52 62 10 24 32 05 60 65 53 28 57 99
+03 50 03 52 07 73 49 92 66 80 01 46 08 67 25 36 73 93 07 42 25 53 13 96 76 83 87 90 54 89 78 22 78 91 73 51 69 09 79 94 83 53 09 40 69 62 10 79 49 47 03 81 30
+71 54 73 33 51 76 59 54 79 37 56 45 84 17 62 21 98 69 41 95 65 24 39 37 62 03 24 48 54 64 46 82 71 78 33 67 09 16 96 68 52 74 79 68 32 21 13 78 96 60 09 69 20 36
+73 26 21 44 46 38 17 83 65 98 07 23 52 46 61 97 33 13 60 31 70 15 36 77 31 58 56 93 75 68 21 36 69 53 90 75 25 82 39 50 65 94 29 30 11 33 11 13 96 02 56 47 07 49 02
+76 46 73 30 10 20 60 70 14 56 34 26 37 39 48 24 55 76 84 91 39 86 95 61 50 14 53 93 64 67 37 31 10 84 42 70 48 20 10 72 60 61 84 79 69 65 99 73 89 25 85 48 92 56 97 16
+03 14 80 27 22 30 44 27 67 75 79 32 51 54 81 29 65 14 19 04 13 82 04 91 43 40 12 52 29 99 07 76 60 25 01 07 61 71 37 92 40 47 99 66 57 01 43 44 22 40 53 53 09 69 26 81 07
+49 80 56 90 93 87 47 13 75 28 87 23 72 79 32 18 27 20 28 10 37 59 21 18 70 04 79 96 03 31 45 71 81 06 14 18 17 05 31 50 92 79 23 47 09 39 47 91 43 54 69 47 42 95 62 46 32 85
+37 18 62 85 87 28 64 05 77 51 47 26 30 65 05 70 65 75 59 80 42 52 25 20 44 10 92 17 71 95 52 14 77 13 24 55 11 65 26 91 01 30 63 15 49 48 41 17 67 47 03 68 20 90 98 32 04 40 68
+90 51 58 60 06 55 23 68 05 19 76 94 82 36 96 43 38 90 87 28 33 83 05 17 70 83 96 93 06 04 78 47 80 06 23 84 75 23 87 72 99 14 50 98 92 38 90 64 61 58 76 94 36 66 87 80 51 35 61 38
+57 95 64 06 53 36 82 51 40 33 47 14 07 98 78 65 39 58 53 06 50 53 04 69 40 68 36 69 75 78 75 60 03 32 39 24 74 47 26 90 13 40 44 71 90 76 51 24 36 50 25 45 70 80 61 80 61 43 90 64 11
+18 29 86 56 68 42 79 10 42 44 30 12 96 18 23 18 52 59 02 99 67 46 60 86 43 38 55 17 44 93 42 21 55 14 47 34 55 16 49 24 23 29 96 51 55 10 46 53 27 92 27 46 63 57 30 65 43 27 21 20 24 83
+81 72 93 19 69 52 48 01 13 83 92 69 20 48 69 59 20 62 05 42 28 89 90 99 32 72 84 17 08 87 36 03 60 31 36 36 81 26 97 36 48 54 56 56 27 16 91 08 23 11 87 99 33 47 02 14 44 73 70 99 43 35 33
+90 56 61 86 56 12 70 59 63 32 01 15 81 47 71 76 95 32 65 80 54 70 34 51 40 45 33 04 64 55 78 68 88 47 31 47 68 87 03 84 23 44 89 72 35 08 31 76 63 26 90 85 96 67 65 91 19 14 17 86 04 71 32 95
+37 13 04 22 64 37 37 28 56 62 86 33 07 37 10 44 52 82 52 06 19 52 57 75 90 26 91 24 06 21 14 67 76 30 46 14 35 89 89 41 03 64 56 97 87 63 22 34 03 79 17 45 11 53 25 56 96 61 23 18 63 31 37 37 47
+77 23 26 70 72 76 77 04 28 64 71 69 14 85 96 54 95 48 06 62 99 83 86 77 97 75 71 66 30 19 57 90 33 01 60 61 14 12 90 99 32 77 56 41 18 14 87 49 10 14 90 64 18 50 21 74 14 16 88 05 45 73 82 47 74 44
+22 97 41 13 34 31 54 61 56 94 03 24 59 27 98 77 04 09 37 40 12 26 87 09 71 70 07 18 64 57 80 21 12 71 83 94 60 39 73 79 73 19 97 32 64 29 41 07 48 84 85 67 12 74 95 20 24 52 41 67 56 61 29 93 35 72 69
+72 23 63 66 01 11 07 30 52 56 95 16 65 26 83 90 50 74 60 18 16 48 43 77 37 11 99 98 30 94 91 26 62 73 45 12 87 73 47 27 01 88 66 99 21 41 95 80 02 53 23 32 61 48 32 43 43 83 14 66 95 91 19 81 80 67 25 88
+08 62 32 18 92 14 83 71 37 96 11 83 39 99 05 16 23 27 10 67 02 25 44 11 55 31 46 64 41 56 44 74 26 81 51 31 45 85 87 09 81 95 22 28 76 69 46 48 64 87 67 76 27 89 31 11 74 16 62 03 60 94 42 47 09 34 94 93 72
+56 18 90 18 42 17 42 32 14 86 06 53 33 95 99 35 29 15 44 20 49 59 25 54 34 59 84 21 23 54 35 90 78 16 93 13 37 88 54 19 86 67 68 55 66 84 65 42 98 37 87 56 33 28 58 38 28 38 66 27 52 21 81 15 08 22 97 32 85 27
+91 53 40 28 13 34 91 25 01 63 50 37 22 49 71 58 32 28 30 18 68 94 23 83 63 62 94 76 80 41 90 22 82 52 29 12 18 56 10 08 35 14 37 57 23 65 67 40 72 39 93 39 70 89 40 34 07 46 94 22 20 05 53 64 56 30 05 56 61 88 27
+23 95 11 12 37 69 68 24 66 10 87 70 43 50 75 07 62 41 83 58 95 93 89 79 45 39 02 22 05 22 95 43 62 11 68 29 17 40 26 44 25 71 87 16 70 85 19 25 59 94 90 41 41 80 61 70 55 60 84 33 95 76 42 63 15 09 03 40 38 12 03 32
+09 84 56 80 61 55 85 97 16 94 82 94 98 57 84 30 84 48 93 90 71 05 95 90 73 17 30 98 40 64 65 89 07 79 09 19 56 36 42 30 23 69 73 72 07 05 27 61 24 31 43 48 71 84 21 28 26 65 65 59 65 74 77 20 10 81 61 84 95 08 52 23 70
+47 81 28 09 98 51 67 64 35 51 59 36 92 82 77 65 80 24 72 53 22 07 27 10 21 28 30 22 48 82 80 48 56 20 14 43 18 25 50 95 90 31 77 08 09 48 44 80 90 22 93 45 82 17 13 96 25 26 08 73 34 99 06 49 24 06 83 51 40 14 15 10 25 01
+54 25 10 81 30 64 24 74 75 80 36 75 82 60 22 69 72 91 45 67 03 62 79 54 89 74 44 83 64 96 66 73 44 30 74 50 37 05 09 97 70 01 60 46 37 91 39 75 75 18 58 52 72 78 51 81 86 52 08 97 01 46 43 66 98 62 81 18 70 93 73 08 32 46 34
+96 80 82 07 59 71 92 53 19 20 88 66 03 26 26 10 24 27 50 82 94 73 63 08 51 33 22 45 19 13 58 33 90 15 22 50 36 13 55 06 35 47 82 52 33 61 36 27 28 46 98 14 73 20 73 32 16 26 80 53 47 66 76 38 94 45 02 01 22 52 47 96 64 58 52 39
+88 46 23 39 74 63 81 64 20 90 33 33 76 55 58 26 10 46 42 26 74 74 12 83 32 43 09 02 73 55 86 54 85 34 28 23 29 79 91 62 47 41 82 87 99 22 48 90 20 05 96 75 95 04 43 28 81 39 81 01 28 42 78 25 39 77 90 57 58 98 17 36 73 22 63 74 51
+29 39 74 94 95 78 64 24 38 86 63 87 93 06 70 92 22 16 80 64 29 52 20 27 23 50 14 13 87 15 72 96 81 22 08 49 72 30 70 24 79 31 16 64 59 21 89 34 96 91 48 76 43 53 88 01 57 80 23 81 90 79 58 01 80 87 17 99 86 90 72 63 32 69 14 28 88 69
+37 17 71 95 56 93 71 35 43 45 04 98 92 94 84 96 11 30 31 27 31 60 92 03 48 05 98 91 86 94 35 90 90 08 48 19 33 28 68 37 59 26 65 96 50 68 22 07 09 49 34 31 77 49 43 06 75 17 81 87 61 79 52 26 27 72 29 50 07 98 86 01 17 10 46 64 24 18 56
+51 30 25 94 88 85 79 91 40 33 63 84 49 67 98 92 15 26 75 19 82 05 18 78 65 93 61 48 91 43 59 41 70 51 22 15 92 81 67 91 46 98 11 11 65 31 66 10 98 65 83 21 05 56 05 98 73 67 46 74 69 34 08 30 05 52 07 98 32 95 30 94 65 50 24 63 28 81 99 57
+19 23 61 36 09 89 71 98 65 17 30 29 89 26 79 74 94 11 44 48 97 54 81 55 39 66 69 45 28 47 13 86 15 76 74 70 84 32 36 33 79 20 78 14 41 47 89 28 81 05 99 66 81 86 38 26 06 25 13 60 54 55 23 53 27 05 89 25 23 11 13 54 59 54 56 34 16 24 53 44 06
+13 40 57 72 21 15 60 08 04 19 11 98 34 45 09 97 86 71 03 15 56 19 15 44 97 31 90 04 87 87 76 08 12 30 24 62 84 28 12 85 82 53 99 52 13 94 06 65 97 86 09 50 94 68 69 74 30 67 87 94 63 07 78 27 80 36 69 41 06 92 32 78 37 82 30 05 18 87 99 72 19 99
+44 20 55 77 69 91 27 31 28 81 80 27 02 07 97 23 95 98 12 25 75 29 47 71 07 47 78 39 41 59 27 76 13 15 66 61 68 35 69 86 16 53 67 63 99 85 41 56 08 28 33 40 94 76 90 85 31 70 24 65 84 65 99 82 19 25 54 37 21 46 33 02 52 99 51 33 26 04 87 02 08 18 96
+54 42 61 45 91 06 64 79 80 82 32 16 83 63 42 49 19 78 65 97 40 42 14 61 49 34 04 18 25 98 59 30 82 72 26 88 54 36 21 75 03 88 99 53 46 51 55 78 22 94 34 40 68 87 84 25 30 76 25 08 92 84 42 61 40 38 09 99 40 23 29 39 46 55 10 90 35 84 56 70 63 23 91 39
+52 92 03 71 89 07 09 37 68 66 58 20 44 92 51 56 13 71 79 99 26 37 02 06 16 67 36 52 58 16 79 73 56 60 59 27 44 77 94 82 20 50 98 33 09 87 94 37 40 83 64 83 58 85 17 76 53 02 83 52 22 27 39 20 48 92 45 21 09 42 24 23 12 37 52 28 50 78 79 20 86 62 73 20 59
+54 96 80 15 91 90 99 70 10 09 58 90 93 50 81 99 54 38 36 10 30 11 35 84 16 45 82 18 11 97 36 43 96 79 97 65 40 48 23 19 17 31 64 52 65 65 37 32 65 76 99 79 34 65 79 27 55 33 03 01 33 27 61 28 66 08 04 70 49 46 48 83 01 45 19 96 13 81 14 21 31 79 93 85 50 05
+92 92 48 84 59 98 31 53 23 27 15 22 79 95 24 76 05 79 16 93 97 89 38 89 42 83 02 88 94 95 82 21 01 97 48 39 31 78 09 65 50 56 97 61 01 07 65 27 21 23 14 15 80 97 44 78 49 35 33 45 81 74 34 05 31 57 09 38 94 07 69 54 69 32 65 68 46 68 78 90 24 28 49 51 45 86 35
+41 63 89 76 87 31 86 09 46 14 87 82 22 29 47 16 13 10 70 72 82 95 48 64 58 43 13 75 42 69 21 12 67 13 64 85 58 23 98 09 37 76 05 22 31 12 66 50 29 99 86 72 45 25 10 28 19 06 90 43 29 31 67 79 46 25 74 14 97 35 76 37 65 46 23 82 06 22 30 76 93 66 94 17 96 13 20 72
+63 40 78 08 52 09 90 41 70 28 36 14 46 44 85 96 24 52 58 15 87 37 05 98 99 39 13 61 76 38 44 99 83 74 90 22 53 80 56 98 30 51 63 39 44 30 91 91 04 22 27 73 17 35 53 18 35 45 54 56 27 78 48 13 69 36 44 38 71 25 30 56 15 22 73 43 32 69 59 25 93 83 45 11 34 94 44 39 92
+12 36 56 88 13 96 16 12 55 54 11 47 19 78 17 17 68 81 77 51 42 55 99 85 66 27 81 79 93 42 65 61 69 74 14 01 18 56 12 01 58 37 91 22 42 66 83 25 19 04 96 41 25 45 18 69 96 88 36 93 10 12 98 32 44 83 83 04 72 91 04 27 73 07 34 37 71 60 59 31 01 54 54 44 96 93 83 36 04 45
+30 18 22 20 42 96 65 79 17 41 55 69 94 81 29 80 91 31 85 25 47 26 43 49 02 99 34 67 99 76 16 14 15 93 08 32 99 44 61 77 67 50 43 55 87 55 53 72 17 46 62 25 50 99 73 05 93 48 17 31 70 80 59 09 44 59 45 13 74 66 58 94 87 73 16 14 85 38 74 99 64 23 79 28 71 42 20 37 82 31 23
+51 96 39 65 46 71 56 13 29 68 53 86 45 33 51 49 12 91 21 21 76 85 02 17 98 15 46 12 60 21 88 30 92 83 44 59 42 50 27 88 46 86 94 73 45 54 23 24 14 10 94 21 20 34 23 51 04 83 99 75 90 63 60 16 22 33 83 70 11 32 10 50 29 30 83 46 11 05 31 17 86 42 49 01 44 63 28 60 07 78 95 40
+44 61 89 59 04 49 51 27 69 71 46 76 44 04 09 34 56 39 15 06 94 91 75 90 65 27 56 23 74 06 23 33 36 69 14 39 05 34 35 57 33 22 76 46 56 10 61 65 98 09 16 69 04 62 65 18 99 76 49 18 72 66 73 83 82 40 76 31 89 91 27 88 17 35 41 35 32 51 32 67 52 68 74 85 80 57 07 11 62 66 47 22 67
+65 37 19 97 26 17 16 24 24 17 50 37 64 82 24 36 32 11 68 34 69 31 32 89 79 93 96 68 49 90 14 23 04 04 67 99 81 74 70 74 36 96 68 09 64 39 88 35 54 89 96 58 66 27 88 97 32 14 06 35 78 20 71 06 85 66 57 02 58 91 72 05 29 56 73 48 86 52 09 93 22 57 79 42 12 01 31 68 17 59 63 76 07 77
+73 81 14 13 17 20 11 09 01 83 08 85 91 70 84 63 62 77 37 07 47 01 59 95 39 69 39 21 99 09 87 02 97 16 92 36 74 71 90 66 33 73 73 75 52 91 11 12 26 53 05 26 26 48 61 50 90 65 01 87 42 47 74 35 22 73 24 26 56 70 52 05 48 41 31 18 83 27 21 39 80 85 26 08 44 02 71 07 63 22 05 52 19 08 20
+17 25 21 11 72 93 33 49 64 23 53 82 03 13 91 65 85 02 40 05 42 31 77 42 05 36 06 54 04 58 07 76 87 83 25 57 66 12 74 33 85 37 74 32 20 69 03 97 91 68 82 44 19 14 89 28 85 85 80 53 34 87 58 98 88 78 48 65 98 40 11 57 10 67 70 81 60 79 74 72 97 59 79 47 30 20 54 80 89 91 14 05 33 36 79 39
+60 85 59 39 60 07 57 76 77 92 06 35 15 72 23 41 45 52 95 18 64 79 86 53 56 31 69 11 91 31 84 50 44 82 22 81 41 40 30 42 30 91 48 94 74 76 64 58 74 25 96 57 14 19 03 99 28 83 15 75 99 01 89 85 79 50 03 95 32 67 44 08 07 41 62 64 29 20 14 76 26 55 48 71 69 66 19 72 44 25 14 01 48 74 12 98 07
+64 66 84 24 18 16 27 48 20 14 47 69 30 86 48 40 23 16 61 21 51 50 26 47 35 33 91 28 78 64 43 68 04 79 51 08 19 60 52 95 06 68 46 86 35 97 27 58 04 65 30 58 99 12 12 75 91 39 50 31 42 64 70 04 46 07 98 73 98 93 37 89 77 91 64 71 64 65 66 21 78 62 81 74 42 20 83 70 73 95 78 45 92 27 34 53 71 15
+30 11 85 31 34 71 13 48 05 14 44 03 19 67 23 73 19 57 06 90 94 72 57 69 81 62 59 68 88 57 55 69 49 13 07 87 97 80 89 05 71 05 05 26 38 40 16 62 45 99 18 38 98 24 21 26 62 74 69 04 85 57 77 35 58 67 91 79 79 57 86 28 66 34 72 51 76 78 36 95 63 90 08 78 47 63 45 31 22 70 52 48 79 94 15 77 61 67 68
+23 33 44 81 80 92 93 75 94 88 23 61 39 76 22 03 28 94 32 06 49 65 41 34 18 23 08 47 62 60 03 63 33 13 80 52 31 54 73 43 70 26 16 69 57 87 83 31 03 93 70 81 47 95 77 44 29 68 39 51 56 59 63 07 25 70 07 77 43 53 64 03 94 42 95 39 18 01 66 21 16 97 20 50 90 16 70 10 95 69 29 06 25 61 41 26 15 59 63 35

extra/project-euler/134/134.factor

@@ -0,0 +1,42 @@
+! Copyright (c) 2007 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel lazy-lists math.algebra math math.functions math.primes
+       math.ranges sequences ;
+IN: project-euler.134
+
+! http://projecteuler.net/index.php?section=problems&id=134
+
+! DESCRIPTION
+! -----------
+
+! Consider the consecutive primes p1 = 19 and p2 = 23. It can be
+! verified that 1219 is the smallest number such that the last digits
+! are formed by p1 whilst also being divisible by p2.
+
+! In fact, with the exception of p1 = 3 and p2 = 5, for every pair of
+! consecutive primes, p2 p1, there exist values of n for which the last
+! digits are formed by p1 and n is divisible by p2. Let S be the
+! smallest of these values of n.
+
+! Find S for every pair of consecutive primes with 5 p1 1000000.
+
+! SOLUTION
+! --------
+
+! Compute the smallest power of 10 greater than m or equal to it
+: next-power-of-10 ( m -- n )
+  10 swap log 10 log / ceiling >integer ^ ; foldable
+
+! Compute S for a given pair (p1, p2) -- that is the smallest positive
+! number such that X = p1 [npt] and X = 0 [p2] (npt being the smallest
+! power of 10 above p1)
+: s ( p1 p2 -- s )
+  over 0 2array rot next-power-of-10 rot 2array chinese-remainder ;
+
+: euler134 ( -- answer )
+  0 5 lprimes-from uncons [ 1000000 > ] luntil [ [ s + ] keep ] leach drop ;
+
+! [ euler134 ] 10 ave-time
+! 3797 ms run / 30 ms GC ave time - 10 trials
+
+MAIN: euler134

extra/project-euler/169/169.factor

@@ -0,0 +1,41 @@
+! Copyright (c) 2007 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+IN: project-euler.169
+USING: combinators kernel math math.functions memoize ;
+
+! http://projecteuler.net/index.php?section=problems&id=169
+
+! DESCRIPTION
+! -----------
+
+! Define f(0)=1 and f(n) to be the number of different ways n can be
+! expressed as a sum of integer powers of 2 using each power no more
+! than twice.
+
+! For example, f(10)=5 since there are five different ways to express 10:
+
+! 1 + 1 + 8
+! 1 + 1 + 4 + 4
+! 1 + 1 + 2 + 2 + 4
+! 2 + 4 + 4
+! 2 + 8
+
+! What is f(1025)?
+
+! SOLUTION
+! --------
+
+MEMO: fn ( n -- x )
+  {
+    { [ dup 2 < ]  [ drop 1 ] }
+    { [ dup odd? ] [ 2/ fn ] }
+    { [ t ]        [ 2/ [ fn ] keep 1- fn + ] }
+  } cond ;
+
+: euler169 ( -- result )
+  10 25 ^ fn ;
+
+! [ euler169 ] 100 ave-time
+! 0 ms run / 0 ms GC ave time - 100 trials
+
+MAIN: euler169

extra/project-euler/173/173.factor

@@ -0,0 +1,34 @@
+! Copyright (c) 2007 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions math.ranges sequences ;
+IN: project-euler.173
+
+! http://projecteuler.net/index.php?section=problems&id=173
+
+! DESCRIPTION
+! -----------
+
+! We shall define a square lamina to be a square outline with a square
+! "hole" so that the shape possesses vertical and horizontal
+! symmetry. For example, using exactly thirty-two square tiles we can
+! form two different square laminae: [see URL for figure]
+
+! With one-hundred tiles, and not necessarily using all of the tiles at
+! one time, it is possible to form forty-one different square laminae.
+
+! Using up to one million tiles how many different square laminae can be
+! formed?
+
+! SOLUTION
+! --------
+
+: laminaes ( upper -- n )
+  4 / dup sqrt [1,b] 0 rot [ over /mod drop - - ] curry reduce ;
+
+: euler173 ( -- answer )
+  1000000 laminaes ;
+
+! [ euler173 ] 100 ave-time
+! 0 ms run / 0 ms GC ave time - 100 trials
+
+MAIN: euler173

extra/project-euler/175/175.factor

@@ -0,0 +1,54 @@
+! Copyright (c) 2007 Samuel Tardieu.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators kernel math math.parser math.ranges sequences vectors ;
+IN: project-euler.175
+
+! http://projecteuler.net/index.php?section=problems&id=175
+
+! DESCRIPTION
+! -----------
+
+! Define f(0)=1 and f(n) to be the number of ways to write n as a sum of
+! powers of 2 where no power occurs more than twice.
+
+! For example, f(10)=5 since there are five different ways to express
+! 10: 10 = 8+2 = 8+1+1 = 4+4+2 = 4+2+2+1+1 = 4+4+1+1
+
+! It can be shown that for every fraction p/q (p0, q0) there exists at
+! least one integer n such that f(n)/f(n-1)=p/q.
+
+! For instance, the smallest n for which f(n)/f(n-1)=13/17 is 241.  The
+! binary expansion of 241 is 11110001.  Reading this binary number from
+! the most significant bit to the least significant bit there are 4
+! one's, 3 zeroes and 1 one. We shall call the string 4,3,1 the
+! Shortened Binary Expansion of 241.
+
+! Find the Shortened Binary Expansion of the smallest n for which
+! f(n)/f(n-1)=123456789/987654321.
+
+! Give your answer as comma separated integers, without any whitespaces.
+
+! SOLUTION
+! --------
+
+: add-bits ( vec n b -- )
+  over zero? [
+    3drop
+  ] [
+    pick length 1 bitand = [ over pop + ] when swap push
+  ] if ;
+
+: compute ( vec ratio -- )
+  {
+    { [ dup integer? ] [ 1- 0 add-bits ] }
+    { [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] }
+    { [ t ] [ [ 1 mod compute ] 2keep >integer 0 add-bits ] }
+  } cond ;
+
+: euler175 ( -- result )
+  V{ 1 } clone dup 123456789/987654321 compute [ number>string ] map "," join ;
+
+! [ euler175 ] 100 ave-time
+! 0 ms run / 0 ms GC ave time - 100 trials
+
+MAIN: euler175

extra/project-euler/ave-time/ave-time.factor

@@ -1,14 +1,11 @@
 ! Copyright (c) 2007 Aaron Schaefer
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays effects inference io kernel math math.functions math.parser
+USING: arrays combinators io kernel math math.functions math.parser
     math.statistics namespaces sequences tools.time ;
 IN: project-euler.ave-time
 
 <PRIVATE
 
-: clean-stack ( quot -- )
-    infer dup effect-out swap effect-in - [ drop ] times ;
-
 : ave-benchmarks ( seq -- pair )
     flip [ mean round ] map ;
 
@@ -16,8 +13,9 @@ PRIVATE>
 
 : collect-benchmarks ( quot n -- seq )
   [
-        1- [ [ benchmark ] keep -rot 2array , [ clean-stack ] keep ] times
+    >r >r datastack r> [ benchmark 2array , ] curry tuck
-    ] curry { } make >r benchmark 2array r> swap add ; inline
+    [ with-datastack drop ] 2curry r> swap times call
+  ] { } make ;
 
 : ave-time ( quot n -- )
     [ collect-benchmarks ] keep swap ave-benchmarks [

extra/project-euler/common/common.factor

@@ -1,9 +1,12 @@
 USING: arrays kernel hashtables math math.functions math.miller-rabin
-    math.ranges namespaces sequences combinators.lib ;
+    math.parser math.ranges namespaces sequences combinators.lib ;
 IN: project-euler.common
 
 ! A collection of words used by more than one Project Euler solution.
 
+: nth-pair ( n seq -- nth next )
+    over 1+ over nth >r nth r> ;
+
 <PRIVATE
 
 : count-shifts ( seq width -- n )
@@ -12,6 +15,9 @@ IN: project-euler.common
 : shift-3rd ( seq obj obj -- seq obj obj )
     rot 1 tail -rot ;
 
+: max-children ( seq -- seq )
+    [ dup length 1- [ over nth-pair max , ] each ] { } make nip ;
+
 : >multiplicity ( seq -- seq )
     dup prune [
         [ 2dup [ = ] curry count 2array , ] each
@@ -20,23 +26,29 @@ IN: project-euler.common
 : reduce-2s ( n -- r s )
     dup even? [ factor-2s >r 1+ r> ] [ 1 swap ] if ;
 
-: tau-limit ( n -- n )
-    sqrt floor >fixnum ;
-
 PRIVATE>
 
-
-: divisor? ( n m -- ? )
-    mod zero? ;
-
-: perfect-square? ( n -- ? )
-    dup sqrt mod zero? ;
-
 : collect-consecutive ( seq width -- seq )
     [
         2dup count-shifts [ 2dup head shift-3rd , ] times
     ] { } make 2nip ;
 
+: divisor? ( n m -- ? )
+    mod zero? ;
+
+: max-path ( triangle -- n )
+    dup length 1 > [
+        2 cut* first2 max-children [ + ] 2map add max-path
+    ] [
+        first first
+    ] if ;
+
+: number>digits ( n -- seq )
+    number>string string>digits ;
+
+: perfect-square? ( n -- ? )
+    dup sqrt divisor? ;
+
 : prime-factorization ( n -- seq )
     [
         2 [ over 1 > ]
@@ -50,12 +62,34 @@ PRIVATE>
 : prime-factors ( n -- seq )
     prime-factorization prune >array ;
 
+: (sum-divisors) ( n -- sum )
+    dup sqrt >fixnum [1,b] [
+        [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each
+        dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
+    ] { } make sum ;
+
+: sum-divisors ( n -- sum )
+    dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
+
+: sum-proper-divisors ( n -- sum )
+    dup sum-divisors swap - ;
+
+: abundant? ( n -- ? )
+    dup sum-proper-divisors < ;
+
+: deficient? ( n -- ? )
+    dup sum-proper-divisors > ;
+
+: perfect? ( n -- ? )
+    dup sum-proper-divisors = ;
+
 ! The divisor function, counts the number of divisors
 : tau ( n -- n )
     prime-factorization* flip second 1 [ 1+ * ] reduce ;
 
 ! Optimized brute-force, is often faster than prime factorization
 : tau* ( n -- n )
-    reduce-2s [ perfect-square? -1 0 ? ] keep dup tau-limit [1,b] [
+    reduce-2s [ perfect-square? -1 0 ? ] keep
+    dup sqrt >fixnum [1,b] [
         dupd divisor? [ >r 2 + r> ] when
     ] each drop * ;

extra/project-euler/project-euler.factor

@@ -1,11 +1,13 @@
 ! Copyright (c) 2007 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.files kernel math.parser namespaces sequences strings
+USING: definitions io io.files kernel math.parser sequences vocabs
-    vocabs vocabs.loader system project-euler.ave-time
+    vocabs.loader project-euler.ave-time project-euler.common math
     project-euler.001 project-euler.002 project-euler.003 project-euler.004
     project-euler.005 project-euler.006 project-euler.007 project-euler.008
     project-euler.009 project-euler.010 project-euler.011 project-euler.012
-    project-euler.013 project-euler.014 project-euler.015 project-euler.016 ;
+    project-euler.013 project-euler.014 project-euler.015 project-euler.016
+    project-euler.017 project-euler.018 project-euler.019 project-euler.020
+    project-euler.021 project-euler.022 project-euler.067 project-euler.134 ;
 IN: project-euler
 
 <PRIVATE
@@ -15,27 +17,21 @@ IN: project-euler
     print readln string>number ;
 
 : number>euler ( n -- str )
-    number>string string>digits 3 0 pad-left [ number>string ] map concat ;
+    number>string 3 CHAR: 0 pad-left ;
 
-: solution-path ( n -- str )
+: solution-path ( n -- str/f )
-    number>euler dup [
+    number>euler "project-euler." swap append
-        "project-euler" vocab-root ?resource-path %
+    vocab where dup [ first ?resource-path ] when ;
-        os "windows" = [
-            "\\project-euler\\" % % "\\" % % ".factor" %
-        ] [
-            "/project-euler/" % % "/" % % ".factor" %
-        ] if
-    ] "" make ;
 
 PRIVATE>
 
 : problem-solved? ( n -- ? )
-    solution-path exists? ;
+    solution-path ;
 
 : run-project-euler ( -- )
     problem-prompt dup problem-solved? [
         dup number>euler "project-euler." swap append run
-        "Answer: " swap number>string append print
+        "Answer: " swap dup number? [ number>string ] when append print
         "Source: " swap solution-path append print
     ] [
         drop "That problem has not been solved yet..." print

extra/rss/rss-tests.factor

@@ -10,7 +10,7 @@ USING: rss io kernel io.files tools.test ;
     f
     "Meerkat"
     "http://meerkat.oreillynet.com"
-    V{
+    {
         T{
             entry
             f
@@ -26,7 +26,7 @@ USING: rss io kernel io.files tools.test ;
     f
     "dive into mark"
     "http://example.org/"
-    V{
+    {
         T{
             entry
             f

extra/rss/rss.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: rss
-USING: xml.utilities kernel assocs
+USING: xml.utilities kernel assocs xml.generator
     strings sequences xml.data xml.writer
     io.streams.string combinators xml xml.entities io.files io
     http.client namespaces xml.generator hashtables ;

extra/sequences/deep/authors.txt

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

extra/sequences/deep/deep-docs.factor

@@ -0,0 +1,29 @@
+USING: help.syntax help.markup sequences.deep ;
+
+HELP: deep-each
+{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ) " } }
+{ $description "Execute a quotation on each nested element of an object and its children, in preorder." } ;
+
+HELP: deep-map
+{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- newelt )" } { "newobj" "the mapped object" } }
+{ $description "Execute a quotation on each nested element of an object and its children, in preorder. That is, the result of the execution of the quotation on the outer is used to map the inner elements." } ;
+
+HELP: deep-subset
+{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "seq" "a sequence" } }
+{ $description "Creates a sequence of sub-nodes in the object which satisfy the given quotation, in preorder. This includes the object itself, if it passes the quotation." } ;
+
+HELP: deep-find
+{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "elt" "an element" } }
+{ $description "Gets the first sub-node of the object, in preorder, which satisfies the quotation. If nothing satisifies it, it returns " { $link f } "." } ;
+
+HELP: deep-contains?
+{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- ? )" } { "?" "a boolean" } }
+{ $description "Tests whether the given object or any subnode satisfies the given quotation." } ;
+
+HELP: flatten
+{ $values { "obj" "an object" } { "seq" "a sequence" } }
+{ $description "Creates a sequence of all of the leaf nodes (non-sequence nodes, but including strings and numbers) in the object." } ;
+
+HELP: deep-change-each
+{ $values { "obj" "an object" } { "quot" "a quotation ( elt -- newelt )" } }
+{ $description "Modifies each sub-node of an object in place, in preorder." } ;

extra/sequences/deep/deep-tests.factor

@@ -0,0 +1,25 @@
+USING: sequences.deep kernel tools.test strings math arrays
+namespaces sequences ;
+
+[ [ "hello" 3 4 swap ] ] [ [ { "hello" V{ 3 4 } } swap ] flatten ] unit-test
+
+[ "foo" t ] [ { { "foo" } "bar" } [ string? ] deep-find* ] unit-test
+
+[ f f ] [ { { "foo" } "bar" } [ number? ] deep-find* ] unit-test
+
+[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find* ] unit-test
+
+: change-something ( seq -- newseq )
+    dup array? [ "hi" add ] [ "hello" append ] if ;
+
+[ { { "heyhello" "hihello" } "hihello" } ]
+[ "hey" 1array 1array [ change-something ] deep-map ] unit-test
+
+[ { { "heyhello" "hihello" } } ]
+[ "hey" 1array 1array [ [ change-something ] deep-change-each ] keep ] unit-test
+
+[ t ] [ "foo" [ string? ] deep-contains?  ] unit-test
+
+[ "foo" ] [ "foo" [ string? ] deep-find ] unit-test
+
+[ { { 1 2 } 1 2 } ] [ [ { 1 2 } [ , ] deep-each ] { } make ] unit-test

extra/sequences/deep/deep.factor

@@ -0,0 +1,43 @@
+! Copyright (C) 2007 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel strings math ;
+IN: sequences.deep
+
+! All traversal goes in postorder
+
+: branch? ( object -- ? )
+    dup sequence? [
+        dup string? swap number? or not
+    ] [ drop f ] if ;
+
+: deep-each ( obj quot -- )
+    [ call ] 2keep over branch?
+    [ [ deep-each ] curry each ] [ 2drop ] if ; inline
+
+: deep-map ( obj quot -- newobj )
+    [ call ] keep over branch?
+    [ [ deep-map ] curry map ] [ drop ] if ; inline
+
+: deep-subset ( obj quot -- seq )
+    over >r
+    pusher >r deep-each r>
+    r> dup branch? [ like ] [ drop ] if ; inline
+
+: deep-find* ( obj quot -- elt ? )
+    [ call ] 2keep rot [ drop t ] [
+        over branch? [
+            f -rot [ >r nip r> deep-find* ] curry find drop >boolean
+        ] [ 2drop f f ] if  
+    ] if ; inline
+
+: deep-find ( obj quot -- elt ) deep-find* drop ; inline
+
+: deep-contains? ( obj quot -- ? ) deep-find* nip ; inline
+
+: deep-change-each ( obj quot -- )
+    over branch? [ [
+        [ call ] keep over >r deep-change-each r>
+    ] curry change-each ] [ 2drop ] if ; inline
+
+: flatten ( obj -- seq )
+    [ branch? not ] deep-subset ;

extra/sequences/deep/summary.txt

@@ -0,0 +1 @@
+Sequence/tree combinators like deep-map, deep-each, etc

extra/sequences/lib/lib-tests.factor

@@ -46,3 +46,10 @@ math.functions tools.test strings ;
 [ { { 0 0 } { 1 0 } { 0 1 } { 1 1 } } ] [ 2 2 exact-strings ] unit-test
 [ t ] [ "ab" 4 strings [ >string ] map "abab" swap member? ] unit-test
 [ { { } { 1 } { 2 } { 1 2 } } ] [ { 1 2 } power-set ] unit-test
+
+[ f ] [ { } ?first ] unit-test
+[ f ] [ { } ?fourth ] unit-test
+[ 1 ] [ { 1 2 3 } ?first ] unit-test
+[ 2 ] [ { 1 2 3 } ?second ] unit-test
+[ 3 ] [ { 1 2 3 } ?third ] unit-test
+[ f ] [ { 1 2 3 } ?fourth ] unit-test

extra/sequences/lib/lib.factor

@@ -64,6 +64,10 @@ IN: sequences.lib
 : delete-random ( seq -- value )
     [ length random ] keep [ nth ] 2keep delete-nth ;
 
+: split-around ( seq quot -- before elem after )
+    dupd find over [ "Element not found" throw ] unless
+    >r cut-slice 1 tail r> swap ; inline
+
 : (map-until) ( quot pred -- quot )
     [ dup ] swap 3compose
     [ [ drop t ] [ , f ] if ] compose [ find 2drop ] curry ;
@@ -131,3 +135,8 @@ PRIVATE>
 : human-sort ( seq -- newseq )
     [ dup [ digit? ] [ string>number ] cut-all ] { } map>assoc
     sort-values keys ;
+
+: ?first ( seq -- first/f ) 0 swap ?nth ; inline
+: ?second ( seq -- second/f ) 1 swap ?nth ; inline
+: ?third ( seq -- third/f ) 2 swap ?nth ; inline
+: ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline

extra/shufflers/shufflers-tests.factor

@@ -1,7 +1,5 @@
 USING: shufflers tools.test ;
 
-[ { 1 1 0 0 1 0 } ] [ BIN: 010011 2 6 translate ] unit-test
-
 SHUFFLE: abcd 4
 [ ] [ 1 2 3 4 abcd- ] unit-test
 [ 1 2 1 2 ] [ 1 2 3 abc-abab ] unit-test

extra/trees/authors.txt

@@ -1 +1,2 @@
 Alex Chapman
+Daniel Ehrenberg

extra/trees/avl/authors.txt

@@ -0,0 +1,2 @@
+Alex Chapman
+Daniel Ehrenberg

extra/trees/avl/avl-docs.factor

@@ -0,0 +1,27 @@
+USING: help.syntax help.markup trees.avl assocs ;
+
+HELP: AVL{
+{ $syntax "AVL{ { key value }... }" }
+{ $values { "key" "a key" } { "value" "a value" } }
+{ $description "Literal syntax for an AVL tree." } ;
+
+HELP: <avl>
+{ $values { "tree" avl } }
+{ $description "Creates an empty AVL tree" } ;
+
+HELP: >avl
+{ $values { "assoc" assoc } { "avl" avl } }
+{ $description "Converts any " { $link assoc } " into an AVL tree." } ;
+
+HELP: avl
+{ $class-description "This is the class for AVL trees. These conform to the assoc protocol and have efficient (logarithmic time) storage and retrieval operations." } ;
+
+ARTICLE: { "avl" "intro" } "AVL trees"
+"This is a library for AVL trees, with logarithmic time storage and retrieval operations. These trees conform to the assoc protocol."
+{ $subsection avl }
+{ $subsection <avl> }
+{ $subsection >avl }
+{ $subsection POSTPONE: AVL{ } ;
+
+IN: trees.avl
+ABOUT: { "avl" "intro" }

extra/trees/avl/avl-tests.factor

@@ -1,10 +1,34 @@
-USING: kernel tools.test trees trees.avl math random sequences ;
+USING: kernel tools.test trees trees.avl math random sequences assocs ;
 IN: temporary
 
-[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } [ single-rotate ] go-left [ node-left dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test
+[ "key1" 0 "key2" 0 ] [
-[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } [ select-rotate ] go-left [ node-left dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test
+    T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 }
-[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 } [ single-rotate ] go-right [ node-right dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test
+    [ single-rotate ] go-left
-[ "key1" 0 "key2" 0 ] [ T{ avl-node T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 } [ select-rotate ] go-right [ node-right dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test
+    [ node-left dup node-key swap avl-node-balance ] keep
+    dup node-key swap avl-node-balance
+] unit-test
+
+[ "key1" 0 "key2" 0 ] [
+    T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 }
+    [ select-rotate ] go-left
+    [ node-left dup node-key swap avl-node-balance ] keep
+    dup node-key swap avl-node-balance
+] unit-test
+
+[ "key1" 0 "key2" 0 ] [
+    T{ avl-node T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 }
+    [ single-rotate ] go-right
+    [ node-right dup node-key swap avl-node-balance ] keep
+    dup node-key swap avl-node-balance
+] unit-test
+
+[ "key1" 0 "key2" 0 ] [
+    T{ avl-node T{ node f "key1" f T{ avl-node T{ node f "key2" } -1 } } -2 }
+    [ select-rotate ] go-right
+    [ node-right dup node-key swap avl-node-balance ] keep
+    dup node-key swap avl-node-balance
+] unit-test
+
 [ "key1" -1 "key2" 0 "key3" 0 ]
 [ T{ avl-node T{ node f "key1" f f
         T{ avl-node T{ node f "key2" f
@@ -61,77 +85,38 @@ IN: temporary
     [ node-left dup node-key swap avl-node-balance ] keep
     dup node-key swap avl-node-balance ] unit-test
 
-! random testing uncovered this little bugger
+[ "eight" ] [
-[ t t ] [ f "d" T{ avl-node
+    <avl> "seven" 7 pick set-at
-              T{ node f "e" f
+    "eight" 8 pick set-at "nine" 9 pick set-at
-                  T{ avl-node 
+    tree-root node-value
-                      T{ node f "b" f
+] unit-test
-                          T{ avl-node T{ node f "a" } 0 }
-                          T{ avl-node T{ node f "c" f } 0 }
-                          0 }
-                      0 }
-                  T{ avl-node T{ node f "f" } 0 } }
-              -1 } node-set dup valid-avl-node? nip swap valid-node? ] unit-test
 
-[ "eight" ] [ <avl-tree> "seven" 7 pick tree-insert "eight" 8 pick tree-insert "nine" 9 pick tree-insert tree-root node-value ] unit-test
+[ "another eight" ] [ ! ERROR!
-[ "another eight" ] [ <avl-tree> "seven" 7 pick tree-set "eight" 8 pick tree-set "another eight" 8 pick tree-set 8 swap tree-get ] unit-test
+    <avl> "seven" 7 pick set-at
-! [ <avl-tree> "seven" 7 pick tree-insert 
+    "another eight" 8 pick set-at 8 swap at
-[ t t ] [ <avl-tree> 3 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
+] unit-test
-[ t t ] [ <avl-tree> 9 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test ! fails when tree growth isn't terminated after a rebalance
-[ t t ] [ <avl-tree> 10 increasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
 
-[ t t ] [ <avl-tree> 3 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-[ t t ] [ <avl-tree> 4 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-[ t t ] [ <avl-tree> 5 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-[ t t ] [ <avl-tree> 10 decreasing-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-
-[ t t ] [ <avl-tree> 5 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-[ t t ] [ <avl-tree> 19 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-[ t t ] [ <avl-tree> 30 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-[ t t ] [ <avl-tree> 82 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-[ t t ] [ <avl-tree> 100 random-tree dup valid-avl-tree? swap valid-tree? ] unit-test
-
-! borrowed from tests/bst.factor
 : test-tree ( -- tree )
-    <avl-tree>
+    AVL{
-    "seven"          7 pick tree-insert
+        { 7 "seven" }
-    "nine"           9 pick tree-insert
+        { 9 "nine" }
-    "four"           4 pick tree-insert
+        { 4 "four" } 
-    "another four"   4 pick tree-insert
+        { 4 "replaced four" } 
-    "replaced seven" 7 pick tree-set ;
+        { 7 "replaced seven" }
+    } clone ;
 
-! test tree-insert, tree-set, tree-get, tree-get*, and tree-get-all
+! test set-at, at, at*
-[ "seven" ] [ <avl-tree> "seven" 7 pick tree-insert 7 swap tree-get ] unit-test
+[ t ] [ test-tree avl? ] unit-test
-[ "seven" t ] [ <avl-tree> "seven" 7 pick tree-insert 7 swap tree-get* ] unit-test
+[ "seven" ] [ <avl> "seven" 7 pick set-at 7 swap at ] unit-test
-[ f f ] [ <avl-tree> "seven" 7 pick tree-insert 8 swap tree-get* ] unit-test
+[ "seven" t ] [ <avl> "seven" 7 pick set-at 7 swap at* ] unit-test
-[ "seven" ] [ <avl-tree> "seven" 7 pick tree-set 7 swap tree-get ] unit-test
+[ f f ] [ <avl> "seven" 7 pick set-at 8 swap at* ] unit-test
-[ "replacement" ] [ <avl-tree> "seven" 7 pick tree-insert "replacement" 7 pick tree-set 7 swap tree-get ] unit-test
+[ "seven" ] [ <avl> "seven" 7 pick set-at 7 swap at ] unit-test
-[ "nine" ] [ test-tree 9 swap tree-get ] unit-test
+[ "replacement" ] [ <avl> "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test
-[ t ] [ test-tree 4 swap tree-get-all { "another four" "four" } sequence= ] unit-test
+[ "nine" ] [ test-tree 9 swap at ] unit-test
-[ t ] [ test-tree 11 swap tree-get-all empty? ] unit-test
+[ "replaced four" ] [ test-tree 4 swap at ] unit-test
-[ t ] [ test-tree 7 swap tree-get-all { "replaced seven" } sequence= ] unit-test
+[ "replaced seven" ] [ test-tree 7 swap at ] unit-test
-
-! test tree-delete
-[ f ] [ test-tree 9 over tree-delete 9 swap tree-get ] unit-test
-[ "replaced seven" ] [ test-tree 9 over tree-delete 7 swap tree-get ] unit-test
-[ f ] [ test-tree 4 over tree-delete-all 4 swap tree-get ] unit-test
-[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete 9 swap tree-get ] unit-test
-[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete-all 9 swap tree-get ] unit-test
-
-: test-random-deletions ( tree -- ? )
-    #! deletes one node at random from the tree, checking avl and tree
-    #! properties after each deletion, until the tree is empty
-    dup stump? [
-        drop t
-    ] [
-        dup tree-keys random over tree-delete dup valid-avl-tree? over valid-tree? and [
-            test-random-deletions
-        ] [
-            dup print-tree
-        ] if
-    ] if ;
-
-[ t ] [ <avl-tree> 5 random-tree test-random-deletions ] unit-test
-[ t ] [ <avl-tree> 30 random-tree test-random-deletions ] unit-test
-[ t ] [ <avl-tree> 100 random-tree test-random-deletions ] unit-test
 
+! test delete-at--all errors!
+[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test
+[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test
+[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test

extra/trees/avl/avl.factor

@@ -1,35 +1,20 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel generic math math.functions math.parser namespaces io
+USING: combinators kernel generic math math.functions math.parser
-sequences trees ;
+namespaces io prettyprint.backend sequences trees assocs parser ;
 IN: trees.avl
 
-TUPLE: avl-tree ;
+TUPLE: avl ;
 
-: <avl-tree> ( -- tree )
+INSTANCE: avl assoc
-    avl-tree construct-empty <tree> over set-delegate ;
+
+: <avl> ( -- tree )
+    avl construct-empty <tree> over set-delegate ;
 
 TUPLE: avl-node balance ;
 
-: <avl-node> ( value key -- node )
+: <avl-node> ( key value -- node )
-    <node> 0 avl-node construct-boa tuck set-delegate ;
+    swap <node> 0 avl-node construct-boa tuck set-delegate ;
-
-M: avl-tree create-node ( value key tree -- node ) drop <avl-node> ;
-
-GENERIC: valid-avl-node? ( obj -- height valid? )
-
-M: f valid-avl-node? ( f -- height valid? ) drop 0 t ;
-
-: check-balance ( node left-height right-height -- node height valid? )
-    2dup max 1+ >r swap - over avl-node-balance = r> swap ;
-
-M: avl-node valid-avl-node? ( node -- height valid? )
-    #! check that this avl node has the right balance marked, and that it isn't unbalanced.
-    dup node-left valid-avl-node? >r over node-right valid-avl-node? >r
-    check-balance r> r> and and
-    rot avl-node-balance abs 2 < and ;
-
-: valid-avl-tree? ( tree -- valid? ) tree-root valid-avl-node? nip ;
 
 : change-balance ( node amount -- )
     over avl-node-balance + swap set-avl-node-balance ;
@@ -65,30 +50,25 @@ M: avl-node valid-avl-node? ( node -- height valid? )
         { [ drop t ] [ t ] } ! balance is -1 or 1, tree is taller
     } cond ;
 
-DEFER: avl-insert
+DEFER: avl-set
 
-: avl-set ( value key node -- node taller? )
+: avl-insert ( value key node -- node taller? )
+    2dup node-key key< left right ? [
+        [ node-link avl-set ] keep swap
+        >r tuck set-node-link r>
+        [ dup current-side get change-balance balance-insert ] [ f ] if
+    ] with-side ;
+
+: (avl-set) ( value key node -- node taller? )
     2dup node-key key= [
         -rot pick set-node-key over set-node-value f
     ] [ avl-insert ] if ;
 
-: avl-insert-or-set ( value key node -- node taller? )
+: avl-set ( value key node -- node taller? )
-    "setting" get [ avl-set ] [ avl-insert ] if ;
+    [ (avl-set) ] [ <avl-node> t ] if* ;
 
-: (avl-insert) ( value key node -- node taller? )
+M: avl set-at ( value key node -- node )
-    [ avl-insert-or-set ] [ <avl-node> t ] if* ;
+    [ avl-set drop ] change-root ;
-
-: avl-insert ( value key node -- node taller? )
-    2dup node-key key< left right ? [
-        [ node-link (avl-insert) ] keep swap
-        >r tuck set-node-link r> [ dup current-side get change-balance balance-insert ] [ f ] if
-    ] with-side ;
-
-M: avl-node node-insert ( value key node -- node )
-    [ f "setting" set avl-insert-or-set ] with-scope drop ;
-
-M: avl-node node-set ( value key node -- node )
-    [ t "setting" set avl-insert-or-set ] with-scope drop ;
 
 : delete-select-rotate ( node -- node shorter? )
     dup node+link avl-node-balance zero? [
@@ -114,7 +94,8 @@ M: avl-node node-set ( value key node -- node )
 
 : avl-replace-with-extremity ( to-replace node -- node shorter? )
     dup node-link [
-        swapd avl-replace-with-extremity >r over set-node-link r> [ balance-delete ] [ f ] if
+        swapd avl-replace-with-extremity >r over set-node-link r>
+        [ balance-delete ] [ f ] if
     ] [
         tuck copy-node-contents node+link t
     ] if* ;
@@ -122,11 +103,8 @@ M: avl-node node-set ( value key node -- node )
 : replace-with-a-child ( node -- node shorter? )
     #! assumes that node is not a leaf, otherwise will recurse forever
     dup node-link [
-        dupd [ avl-replace-with-extremity ] with-other-side >r over set-node-link r> [
+        dupd [ avl-replace-with-extremity ] with-other-side
-            balance-delete
+        >r over set-node-link r> [ balance-delete ] [ f ] if
-        ] [
-            f
-        ] if
     ] [
         [ replace-with-a-child ] with-other-side
     ] if* ;
@@ -137,7 +115,7 @@ M: avl-node node-set ( value key node -- node )
     dup leaf? [
         drop f t
     ] [
-        random-side [ replace-with-a-child ] with-side ! random not necessary, just for fun
+        left [ replace-with-a-child ] with-side
     ] if ;
 
 GENERIC: avl-delete ( key node -- node shorter? deleted? )
@@ -145,30 +123,36 @@ GENERIC: avl-delete ( key node -- node shorter? deleted? )
 M: f avl-delete ( key f -- f f f ) nip f f ;
 
 : (avl-delete) ( key node -- node shorter? deleted? )
-    tuck node-link avl-delete >r >r over set-node-link r> [ balance-delete r> ] [ f r> ] if ;
+    tuck node-link avl-delete >r >r over set-node-link r>
+    [ balance-delete r> ] [ f r> ] if ;
 
 M: avl-node avl-delete ( key node -- node shorter? deleted? )
     2dup node-key key-side dup zero? [
         drop nip avl-delete-node t
     ] [
-        [
+        [ (avl-delete) ] with-side
-            (avl-delete)
-        ] with-side
     ] if ;
 
-M: avl-node node-delete ( key node -- node ) avl-delete 2drop ;
+M: avl delete-at ( key node -- )
+    [ avl-delete 2drop ] change-root ;
 
-M: avl-node node-delete-all ( key node -- node )
+M: avl new-assoc 2drop <avl> ;
-    #! deletes until there are no more. not optimal.
-    dupd [ avl-delete nip ] with-scope [
-        node-delete-all
-    ] [
-        nip
-    ] if ;
 
-M: avl-node print-node ( depth node -- )
+: >avl ( assoc -- avl )
-    over 1+ over node-right print-node
+    T{ avl T{ tree f f 0 } } assoc-clone-like ;
-    over [ drop "   " write ] each
-    dup avl-node-balance number>string write " " write dup node-key number>string print
-    >r 1+ r> node-left print-node ;
 
+M: avl assoc-like
+    drop dup avl? [ >avl ] unless ;
+
+: AVL{
+    \ } [ >avl ] parse-literal ; parsing
+
+M: avl pprint-delims drop \ AVL{ \ } ;
+
+! When tuple inheritance is used, the following lines won't be necessary
+M: avl assoc-size tree-count ;
+M: avl clear-assoc delegate clear-assoc ;
+M: avl assoc-find >r tree-root r> find-node ;
+M: avl clone dup assoc-clone-like ;
+M: avl >pprint-sequence >alist ;
+M: avl pprint-narrow? drop t ;

extra/trees/avl/summary.txt

@@ -0,0 +1 @@
+Balanced AVL trees

extra/trees/binary/binary-tests.factor

@@ -1,45 +0,0 @@
-USING: trees trees.binary tools.test kernel sequences ;
-IN: temporary
-
-: test-tree ( -- tree )
-    <bst>
-    "seven"          7 pick tree-insert
-    "nine"           9 pick tree-insert
-    "four"           4 pick tree-insert
-    "another four"   4 pick tree-insert
-    "replaced seven" 7 pick tree-set ;
-
-! test tree-insert, tree-set, tree-get, tree-get*, and tree-get-all
-[ "seven" ] [ <bst> "seven" 7 pick tree-insert 7 swap tree-get ] unit-test
-[ "seven" t ] [ <bst> "seven" 7 pick tree-insert 7 swap tree-get* ] unit-test
-[ f f ] [ <bst> "seven" 7 pick tree-insert 8 swap tree-get* ] unit-test
-[ "seven" ] [ <bst> "seven" 7 pick tree-set 7 swap tree-get ] unit-test
-[ "replacement" ] [ <bst> "seven" 7 pick tree-insert "replacement" 7 pick tree-set 7 swap tree-get ] unit-test
-[ "four" ] [ test-tree 4 swap tree-get ] unit-test
-[ "nine" ] [ test-tree 9 swap tree-get ] unit-test
-[ t ] [ test-tree 4 swap tree-get-all { "another four" "four" } sequence= ] unit-test
-[ t ] [ test-tree 11 swap tree-get-all empty? ] unit-test
-[ t ] [ test-tree 7 swap tree-get-all { "replaced seven" } sequence= ] unit-test
-
-! test tree-delete
-[ f ] [ test-tree 9 over tree-delete 9 swap tree-get ] unit-test
-[ "replaced seven" ] [ test-tree 9 over tree-delete 7 swap tree-get ] unit-test
-[ "four" ] [ test-tree 9 over tree-delete 4 swap tree-get ] unit-test
-! TODO: sometimes this shows up as "another four" because of randomisation
-! [ "nine" "four" ] [ test-tree 7 over tree-delete 9 over tree-get 4 rot tree-get ] unit-test
-! [ "another four" ] [ test-tree 4 over tree-delete 4 swap tree-get ] unit-test
-[ f ] [ test-tree 4 over tree-delete-all 4 swap tree-get ] unit-test
-[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete 9 swap tree-get ] unit-test
-[ "nine" ] [ test-tree 7 over tree-delete 4 over tree-delete-all 9 swap tree-get ] unit-test
-
-! test valid-node?
-[ t ] [ T{ node f 0 } valid-node? ] unit-test
-[ t ] [ T{ node f 0 f T{ node f -1 } } valid-node? ] unit-test
-[ t ] [ T{ node f 0 f f T{ node f 1 } } valid-node? ] unit-test
-[ t ] [ T{ node f 0 f T{ node f -1 } T{ node f 1 } } valid-node? ] unit-test
-[ f ] [ T{ node f 0 f T{ node f 1 } } valid-node? ] unit-test
-[ f ] [ T{ node f 0 f f T{ node f -1 } } valid-node? ] unit-test
-
-! random testing
-[ t ] [ <bst> 10 random-tree valid-tree? ] unit-test
-

extra/trees/binary/binary.factor

@@ -1,88 +0,0 @@
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generic math trees ;
-IN: trees.binary
-
-TUPLE: bst ;
-
-: <bst> ( -- tree ) bst construct-empty <tree> over set-delegate ;
-
-TUPLE: bst-node ;
-
-: <bst-node> ( value key -- node )
-    <node> bst-node construct-empty tuck set-delegate ;
-
-M: bst create-node ( value key tree -- node ) drop <bst-node> ;
-
-M: bst-node node-insert ( value key node -- node )
-    2dup node-key key-side [
-        [ node-link [ node-insert ] [ <bst-node> ] if* ] keep tuck set-node-link 
-    ] with-side ;
-
-M: bst-node node-set ( value key node -- node )
-    2dup node-key key-side dup 0 = [
-        drop nip [ set-node-value ] keep
-    ] [
-        [ [ node-link [ node-set ] [ <bst-node> ] if* ] keep tuck set-node-link ] with-side
-    ] if ;
-
-DEFER: delete-node
-
-: (prune-extremity) ( parent node -- new-extremity )
-    dup node-link [
-        rot drop (prune-extremity)
-    ] [
-        tuck delete-node swap set-node-link
-    ] if* ;
-
-: prune-extremity ( node -- new-extremity )
-    #! remove and return the leftmost or rightmost child of this node.
-    #! assumes at least one child
-    dup node-link (prune-extremity) ;
-
-: replace-with-child ( node -- node )
-    dup dup node-link copy-node-contents dup node-link delete-node over set-node-link ;
-
-: replace-with-extremity ( node -- node )
-    dup node-link dup node+link [
-        ! predecessor/successor is not the immediate child
-        [ prune-extremity ] with-other-side dupd copy-node-contents
-    ] [
-        ! node-link is the predecessor/successor
-        drop replace-with-child
-    ] if ;
-
-: delete-node-with-two-children ( node -- node )
-    #! randomised to minimise tree unbalancing
-    random-side [ replace-with-extremity ] with-side ;
-
-: delete-node ( node -- node )
-    #! delete this node, returning its replacement
-    dup node-left [
-        dup node-right [
-            delete-node-with-two-children
-        ] [
-            node-left ! left but no right
-        ] if
-    ] [
-        dup node-right [
-            node-right ! right but not left
-        ] [
-            drop f ! no children
-        ] if
-    ] if ;
-
-M: bst-node node-delete ( key node -- node )
-    2dup node-key key-side dup zero? [
-        drop nip delete-node
-    ] [
-        [ tuck node-link node-delete over set-node-link ] with-side
-    ] if ;
-
-M: bst-node node-delete-all ( key node -- node )
-    2dup node-key key-side dup zero? [
-        drop delete-node node-delete-all
-    ] [
-        [ tuck node-link node-delete-all over set-node-link ] with-side
-    ] if ;
-

extra/trees/splay/authors.txt

@@ -1 +1,2 @@
 Mackenzie Straight
+Daniel Ehrenberg

extra/trees/splay/splay-docs.factor

@@ -0,0 +1,27 @@
+USING: help.syntax help.markup trees.splay assocs ;
+
+HELP: SPLAY{
+{ $syntax "SPLAY{ { key value }... }" }
+{ $values { "key" "a key" } { "value" "a value" } }
+{ $description "Literal syntax for an splay tree." } ;
+
+HELP: <splay>
+{ $values { "tree" splay } }
+{ $description "Creates an empty splay tree" } ;
+
+HELP: >splay
+{ $values { "assoc" assoc } { "splay" splay } }
+{ $description "Converts any " { $link assoc } " into an splay tree." } ;
+
+HELP: splay
+{ $class-description "This is the class for splay trees. Splay trees have amortized average-case logarithmic time storage and retrieval operations, and better complexity on more skewed lookup distributions, though in bad situations they can degrade to linear time, resembling a linked list. These conform to the assoc protocol." } ;
+
+ARTICLE: { "splay" "intro" } "Splay trees"
+"This is a library for splay trees. Splay trees have amortized average-case logarithmic time storage and retrieval operations, and better complexity on more skewed lookup distributions, though in bad situations they can degrade to linear time, resembling a linked list. These trees conform to the assoc protocol."
+{ $subsection splay }
+{ $subsection <splay> }
+{ $subsection >splay }
+{ $subsection POSTPONE: SPLAY{ } ;
+
+IN: trees.splay
+ABOUT: { "splay" "intro" }

extra/trees/splay/splay-tests.factor

@@ -8,7 +8,7 @@ IN: temporary
     100 [ drop 100 random swap at drop ] curry* each ;
 
 : make-numeric-splay-tree ( n -- splay-tree )
-    dup <splay-tree> -rot [ pick set-at ] 2each ;
+    <splay> [ [ dupd set-at ] curry each ] keep ;
 
 [ t ] [
     100 make-numeric-splay-tree dup randomize-numeric-splay-tree
@@ -18,10 +18,10 @@ IN: temporary
 [ 10 ] [ 10 make-numeric-splay-tree keys length ] unit-test
 [ 10 ] [ 10 make-numeric-splay-tree values length ] unit-test
 
-[ f ] [ <splay-tree> f 4 pick set-at 4 swap at ] unit-test
+[ f ] [ <splay> f 4 pick set-at 4 swap at ] unit-test
 
 ! Ensure that f can be a value
-[ t ] [ <splay-tree> f 4 pick set-at 4 swap key? ] unit-test
+[ t ] [ <splay> f 4 pick set-at 4 swap key? ] unit-test
 
 [
 { { 1 "a" } { 2 "b" } { 3 "c" } { 4 "d" } { 5 "e" } { 6 "f" } }
@@ -29,5 +29,5 @@ IN: temporary
 {
     { 4 "d" } { 5 "e" } { 6 "f" }
     { 1 "a" } { 2 "b" } { 3 "c" }
-} >splay-tree >alist
+} >splay >alist
 ] unit-test

extra/trees/splay/splay.factor

@@ -1,59 +1,56 @@
 ! Copyright (c) 2005 Mackenzie Straight.
-! See http://factorcode.org/license.txt for BSD license.
+! See http://factor.sf.net/license.txt for BSD license.
-USING: kernel math combinators assocs parser ;
+USING: arrays kernel math namespaces sequences assocs parser
+prettyprint.backend trees generic ;
 IN: trees.splay
 
-TUPLE: splay-tree r count ;
+TUPLE: splay ;
-INSTANCE: splay-tree assoc
 
-: <splay-tree> ( -- splay-tree )
+: <splay> ( -- splay-tree )
-    0 { set-splay-tree-count } splay-tree construct ;
+    \ splay construct-empty
+    <tree> over set-delegate ;
 
-<PRIVATE
+INSTANCE: splay assoc
-
-TUPLE: splay-node v k l r ;
-
-C: <splay-node> splay-node 
 
 : rotate-right ( node -- node )
-    dup splay-node-l
+    dup node-left
-    [ splay-node-r swap set-splay-node-l ] 2keep
+    [ node-right swap set-node-left ] 2keep
-    [ set-splay-node-r ] keep ;
+    [ set-node-right ] keep ;
                                                         
 : rotate-left ( node -- node )
-    dup splay-node-r
+    dup node-right
-    [ splay-node-l swap set-splay-node-r ] 2keep
+    [ node-left swap set-node-right ] 2keep
-    [ set-splay-node-l ] keep ;
+    [ set-node-left ] keep ;
 
 : link-right ( left right key node -- left right key node )
-    swap >r [ swap set-splay-node-l ] 2keep
+    swap >r [ swap set-node-left ] 2keep
-    nip dup splay-node-l r> swap ;
+    nip dup node-left r> swap ;
 
 : link-left ( left right key node -- left right key node )
-    swap >r rot [ set-splay-node-r ] 2keep
+    swap >r rot [ set-node-right ] 2keep
-    drop dup splay-node-r swapd r> swap ;
+    drop dup node-right swapd r> swap ;
 
 : cmp ( key node -- obj node -1/0/1 )
-    2dup splay-node-k <=> ;
+    2dup node-key <=> ;
 
 : lcmp ( key node -- obj node -1/0/1 ) 
-    2dup splay-node-l splay-node-k <=> ;
+    2dup node-left node-key <=> ;
 
 : rcmp ( key node -- obj node -1/0/1 ) 
-    2dup splay-node-r splay-node-k <=> ;
+    2dup node-right node-key <=> ;
 
 DEFER: (splay)
 
 : splay-left ( left right key node -- left right key node )
-    dup splay-node-l [
+    dup node-left [
         lcmp 0 < [ rotate-right ] when
-        dup splay-node-l [ link-right (splay) ] when
+        dup node-left [ link-right (splay) ] when
     ] when ;
 
 : splay-right ( left right key node -- left right key node )
-    dup splay-node-r [
+    dup node-right [
         rcmp 0 > [ rotate-left ] when
-        dup splay-node-r [ link-left (splay) ] when
+        dup node-right [ link-left (splay) ] when
     ] when ;
 
 : (splay) ( left right key node -- left right key node )
@@ -61,118 +58,96 @@ DEFER: (splay)
     [ drop splay-left ] [ 0 > [ splay-right ] when ] if ;
 
 : assemble ( head left right node -- root )
-    [ splay-node-r swap set-splay-node-l ] keep
+    [ node-right swap set-node-left ] keep
-    [ splay-node-l swap set-splay-node-r ] keep
+    [ node-left swap set-node-right ] keep
-    [ swap splay-node-l swap set-splay-node-r ] 2keep
+    [ swap node-left swap set-node-right ] 2keep
-    [ swap splay-node-r swap set-splay-node-l ] keep ;
+    [ swap node-right swap set-node-left ] keep ;
 
 : splay-at ( key node -- node )
-    >r >r T{ splay-node } clone dup dup r> r>
+    >r >r T{ node } clone dup dup r> r>
     (splay) nip assemble ;
 
 : splay ( key tree -- )
-    [ splay-tree-r splay-at ] keep set-splay-tree-r ;
+    [ tree-root splay-at ] keep set-tree-root ;
 
 : splay-split ( key tree -- node node )
-    2dup splay splay-tree-r cmp 0 < [
+    2dup splay tree-root cmp 0 < [
-        nip dup splay-node-l swap f over set-splay-node-l
+        nip dup node-left swap f over set-node-left
     ] [
-        nip dup splay-node-r swap f over set-splay-node-r swap
+        nip dup node-right swap f over set-node-right swap
     ] if ;
 
-: (get-splay) ( key tree -- node ? )
+: get-splay ( key tree -- node ? )
-    2dup splay splay-tree-r cmp 0 = [
+    2dup splay tree-root cmp 0 = [
         nip t
     ] [
         2drop f f
     ] if ;
 
 : get-largest ( node -- node )
-    dup [ dup splay-node-r [ nip get-largest ] when* ] when ;
+    dup [ dup node-right [ nip get-largest ] when* ] when ;
 
 : splay-largest
-    dup [ dup get-largest splay-node-k swap splay-at ] when ;
+    dup [ dup get-largest node-key swap splay-at ] when ;
 
 : splay-join ( n2 n1 -- node )
     splay-largest [
-        [ set-splay-node-r ] keep
+        [ set-node-right ] keep
     ] [
         drop f
     ] if* ;
 
-: (remove-splay) ( key tree -- )
+: remove-splay ( key tree -- )
-    tuck (get-splay) nip [
+    tuck get-splay nip [
-        dup splay-tree-count 1- over set-splay-tree-count
+        dup dec-count
-        dup splay-node-r swap splay-node-l splay-join
+        dup node-right swap node-left splay-join
-        swap set-splay-tree-r
+        swap set-tree-root
     ] [ drop ] if* ;
 
-: (set-splay) ( value key tree -- )
+: set-splay ( value key tree -- )
-    2dup (get-splay) [ 2nip set-splay-node-v ] [
+    2dup get-splay [ 2nip set-node-value ] [
-       drop dup splay-tree-count 1+ over set-splay-tree-count
+       drop dup inc-count
        2dup splay-split rot
-       >r <splay-node> r> set-splay-tree-r
+       >r >r swapd r> node construct-boa r> set-tree-root
     ] if ;
 
 : new-root ( value key tree -- )
-    [ 1 swap set-splay-tree-count ] keep
+    [ 1 swap set-tree-count ] keep
-    >r f f <splay-node> r> set-splay-tree-r ;
+    >r swap <node> r> set-tree-root ;
 
-: splay-call ( splay-node call -- )
+M: splay set-at ( value key tree -- )
-    >r [ splay-node-k ] keep splay-node-v r> call ; inline
+    dup tree-root [ set-splay ] [ new-root ] if ;
 
-: (splay-tree-traverse) ( splay-node quot -- key value ? )
+M: splay at* ( key tree -- value ? )
-    {
+    dup tree-root [
-        { [ over not ] [ 2drop f f f ] }
+        get-splay >r dup [ node-value ] when r>
-        { [ [
-              >r splay-node-l r> (splay-tree-traverse)
-            ] 2keep rot ]
-          [ 2drop t ] }
-        { [ >r 2nip r> [ splay-call ] 2keep rot ]
-          [ drop [ splay-node-k ] keep splay-node-v t ] }
-        { [ t ] [ >r splay-node-r r> (splay-tree-traverse) ] }
-    } cond ; inline
-
-PRIVATE>
-
-M: splay-tree assoc-find ( splay-tree quot -- key value ? )
-    #! quot: ( k v -- ? )
-    #! Not tail recursive so will fail on large splay trees.
-    >r splay-tree-r r> (splay-tree-traverse) ;
-
-M: splay-tree set-at ( value key tree -- )
-    dup splay-tree-r [ (set-splay) ] [ new-root ] if ;
-
-M: splay-tree at* ( key tree -- value ? )
-    dup splay-tree-r [
-        (get-splay) >r dup [ splay-node-v ] when r>
     ] [
         2drop f f
     ] if ;
 
-M: splay-tree delete-at ( key tree -- )
+M: splay delete-at ( key tree -- )
-    dup splay-tree-r [ (remove-splay) ] [ 2drop ] if ;
+    dup tree-root [ remove-splay ] [ 2drop ] if ;
 
-M: splay-tree new-assoc
+M: splay new-assoc
-    2drop <splay-tree> ;
+    2drop <splay> ;
 
-: >splay-tree ( assoc -- splay-tree )
+: >splay ( assoc -- splay-tree )
-    T{ splay-tree f f 0 } assoc-clone-like ;
+    T{ splay T{ tree f f 0 } } assoc-clone-like ;
 
-: S{
+: SPLAY{
-    \ } [ >splay-tree ] parse-literal ; parsing
+    \ } [ >splay ] parse-literal ; parsing
 
-M: splay-tree assoc-like
+M: splay assoc-like
-    drop dup splay-tree? [ >splay-tree ] unless ;
+    drop dup splay? [
+        dup tree? [ <splay> tuck set-delegate ] [ >splay ] if
+    ] unless ;
 
-M: splay-tree clear-assoc
+M: splay pprint-delims drop \ SPLAY{ \ } ;
-    0 over set-splay-tree-count
-    f swap set-splay-tree-r ;
 
-M: splay-tree assoc-size
+! When tuple inheritance is used, the following lines won't be necessary
-    splay-tree-count ;
+M: splay assoc-size tree-count ;
-
+M: splay clear-assoc delegate clear-assoc ;
-USE: prettyprint.backend
+M: splay assoc-find >r tree-root r> find-node ;
-M: splay-tree pprint-delims drop \ S{ \ } ;
+M: splay clone dup assoc-clone-like ;
-M: splay-tree >pprint-sequence >alist ;
+M: splay >pprint-sequence >alist ;
-M: splay-tree pprint-narrow? drop t ;
+M: splay pprint-narrow? drop t ;

extra/trees/summary.txt

@@ -1 +1 @@
-Binary search and avl (balanced) trees
+Binary search trees

extra/trees/todo.txt

@@ -1,2 +0,0 @@
-- Make trees.splay use the same tree protocol as trees.binary and trees.avl
-- Make all trees follow the assoc protocol

extra/trees/trees-docs.factor

@@ -0,0 +1,27 @@
+USING: help.syntax help.markup trees assocs ;
+
+HELP: TREE{
+{ $syntax "TREE{ { key value }... }" }
+{ $values { "key" "a key" } { "value" "a value" } }
+{ $description "Literal syntax for an unbalanced tree." } ;
+
+HELP: <tree>
+{ $values { "tree" tree } }
+{ $description "Creates an empty unbalanced binary tree" } ;
+
+HELP: >tree
+{ $values { "assoc" assoc } { "tree" tree } }
+{ $description "Converts any " { $link assoc } " into an unbalanced binary tree." } ;
+
+HELP: tree
+{ $class-description "This is the class for unbalanced binary search trees. It is not usually intended to be used directly but rather as a basis for other trees." } ;
+
+ARTICLE: { "trees" "intro" } "Binary search trees"
+"This is a library for unbalanced binary search trees. It is not intended to be used directly in most situations but rather as a base class for new trees, because performance can degrade to linear time storage/retrieval by the number of keys. These binary search trees conform to the assoc protocol."
+{ $subsection tree }
+{ $subsection <tree> }
+{ $subsection >tree }
+{ $subsection POSTPONE: TREE{ } ;
+
+IN: trees
+ABOUT: { "trees" "intro" }

extra/trees/trees-tests.factor

@@ -0,0 +1,28 @@
+USING: trees assocs tools.test kernel sequences ;
+IN: temporary
+
+: test-tree ( -- tree )
+    TREE{
+        { 7 "seven" }
+        { 9 "nine" }
+        { 4 "four" } 
+        { 4 "replaced four" } 
+        { 7 "replaced seven" }
+    } clone ;
+
+! test set-at, at, at*
+[ "seven" ] [ <tree> "seven" 7 pick set-at 7 swap at ] unit-test
+[ "seven" t ] [ <tree> "seven" 7 pick set-at 7 swap at* ] unit-test
+[ f f ] [ <tree> "seven" 7 pick set-at 8 swap at* ] unit-test
+[ "seven" ] [ <tree> "seven" 7 pick set-at 7 swap at ] unit-test
+[ "replacement" ] [ <tree> "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test
+[ "replaced four" ] [ test-tree 4 swap at ] unit-test
+[ "nine" ] [ test-tree 9 swap at ] unit-test
+
+! test delete-at
+[ f ] [ test-tree 9 over delete-at 9 swap at ] unit-test
+[ "replaced seven" ] [ test-tree 9 over delete-at 7 swap at ] unit-test
+[ "replaced four" ] [ test-tree 9 over delete-at 4 swap at ] unit-test
+[ "nine" "replaced four" ] [ test-tree 7 over delete-at 9 over at 4 rot at ] unit-test
+[ "nine" ] [ test-tree 7 over delete-at 4 over delete-at 9 swap at ] unit-test
+

extra/trees/trees.factor

@@ -1,17 +1,19 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generic math math.parser sequences arrays io namespaces
+USING: kernel generic math sequences arrays io namespaces
-namespaces.private random layouts ;
+prettyprint.private kernel.private assocs random combinators
+parser prettyprint.backend ;
 IN: trees
 
-TUPLE: tree root ;
+TUPLE: tree root count ;
+: <tree> ( -- tree )
+    f 0 tree construct-boa ;
 
-: <tree> ( -- tree ) tree construct-empty ;
+INSTANCE: tree assoc
 
 TUPLE: node key value left right ;
-
+: <node> ( key value -- node )
-: <node> ( value key -- node )
+    f f node construct-boa ;
-    swap f f node construct-boa ;
 
 SYMBOL: current-side
 
@@ -20,28 +22,32 @@ SYMBOL: current-side
 
 : go-left? ( -- ? ) current-side get left = ;
 
-: node-link@ ( -- ? quot quot ) go-left? [ node-left ] [ node-right ] ; inline
+: inc-count ( tree -- )
-: set-node-link@ ( -- ? quot quot ) go-left? [ set-node-left ] [ set-node-right ] ; inline
+    dup tree-count 1+ swap set-tree-count ;
 
-: node-link ( node -- child ) node-link@ if ;
+: dec-count ( tree -- )
-: set-node-link ( child node -- ) set-node-link@ if ;
+    dup tree-count 1- swap set-tree-count ;
-: node+link ( node -- child ) node-link@ swap if ;
-: set-node+link ( child node -- ) set-node-link@ swap if ;
 
-: with-side ( side quot -- ) H{ } clone >n swap current-side set call ndrop ; inline
+: node-link@ ( node ? -- node )
+    go-left? xor [ node-left ] [ node-right ] if ;
+: set-node-link@ ( left parent ? -- ) 
+    go-left? xor [ set-node-left ] [ set-node-right ] if ;
+
+: node-link ( node -- child ) f node-link@  ;
+: set-node-link ( child node -- ) f set-node-link@ ;
+: node+link ( node -- child ) t node-link@ ;
+: set-node+link ( child node -- ) t set-node-link@ ;
+
+: with-side ( side quot -- ) [ swap current-side set call ] with-scope ; inline
 : with-other-side ( quot -- ) current-side get neg swap with-side ; inline
 : go-left ( quot -- ) left swap with-side ; inline
 : go-right ( quot -- ) right swap with-side ; inline
 
-GENERIC: create-node ( value key tree -- node )
+: change-root ( tree quot -- )
+    swap [ tree-root swap call ] keep set-tree-root ; inline
 
-GENERIC: copy-node-contents ( new old -- )
+: leaf? ( node -- ? )
-
+    dup node-left swap node-right or not ;
-M: node copy-node-contents ( new old -- )
-    #! copy old's key and value into new (keeping children and parent)
-    dup node-key pick set-node-key node-value swap set-node-value ;
-
-M: tree create-node ( value key tree -- node ) drop <node> ;
 
 : key-side ( k1 k2 -- side )
     #! side is -1 if k1 < k2, 0 if they are equal, or 1 if k1 > k2
@@ -56,137 +62,143 @@ M: tree create-node ( value key tree -- node ) drop <node> ;
 : choose-branch ( key node -- key node-left/right )
     2dup node-key key-side [ node-link ] with-side ;
 
-GENERIC: node-get ( key node -- value )
+: node-at* ( key node -- value ? )
-
+    [
-: tree-get ( key tree -- value ) tree-root node-get ;
-
-M: node node-get ( key node -- value )
-    2dup node-key key= [
-        nip node-value
-    ] [
-        choose-branch node-get
-    ] if ;
-
-M: f node-get ( key f -- f ) nip ;
-
-GENERIC: node-get* ( key node -- value ? )
-
-: tree-get* ( key tree -- value ? ) tree-root node-get* ;
-
-M: node node-get* ( key node -- value ? )
         2dup node-key key= [
             nip node-value t
         ] [
-        choose-branch node-get*
+            choose-branch node-at*
-    ] if ;
+        ] if
+    ] [ drop f f ] if* ;
 
-M: f node-get* ( key f -- f f ) nip f ;
+M: tree at* ( key tree -- value ? )
+    tree-root node-at* ;
 
-GENERIC: node-get-all ( key node -- seq )
+: node-set ( value key node -- node )
-
+    2dup node-key key-side dup zero? [
-: tree-get-all ( key tree -- seq ) tree-root node-get-all ;
+        drop nip [ set-node-value ] keep
-
-M: f node-get-all ( key f -- V{} ) 2drop V{ } clone ;
-
-M: node node-get-all ( key node -- seq )
-    2dup node-key key= [
-        ! duplicate keys are stored to the right because of choose-branch
-        2dup node-right node-get-all >r nip node-value r> tuck push
     ] [
-        choose-branch node-get-all
+        [
+            [ node-link [ node-set ] [ swap <node> ] if* ] keep
+            [ set-node-link ] keep
+        ] with-side
     ] if ;
 
-GENERIC: node-insert ( value key node -- node ) ! can add duplicates
+M: tree set-at ( value key tree -- )
+    [ [ node-set ] [ swap <node> ] if* ] change-root ;
 
-: tree-insert ( value key tree -- )
+: valid-node? ( node -- ? )
-    [ dup tree-root [ nip node-insert ] [ create-node ] if* ] keep set-tree-root ;
+    [
-
-GENERIC: node-set ( value key node -- node )
-    #! note that this only sets the first node with this key. if more than one
-    #! has been inserted then the others won't be modified. (should they be deleted?)
-
-: tree-set ( value key tree -- )
-    [ dup tree-root [ nip node-set ] [ create-node ] if* ] keep set-tree-root ;
-
-GENERIC: node-delete ( key node -- node )
-
-: tree-delete ( key tree -- )
-    [ tree-root node-delete ] keep set-tree-root ;
-
-GENERIC: node-delete-all ( key node -- node )
-
-M: f node-delete-all ( key f -- f ) nip ;
-
-: tree-delete-all ( key tree -- )
-    [ tree-root node-delete-all ] keep set-tree-root ;
-
-: node-map-link ( node quot -- node )
-    over node-link swap call over set-node-link ;
-
-: node-map ( node quot -- node )
-    over [
-        tuck [ node-map-link ] go-left over call swap [ node-map-link ] go-right
-    ] [
-        drop
-    ] if ;
-
-: tree-map ( tree quot -- )
-    #! apply quot to each element of the tree, in order
-    over tree-root swap node-map swap set-tree-root ;
-
-: node>node-seq ( node -- seq )
-    dup [
-        dup node-left node>node-seq over 1array rot node-right node>node-seq 3append
-    ] when ;
-
-: tree>node-seq ( tree -- seq )
-    tree-root node>node-seq ;
-
-: tree-keys ( tree -- keys )
-    tree>node-seq [ node-key ] map ;
-
-: tree-values ( tree -- values )
-    tree>node-seq [ node-value ] map ;
-
-: leaf? ( node -- ? )
-    dup node-left swap node-right or not ;
-
-GENERIC: valid-node? ( node -- ? )
-
-M: f valid-node? ( f -- t ) not ;
-
-M: node valid-node? ( node -- ? )
         dup dup node-left [ node-key swap node-key key< ] when* >r
         dup dup node-right [ node-key swap node-key key> ] when* r> and swap
-    dup node-left valid-node? swap node-right valid-node? and and ;
+        dup node-left valid-node? swap node-right valid-node? and and
+    ] [ t ] if* ;
 
 : valid-tree? ( tree -- ? ) tree-root valid-node? ;
 
-DEFER: print-tree
+: tree-call ( node call -- )
+    >r [ node-key ] keep node-value r> call ; inline
  
-: random-tree ( tree size -- tree )
+: find-node ( node quot -- key value ? )
-    [ most-positive-fixnum random pick tree-set ] each ;
+    {
+        { [ over not ] [ 2drop f f f ] }
+        { [ [
+              >r node-left r> find-node
+            ] 2keep rot ]
+          [ 2drop t ] }
+        { [ >r 2nip r> [ tree-call ] 2keep rot ]
+          [ drop [ node-key ] keep node-value t ] }
+        { [ t ] [ >r node-right r> find-node ] }
+    } cond ; inline
 
-: increasing-tree ( tree size -- tree )
+M: tree assoc-find ( tree quot -- key value ? )
-    [ dup pick tree-set ] each ;
+    >r tree-root r> find-node ;
 
-: decreasing-tree ( tree size -- tree )
+M: tree clear-assoc
-    reverse increasing-tree ;
+    0 over set-tree-count
+    f swap set-tree-root ;
 
-GENERIC: print-node ( depth node -- )
+M: tree assoc-size
+    tree-count ;
 
-M: f print-node ( depth f -- ) 2drop ;
+: copy-node-contents ( new old -- )
+    dup node-key pick set-node-key node-value swap set-node-value ;
 
-M: node print-node ( depth node -- )
+! Deletion
-    ! not pretty, but ok for debugging
+DEFER: delete-node
-    over 1+ over node-right print-node
-    over [ drop "   " write ] each dup node-key number>string print
-    >r 1+ r> node-left print-node ;
 
-: print-tree ( tree -- )
+: (prune-extremity) ( parent node -- new-extremity )
-    tree-root 1 swap print-node ;
+    dup node-link [
+        rot drop (prune-extremity)
+    ] [
+        tuck delete-node swap set-node-link
+    ] if* ;
 
-: stump? ( tree -- ? )
+: prune-extremity ( node -- new-extremity )
-    #! is this tree empty?
+    #! remove and return the leftmost or rightmost child of this node.
-    tree-root not ;
+    #! assumes at least one child
+    dup node-link (prune-extremity) ;
 
+: replace-with-child ( node -- node )
+    dup dup node-link copy-node-contents dup node-link delete-node over set-node-link ;
+
+: replace-with-extremity ( node -- node )
+    dup node-link dup node+link [
+        ! predecessor/successor is not the immediate child
+        [ prune-extremity ] with-other-side dupd copy-node-contents
+    ] [
+        ! node-link is the predecessor/successor
+        drop replace-with-child
+    ] if ;
+
+: delete-node-with-two-children ( node -- node )
+    #! randomised to minimise tree unbalancing
+    random-side [ replace-with-extremity ] with-side ;
+
+: delete-node ( node -- node )
+    #! delete this node, returning its replacement
+    dup node-left [
+        dup node-right [
+            delete-node-with-two-children
+        ] [
+            node-left ! left but no right
+        ] if
+    ] [
+        dup node-right [
+            node-right ! right but not left
+        ] [
+            drop f ! no children
+        ] if
+    ] if ;
+
+: delete-bst-node ( key node -- node )
+    2dup node-key key-side dup zero? [
+        drop nip delete-node
+    ] [
+        [ tuck node-link delete-bst-node over set-node-link ] with-side
+    ] if ;
+
+M: tree delete-at
+    [ delete-bst-node ] change-root ;
+
+M: tree new-assoc
+    2drop <tree> ;
+
+M: tree clone dup assoc-clone-like ;
+
+: >tree ( assoc -- tree )
+    T{ tree f f 0 } assoc-clone-like ;
+
+GENERIC: tree-assoc-like ( assoc -- tree )
+M: tuple tree-assoc-like ! will need changes for tuple inheritance
+    dup delegate dup tree? [ nip ] [ drop >tree ] if ;
+M: tree tree-assoc-like ;
+M: assoc tree-assoc-like >tree ;
+M: tree assoc-like drop tree-assoc-like ;
+
+: TREE{
+    \ } [ >tree ] parse-literal ; parsing
+
+M: tree pprint-delims drop \ TREE{ \ } ;
+M: tree >pprint-sequence >alist ;
+M: tree pprint-narrow? drop t ;

extra/tuple-syntax/about.txt

@@ -0,0 +1 @@
+Tuple literals with named slots

extra/tuple-syntax/authors.txt

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

extra/tuple-syntax/tags.txt

@@ -0,0 +1 @@
+syntax

extra/tuple-syntax/tuple-syntax-docs.factor

@@ -0,0 +1,10 @@
+USING: help.markup help.syntax tuple-syntax ;
+
+HELP: TUPLE{
+{ $syntax "TUPLE{ class slot-name: value... }" }
+{ $values { "class" "a tuple class word" } { "slot-name" "the name of a slot, without the tuple class name" } { "value" "the value for a slot" } }
+{ $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } ". The class word must be specified. Slots which aren't specified are set to f. If slot names are duplicated, the latest one is used." }
+{ $see-also POSTPONE: T{ } ;
+
+IN: tuple-syntax
+ABOUT: POSTPONE: TUPLE{

extra/tuple-syntax/tuple-syntax-tests.factor

@@ -0,0 +1,7 @@
+USING: tools.test tuple-syntax ;
+
+TUPLE: foo bar baz ;
+
+[ T{ foo } ] [ TUPLE{ foo } ] unit-test
+[ T{ foo 1 { 2 3 } { 4 { 5 } } } ]
+[ TUPLE{ foo bar: { 2 3 } delegate: 1 baz: { 4 { 5 } } } ] unit-test

extra/tuple-syntax/tuple-syntax.factor

@@ -0,0 +1,21 @@
+USING: kernel sequences slots parser words classes ;
+IN: tuple-syntax
+
+! TUPLE: foo bar baz ;
+! TUPLE{ foo bar: 1 baz: 2 }
+
+: parse-object ( -- object )
+    scan-word dup parsing? [ V{ } clone swap execute first ] when ;
+
+: parse-slot-writer ( tuple -- slot-setter )
+    scan dup "}" = [ 2drop f ] [
+        1 head* swap class "slots" word-prop
+        [ slot-spec-name = ] curry* find nip slot-spec-writer
+    ] if ;
+
+: parse-slots ( accum tuple -- accum tuple )
+    dup parse-slot-writer
+    [ parse-object pick rot execute parse-slots ] when* ;
+
+: TUPLE{
+    scan-word construct-empty parse-slots parsed ; parsing