steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

trees.splay: use typed.

db4
John Benediktsson 2013-03-06 18:42:06 -08:00
parent 85d0c607b0
commit e008810677
1 changed files with 20 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
extra/trees/splay/splay.factor
View File

@ -1,8 +1,7 @@
! Copyright (c) 2005 Mackenzie Straight. ! Copyright (c) 2005 Mackenzie Straight.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces sequences assocs parser USING: accessors assocs combinators kernel math.order parser
trees generic math.order accessors prettyprint.custom prettyprint.custom trees trees.private typed ;
trees.private combinators ;
IN: trees.splay IN: trees.splay
TUPLE: splay < tree ; TUPLE: splay < tree ;
@ -12,75 +11,75 @@ TUPLE: splay < tree ;
<PRIVATE <PRIVATE
: rotate-right ( node -- node ) TYPED: rotate-right ( node: node -- node )
dup left>> dup left>>
[ right>> swap left<< ] 2keep [ right>> swap left<< ] 2keep
[ right<< ] keep ; [ right<< ] keep ;
: rotate-left ( node -- node ) TYPED: rotate-left ( node: node -- node )
dup right>> dup right>>
[ left>> swap right<< ] 2keep [ left>> swap right<< ] 2keep
[ left<< ] keep ; [ left<< ] keep ;
: link-right ( left right key node -- left right key node ) TYPED: link-right ( left right key node: node -- left right key node )
swap [ [ swap left<< ] 2keep swap [ [ swap left<< ] 2keep
nip dup left>> ] dip swap ; nip dup left>> ] dip swap ;
: link-left ( left right key node -- left right key node ) TYPED: link-left ( left right key node: node -- left right key node )
swap [ rot [ right<< ] 2keep swap [ rot [ right<< ] 2keep
drop dup right>> swapd ] dip swap ; drop dup right>> swapd ] dip swap ;
: cmp ( key node -- obj node <=> ) : cmp ( key node -- obj node <=> )
2dup key>> <=> ; 2dup key>> <=> ; inline
: lcmp ( key node -- obj node <=> ) : lcmp ( key node -- obj node <=> )
2dup left>> key>> <=> ; 2dup left>> key>> <=> ; inline
: rcmp ( key node -- obj node <=> ) : rcmp ( key node -- obj node <=> )
2dup right>> key>> <=> ; 2dup right>> key>> <=> ; inline
DEFER: (splay) DEFER: (splay)
: splay-left ( left right key node -- left right key node ) TYPED: splay-left ( left right key node: node -- left right key node )
dup left>> [ dup left>> [
lcmp +lt+ = [ rotate-right ] when lcmp +lt+ = [ rotate-right ] when
dup left>> [ link-right (splay) ] when dup left>> [ link-right (splay) ] when
] when ; ] when ;
: splay-right ( left right key node -- left right key node ) TYPED: splay-right ( left right key node: node -- left right key node )
dup right>> [ dup right>> [
rcmp +gt+ = [ rotate-left ] when rcmp +gt+ = [ rotate-left ] when
dup right>> [ link-left (splay) ] when dup right>> [ link-left (splay) ] when
] when ; ] when ;
: (splay) ( left right key node -- left right key node ) TYPED: (splay) ( left right key node: node -- left right key node )
cmp { cmp {
{ +lt+ [ splay-left ] } { +lt+ [ splay-left ] }
{ +gt+ [ splay-right ] } { +gt+ [ splay-right ] }
{ +eq+ [ ] } { +eq+ [ ] }
} case ; } case ;
: assemble ( head left right node -- root ) TYPED: assemble ( head left right node: node -- root )
[ right>> swap left<< ] keep [ right>> swap left<< ] keep
[ left>> swap right<< ] keep [ left>> swap right<< ] keep
[ swap left>> swap right<< ] 2keep [ swap left>> swap right<< ] 2keep
[ swap right>> swap left<< ] keep ; [ swap right>> swap left<< ] keep ;
: splay-at ( key node -- node ) TYPED: splay-at ( key node: node -- node )
[ T{ node } clone dup dup ] 2dip [ T{ node } clone dup dup ] 2dip
(splay) nip assemble ; (splay) nip assemble ;
: do-splay ( key tree -- ) TYPED: do-splay ( key tree: splay -- )
[ root>> splay-at ] keep root<< ; [ root>> splay-at ] keep root<< ;
: splay-split ( key tree -- node node ) TYPED: splay-split ( key tree: splay -- node node )
2dup do-splay root>> cmp +lt+ = [ 2dup do-splay root>> cmp +lt+ = [
nip dup left>> swap f over left<< nip dup left>> swap f over left<<
] [ ] [
nip dup right>> swap f over right<< swap nip dup right>> swap f over right<< swap
] if ; ] if ;
: get-splay ( key tree -- node ? ) TYPED: get-splay ( key tree: splay -- node ? )
2dup do-splay root>> cmp +eq+ = [ 2dup do-splay root>> cmp +eq+ = [
nip t nip t
] [ ] [
@ -96,20 +95,20 @@ DEFER: (splay)
: splay-join ( n2 n1 -- node ) : splay-join ( n2 n1 -- node )
splay-largest [ [ right<< ] keep ] when* ; splay-largest [ [ right<< ] keep ] when* ;
: remove-splay ( key tree -- ) TYPED: remove-splay ( key tree: splay -- )
2dup get-splay [ 2dup get-splay [
dup right>> swap left>> splay-join dup right>> swap left>> splay-join
>>root dec-count drop >>root dec-count drop
] [ 3drop ] if ; ] [ 3drop ] if ;
: set-splay ( value key tree -- ) TYPED: set-splay ( value key tree: splay -- )
2dup get-splay [ 2nip value<< ] [ 2dup get-splay [ 2nip value<< ] [
drop dup inc-count drop dup inc-count
2dup splay-split rot 2dup splay-split rot
[ [ swapd ] dip node boa ] dip root<< [ [ swapd ] dip node boa ] dip root<<
] if ; ] if ;
: new-root ( value key tree -- ) TYPED: new-root ( value key tree: splay -- )
1 >>count 1 >>count
[ swap <node> ] dip root<< ; [ swap <node> ] dip root<< ;