From b9d9f3e2bd67cbd3efee5d9f703a3737834619d3 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 4 May 2010 18:10:34 -0500 Subject: [PATCH] Cleaning up trees code a little bit --- extra/trees/avl/avl-tests.factor | 2 +- extra/trees/avl/avl.factor | 18 ++++++++++----- extra/trees/splay/splay.factor | 38 +++++++++++++++++++------------- extra/trees/trees.factor | 23 ++++++++++++++----- 4 files changed, 54 insertions(+), 27 deletions(-) diff --git a/extra/trees/avl/avl-tests.factor b/extra/trees/avl/avl-tests.factor index f9edc9c3b8..41a6310a64 100644 --- a/extra/trees/avl/avl-tests.factor +++ b/extra/trees/avl/avl-tests.factor @@ -1,5 +1,5 @@ USING: kernel tools.test trees trees.avl math random sequences -assocs accessors ; +assocs accessors trees.avl.private trees.private ; IN: trees.avl.tests [ "key1" 0 "key2" 0 ] [ diff --git a/extra/trees/avl/avl.factor b/extra/trees/avl/avl.factor index 4903307af1..401ac205d6 100644 --- a/extra/trees/avl/avl.factor +++ b/extra/trees/avl/avl.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel generic math math.functions math.parser namespaces io sequences trees shuffle -assocs parser accessors math.order prettyprint.custom ; +assocs parser accessors math.order prettyprint.custom +trees.private ; IN: trees.avl TUPLE: avl < tree ; @@ -10,6 +11,8 @@ TUPLE: avl < tree ; : ( -- tree ) avl new-tree ; + ( key value -- node ) @@ -20,11 +23,14 @@ TUPLE: avl-node < node balance ; 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 + [ set-node-link ] keep ; : single-rotate ( node -- node ) - 0 over (>>balance) 0 over node+link + 0 >>balance + 0 over node+link (>>balance) rotate ; : pick-balances ( a node -- balance balance ) @@ -61,7 +67,7 @@ DEFER: avl-set : avl-insert ( value key node -- node taller? ) 2dup key>> before? left right ? [ [ node-link avl-set ] keep swap - [ tuck set-node-link ] dip + [ [ set-node-link ] keep ] dip [ dup current-side get increase-balance balance-insert ] [ f ] if ] with-side ; @@ -146,6 +152,8 @@ M: avl delete-at ( key node -- ) M: avl new-assoc 2drop ; +PRIVATE> + : >avl ( assoc -- avl ) T{ avl f f 0 } assoc-clone-like ; diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index 67b2f6b624..79c19416a0 100644 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -1,7 +1,8 @@ ! Copyright (c) 2005 Mackenzie Straight. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math namespaces sequences assocs parser -trees generic math.order accessors prettyprint.custom shuffle ; +trees generic math.order accessors prettyprint.custom +trees.private combinators ; IN: trees.splay TUPLE: splay < tree ; @@ -9,6 +10,8 @@ TUPLE: splay < tree ; : ( -- tree ) \ splay new-tree ; +> [ right>> swap (>>left) ] 2keep @@ -27,32 +30,35 @@ TUPLE: splay < tree ; swap [ rot [ (>>right) ] 2keep drop dup right>> swapd ] dip swap ; -: cmp ( key node -- obj node -1/0/1 ) - 2dup key>> key-side ; +: cmp ( key node -- obj node <=> ) + 2dup key>> <=> ; -: lcmp ( key node -- obj node -1/0/1 ) - 2dup left>> key>> key-side ; +: lcmp ( key node -- obj node <=> ) + 2dup left>> key>> <=> ; -: rcmp ( key node -- obj node -1/0/1 ) - 2dup right>> key>> key-side ; +: rcmp ( key node -- obj node <=> ) + 2dup right>> key>> <=> ; DEFER: (splay) : splay-left ( left right key node -- left right key node ) dup left>> [ - lcmp 0 < [ rotate-right ] when + lcmp +lt+ = [ rotate-right ] when dup left>> [ link-right (splay) ] when ] when ; : splay-right ( left right key node -- left right key node ) dup right>> [ - rcmp 0 > [ rotate-left ] when + rcmp +gt+ = [ rotate-left ] when dup right>> [ link-left (splay) ] when ] when ; : (splay) ( left right key node -- left right key node ) - cmp dup 0 < - [ drop splay-left ] [ 0 > [ splay-right ] when ] if ; + cmp { + { +lt+ [ splay-left ] } + { +gt+ [ splay-right ] } + { +eq+ [ ] } + } case ; : assemble ( head left right node -- root ) [ right>> swap (>>left) ] keep @@ -64,18 +70,18 @@ DEFER: (splay) [ T{ node } clone dup dup ] 2dip (splay) nip assemble ; -: splay ( key tree -- ) +: do-splay ( key tree -- ) [ root>> splay-at ] keep (>>root) ; : splay-split ( key tree -- node node ) - 2dup splay root>> cmp 0 < [ + 2dup do-splay root>> cmp +lt+ = [ nip dup left>> swap f over (>>left) ] [ nip dup right>> swap f over (>>right) swap ] if ; : get-splay ( key tree -- node ? ) - 2dup splay root>> cmp 0 = [ + 2dup do-splay root>> cmp +eq+ = [ nip t ] [ 2drop f f @@ -95,7 +101,7 @@ DEFER: (splay) ] if* ; : remove-splay ( key tree -- ) - tuck get-splay nip [ + [ get-splay nip ] keep [ dup dec-count dup right>> swap left>> splay-join swap (>>root) @@ -128,6 +134,8 @@ M: splay delete-at ( key tree -- ) M: splay new-assoc 2drop ; +PRIVATE> + : >splay ( assoc -- tree ) T{ splay f f 0 } assoc-clone-like ; diff --git a/extra/trees/trees.factor b/extra/trees/trees.factor index 77e5e5bdc0..821aceaab1 100644 --- a/extra/trees/trees.factor +++ b/extra/trees/trees.factor @@ -2,22 +2,27 @@ ! 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 -shuffle ; +parser math.order accessors deques make prettyprint.custom ; IN: trees TUPLE: tree root count ; +>root 0 >>count ; inline +PRIVATE> + : ( -- tree ) tree new-tree ; INSTANCE: tree assoc +> key-side dup 0 eq? [ drop nip delete-node ] [ - [ tuck node-link delete-bst-node over set-node-link ] with-side + [ + [ node-link delete-bst-node ] + [ set-node-link ] + [ ] tri + ] with-side ] if ; +PRIVATE> + M: tree delete-at [ delete-bst-node ] change-root drop ;