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

revert some changes in trees

db4
Doug Coleman 2008-04-28 14:42:42 -05:00
parent 61ffc2efe6
commit bd654f8621
1 changed files with 18 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
extra/trees/trees.factor
View File

@ -25,7 +25,17 @@ TUPLE: node key value left right ;
SYMBOL: current-side SYMBOL: current-side
: go-left? ( -- ? ) current-side get +lt+ eq? ; : left ( -- symbol ) -1 ; inline
: right ( -- symbol ) 1 ; inline
: key-side ( k1 k2 -- n )
<=> {
{ +lt+ [ -1 ] }
{ +eq+ [ 0 ] }
{ +gt+ [ 1 ] }
} case ;
: go-left? ( -- ? ) current-side get left eq? ;
: inc-count ( tree -- ) [ 1+ ] change-count drop ; : inc-count ( tree -- ) [ 1+ ] change-count drop ;
@ -43,9 +53,9 @@ SYMBOL: current-side
: with-side ( side quot -- ) [ swap current-side set call ] with-scope ; inline : with-side ( side quot -- ) [ swap current-side set call ] with-scope ; inline
: with-other-side ( quot -- ) : with-other-side ( quot -- )
current-side get invert-comparison swap with-side ; inline current-side get neg swap with-side ; inline
: go-left ( quot -- ) +lt+ swap with-side ; inline : go-left ( quot -- ) left swap with-side ; inline
: go-right ( quot -- ) +gt+ swap with-side ; inline : go-right ( quot -- ) right swap with-side ; inline
: change-root ( tree quot -- ) : change-root ( tree quot -- )
swap [ root>> swap call ] keep set-tree-root ; inline swap [ root>> swap call ] keep set-tree-root ; inline
@ -53,10 +63,10 @@ SYMBOL: current-side
: leaf? ( node -- ? ) : leaf? ( node -- ? )
[ left>> ] [ right>> ] bi or not ; [ left>> ] [ right>> ] bi or not ;
: random-side ( -- side ) +lt+ +gt+ 2array random ; : random-side ( -- side ) left right 2array random ;
: choose-branch ( key node -- key node-left/right ) : choose-branch ( key node -- key node-left/right )
2dup node-key <=> [ node-link ] with-side ; 2dup node-key key-side [ node-link ] with-side ;
: node-at* ( key node -- value ? ) : node-at* ( key node -- value ? )
[ [
@ -71,7 +81,7 @@ M: tree at* ( key tree -- value ? )
root>> node-at* ; root>> node-at* ;
: node-set ( value key node -- node ) : node-set ( value key node -- node )
2dup key>> <=> dup +eq+ eq? [ 2dup key>> key-side dup 0 eq? [
drop nip swap >>value drop nip swap >>value
] [ ] [
[ [
@ -165,7 +175,7 @@ DEFER: delete-node
] if ; ] if ;
: delete-bst-node ( key node -- node ) : delete-bst-node ( key node -- node )
2dup node-key <=> dup +eq+ eq? [ 2dup node-key key-side dup 0 eq? [
drop nip delete-node drop nip delete-node
] [ ] [
[ tuck node-link delete-bst-node over set-node-link ] with-side [ tuck node-link delete-bst-node over set-node-link ] with-side