Merge http://littledan.onigirihouse.com/factor.git

Conflicts: extra/project-euler/010/010.factor extra/project-euler/018/018.factor extra/project-euler/019/019.factor extra/project-euler/067/067.factor extra/project-euler/project-euler.factor
2007-12-30 22:41:04 -05:00 · 2007-12-30 22:41:04 -05:00 · 2f04bfadbe
parent 41fa14010d bea0eb759a
commit 2f04bfadbe
58 changed files with 1123 additions and 710 deletions
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@ -45,8 +45,10 @@ PROTOCOL: sequence-protocol
    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
--- a/extra/html/elements/elements.factor
+++ b/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 -- )
--- a/extra/html/html.factor
+++ b/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' )
--- a/extra/lazy-lists/lazy-lists-docs.factor
+++ b/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." }
-{ $see-also cons car cdr nil nil? list? } ;
+{ $description "Constructs a cons cell." } ;

 HELP: car
 { $values { "cons" "a cons object" } { "car" "the first item in the list" } }
-{ $description "Returns the first item in the list." } 
-{ $see-also cons cdr nil nil? list? } ;
+{ $description "Returns the first item in the list." } ;

 HELP: cdr
 { $values { "cons" "a cons object" } { "cdr" "a cons object" } }
-{ $description "Returns the tail of the list." } 
-{ $see-also cons car nil nil? list? } ;
+{ $description "Returns the tail of the list." } ;

 HELP: nil 
 { $values { "cons" "An empty cons" } }
-{ $description "Returns a representation of an empty list" } 
-{ $see-also cons car cdr nil? list? } ;
+{ $description "Returns a representation of an empty list" } ;

 HELP: nil? 
 { $values { "cons" "a cons object" } { "?" "a boolean" } }
-{ $description "Return true if the cons object is the nil cons." } 
-{ $see-also cons car cdr nil list? } ;
+{ $description "Return true if the cons object is the nil cons." } ;

 HELP: list? 
 { $values { "object" "an object" } { "?" "a boolean" } }
