trees: some cleanup.

diff --git a/extra/trees/splay/splay-tests.factor b/extra/trees/splay/splay-tests.factor
index deabe23973b0801c0c709fd1fc061ce9bc79887b..b108f23824dc9ab6a253888f2ccb144b7a6c4fb7 100644 (file)
--- a/extra/trees/splay/splay-tests.factor
+++ b/extra/trees/splay/splay-tests.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2005 Mackenzie Straight.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel tools.test trees.splay math namespaces assocs
-sequences random sets make grouping ;
+USING: assocs grouping kernel math random sequences sets
+tools.test trees.splay ;
 IN: trees.splay.tests
 
 : randomize-numeric-splay-tree ( splay-tree -- )
@@ -10,29 +10,29 @@ IN: trees.splay.tests
 : make-numeric-splay-tree ( n -- splay-tree )
     iota <splay> [ [ conjoin ] curry each ] keep ;
 
-[ t ] [
+{ t } [
     100 make-numeric-splay-tree dup randomize-numeric-splay-tree
-    [ [ drop , ] assoc-each ] { } make [ < ] monotonic?
+    [ drop ] { } assoc>map [ < ] monotonic?
 ] unit-test
 
-[ 10 ] [ 10 make-numeric-splay-tree keys length ] unit-test
-[ 10 ] [ 10 make-numeric-splay-tree values length ] unit-test
+{ 10 } [ 10 make-numeric-splay-tree keys length ] unit-test
+{ 10 } [ 10 make-numeric-splay-tree values length ] unit-test
 
-[ f ] [ <splay> f 4 pick set-at 4 of ] unit-test
+{ f } [ <splay> f 4 pick set-at 4 of ] unit-test
 
 ! Ensure that f can be a value
-[ t ] [ <splay> 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" } }
-] [
 {
-    { 4 "d" } { 5 "e" } { 6 "f" }
-    { 1 "a" } { 2 "b" } { 3 "c" }
-} >splay >alist
+    { { 1 "a" } { 2 "b" } { 3 "c" } { 4 "d" } { 5 "e" } { 6 "f" } }
+} [
+    {
+        { 4 "d" } { 5 "e" } { 6 "f" }
+        { 1 "a" } { 2 "b" } { 3 "c" }
+    } >splay >alist
 ] unit-test
 
-[ 0 ] [
+{ 0 } [
     100 iota [ dup zip >splay ] keep
     [ over delete-at ] each assoc-size
 ] unit-test

diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor
index b70caa585e9fa740d3b3aebbb57e09b74d3a4621..79a4fc2b6baeb83ee3d74c74b1978521628862cf 100644 (file)
--- a/extra/trees/splay/splay.factor
+++ b/extra/trees/splay/splay.factor
@@ -12,30 +12,28 @@ TUPLE: splay < tree ;
 <PRIVATE
 
 TYPED: rotate-right ( node: node -- node )
-    dup left>>
-    [ right>> swap left<< ] 2keep
-    [ right<< ] keep ;
+    dup left>> [ >>left ] change-right ;
 
 TYPED: rotate-left ( node: node -- node )
-    dup right>>
-    [ left>> swap right<< ] 2keep
-    [ left<< ] keep ;
+    dup right>> [ >>right ] change-left ;
 
 TYPED: link-right ( left right key node: node -- left right key node )
-    swap [ [ swap left<< ] 2keep
-    nip dup left>> ] dip swap ;
+    swap [
+        [ swap left<< ] [ ] [ left>> ] tri
+    ] dip swap ;
 
 TYPED: link-left ( left right key node: node -- left right key node )
-    swap [ rot [ right<< ] 2keep
-    drop dup right>> swapd ] dip swap ;
+    swap [
+        [ rot right<< ] [ ] [ right>> ] tri swapd
+    ] dip swap ;
 
-: cmp ( key node -- obj node <=> )
+: cmp ( key node -- key node <=> )
     2dup key>> <=> ; inline
 
-: lcmp ( key node -- obj node <=> ) 
+: lcmp ( key node -- key node <=> )
     2dup left>> key>> <=> ; inline
 
-: rcmp ( key node -- obj node <=> ) 
+: rcmp ( key node -- key node <=> )
     2dup right>> key>> <=> ; inline
 
 DEFER: (splay)
@@ -60,23 +58,25 @@ TYPED: (splay) ( left right key node: node -- left right key node )
     } case ;
 
 TYPED: assemble ( head left right node: node -- root )
-    [ right>> swap left<< ] keep
-    [ left>> swap right<< ] keep
-    [ swap left>> swap right<< ] 2keep
-    [ swap right>> swap left<< ] keep ;
+    {
+        [ right>> swap left<< ]
+        [ left>> swap right<< ]
+        [ over left>> swap right<< ]
+        [ swap right>> swap left<< ]
+        [ ]
+    } cleave ;
 
 TYPED: splay-at ( key node: node -- node )
-    [ T{ node } clone dup dup ] 2dip
-    (splay) nip assemble ;
+    [ T{ node } clone dup dup ] 2dip (splay) nip assemble ;
 
 TYPED: do-splay ( key tree: splay -- )
     [ root>> splay-at ] keep root<< ;
 
 TYPED: splay-split ( key tree: splay -- node node )
     2dup do-splay root>> cmp +lt+ = [
-        nip dup left>> swap f over left<<
+        nip [ left>> ] [ f >>left ] bi
     ] [
-        nip dup right>> swap f over right<< swap
+        nip [ right>> ] [ f >>right ] bi swap
     ] if ;
 
 TYPED: get-splay ( key tree: splay -- node ? )
@@ -97,32 +97,35 @@ TYPED: get-splay ( key tree: splay -- node ? )
 
 TYPED: remove-splay ( key tree: splay -- )
     2dup get-splay [
-        dup right>> swap left>> splay-join
+        [ right>> ] [ left>> ] bi splay-join
         >>root dec-count drop
-    ] [ 3drop ] if ;
+    ] [
+        3drop
+    ] if ;
 
 TYPED: set-splay ( value key tree: splay -- )
