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

trees, make pop/slurp work for all trees 

It is not as optimized as it could be but it is a simple way
to ensure that the tree properties are maintained.
char-rename
Jon Harper 2017-01-25 15:25:56 +01:00 committed by John Benediktsson
parent e0bd21e24a
commit d800d026de
1 changed files with 13 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
extra/trees/trees.factor
View File

@ -415,34 +415,25 @@ PRIVATE>
<PRIVATE <PRIVATE
: (pop-tree-extremity) ( tree -- node/f ) : pop-tree-extremity ( tree node/f -- node/f )
dup root>> dup node-link dup [
[ (prune-extremity) nip ] [ key>> swap delete-at ] keep node>entry
[ [ delete-node swap root<< ] keep ] if* ;
: pop-tree-extremity ( tree -- node/f )
[ (pop-tree-extremity) ] [ over [ dec-count ] [ drop ] if ] bi
node>entry ;
: slurp-tree ( tree quot: ( ... entry -- ... ) -- ... )
[ drop [ count>> 0 = ] curry ]
[ [ [ pop-tree-extremity ] curry ] dip compose ] 2bi until ; inline
: pop-tree ( tree -- entry )
dup root>> dup [
drop pop-tree-extremity
] [ nip ] if ; ] [ nip ] if ;
:: slurp-tree ( tree quot: ( ... entry -- ... ) getter: ( tree -- node ) -- ... )
[ tree count>> 0 = ]
[ tree getter call quot call ] until ; inline
PRIVATE> PRIVATE>
: pop-tree-left ( tree -- pair/f ) : pop-tree-left ( tree -- node/f )
left [ pop-tree ] with-side ; dup first-node pop-tree-extremity ;
: pop-tree-right ( tree -- pair/f ) : pop-tree-right ( tree -- node/f )
right [ pop-tree ] with-side ; dup last-node pop-tree-extremity ;
: slurp-tree-left ( tree quot: ( ... entry -- ... ) -- ... ) : slurp-tree-left ( tree quot: ( ... entry -- ... ) -- ... )
left [ slurp-tree ] with-side ; inline [ pop-tree-left ] slurp-tree ; inline
: slurp-tree-right ( tree quot: ( ... entry -- ... ) -- ... ) : slurp-tree-right ( tree quot: ( ... entry -- ... ) -- ... )
right [ slurp-tree ] with-side ; inline [ pop-tree-right ] slurp-tree ; inline