-{ $description "Returns true if the object conforms to the list protocol." } 
-{ $see-also cons car cdr nil } ;
+{ $description "Returns true if the object conforms to the list protocol." } ;
+
+{ 1list 2list 3list } related-words

 HELP: 1list
 { $values { "obj" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 1 element." } 
-{ $see-also 2list 3list } ;
+{ $description "Create a list with 1 element." } ;

 HELP: 2list
 { $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 2 elements." } 
-{ $see-also 1list 3list } ;
+{ $description "Create a list with 2 elements." } ;

 HELP: 3list
 { $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 3 elements." } 
-{ $see-also 1list 2list } ;
+{ $description "Create a list with 3 elements." } ;

 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." } 
-{ $see-also 2lazy-list 3lazy-list } ;
+{ $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." } ;

 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." } 
-{ $see-also 1lazy-list 3lazy-list } ;
+{ $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." } ;

 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." } 
-{ $see-also 1lazy-list 2lazy-list } ;
+{ $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." } ;

 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." } 
-{ $see-also cons car cdr } ;
+{ $description "Put the head and tail of the list on the stack." } ;
+
+{ 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." } 
-{ $see-also lmap lmap-with ltake lsubset lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ;
+{ $description "Call the quotation for each item in the list." } ;
+
+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." } 
-{ $see-also leach ltake lsubset lappend lmap-with  lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ;
+{ $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." } ;

 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." } 
-{ $see-also leach ltake lsubset lappend lmap lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ;
+{ $description "Variant of " { $link lmap } " which pushes a retained object on each invocation of the quotation." } ;

 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." } 
-{ $see-also leach lmap lmap-with lsubset lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ;
+{ $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." } ;

 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." } 
-{ $see-also leach lmap lmap-with ltake lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ;
+{ $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." } ;

 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." }
-{ $see-also luntil } ;
+{ $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." } ;

 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." }
-{ $see-also lwhile } ;
+{ $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." } ;

 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." } 
-{ $see-also leach lmap lmap-with ltake lsubset lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ;
+{ $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." } ;

 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." } 
-{ $see-also leach lmap lmap-with ltake lsubset lfrom lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge } ;
+{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;

 HELP: lfrom
 { $values { "n" "an integer" } { "list" "a lazy list of integers" } }
-{ $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 } ;
+{ $description "Return an infinite lazy list of incrementing integers starting from n." } ;

 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." } 
-{ $see-also leach lmap lmap-with ltake lsubset lcartesian-product lcartesian-product* lfrom-by lcomp lcomp* lmerge } ;
+{ $description "Concatenates a list of lists together into one list." } ;

 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." } 
-{ $see-also leach lmap lmap-with lconcat ltake lsubset lfrom-by lcartesian-product* lcomp lcomp* lmerge } ;
+{ $description "Given two lists, return a list containing the cartesian product of those lists." } ;

 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." } 
-{ $see-also leach lmap lmap-with lconcat ltake lsubset lfrom-by lcartesian-product lcomp lcomp* lmerge } ;
+{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ;

 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" } "." } 
-{ $see-also leach lmap lmap-with lconcat ltake lsubset lfrom-by lcartesian-product lcomp* lmerge } ;
+{ $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" } "." } ;

 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" } "." } 
+{ $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 } }
--- a/extra/lazy-lists/lazy-lists.factor
+++ b/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
-   rot over call [ 2drop nil ] [ luntil ] if ;
+   [ lazy-until-cons uncons swap ] keep lazy-until-quot tuck call
+   [ 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?
-   [ 2drop nil ] [ swap lazy-while-quot lwhile ] if ;
+   [ lazy-while-cons cdr ] keep lazy-while-quot lwhile ;

 M: lazy-while nil? ( lazy-while -- bool )
-   dup lazy-while-cons nil?
-   [ nip ] [ [ car ] keep lazy-while-quot call not ] if* ;
+   [ car ] keep lazy-while-quot call not ;

 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? [
-    lazy-append-list2 nil?
-  ] [
-    drop f
-  ] if ;
+   drop f ;

 M: lazy-append list? ( object -- bool )
  drop t ;
--- a/extra/math/algebra/algebra-docs.factor
+++ b/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" } "." } ;
--- a/extra/math/algebra/algebra-tests.factor
+++ b/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
--- a/extra/math/algebra/algebra.factor
+++ b/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
--- a/extra/math/algebra/authors.txt
+++ b/extra/math/algebra/authors.txt
@ -0,0 +1 @@
+Samuel Tardieu
--- a/extra/math/algebra/summary.txt
+++ b/extra/math/algebra/summary.txt
@ -0,0 +1 @@
+Various algebra-related words
--- a/extra/math/erato/erato.factor
+++ b/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 ;
--- a/extra/math/primes/authors.txt
+++ b/extra/math/primes/authors.txt
@ -0,0 +1 @@
+Samuel Tardieu
--- a/extra/math/primes/factors/authors.txt
+++ b/extra/math/primes/factors/authors.txt
@ -0,0 +1 @@
+Samuel Tardieu
--- a/extra/math/primes/factors/factors-docs.factor
+++ b/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" } "." } } ;
--- a/extra/math/primes/factors/factors-tests.factor
+++ b/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
--- a/extra/math/primes/factors/factors.factor
+++ b/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
--- a/extra/math/primes/factors/summary.txt
+++ b/extra/math/primes/factors/summary.txt
@ -0,0 +1 @@
+Prime factors decomposition
--- a/extra/math/primes/primes-docs.factor
+++ b/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" } "." } ;
--- a/extra/math/primes/primes-tests.factor
+++ b/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
--- a/extra/math/primes/primes.factor
+++ b/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
--- a/extra/math/primes/summary.txt
+++ b/extra/math/primes/summary.txt
@ -0,0 +1,2 @@
+Prime numbers test and generation
+
--- a/extra/project-euler/003/003.factor
+++ b/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 ;
+  317584931803 largest-prime-factor ;

-! [ euler003 ] 100 ave-time
-! 404 ms run / 9 ms GC ave time - 100 trials
+! [ euler003 ] time
+! 2 ms run / 0 ms GC time

 MAIN: euler003
--- a/extra/project-euler/007/007.factor
+++ b/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 ;
+  10001 nth-prime ;

 ! [ euler007 ] time
-! 19230 ms run / 487 ms GC time
+! 22 ms run / 0 ms GC time

 MAIN: euler007
--- a/extra/project-euler/010/010.factor
+++ b/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
-    namespaces sequences ;
+USING: kernel math.primes sequences ;
 IN: project-euler.010

 ! http://projecteuler.net/index.php?section=problems&id=10
@ -17,12 +16,10 @@ IN: project-euler.010
 ! SOLUTION
 ! --------

-! Sieve of Eratosthenes and lazy summing
-
 : euler010 ( -- answer )
-    0 1000000 lerato [ + ] leach ;
+    1000000 primes-upto sum ;

-! [ euler010 ] time
-! 765 ms run / 7 ms GC time
+! [ euler010 ] 100 ave-time
+! 14 ms run / 0 ms GC ave time - 100 trials

 MAIN: euler010
--- a/extra/project-euler/018/018.factor
+++ b/extra/project-euler/018/018.factor
@ -1,6 +1,6 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel project-euler.common ;
+USING: kernel math project-euler.common sequences ;
 IN: project-euler.018

 ! http://projecteuler.net/index.php?section=problems&id=18
@ -45,9 +45,55 @@ IN: project-euler.018
 ! SOLUTION
 ! --------

+! Propagate from bottom to top the longest cumulative path. This is very
+! efficient and will be reused in problem 67.
+
 <PRIVATE

-: source-018 ( -- triangle )
+: 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 }
@ -66,10 +112,10 @@ IN: project-euler.018

 PRIVATE>

-: euler018 ( -- answer )
-    source-018 max-path ;
+: euler018a ( -- answer )
+    source-018a max-path ;

-! [ euler018 ] 100 ave-time
+! [ euler018a ] 100 ave-time
 ! 0 ms run / 0 ms GC ave time - 100 trials

 MAIN: euler018
--- a/extra/project-euler/019/019.factor
+++ b/extra/project-euler/019/019.factor
@ -1,6 +1,7 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: calendar combinators.lib kernel math namespaces ;
+USING: calendar combinators combinators.lib kernel math math.ranges namespaces
+    sequences ;
 IN: project-euler.019

 ! http://projecteuler.net/index.php?section=problems&id=19
@ -25,6 +26,21 @@ IN: project-euler.019
 ! 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 )
@ -45,10 +61,10 @@ IN: project-euler.019

 PRIVATE>

-: euler019 ( -- answer )
+: euler019a ( -- answer )
    start-date end-date first-days [ zero? ] count ;

-! [ euler019 ] 100 ave-time
+! [ euler019a ] 100 ave-time
 ! 131 ms run / 3 ms GC ave time - 100 trials

 MAIN: euler019
--- a/extra/project-euler/067/067.factor
+++ b/extra/project-euler/067/067.factor
@ -1,7 +1,7 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! 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.common sequences
-    splitting system vocabs ;
+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
@ -32,9 +32,30 @@ IN: project-euler.067
 ! SOLUTION
 ! --------

+! Propagate from bottom to top the longest cumulative path as is done in
+! problem 18.
+
 <PRIVATE

-: (source-067) ( -- path )
+: pyramid ( -- seq )
+  "resource:extra/project-euler/067/triangle.txt" ?resource-path <file-reader>
+  lines [ " " split [ string>number ] map ] map ;
+
+PRIVATE>
+
+: euler067 ( -- best )
+    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" = [
@ -44,18 +65,18 @@ IN: project-euler.067
        ] if
    ] "" make ;

-: source-067 ( -- triangle )
-    (source-067) <file-reader> lines [ " " split [ string>number ] map ] map ;
+: source-067a ( -- triangle )
+    (source-067a) <file-reader> lines [ " " split [ string>number ] map ] map ;

 PRIVATE>

-: euler067 ( -- answer )
-    source-067 max-path ;
+: euler067a ( -- answer )
+    source-067a max-path ;

-! [ euler067 ] 100 ave-time
+! [ euler067a ] 100 ave-time
 ! 15 ms run / 0 ms GC ave time - 100 trials

-! source-067 [ max-path ] curry 100 ave-time
+! source-067a [ max-path ] curry 100 ave-time
 ! 3 ms run / 0 ms GC ave time - 100 trials

-MAIN: euler067
+MAIN: euler067a
--- a/extra/project-euler/134/134.factor
+++ b/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
--- a/extra/project-euler/ave-time/ave-time.factor
+++ b/extra/project-euler/ave-time/ave-time.factor
@ -1,23 +1,21 @@
 ! 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 ;

 PRIVATE>

 : collect-benchmarks ( quot n -- seq )
-    [
-        1- [ [ benchmark ] keep -rot 2array , [ clean-stack ] keep ] times
-    ] curry { } make >r benchmark 2array r> swap add ; inline
+  [
+    >r >r datastack r> [ benchmark 2array , ] curry tuck
+    [ with-datastack drop ] 2curry r> swap times call
+  ] { } make ;

 : ave-time ( quot n -- )
    [ collect-benchmarks ] keep swap ave-benchmarks [
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@ -1,13 +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
-    vocabs vocabs.loader system project-euler.ave-time project-euler.common
+USING: definitions io io.files kernel math.parser sequences vocabs
+    vocabs.loader project-euler.ave-time project-euler.common
    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.017 project-euler.018 project-euler.019 project-euler.020
-    project-euler.021 project-euler.022 project-euler.067 ;
+    project-euler.021 project-euler.022 project-euler.067 project-euler.134 ;
 IN: project-euler

 <PRIVATE
@ -17,22 +17,16 @@ IN: project-euler
    print readln string>number ;

 : number>euler ( n -- str )
-    number>digits 3 0 pad-left [ number>string ] map concat ;
+    number>string 3 CHAR: 0 pad-left ;

-: solution-path ( n -- str )
-    number>euler dup [
-        "project-euler" vocab-root ?resource-path %
-        os "windows" = [
-            "\\project-euler\\" % % "\\" % % ".factor" %
-        ] [
-            "/project-euler/" % % "/" % % ".factor" %
-        ] if
-    ] "" make ;
+: solution-path ( n -- str/f )
+    number>euler "project-euler." swap append
+    vocab where dup [ first ?resource-path ] when ;

 PRIVATE>

 : problem-solved? ( n -- ? )
-    solution-path exists? ;
+    solution-path ;

 : run-project-euler ( -- )
    problem-prompt dup problem-solved? [
--- a/extra/sequences/deep/authors.txt
+++ b/extra/sequences/deep/authors.txt
@ -0,0 +1 @@
+Daniel Ehrenberg
--- a/extra/sequences/deep/deep-docs.factor
+++ b/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." } ;
--- a/extra/sequences/deep/deep-tests.factor
+++ b/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
--- a/extra/sequences/deep/deep.factor
+++ b/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 ;
--- a/extra/sequences/deep/summary.txt
+++ b/extra/sequences/deep/summary.txt
@ -0,0 +1 @@
+Sequence/tree combinators like deep-map, deep-each, etc
--- a/extra/shufflers/shufflers-tests.factor
+++ b/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
--- a/extra/trees/authors.txt
+++ b/extra/trees/authors.txt
@ -1 +1,2 @@
 Alex Chapman
+Daniel Ehrenberg
--- a/extra/trees/avl/authors.txt
+++ b/extra/trees/avl/authors.txt
@ -0,0 +1,2 @@
+Alex Chapman
+Daniel Ehrenberg
--- a/extra/trees/avl/avl-docs.factor
+++ b/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" }
--- a/extra/trees/avl/avl-tests.factor
+++ b/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 ] [ 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" 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 ] [
+    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
-[ t t ] [ f "d" T{ avl-node
-              T{ node f "e" f
-                  T{ avl-node 
-                      T{ node f "b" f
-                          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> "seven" 7 pick set-at
+    "eight" 8 pick set-at "nine" 9 pick set-at
+    tree-root node-value
+] 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" ] [ <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-tree> "seven" 7 pick tree-insert 
-[ t t ] [ <avl-tree> 3 increasing-tree dup valid-avl-tree? swap valid-tree? ] 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
+[ "another eight" ] [ ! ERROR!
+    <avl> "seven" 7 pick set-at
+    "another eight" 8 pick set-at 8 swap at
+] 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>
-    "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 ;
+    AVL{
+        { 7 "seven" }
+        { 9 "nine" }
+        { 4 "four" } 
+        { 4 "replaced four" } 
+        { 7 "replaced seven" }
+    } clone ;

-! test tree-insert, tree-set, tree-get, tree-get*, and tree-get-all
-[ "seven" ] [ <avl-tree> "seven" 7 pick tree-insert 7 swap tree-get ] unit-test
-[ "seven" t ] [ <avl-tree> "seven" 7 pick tree-insert 7 swap tree-get* ] unit-test
-[ f f ] [ <avl-tree> "seven" 7 pick tree-insert 8 swap tree-get* ] unit-test
-[ "seven" ] [ <avl-tree> "seven" 7 pick tree-set 7 swap tree-get ] unit-test
-[ "replacement" ] [ <avl-tree> "seven" 7 pick tree-insert "replacement" 7 pick tree-set 7 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
-[ 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 set-at, at, at*
+[ t ] [ test-tree avl? ] unit-test
+[ "seven" ] [ <avl> "seven" 7 pick set-at 7 swap at ] unit-test
+[ "seven" t ] [ <avl> "seven" 7 pick set-at 7 swap at* ] unit-test
+[ f f ] [ <avl> "seven" 7 pick set-at 8 swap at* ] unit-test
+[ "seven" ] [ <avl> "seven" 7 pick set-at 7 swap at ] unit-test
+[ "replacement" ] [ <avl> "seven" 7 pick set-at "replacement" 7 pick set-at 7 swap at ] unit-test
+[ "nine" ] [ test-tree 9 swap at ] unit-test
+[ "replaced four" ] [ test-tree 4 swap at ] unit-test
+[ "replaced seven" ] [ test-tree 7 swap at ] 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
--- a/extra/trees/avl/avl.factor
+++ b/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
-sequences trees ;
+USING: combinators kernel generic math math.functions math.parser
+namespaces io prettyprint.backend sequences trees assocs parser ;
 IN: trees.avl

-TUPLE: avl-tree ;
+TUPLE: avl ;

-: <avl-tree> ( -- tree )
-    avl-tree construct-empty <tree> over set-delegate ;
+INSTANCE: avl assoc
+
+: <avl> ( -- tree )
+    avl construct-empty <tree> over set-delegate ;

 TUPLE: avl-node balance ;

-: <avl-node> ( value key -- node )
-    <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 ;
+: <avl-node> ( key value -- node )
+    swap <node> 0 avl-node construct-boa tuck set-delegate ;

 : 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? )
-    "setting" get [ avl-set ] [ avl-insert ] if ;
+: avl-set ( value key node -- node taller? )
+    [ (avl-set) ] [ <avl-node> t ] if* ;

-: (avl-insert) ( value key node -- node taller? )
-    [ avl-insert-or-set ] [ <avl-node> t ] if* ;
-
-: 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 ;
+M: avl set-at ( value key node -- node )
+    [ avl-set drop ] change-root ;

 : 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> [
-            balance-delete
-        ] [
-            f
-        ] if
+        dupd [ avl-replace-with-extremity ] with-other-side
+        >r over set-node-link r> [ balance-delete ] [ 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 )
-    #! deletes until there are no more. not optimal.
-    dupd [ avl-delete nip ] with-scope [
-        node-delete-all
-    ] [
-        nip
-    ] if ;
+M: avl new-assoc 2drop <avl> ;

-M: avl-node print-node ( depth node -- )
-    over 1+ over node-right print-node
-    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 ;
+: >avl ( assoc -- avl )
+    T{ avl T{ tree f f 0 } } assoc-clone-like ;

+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 ;
--- a/extra/trees/avl/summary.txt
+++ b/extra/trees/avl/summary.txt
@ -0,0 +1 @@
+Balanced AVL trees
--- a/extra/trees/binary/binary-tests.factor
+++ b/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
-
--- a/extra/trees/binary/binary.factor
+++ b/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 ;
-
--- a/extra/trees/splay/authors.txt
+++ b/extra/trees/splay/authors.txt
@ -1 +1 @@
-Mackenzie Straight
+Mackenzie Straight, Daniel Ehrenberg
--- a/extra/trees/splay/splay-docs.factor
+++ b/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" }
--- a/extra/trees/splay/splay-tests.factor
+++ b/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
--- a/extra/trees/splay/splay.factor
+++ b/extra/trees/splay/splay.factor
@ -1,59 +1,56 @@
 ! Copyright (c) 2005 Mackenzie Straight.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math combinators assocs parser ;
+! See http://factor.sf.net/license.txt for BSD license.
+USING: arrays kernel math namespaces sequences assocs parser
+prettyprint.backend trees generic ;
 IN: trees.splay

-TUPLE: splay-tree r count ;
-INSTANCE: splay-tree assoc
+TUPLE: splay ;

-: <splay-tree> ( -- splay-tree )
-    0 { set-splay-tree-count } splay-tree construct ;
+: <splay> ( -- splay-tree )
+    \ splay construct-empty
+    <tree> over set-delegate ;

-<PRIVATE
-
-TUPLE: splay-node v k l r ;
-
-C: <splay-node> splay-node 
+INSTANCE: splay assoc

 : rotate-right ( node -- node )
-    dup splay-node-l
-    [ splay-node-r swap set-splay-node-l ] 2keep
-    [ set-splay-node-r ] keep ;
+    dup node-left
+    [ node-right swap set-node-left ] 2keep
+    [ set-node-right ] keep ;
                                                        
 : rotate-left ( node -- node )
-    dup splay-node-r
-    [ splay-node-l swap set-splay-node-r ] 2keep
-    [ set-splay-node-l ] keep ;
+    dup node-right
+    [ node-left swap set-node-right ] 2keep
+    [ set-node-left ] keep ;

 : link-right ( left right key node -- left right key node )
-    swap >r [ swap set-splay-node-l ] 2keep
-    nip dup splay-node-l r> swap ;
+    swap >r [ swap set-node-left ] 2keep
+    nip dup node-left r> swap ;

 : link-left ( left right key node -- left right key node )
-    swap >r rot [ set-splay-node-r ] 2keep
-    drop dup splay-node-r swapd r> swap ;
+    swap >r rot [ set-node-right ] 2keep
+    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
-    [ splay-node-l swap set-splay-node-r ] keep
-    [ swap splay-node-l swap set-splay-node-r ] 2keep
-    [ swap splay-node-r swap set-splay-node-l ] keep ;
+    [ node-right swap set-node-left ] keep
+    [ node-left swap set-node-right ] keep
+    [ swap node-left swap set-node-right ] 2keep
+    [ 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 < [
-        nip dup splay-node-l swap f over set-splay-node-l
+    2dup splay tree-root cmp 0 < [
+        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 ? )
-    2dup splay splay-tree-r cmp 0 = [
+: get-splay ( key tree -- node ? )
+    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 -- )
-    tuck (get-splay) nip [
-        dup splay-tree-count 1- over set-splay-tree-count
-        dup splay-node-r swap splay-node-l splay-join
-        swap set-splay-tree-r
+: remove-splay ( key tree -- )
+    tuck get-splay nip [
+        dup dec-count
+        dup node-right swap node-left splay-join
+        swap set-tree-root
    ] [ drop ] if* ;

-: (set-splay) ( value key tree -- )
-    2dup (get-splay) [ 2nip set-splay-node-v ] [
-       drop dup splay-tree-count 1+ over set-splay-tree-count
+: set-splay ( value key tree -- )
+    2dup get-splay [ 2nip set-node-value ] [
+       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
-    >r f f <splay-node> r> set-splay-tree-r ;
+    [ 1 swap set-tree-count ] keep
+    >r swap <node> r> set-tree-root ;

-: splay-call ( splay-node call -- )
-    >r [ splay-node-k ] keep splay-node-v r> call ; inline
-    
-: (splay-tree-traverse) ( splay-node quot -- key value ? )
-    {
-        { [ over not ] [ 2drop f f f ] }
-        { [ [
-              >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
+M: splay set-at ( value key tree -- )
+    dup tree-root [ set-splay ] [ new-root ] if ;

-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>
+M: splay at* ( key tree -- value ? )
+    dup tree-root [
+        get-splay >r dup [ node-value ] when r>
    ] [
        2drop f f
    ] if ;

-M: splay-tree delete-at ( key tree -- )
-    dup splay-tree-r [ (remove-splay) ] [ 2drop ] if ;
+M: splay delete-at ( key tree -- )
+    dup tree-root [ remove-splay ] [ 2drop ] if ;

-M: splay-tree new-assoc
-    2drop <splay-tree> ;
+M: splay new-assoc
+    2drop <splay> ;

-: >splay-tree ( assoc -- splay-tree )
-    T{ splay-tree f f 0 } assoc-clone-like ;
+: >splay ( assoc -- splay-tree )
+    T{ splay T{ tree f f 0 } } assoc-clone-like ;

-: S{
-    \ } [ >splay-tree ] parse-literal ; parsing
+: SPLAY{
+    \ } [ >splay ] parse-literal ; parsing

-M: splay-tree assoc-like
-    drop dup splay-tree? [ >splay-tree ] unless ;
+M: splay assoc-like
+    drop dup splay? [
+        dup tree? [ <splay> tuck set-delegate ] [ >splay ] if
+    ] unless ;

-M: splay-tree clear-assoc
-    0 over set-splay-tree-count
-    f swap set-splay-tree-r ;
+M: splay pprint-delims drop \ SPLAY{ \ } ;

-M: splay-tree assoc-size
-    splay-tree-count ;
-
-USE: prettyprint.backend
-M: splay-tree pprint-delims drop \ S{ \ } ;
-M: splay-tree >pprint-sequence >alist ;
-M: splay-tree pprint-narrow? drop t ;
+! When tuple inheritance is used, the following lines won't be necessary
+M: splay assoc-size tree-count ;
+M: splay clear-assoc delegate clear-assoc ;
+M: splay assoc-find >r tree-root r> find-node ;
+M: splay clone dup assoc-clone-like ;
+M: splay >pprint-sequence >alist ;
+M: splay pprint-narrow? drop t ;
--- a/extra/trees/summary.txt
+++ b/extra/trees/summary.txt
@ -1 +1 @@
-Binary search and avl (balanced) trees
+Binary search trees
--- a/extra/trees/todo.txt
+++ b/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
--- a/extra/trees/trees-docs.factor
+++ b/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" }
--- a/extra/trees/trees-tests.factor
+++ b/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
+
--- a/extra/trees/trees.factor
+++ b/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
-namespaces.private random layouts ;
+USING: kernel generic math sequences arrays io namespaces
+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> ( value key -- node )
-    swap f f node construct-boa ;
+: <node> ( key value -- node )
+    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
-: set-node-link@ ( -- ? quot quot ) go-left? [ set-node-left ] [ set-node-right ] ; inline
+: inc-count ( tree -- )
+    dup tree-count 1+ swap set-tree-count ;

-: node-link ( node -- child ) node-link@ if ;
-: set-node-link ( child node -- ) set-node-link@ if ;
-: node+link ( node -- child ) node-link@ swap if ;
-: set-node+link ( child node -- ) set-node-link@ swap if ;
+: dec-count ( tree -- )
+    dup tree-count 1- swap set-tree-count ;

-: 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 -- )
-
-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> ;
+: leaf? ( node -- ? )
+    dup node-left swap node-right or not ;

 : 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 ? )
+    [
+        2dup node-key key= [
+            nip node-value t
+        ] [
+            choose-branch node-at*
+        ] if
+    ] [ drop f f ] if* ;

-: tree-get ( key tree -- value ) tree-root node-get ;
+M: tree at* ( key tree -- value ? )
+    tree-root node-at* ;

-M: node node-get ( key node -- value )
-    2dup node-key key= [
-        nip node-value
+: node-set ( value key node -- node )
+    2dup node-key key-side dup zero? [
+        drop nip [ set-node-value ] keep
    ] [
-        choose-branch node-get
+        [
+            [ node-link [ node-set ] [ swap <node> ] if* ] keep
+            [ set-node-link ] keep
+        ] with-side
    ] if ;

-M: f node-get ( key f -- f ) nip ;
+M: tree set-at ( value key tree -- )
+    [ [ node-set ] [ swap <node> ] if* ] change-root ;

-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*
-    ] if ;
-
-M: f node-get* ( key f -- f f ) nip f ;
-
-GENERIC: node-get-all ( key node -- seq )
-
-: tree-get-all ( key tree -- seq ) tree-root node-get-all ;
-
-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
-    ] if ;
-
-GENERIC: node-insert ( value key node -- node ) ! can add duplicates
-
-: tree-insert ( value key tree -- )
-    [ 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 ;
+: 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
+    ] [ 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
+ 
+: find-node ( node quot -- key value ? )
+    {
+        { [ 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

-: random-tree ( tree size -- tree )
-    [ most-positive-fixnum random pick tree-set ] each ;
+M: tree assoc-find ( tree quot -- key value ? )
+    >r tree-root r> find-node ;

-: increasing-tree ( tree size -- tree )
-    [ dup pick tree-set ] each ;
+M: tree clear-assoc
+    0 over set-tree-count
+    f swap set-tree-root ;

-: decreasing-tree ( tree size -- tree )
-    reverse increasing-tree ;
+M: tree assoc-size
+    tree-count ;

-GENERIC: print-node ( depth node -- )
+: copy-node-contents ( new old -- )
+    dup node-key pick set-node-key node-value swap set-node-value ;

-M: f print-node ( depth f -- ) 2drop ;
+! Deletion
+DEFER: delete-node

-M: node print-node ( depth node -- )
-    ! not pretty, but ok for debugging
-    over 1+ over node-right print-node
-    over [ drop "   " write ] each dup node-key number>string print
-    >r 1+ r> node-left print-node ;
+: (prune-extremity) ( parent node -- new-extremity )
+    dup node-link [
+        rot drop (prune-extremity)
+    ] [
+        tuck delete-node swap set-node-link
+    ] if* ;

-: print-tree ( tree -- )
-    tree-root 1 swap print-node ;
+: 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) ;

-: stump? ( tree -- ? )
-    #! is this tree empty?
-    tree-root not ;
+: 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 ;
--- a/extra/xml/data/data.factor
+++ b/extra/xml/data/data.factor
@ -96,10 +96,10 @@ CONSULT: sequence-protocol tag tag-children ;
 INSTANCE: tag sequence

 M: tag like
-    over tag? [
+    over tag? [ drop ] [
        [ delegate ] keep tag-attrs
        rot dup [ V{ } like ] when <tag>
-    ] unless ;
+    ] if ;

 M: tag clone
    [ delegate clone ] keep [ tag-attrs clone ] keep
--- a/extra/xml/test/templating.factor
+++ b/extra/xml/test/templating.factor
@ -40,4 +40,4 @@ M: object (r-ref) drop ;
        sample-doc string>xml dup template xml>string
    ] with-scope ;

-[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><html xmlns:f=\"http://littledan.onigirihouse.com/namespaces/replace\"><body><span f:sub=\"foo\">foo</span><div f:sub=\"bar\">blah<a/></div><p f:sub=\"baz\"/></body></html>" ] [ test-refs ] unit-test
+[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<html xmlns:f=\"http://littledan.onigirihouse.com/namespaces/replace\"><body><span f:sub=\"foo\">foo</span><div f:sub=\"bar\">blah<a/></div><p f:sub=\"baz\"/></body></html>" ] [ test-refs ] unit-test
--- a/extra/xml/test/test.factor
+++ b/extra/xml/test/test.factor
@ -26,7 +26,7 @@ SYMBOL: xml-file
 ] unit-test
 [ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test
 [ "that" ] [ xml-file get "this" swap at ] unit-test
-[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><a b=\"c\"/>" ]
+[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<a b=\"c\"/>" ]
    [ "<a b='c'/>" string>xml xml>string ] unit-test
 [ "abcd" ] [
    "<main>a<sub>bc</sub>d<nothing/></main>" string>xml
@ -44,5 +44,7 @@ SYMBOL: xml-file
    at swap "z" >r tuck r> swap set-at
    T{ name f "blah" "z" f } swap at ] unit-test
 [ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
-[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><foo>bar baz</foo>" ]
+[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<foo>bar baz</foo>" ]
 [ "<foo>bar</foo>" string>xml [ " baz" append ] map xml>string ] unit-test
+[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<foo>\n  bar\n</foo>" ]
+[ "<foo>         bar            </foo>" string>xml pprint-xml>string ] unit-test
--- a/extra/xml/writer/writer.factor
+++ b/extra/xml/writer/writer.factor
@ -4,18 +4,60 @@ USING: hashtables kernel math namespaces sequences strings
 io io.streams.string xml.data assocs ;
 IN: xml.writer

-: write-entities
+SYMBOL: xml-pprint?
+SYMBOL: sensitive-tags
+SYMBOL: indentation
+SYMBOL: indenter
+"  " indenter set-global
+
+: sensitive? ( tag -- ? )
+    sensitive-tags get swap [ names-match? ] curry contains? ;
+
+: ?indent ( -- )
+    xml-pprint? get [
+        nl indentation get indenter get <repetition> [ write ] each
+    ] when ;
+
+: indent ( -- )
+    xml-pprint? get [ 1 indentation +@ ] when ;
+
+: unindent ( -- )
+    xml-pprint? get [ -1 indentation +@ ] when ;
+
+: trim-whitespace ( string -- no-whitespace )
+    [ [ blank? not ] find drop 0 or ] keep
+    [ [ blank? not ] find-last drop [ 1+ ] [ 0 ] if* ] keep
+    subseq ;
+
+: ?filter-children ( children -- no-whitespace )
+    xml-pprint? get [
+        [ dup string? [ trim-whitespace ] when ] map
+        [ dup empty? swap string? and not ] subset
+    ] when ;
+
+: entities-out
    H{
        { CHAR: < "&lt;"   }
        { CHAR: > "&gt;"   }
        { CHAR: & "&amp;"  }
+    } ;
+
+: quoted-entities-out
+    H{
+        { CHAR: & "&amp;"  }
        { CHAR: ' "&apos;" }
        { CHAR: " "&quot;" }
    } ;

-: chars>entities ( str -- str )
+: escape-string-by ( str table -- escaped )
    #! Convert <, >, &, ' and " to HTML entities.
-    [ [ dup write-entities at [ % ] [ , ] ?if ] each ] "" make ;
+    [ [ dupd at [ % ] [ , ] ?if ] curry each ] "" make ;
+
+: escape-string ( str -- newstr )
+    entities-out escape-string-by ;
+
+: escape-quoted-string ( str -- newstr )
+    quoted-entities-out escape-string-by ;

 : print-name ( name -- )
    dup name-space f like
@ -27,27 +69,35 @@ IN: xml.writer
        " " write
        swap print-name
        "=\"" write
-        chars>entities write
+        escape-quoted-string write
        "\"" write
    ] assoc-each ;

 GENERIC: write-item ( object -- )

 M: string write-item
-    chars>entities write ;
+    escape-string write ;
+
+: write-tag ( tag -- )
+    CHAR: < write1
+    dup print-name tag-attrs print-attrs ;

 M: contained-tag write-item
-    CHAR: < write1
-    dup print-name tag-attrs print-attrs
-    "/>" write ;
+    write-tag "/>" write ;
+
+: write-children ( tag -- )
+    indent tag-children ?filter-children
+    [ ?indent write-item ] each unindent ;
+
+: write-end-tag ( tag -- )
+    ?indent "</" write print-name CHAR: > write1 ;

 M: open-tag write-item
-    CHAR: < write1
-    dup print-name
-    dup tag-attrs print-attrs
-    CHAR: > write1
-    dup tag-children [ write-item ] each
-    "</" write print-name CHAR: > write1 ;
+    xml-pprint? [ [
+        over sensitive? not and xml-pprint? set
+        dup write-tag CHAR: > write1
+        dup write-children write-end-tag
+    ] keep ] change ;

 M: comment write-item
    "<!--" write comment-text write "-->" write ;
@ -62,7 +112,7 @@ M: instruction write-item
    "<?xml version=\"" write dup prolog-version write
    "\" encoding=\"" write dup prolog-encoding write
    prolog-standalone [ "\" standalone=\"yes" write ] when
-    "\"?>" write ;
+    "\"?>\n" write ;

 : write-chunk ( seq -- )
    [ write-item ] each ;
@ -79,3 +129,22 @@ M: instruction write-item
 : xml>string ( xml -- string )
    [ write-xml ] string-out ;

+: with-xml-pprint ( sensitive-tags quot -- )
+    [
+        swap [ assure-name ] map sensitive-tags set
+        0 indentation set
+        xml-pprint? on
+        call
+    ] with-scope ; inline
+
+: pprint-xml-but ( xml sensitive-tags -- )
+    [ print-xml ] with-xml-pprint ;
+
+: pprint-xml ( xml -- )
+    f pprint-xml-but ;
+
+: pprint-xml>string-but ( xml sensitive-tags -- string )
+    [ xml>string ] with-xml-pprint ;
+
+: pprint-xml>string ( xml -- string )
+    f pprint-xml>string-but ;
--- a/extra/xml/xml-docs.factor
+++ b/extra/xml/xml-docs.factor
@ -7,14 +7,29 @@ strings sequences io ;
 HELP: string>xml
 { $values { "string" "a string" } { "xml" "an xml document" } }
 { $description "converts a string into an " { $link xml }
-    " datatype for further processing" }
-{ $see-also xml>string xml-reprint } ;
+    " datatype for further processing" } ;
+
+HELP: read-xml
+{ $values { "stream" "a stream that supports readln" }
+    { "xml" "an XML document" } }
+{ $description "exausts the given stream, reading an XML document from it" } ;
+
+HELP: file>xml
+{ $values { "filename" "a string representing a filename" }
+    { "xml" "an XML document" } }
+{ $description "opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree" } ;
+
+{ string>xml read-xml file>xml } related-words

 HELP: xml>string
 { $values { "xml" "an xml document" } { "string" "a string" } }
 { $description "converts an xml document (" { $link xml } ") into a string" }
-{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" }
-{ $see-also string>xml xml-reprint write-xml } ;
+{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
+
+HELP: pprint-xml>string
+{ $values { "xml" "an xml document" } { "string" "a string" } }
+{ $description "converts an xml document (" { $link xml } ") into a string in a prettyprinted form." }
+{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;

 HELP: xml-parse-error
 { $class-description "the exception class that all parsing errors in XML documents are in." } ;
@ -22,20 +37,34 @@ HELP: xml-parse-error
 HELP: xml-reprint
 { $values { "string" "a string of XML" } }
 { $description "parses XML and prints it out again, for testing purposes" }
-{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" }
-{ $see-also write-xml xml>string string>xml } ;
+{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;

 HELP: write-xml
 { $values { "xml" "an XML document" } }
 { $description "prints the contents of an XML document (" { $link xml } ") to stdio" }
-{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" }
-{ $see-also xml>string xml-reprint read-xml } ;
+{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;

-HELP: read-xml
-{ $values { "stream" "a stream that supports readln" }
-    { "xml" "an XML document" } }
-{ $description "exausts the given stream, reading an XML document from it" }
-{ $see-also write-xml string>xml } ;
+HELP: print-xml
+{ $values { "xml" "an XML document" } }
+{ $description "prints the contents of an XML document (" { $link xml } ") to stdio, followed by a newline" }
+{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
+
+HELP: pprint-xml
+{ $values { "xml" "an XML document" } }
+{ $description "prints the contents of an XML document (" { $link xml } ") to stdio in a prettyprinted form." }
+{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
+
+HELP: pprint-xml-but
+{ $values { "xml" "an XML document" } { "sensitive-tags" "a sequence of names" } }
+{ $description "Prettyprints an XML document, leaving the whitespace of the tags with names in sensitive-tags intact." }
+{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
+
+HELP: pprint-xml>string-but
+{ $values { "xml" "an XML document" } { "sensitive-tags" "a sequence of names" } { "string" string } }
+{ $description "Prettyprints an XML document, returning the result as a string and leaving the whitespace of the tags with names in sensitive-tags intact." }
+{ $notes "does not preserve what type of quotes were used or what data was omitted from version declaration" } ;
+
+{ xml>string print-xml write-xml pprint-xml xml-reprint pprint-xml>string pprint-xml>string-but pprint-xml-but } related-words

 HELP: PROCESS:
 { $syntax "PROCESS: word" }
@ -318,26 +347,27 @@ HELP: with-html-entities
 { $description "calls the given quotation using HTML entity values" }
 { $see-also html-entities with-entities } ;

-HELP: file>xml
-{ $values { "filename" "a string representing a filename" }
-    { "xml" "an XML document" } }
-{ $description "opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree" }
-{ $see-also string>xml read-xml } ;
-
-ARTICLE: { "xml" "basic" } "Basic words for XML processing"
-    "These are the most basic words needed for processing an XML document"
-    $nl
-    "Parsing XML:"
+ARTICLE: { "xml" "reading" } "Reading XML"
+    "The following words are used to read something into an XML document"
    { $subsection string>xml }
    { $subsection read-xml }
    { $subsection xml-chunk }
-    { $subsection file>xml }
-    "Printing XML"
-    { $subsection xml>string }
-    { $subsection write-xml }
+    { $subsection file>xml } ;
+
+ARTICLE: { "xml" "writing" } "Writing XML"
+    "These words are used in implementing prettyprint"
    { $subsection write-item }
    { $subsection write-chunk }
-    "Other"
+    "These words are used to print XML normally"
+    { $subsection xml>string }
+    { $subsection write-xml }
+    { $subsection print-xml }
+    "These words are used to prettyprint XML"
+    { $subsection pprint-xml>string }
+    { $subsection pprint-xml>string-but }
+    { $subsection pprint-xml }
+    { $subsection pprint-xml-but }
+    "This word reads and writes XML"
    { $subsection xml-reprint } ;

 ARTICLE: { "xml" "classes" } "XML data classes"
@ -433,7 +463,8 @@ ARTICLE: { "xml" "intro" } "XML"
    "The XML module attempts to implement the XML 1.1 standard, converting strings of text into XML and vice versa. It currently is a work in progress."
    $nl
    "The XML module was implemented by Daniel Ehrenberg, with contributions from the Factor community"
-    { $subsection { "xml" "basic" } }
+    { $subsection { "xml" "reading" } }
+    { $subsection { "xml" "writing" } }
    { $subsection { "xml" "classes" } }
    { $subsection { "xml" "construct" } }
    { $subsection { "xml" "utils" } }
				`@ -0,0 +1 @@`
				`Sequence/tree combinators like deep-map, deep-each, etc`