109 lines
2.7 KiB
Factor
109 lines
2.7 KiB
Factor
! * Crit-bit trees
|
|
! ** Rationale
|
|
! Critbit trees are described in [[https://cr.yp.to/critbit.html][djb's crit-bit tree]]. They are an evolution of
|
|
! PATRICIA trees showing that fast insertion, deletion, exact searching and suffix
|
|
! searching is possible with this data structure.
|
|
|
|
! The strength of this datastructure, according to its author, lies in its simple
|
|
! design and its optimisation to be machine parsable using machine word-sized
|
|
! operations where possible. Like PATRICIA trees, crit-bit trees are
|
|
! prefix-compressed, with internal nodes storing next decision point (the critical
|
|
! bit) in a length field (encoded as an integer and a mask) and two successor
|
|
! pointers. Arbitrary data objects make up its leaves.
|
|
|
|
USING: accessors fry 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 ( bits byte# class -- node )
|
|
new
|
|
swap >>byte#
|
|
swap >>bits ; inline
|
|
|
|
: <node> ( bits byte# -- 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 ( obj tree -- bytes treebytes )
|
|
[ object>bytes ] [ root>> ] bi*
|
|
[ dup node? ] [ successor ] while ;
|
|
|
|
PRIVATE>
|
|
|
|
: member? ( obj tree -- ? )
|
|
dup critbit?
|
|
[ walk-critbit = ]
|
|
[ 2drop f ] if ;
|
|
|
|
<PRIVATE
|
|
|
|
! Produce a byte with all bits set except the msb from bits*.
|
|
! See MAGIC Algorithms for rationale.
|
|
: msb0 ( bits* -- bits )
|
|
dup -1 shift bitor
|
|
dup -2 shift bitor
|
|
dup -4 shift bitor
|
|
dup -1 shift bitnot bitand 255 bitxor ;
|
|
|
|
: byte-params ( newbyte oldbyte -- direction bits )
|
|
swap over
|
|
bitxor msb0
|
|
[ direction ] keep ;
|
|
|
|
: node-params ( newbytes oldbytes -- direction bits byte# )
|
|
2dup mismatch
|
|
! newbytes oldbytes byte# -> direction bits byte#
|
|
[ [ '[ _ swap nth ] bi@ byte-params ] keep ]
|
|
[ 2dup [ length ] bi@ - 0 < [ drop ] [ nip ] if
|
|
[ last ] [ length 1 - ] bi
|
|
[ dup byte-params ] dip
|
|
] if* ;
|
|
|
|
PRIVATE>
|
|
|
|
: put ( obj tree -- tree )
|
|
dup critbit?
|
|
[ dup empty?
|
|
[ swap object>bytes >>root ]
|
|
[ walk-critbit
|
|
[ dup ] dip
|
|
node-params
|
|
<node>
|
|
swap 0 = [ swap >>right ] [ swap >>left ] if
|
|
] if ]
|
|
[ 2drop "Not a critbit tree" throw ] if ;
|