From 6d0d6ac80a6d9ff58cc0a591d329b65163272c1a Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-9.local>
Date: Wed, 21 Nov 2007 23:56:50 -0600
Subject: [PATCH 1/5] Non-working change in trees--should be followed by other
 tree patches

---
 extra/trees/splay/splay.factor | 162 ++++++++-------------
 extra/trees/trees.factor       | 259 +++++++++++++++------------------
 2 files changed, 183 insertions(+), 238 deletions(-)

diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor
index 4249bbd564..f83cf15d1f 100644
--- a/extra/trees/splay/splay.factor
+++ b/extra/trees/splay/splay.factor
@@ -1,59 +1,53 @@
 ! 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
-
-: <splay-tree> ( -- splay-tree )
-    0 { set-splay-tree-count } splay-tree construct ;
-
-<PRIVATE
-
-TUPLE: splay-node v k l r ;
-
-C: <splay-node> splay-node 
+TUPLE: splay ;
+: <splay> ( -- splay-tree )
+    splay construct-empty
+    <tree> over set-delegate ;
 
 : 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 +55,88 @@ 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 = [
+    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
+        dup tree-count 1- over set-tree-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
+    2dup (get-splay) [ 2nip set-node-value ] [
+       drop dup tree-count 1+ over set-tree-count
        2dup splay-split rot
-       >r <splay-node> r> set-splay-tree-r
+       >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 <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-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 ;
+M: splay pprint-delims drop \ SPLAY{ \ } ;
diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor
index 0d49cb54d1..372d9b2501 100644
--- a/extra/trees/trees.factor
+++ b/extra/trees/trees.factor
@@ -1,17 +1,16 @@
 ! 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 ;
 IN: trees
 
-TUPLE: tree root ;
-
-: <tree> ( -- tree ) tree construct-empty ;
+TUPLE: tree root count ;
+: <tree> ( -- tree )
+    f 0 tree construct-boa ;
 
 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 +19,26 @@ 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
+: 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 ) 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 ;
+: 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 -- ) H{ } clone >n swap current-side set call ndrop ; inline
+: 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 +53,121 @@ 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
+    ] [ 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 ] [ <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 ] [ <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 ;

From d5baea215d3e886315ec2738d01a02615a4d49c7 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Tue, 25 Dec 2007 02:28:55 -0500
Subject: [PATCH 2/5] Splay tree fixes

---
 extra/trees/splay/splay-tests.factor |  8 +++----
 extra/trees/splay/splay.factor       | 36 ++++++++++++++++++----------
 extra/trees/trees.factor             | 10 +++++++-
 3 files changed, 36 insertions(+), 18 deletions(-)

diff --git a/extra/trees/splay/splay-tests.factor b/extra/trees/splay/splay-tests.factor
index f3548947a8..eb2dafb1d2 100644
--- 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
diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor
index f83cf15d1f..dd40a77501 100644
--- a/extra/trees/splay/splay.factor
+++ b/extra/trees/splay/splay.factor
@@ -5,10 +5,13 @@ prettyprint.backend trees generic ;
 IN: trees.splay
 
 TUPLE: splay ;
+
 : <splay> ( -- splay-tree )
-    splay construct-empty
+    \ splay construct-empty
     <tree> over set-delegate ;
 
+INSTANCE: splay assoc
+
 : rotate-right ( node -- node )
     dup node-left
     [ node-right swap set-node-left ] 2keep
@@ -74,7 +77,7 @@ DEFER: (splay)
         nip dup node-right swap f over set-node-right swap
     ] if ;
 
-: (get-splay) ( key tree -- node ? )
+: get-splay ( key tree -- node ? )
     2dup splay tree-root cmp 0 = [
         nip t
     ] [
@@ -94,36 +97,36 @@ DEFER: (splay)
         drop f
     ] if* ;
 
-: (remove-splay) ( key tree -- )
-    tuck (get-splay) nip [
-        dup tree-count 1- over set-tree-count
+: 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-node-value ] [
-       drop dup tree-count 1+ over set-tree-count
+: set-splay ( value key tree -- )
+    2dup get-splay [ 2nip set-node-value ] [
+       drop dup inc-count
        2dup splay-split rot
-       >r node construct-boa r> set-tree-root
+       >r >r swapd r> node construct-boa r> set-tree-root
     ] if ;
 
 : new-root ( value key tree -- )
     [ 1 swap set-tree-count ] keep
-    >r <node> r> set-tree-root ;
+    >r swap <node> r> set-tree-root ;
 
 M: splay set-at ( value key tree -- )
-    dup tree-root [ (set-splay) ] [ new-root ] if ;
+    dup tree-root [ set-splay ] [ new-root ] if ;
 
 M: splay at* ( key tree -- value ? )
     dup tree-root [
-        (get-splay) >r dup [ node-value ] when r>
+        get-splay >r dup [ node-value ] when r>
     ] [
         2drop f f
     ] if ;
 
 M: splay delete-at ( key tree -- )
-    dup tree-root [ (remove-splay) ] [ 2drop ] if ;
+    dup tree-root [ remove-splay ] [ 2drop ] if ;
 
 M: splay new-assoc
     2drop <splay> ;
@@ -140,3 +143,10 @@ M: splay assoc-like
     ] unless ;
 
 M: splay pprint-delims drop \ SPLAY{ \ } ;
