From 51b5ec84f623f473bff3e25fab87334e5d863526 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 5 May 2008 01:54:56 -0500 Subject: [PATCH] Modernizing the trees library --- extra/trees/avl/avl-tests.factor | 62 +++++++++++++++----------------- extra/trees/avl/avl.factor | 62 +++++++++++++++++--------------- extra/trees/splay/splay.factor | 8 ++--- extra/trees/trees.factor | 45 +++++++++++------------ 4 files changed, 86 insertions(+), 91 deletions(-) mode change 100644 => 100755 extra/trees/avl/avl-tests.factor mode change 100644 => 100755 extra/trees/splay/splay.factor diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor old mode 100644 new mode 100755 index 570125cb45..5cb6606ce4 --- a/extra/trees/avl/avl-tests.factor +++ b/extra/trees/avl/avl-tests.factor @@ -2,85 +2,79 @@ USING: kernel tools.test trees trees.avl math random sequences assocs ; IN: trees.avl.tests [ "key1" 0 "key2" 0 ] [ - T{ avl-node T{ node f "key1" f f T{ avl-node T{ node f "key2" } 1 } } 2 } + T{ avl-node f "key1" f f T{ avl-node f "key2" f f 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 } + T{ avl-node f "key1" f f T{ avl-node f "key2" f f f 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 } + T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -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 } + T{ avl-node f "key1" f T{ avl-node f "key2" f f f -1 } f -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 - T{ avl-node T{ node f "key3" } 1 } } - -1 } } - 2 } [ double-rotate ] go-left +[ T{ avl-node f "key1" f f + T{ avl-node f "key2" f + T{ avl-node f "key3" f f f 1 } f -1 } 2 } + [ double-rotate ] go-left [ node-left dup node-key swap avl-node-balance ] keep [ node-right dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test [ "key1" 0 "key2" 0 "key3" 0 ] -[ T{ avl-node T{ node f "key1" f f - T{ avl-node T{ node f "key2" f - T{ avl-node T{ node f "key3" } 0 } } - -1 } } - 2 } [ double-rotate ] go-left +[ T{ avl-node f "key1" f f + T{ avl-node f "key2" f + T{ avl-node f "key3" f f f 0 } f -1 } 2 } + [ double-rotate ] go-left [ node-left dup node-key swap avl-node-balance ] keep [ node-right dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test [ "key1" 0 "key2" 1 "key3" 0 ] -[ T{ avl-node T{ node f "key1" f f - T{ avl-node T{ node f "key2" f - T{ avl-node T{ node f "key3" } -1 } } - -1 } } - 2 } [ double-rotate ] go-left +[ T{ avl-node f "key1" f f + T{ avl-node f "key2" f + T{ avl-node f "key3" f f f -1 } f -1 } 2 } + [ double-rotate ] go-left [ node-left dup node-key swap avl-node-balance ] keep [ 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 - T{ avl-node T{ node f "key2" f f - T{ avl-node T{ node f "key3" } -1 } } - 1 } } - -2 } [ double-rotate ] go-right +[ T{ avl-node f "key1" f + T{ avl-node f "key2" f f + T{ avl-node f "key3" f f f -1 } 1 } f -2 } + [ double-rotate ] go-right [ node-right dup node-key swap avl-node-balance ] keep [ node-left dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test [ "key1" 0 "key2" 0 "key3" 0 ] -[ T{ avl-node T{ node f "key1" f - T{ avl-node T{ node f "key2" f f - T{ avl-node T{ node f "key3" } 0 } } - 1 } } - -2 } [ double-rotate ] go-right +[ T{ avl-node f "key1" f + T{ avl-node f "key2" f f + T{ avl-node f "key3" f f f 0 } 1 } f -2 } + [ double-rotate ] go-right [ node-right dup node-key swap avl-node-balance ] keep [ node-left dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test [ "key1" 0 "key2" -1 "key3" 0 ] -[ T{ avl-node T{ node f "key1" f - T{ avl-node T{ node f "key2" f f - T{ avl-node T{ node f "key3" } 1 } } - 1 } } - -2 } [ double-rotate ] go-right +[ T{ avl-node f "key1" f + T{ avl-node f "key2" f f + T{ avl-node f "key3" f f f 1 } 1 } f -2 } + [ double-rotate ] go-right [ node-right dup node-key swap avl-node-balance ] keep [ node-left dup node-key swap avl-node-balance ] keep dup node-key swap avl-node-balance ] unit-test diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor index 3a37ec5fc7..866e035a21 100755 --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -1,33 +1,34 @@ ! 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 prettyprint.backend sequences trees assocs parser -math.order ; +USING: combinators kernel generic math math.functions +math.parser namespaces io prettyprint.backend sequences trees +assocs parser accessors math.order ; IN: trees.avl -TUPLE: avl ; - -INSTANCE: avl tree-mixin +TUPLE: avl < tree ; : ( -- tree ) - avl construct-tree ; + avl new-tree ; -TUPLE: avl-node balance ; +TUPLE: avl-node < node balance ; : ( key value -- node ) - swap 0 avl-node boa tuck set-delegate ; + avl-node new-node + 0 >>balance ; -: change-balance ( node amount -- ) - over avl-node-balance + swap set-avl-node-balance ; +: increase-balance ( node amount -- ) + swap [ + ] change-balance drop ; : rotate ( node -- node ) - dup node+link dup node-link pick set-node+link tuck set-node-link ; + dup node+link dup node-link pick set-node+link + tuck set-node-link ; : single-rotate ( node -- node ) - 0 over set-avl-node-balance 0 over node+link set-avl-node-balance rotate ; + 0 over (>>balance) 0 over node+link + (>>balance) rotate ; : pick-balances ( a node -- balance balance ) - avl-node-balance { + balance>> { { [ dup zero? ] [ 2drop 0 0 ] } { [ over = ] [ neg 0 ] } [ 0 swap ] @@ -36,18 +37,22 @@ TUPLE: avl-node balance ; : double-rotate ( node -- node ) [ node+link [ - node-link current-side get neg over pick-balances rot 0 swap set-avl-node-balance - ] keep set-avl-node-balance - ] keep tuck set-avl-node-balance - dup node+link [ rotate ] with-other-side over set-node+link rotate ; + node-link current-side get neg + over pick-balances rot 0 swap (>>balance) + ] keep (>>balance) + ] keep swap >>balance + dup node+link [ rotate ] with-other-side + over set-node+link rotate ; : select-rotate ( node -- node ) - dup node+link avl-node-balance current-side get = [ double-rotate ] [ single-rotate ] if ; + dup node+link balance>> current-side get = + [ double-rotate ] [ single-rotate ] if ; : balance-insert ( node -- node taller? ) dup avl-node-balance { { [ dup zero? ] [ drop f ] } - { [ dup abs 2 = ] [ sgn neg [ select-rotate ] with-side f ] } + { [ dup abs 2 = ] + [ sgn neg [ select-rotate ] with-side f ] } { [ drop t ] [ t ] } ! balance is -1 or 1, tree is taller } cond ; @@ -57,7 +62,8 @@ DEFER: avl-set 2dup node-key before? left right ? [ [ node-link avl-set ] keep swap >r tuck set-node-link r> - [ dup current-side get change-balance balance-insert ] [ f ] if + [ dup current-side get increase-balance balance-insert ] + [ f ] if ] with-side ; : (avl-set) ( value key node -- node taller? ) @@ -66,10 +72,10 @@ DEFER: avl-set ] [ avl-insert ] if ; : avl-set ( value key node -- node taller? ) - [ (avl-set) ] [ t ] if* ; + [ (avl-set) ] [ swap t ] if* ; M: avl set-at ( value key node -- node ) - [ avl-set drop ] change-root ; + [ avl-set drop ] change-root drop ; : delete-select-rotate ( node -- node shorter? ) dup node+link avl-node-balance zero? [ @@ -87,10 +93,10 @@ M: avl set-at ( value key node -- node ) } cond ; : balance-delete ( node -- node shorter? ) - current-side get over avl-node-balance { + current-side get over balance>> { { [ dup zero? ] [ drop neg over set-avl-node-balance f ] } - { [ dupd = ] [ drop 0 over set-avl-node-balance t ] } - [ dupd neg change-balance rebalance-delete ] + { [ dupd = ] [ drop 0 >>balance t ] } + [ dupd neg increase-balance rebalance-delete ] } cond ; : avl-replace-with-extremity ( to-replace node -- node shorter? ) @@ -135,12 +141,12 @@ M: avl-node avl-delete ( key node -- node shorter? deleted? ) ] if ; M: avl delete-at ( key node -- ) - [ avl-delete 2drop ] change-root ; + [ avl-delete 2drop ] change-root drop ; M: avl new-assoc 2drop ; : >avl ( assoc -- avl ) - T{ avl T{ tree f f 0 } } assoc-clone-like ; + T{ avl f f 0 } assoc-clone-like ; M: avl assoc-like drop dup avl? [ >avl ] unless ; diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor old mode 100644 new mode 100755 index 8931db3a10..ef5fcf8ca6 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -4,12 +4,10 @@ USING: arrays kernel math namespaces sequences assocs parser prettyprint.backend trees generic math.order ; IN: trees.splay -TUPLE: splay ; +TUPLE: splay < tree ; : ( -- tree ) - \ splay construct-tree ; - -INSTANCE: splay tree-mixin + \ splay new-tree ; : rotate-right ( node -- node ) dup node-left @@ -131,7 +129,7 @@ M: splay new-assoc 2drop ; : >splay ( assoc -- tree ) - T{ splay T{ tree f f 0 } } assoc-clone-like ; + T{ splay f f 0 } assoc-clone-like ; : SPLAY{ \ } [ >splay ] parse-literal ; parsing diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 3cad81e447..3b0ab01666 100755 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -5,23 +5,25 @@ prettyprint.private kernel.private assocs random combinators parser prettyprint.backend math.order accessors ; IN: trees -MIXIN: tree-mixin - TUPLE: tree root count ; +: new-tree ( class -- tree ) + new + f >>root + 0 >>count ; inline + : ( -- tree ) - f 0 tree boa ; + tree new-tree ; -: construct-tree ( class -- tree ) - new over set-delegate ; inline - -INSTANCE: tree tree-mixin - -INSTANCE: tree-mixin assoc +INSTANCE: tree assoc TUPLE: node key value left right ; + +: new-node ( key value class -- node ) + new swap >>value swap >>key ; + : ( key value -- node ) - f f node boa ; + node new-node ; SYMBOL: current-side @@ -57,9 +59,6 @@ SYMBOL: current-side : go-left ( quot -- ) left swap with-side ; inline : go-right ( quot -- ) right swap with-side ; inline -: change-root ( tree quot -- ) - swap [ root>> swap call ] keep set-tree-root ; inline - : leaf? ( node -- ? ) [ left>> ] [ right>> ] bi or not ; @@ -91,7 +90,7 @@ M: tree at* ( key tree -- value ? ) ] if ; M: tree set-at ( value key tree -- ) - [ [ node-set ] [ swap ] if* ] change-root ; + [ [ node-set ] [ swap ] if* ] change-root drop ; : valid-node? ( node -- ? ) [ @@ -117,10 +116,10 @@ M: tree set-at ( value key tree -- ) [ >r right>> r> find-node ] } cond ; inline -M: tree-mixin assoc-find ( tree quot -- key value ? ) +M: tree assoc-find ( tree quot -- key value ? ) >r root>> r> find-node ; -M: tree-mixin clear-assoc +M: tree clear-assoc 0 >>count f >>root drop ; @@ -182,7 +181,7 @@ DEFER: delete-node ] if ; M: tree delete-at - [ delete-bst-node ] change-root ; + [ delete-bst-node ] change-root drop ; M: tree new-assoc 2drop ; @@ -192,14 +191,12 @@ M: tree clone dup assoc-clone-like ; : >tree ( assoc -- tree ) T{ tree f f 0 } assoc-clone-like ; -M: tree-mixin assoc-like drop dup tree? [ >tree ] unless ; +M: tree assoc-like drop dup tree? [ >tree ] unless ; : TREE{ \ } [ >tree ] parse-literal ; parsing - + M: tree pprint-delims drop \ TREE{ \ } ; - -M: tree-mixin assoc-size count>> ; -M: tree-mixin clone dup assoc-clone-like ; -M: tree-mixin >pprint-sequence >alist ; -M: tree-mixin pprint-narrow? drop t ; +M: tree assoc-size count>> ; +M: tree >pprint-sequence >alist ; +M: tree pprint-narrow? drop t ;