-    2dup get-splay [ 2nip value<< ] [
-       drop dup inc-count
-       2dup splay-split rot
-       [ [ swapd ] dip node boa ] dip root<<
+    2dup get-splay [
+        2nip value<<
+    ] [
+        drop dup inc-count
+        2dup splay-split rot
+        [ [ swap ] 2dip node boa ] dip root<<
     ] if ;
 
 TYPED: new-root ( value key tree: splay -- )
-    1 >>count
-    [ swap <node> ] dip root<< ;
+    [ swap <node> ] [ 1 >>count root<< ] bi* ;
 
-M: splay set-at ( value key tree -- )
+M: splay set-at
     dup root>> [ set-splay ] [ new-root ] if ;
 
-M: splay at* ( key tree -- value ? )
+M: splay at*
     dup root>> [
         get-splay [ dup [ value>> ] when ] dip
     ] [
         2drop f f
     ] if ;
 
-M: splay delete-at ( key tree -- )
+M: splay delete-at
     dup root>> [ remove-splay ] [ 2drop ] if ;
 
 M: splay new-assoc

diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor
index 76a8e39d8337be9623160b2dd2eac802ad9120bb..b182d67aa673b5652c42803e3484c52233a821e1 100644 (file)
--- a/extra/trees/trees.factor
+++ b/extra/trees/trees.factor
@@ -1,8 +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
-parser math.order accessors deques make prettyprint.custom ;
+USING: accessors arrays assocs combinators
+combinators.short-circuit kernel make math math.order namespaces
+parser prettyprint.custom random ;
 IN: trees
 
 TUPLE: tree root { count integer } ;
@@ -40,9 +40,9 @@ CONSTANT: right 1
 
 : key-side ( k1 k2 -- n )
     <=> {
-        { +lt+ [ -1 ] }
+        { +lt+ [ left ] }
         { +eq+ [ 0 ] }
-        { +gt+ [ 1 ] }
+        { +gt+ [ right ] }
     } case ;
 
 : go-left? ( -- ? ) current-side get left eq? ;
@@ -54,7 +54,7 @@ CONSTANT: right 1
 : node-link@ ( node ? -- node )
     go-left? xor [ left>> ] [ right>> ] if ;
 
-: set-node-link@ ( left parent ? -- ) 
+: set-node-link@ ( left parent ? -- )
     go-left? xor [ left<< ] [ right<< ] if ;
 
 : node-link ( node -- child ) f node-link@  ;
@@ -76,10 +76,10 @@ CONSTANT: right 1
 : go-right ( quot -- ) right swap with-side ; inline
 
 : leaf? ( node -- ? )
-    [ left>> ] [ right>> ] bi or not ;
+    { [ left>> not ] [ right>> not ] } 1&& ;
 
 : random-side ( -- side )
-    left right 2array random ;
+    2 random 0 eq? left right ? ;
 
 : choose-branch ( key node -- key node-left/right )
     2dup key>> key-side [ node-link ] with-side ;
@@ -93,7 +93,7 @@ CONSTANT: right 1
         ] if
     ] [ drop f f ] if* ;
 
