Modernizing the trees library
Daniel Ehrenberg
parent
e1b5a081d2
commit
51b5ec84f6
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <avl> ( -- tree )
|
||||
avl construct-tree ;
|
||||
avl new-tree ;
|
||||
|
||||
TUPLE: avl-node balance ;
|
||||
TUPLE: avl-node < node balance ;
|
||||
|
||||
: <avl-node> ( key value -- node )
|
||||
swap <node> 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) ] [ <avl-node> t ] if* ;
|
||||
[ (avl-set) ] [ swap <avl-node> 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> ;
|
||||
|
||||
: >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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <splay> ( -- 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> ;
|
||||
|
||||
: >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
|
||||
|
|
|
|||
|
|
@ -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> ( -- tree )
|
||||
f 0 tree boa ;
|
||||
tree new-tree ;
|
||||
|
||||
: construct-tree ( class -- tree )
|
||||
new <tree> 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 ;
|
||||
|
||||
: <node> ( 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 <node> ] if* ] change-root ;
|
||||
[ [ node-set ] [ swap <node> ] 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 <tree> ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue