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] 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* ;