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/interval/authors.txt b/extra/trees/interval/authors.txt new file mode 100755 index 0000000000..504363d316 --- /dev/null +++ b/extra/trees/interval/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/trees/interval/interval-tests.factor b/extra/trees/interval/interval-tests.factor new file mode 100755 index 0000000000..ef3cf08895 --- /dev/null +++ b/extra/trees/interval/interval-tests.factor @@ -0,0 +1,21 @@ +USING: kernel namespaces trees.avl trees.interval tools.test ; +IN: trees.interval.test + +SYMBOL: test + + test set + +[ f ] [ 2 test get interval-at ] unit-test +[ ] [ 2 1 test get add-single ] unit-test +[ 2 ] [ 1 test get interval-at ] unit-test +[ f ] [ 2 test get interval-at ] unit-test +[ f ] [ 0 test get interval-at ] unit-test + +[ ] [ 3 4 8 test get add-range ] unit-test +[ 3 ] [ 5 test get interval-at ] unit-test +[ 3 ] [ 8 test get interval-at ] unit-test +[ 3 ] [ 4 test get interval-at ] unit-test +[ f ] [ 9 test get interval-at ] unit-test +[ 2 ] [ 1 test get interval-at ] unit-test +[ f ] [ 2 test get interval-at ] unit-test +[ f ] [ 0 test get interval-at ] unit-test diff --git a/extra/trees/interval/interval.factor b/extra/trees/interval/interval.factor new file mode 100755 index 0000000000..9b3b4a4c6c --- /dev/null +++ b/extra/trees/interval/interval.factor @@ -0,0 +1,42 @@ +! Copyright (c) 2008 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: trees trees.avl kernel math accessors math.intervals +math.order assocs ; +IN: trees.interval + +TUPLE: int-node interval max-under value ; +: ( value start end -- int-node ) + [ [a,b] ] keep rot int-node boa ; + +: interval-choose-branch ( key node -- key left/right ) + dup left>> [ + max-under>> pick >= [ left>> ] [ right>> ] if + ] [ right>> ] if* ; + +: (interval-at*) ( key node -- value ? ) + [ + 2dup value>> interval>> interval-contains? + [ nip value>> value>> t ] + [ interval-choose-branch (interval-at*) ] if + ] [ drop f f ] if* ; + +: interval-at* ( key tree -- value ? ) + root>> (interval-at*) ; + +: interval-at ( key tree -- value ) interval-at* drop ; +: interval-key? ( key tree -- ? ) interval-at* nip ; + +: update-max-under ( max key node -- ) + ! The outer conditional shouldn't be necessary + [ + 2dup key>> = [ 3drop ] [ + [ nip value>> [ max ] change-max-under drop ] + [ choose-branch update-max-under ] 3bi + ] if + ] [ 2drop ] if* ; + +: add-range ( value start end tree -- ) + [ >r over >r r> r> set-at ] + [ root>> swapd update-max-under ] 3bi ; + +: add-single ( value key tree -- ) dupd add-range ; diff --git a/extra/trees/interval/summary.txt b/extra/trees/interval/summary.txt new file mode 100755 index 0000000000..e4f4ad152f --- /dev/null +++ b/extra/trees/interval/summary.txt @@ -0,0 +1 @@ +Interval trees for disjoint closed ranges 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 ;