+M: splay >pprint-sequence >alist ;
+M: splay 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 ;
diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor
index 372d9b2501..8c88e6f159 100644
--- a/extra/trees/trees.factor
+++ b/extra/trees/trees.factor
@@ -8,6 +8,8 @@ TUPLE: tree root count ;
 : <tree> ( -- tree )
     f 0 tree construct-boa ;
 
+INSTANCE: tree assoc
+
 TUPLE: node key value left right ;
 : <node> ( key value -- node )
     f f node construct-boa ;
@@ -19,6 +21,12 @@ SYMBOL: current-side
 
 : go-left? ( -- ? ) current-side get left = ;
 
+: inc-count ( tree -- )
+    dup tree-count 1+ swap set-tree-count ;
+
+: dec-count ( tree -- )
+    dup tree-count 1- swap set-tree-count ;
+
 : node-link@ ( node ? -- node )
     go-left? xor [ node-left ] [ node-right ] if ;
 : set-node-link@ ( left parent ? -- ) 
@@ -60,7 +68,7 @@ SYMBOL: current-side
         ] [
             choose-branch node-at*
         ] if
-    ] [ f f ] if* ;
+    ] [ drop f f ] if* ;
 
 M: tree at* ( key tree -- value ? )
     tree-root node-at* ;

From 05b76f181f6671eaec45d146a5ba372a6b6cf16d Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Thu, 27 Dec 2007 13:56:03 -0500
Subject: [PATCH 3/5] Extra/trees changes

---
 extra/trees/avl/avl-tests.factor | 130 ++++++++++++++-----------------
 extra/trees/avl/avl.factor       | 113 +++++++++++----------------
 extra/trees/trees.factor         |  13 +++-
 3 files changed, 116 insertions(+), 140 deletions(-)

diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor
index aba97ad043..5cea2c1c35 100644
--- 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,37 @@ 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
-
-[ 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
+[ "another eight" ] [
+    <avl> "seven" 7 pick set-at
+    "another eight" 8 pick set-at 8 swap at
+] 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>
+    "seven"          7 pick set-at
+    "nine"           9 pick set-at
+    "four"           4 pick set-at
+    "replaced four"  4 pick set-at
+    "replaced seven" 7 pick set-at ;
 
-! 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*
+[ "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
+[ 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
diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor
index 654a078a23..03741b5ecd 100644
--- 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-insert) ( value key node -- node taller? )
+    [ avl-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 ;
 
 : 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-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-node 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,33 @@ 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 ;
 
+: AVL{
+    \ } [ >avl ] parse-literal ; parsing
+
+M: avl pprint-delims drop \ AVL{ \ } ;
+M: avl >pprint-sequence >alist ;
+M: avl pprint-narrow? drop t ;
+
+! 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 ;
diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor
index 8c88e6f159..55031f77cb 100644
--- a/extra/trees/trees.factor
+++ b/extra/trees/trees.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel generic math sequences arrays io namespaces
-prettyprint.private kernel.private assocs random combinators ;
+prettyprint.private kernel.private assocs random combinators
+parser prettyprint.backend ;
 IN: trees
 
 TUPLE: tree root count ;
@@ -179,3 +180,13 @@ DEFER: delete-node
 
 M: tree delete-at
     [ delete-bst-node ] change-root ;
+
+: >tree ( assoc -- bst )
+    T{ tree f f 0 } assoc-clone-like ;
+
+: TREE{
+    \ } [ >tree ] parse-literal ; parsing
+
+M: tree pprint-delims drop \ TREE{ \ } ;
+M: tree >pprint-sequence >alist ;
+M: tree pprint-narrow? drop t ;

From 8a562bc81fe5a427c20a1ee4488256af1b24d713 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Thu, 27 Dec 2007 20:16:55 -0500
Subject: [PATCH 4/5] Trees on the assoc protocol

---
 extra/trees/authors.txt                |  1 +
 extra/trees/avl/authors.txt            |  2 +
 extra/trees/avl/avl-docs.factor        | 27 ++++++++
 extra/trees/avl/avl-tests.factor       | 19 +++---
 extra/trees/avl/avl.factor             | 23 ++++---
 extra/trees/avl/summary.txt            |  1 +
 extra/trees/binary/binary-tests.factor | 45 -------------
 extra/trees/binary/binary.factor       | 88 --------------------------
 extra/trees/splay/authors.txt          |  2 +-
 extra/trees/splay/splay-docs.factor    | 27 ++++++++
 extra/trees/splay/splay.factor         |  5 +-
 extra/trees/summary.txt                |  2 +-
 extra/trees/todo.txt                   |  2 -
 extra/trees/trees-docs.factor          | 27 ++++++++
 extra/trees/trees-tests.factor         | 28 ++++++++
 extra/trees/trees.factor               | 18 +++++-
 16 files changed, 156 insertions(+), 161 deletions(-)
 create mode 100644 extra/trees/avl/authors.txt
 create mode 100644 extra/trees/avl/avl-docs.factor
 create mode 100644 extra/trees/avl/summary.txt
 delete mode 100644 extra/trees/binary/binary-tests.factor
 delete mode 100644 extra/trees/binary/binary.factor
 create mode 100644 extra/trees/splay/splay-docs.factor
 delete mode 100644 extra/trees/todo.txt
 create mode 100644 extra/trees/trees-docs.factor
 create mode 100644 extra/trees/trees-tests.factor

diff --git a/extra/trees/authors.txt b/extra/trees/authors.txt
index e9c193bac7..39c1f37d37 100644
--- a/extra/trees/authors.txt
+++ b/extra/trees/authors.txt
@@ -1 +1,2 @@
 Alex Chapman
+Daniel Ehrenberg
diff --git a/extra/trees/avl/authors.txt b/extra/trees/avl/authors.txt
new file mode 100644
index 0000000000..39c1f37d37
--- /dev/null
+++ b/extra/trees/avl/authors.txt
@@ -0,0 +1,2 @@
+Alex Chapman
+Daniel Ehrenberg
diff --git a/extra/trees/avl/avl-docs.factor b/extra/trees/avl/avl-docs.factor
new file mode 100644
index 0000000000..12465eec98
--- /dev/null
+++ 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" }
diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor
index 5cea2c1c35..0964ea7e56 100644
--- a/extra/trees/avl/avl-tests.factor
+++ b/extra/trees/avl/avl-tests.factor
@@ -91,21 +91,22 @@ IN: temporary
     tree-root node-value
 ] unit-test
 
-[ "another eight" ] [
+[ "another eight" ] [ ! ERROR!
     <avl> "seven" 7 pick set-at
     "another eight" 8 pick set-at 8 swap at
 ] unit-test
 
-! borrowed from tests/bst.factor
 : test-tree ( -- tree )
-    <avl>
-    "seven"          7 pick set-at
-    "nine"           9 pick set-at
-    "four"           4 pick set-at
-    "replaced four"  4 pick set-at
-    "replaced seven" 7 pick set-at ;
+    AVL{
+        { 7 "seven" }
+        { 9 "nine" }
+        { 4 "four" } 
+        { 4 "replaced four" } 
+        { 7 "replaced seven" }
+    } clone ;
 
 ! 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
@@ -115,7 +116,7 @@ IN: temporary
 [ "replaced four" ] [ test-tree 4 swap at ] unit-test
 [ "replaced seven" ] [ test-tree 7 swap at ] unit-test
 
-! test delete-at
+! 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
diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor
index 03741b5ecd..0c4bf5af28 100644
--- a/extra/trees/avl/avl.factor
+++ b/extra/trees/avl/avl.factor
@@ -52,22 +52,22 @@ TUPLE: avl-node balance ;
 
 DEFER: avl-set
 
-: (avl-insert) ( value key node -- node taller? )
-    [ avl-set ] [ <avl-node> t ] if* ;
-
 : avl-insert ( value key node -- node taller? )
     2dup node-key key< left right ? [
-        [ node-link (avl-insert) ] keep swap
+        [ 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? )
+: (avl-set) ( value key node -- node taller? )
     2dup node-key key= [
         -rot pick set-node-key over set-node-value f
     ] [ avl-insert ] if ;
 
-M: avl-node set-at ( value key node -- node )
+: avl-set ( value key node -- node taller? )
+    [ (avl-set) ] [ <avl-node> t ] if* ;
+
+M: avl set-at ( value key node -- node )
     [ avl-set drop ] change-root ;
 
 : delete-select-rotate ( node -- node shorter? )
@@ -136,20 +136,23 @@ M: avl-node avl-delete ( key node -- node shorter? deleted? )
 M: avl delete-at ( key node -- )
     [ avl-delete 2drop ] change-root ;
 
-M: avl new-assoc
-    2drop <avl> ;
+M: avl new-assoc 2drop <avl> ;
 
 : >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{ \ } ;
-M: avl >pprint-sequence >alist ;
-M: avl pprint-narrow? drop t ;
 
 ! 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 ;
diff --git a/extra/trees/avl/summary.txt b/extra/trees/avl/summary.txt
new file mode 100644
index 0000000000..c2360c2ed3
--- /dev/null
+++ b/extra/trees/avl/summary.txt
@@ -0,0 +1 @@
+Balanced AVL trees
diff --git a/extra/trees/binary/binary-tests.factor b/extra/trees/binary/binary-tests.factor
deleted file mode 100644
index 7abf2f0da5..0000000000
--- a/extra/trees/binary/binary-tests.factor
+++ /dev/null
@@ -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
-
diff --git a/extra/trees/binary/binary.factor b/extra/trees/binary/binary.factor
deleted file mode 100644
index 5fc7abc636..0000000000
--- a/extra/trees/binary/binary.factor
+++ /dev/null
@@ -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 ;
-
diff --git a/extra/trees/splay/authors.txt b/extra/trees/splay/authors.txt
index 09839c9c91..a2c0a7cc80 100644
--- a/extra/trees/splay/authors.txt
+++ b/extra/trees/splay/authors.txt
@@ -1 +1 @@
-Mackenzie Straight
+Mackenzie Straight, Daniel Ehrenberg
diff --git a/extra/trees/splay/splay-docs.factor b/extra/trees/splay/splay-docs.factor
new file mode 100644
index 0000000000..b621155e73
--- /dev/null
+++ 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" }
diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor
index dd40a77501..5f7c50cfb2 100644
--- a/extra/trees/splay/splay.factor
+++ b/extra/trees/splay/splay.factor
@@ -143,10 +143,11 @@ M: splay assoc-like
     ] unless ;
 
 M: splay pprint-delims drop \ SPLAY{ \ } ;
-M: splay >pprint-sequence >alist ;
-M: splay 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 ;
diff --git a/extra/trees/summary.txt b/extra/trees/summary.txt
index cf7b64c8a1..18ad35db8f 100644
--- a/extra/trees/summary.txt
+++ b/extra/trees/summary.txt
@@ -1 +1 @@
-Binary search and avl (balanced) trees
+Binary search trees
diff --git a/extra/trees/todo.txt b/extra/trees/todo.txt
deleted file mode 100644
index 7eb295302a..0000000000
--- a/extra/trees/todo.txt
+++ /dev/null
@@ -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
diff --git a/extra/trees/trees-docs.factor b/extra/trees/trees-docs.factor
new file mode 100644
index 0000000000..12bae4bac5
--- /dev/null
+++ 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" }
diff --git a/extra/trees/trees-tests.factor b/extra/trees/trees-tests.factor
new file mode 100644
index 0000000000..2795b0d5da
--- /dev/null
+++ 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
+
diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor
index 55031f77cb..971c961cbc 100644
--- a/extra/trees/trees.factor
+++ b/extra/trees/trees.factor
@@ -79,13 +79,13 @@ M: tree at* ( key tree -- value ? )
         drop nip [ set-node-value ] keep
     ] [
         [
-            [ node-link [ node-set ] [ <node> ] if* ] keep
+            [ node-link [ node-set ] [ swap <node> ] if* ] keep
             [ set-node-link ] keep
         ] with-side
     ] if ;
 
 M: tree set-at ( value key tree -- )
-    [ [ node-set ] [ <node> ] if* ] change-root ;
+    [ [ node-set ] [ swap <node> ] if* ] change-root ;
 
 : valid-node? ( node -- ? )
     [
@@ -181,9 +181,21 @@ DEFER: delete-node
 M: tree delete-at
     [ delete-bst-node ] change-root ;
 
-: >tree ( assoc -- bst )
+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
 

From c9368951606704deb541c1795e63ac2c9d38f2f0 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Thu, 27 Dec 2007 21:03:12 -0500
Subject: [PATCH 5/5] sequences.deep bug fix

---
 extra/sequences/deep/deep.factor | 9 ++++-----
 1 file changed, 4 insertions(+), 5 deletions(-)

diff --git a/extra/sequences/deep/deep.factor b/extra/sequences/deep/deep.factor
index 6e36878b78..c55647bbcb 100644
--- a/extra/sequences/deep/deep.factor
+++ b/extra/sequences/deep/deep.factor
@@ -5,11 +5,10 @@ IN: sequences.deep
 
 ! All traversal goes in postorder
 
-GENERIC: branch? ( object -- ? )
-M: sequence branch? drop t ;
-M: string branch? drop f ;
-M: number branch? drop f ;
-M: object branch? drop f ;
+: branch? ( object -- ? )
+    dup sequence? [
+        dup string? swap number? or not
+    ] [ drop f ] if ;
 
 : deep-each ( obj quot -- )
     [ call ] 2keep over branch?