-M: tree at* ( key tree -- value ? )
+M: tree at*
     root>> node-at* ;
 
 : node-set ( value key node -- node )
@@ -106,15 +106,17 @@ M: tree at* ( key tree -- value ? )
         ] with-side
     ] if ;
 
-M: tree set-at ( value key tree -- )
+M: tree set-at
     [ [ node-set ] [ swap <node> ] if* ] change-root drop ;
 
 : valid-node? ( node -- ? )
     [
-        dup dup left>> [ key>> swap key>> before? ] when*
-        [
-        dup dup right>> [ key>> swap key>> after? ] when* ] dip and swap
-        dup left>> valid-node? swap right>> valid-node? and and
+        {
+            [ dup left>> [ key>> swap key>> before? ] when* ]
+            [ dup right>> [ key>> swap key>> after? ] when* ]
+            [ left>> valid-node? ]
+            [ right>> valid-node? ]
+        } 1&&
     ] [ t ] if* ;
 
 : valid-tree? ( tree -- ? ) root>> valid-node? ;
@@ -127,7 +129,8 @@ M: tree set-at ( value key tree -- )
         tri
     ] when* ;
 
-M: tree >alist [ root>> (node>alist) ] { } make ;
+M: tree >alist
+    [ root>> (node>alist) ] { } make ;
 
 M: tree clear-assoc
     0 >>count
@@ -170,19 +173,15 @@ DEFER: delete-node
 
 : delete-node ( node -- node )
     #! delete this node, returning its replacement
-    dup left>> [
-        dup right>> [
-            delete-node-with-two-children
+    dup [ right>> ] [ left>> ] bi [
+        swap [
+            drop delete-node-with-two-children
         ] [
-            left>> ! left but no right
+            nip ! left but no right
         ] if
     ] [
-        dup right>> [
-            right>> ! right but not left
-        ] [
-            drop f ! no children
-        ] if
-    ] if ;
+        nip ! right but no left, or no children
+    ] if* ;
 
 : delete-bst-node ( key node -- node )
     2dup key>> key-side dup 0 eq? [
@@ -212,7 +211,7 @@ M: tree assoc-like drop dup tree? [ >tree ] unless ;
 
 SYNTAX: TREE{
     \ } [ >tree ] parse-literal ;
-                                                        
+
 M: tree assoc-size count>> ;
 M: tree pprint-delims drop \ TREE{ \ } ;
 M: tree >pprint-sequence >alist ;