1
0
Fork 0

WIP Initial code

master
Michael Raitza 2019-04-23 09:36:06 +02:00
parent 0f4884bd8b
commit f2c44cae8d
2 changed files with 77 additions and 0 deletions

View File

@ -0,0 +1,8 @@
USING: critbit tools.test ;
IN: critbit.tests
{ t } [ <critbit> empty? ] unit-test
{ 0 } [ 0 0b11111011 direction ] unit-test
{ 1 } [ 4 0b11111011 direction ] unit-test

69
critbit/critbit.factor Normal file
View File

@ -0,0 +1,69 @@
USING: accessors kernel math sequences serialize ;
IN: critbit
TUPLE: critbit root ;
<PRIVATE
: new-critbit ( class -- critbit )
new
f >>root ; inline
PRIVATE>
: <critbit> ( -- critbit )
critbit new-critbit ;
<PRIVATE
TUPLE: node left right { byte# integer } { bits integer } ;
: new-node ( byte# bits class -- node )
new
swap >>byte#
swap >>bits ; inline
: <node> ( byte# bits -- node )
node new-node ;
PRIVATE>
: empty? ( tree -- ? )
root>> f = ; inline
! : walk-crit ( obj node -- ? )
! ;
: direction ( byte bits -- direction )
bitor 1 + -8 shift ;
<PRIVATE
: successor ( bytes node -- bytes successor )
2dup [ byte#>> ] [ bits>> ] bi
[ 2dup swap length < [ swap nth ] [ 2drop 0 ] if ] dip
direction 0 = [ left>> ] [ right>> ] if ;
: walk-critbit ( bytes obj -- bytes obj )
[ dup node? ] [ successor ] while ;
PRIVATE>
: member? ( obj tree -- ? )
dup critbit?
[ [ object>bytes ] [ root>> ] bi* walk-critbit = ]
[ 2drop f ] if ;
: find-byte ( newbytes oldbytes -- x )
2dup [ bitxor dup 0 = ] 2all?
[ [ length ] dip nth ]
[ ] if;
: put ( obj tree -- tree )
dup critbit?
[ dup empty?
[ swap object>bytes >>root ]
[ [ object>bytes ] [ root>> ] bi* walk-critbit
] if ]
[ 2drop "Not a critbit tree" throw ] if ;