2020-02-09 01:24:19 +01:00
|
|
|
! Copyright (C) 2020 Michael Raitza
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
|
|
!
|
|
|
|
! * 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.
|
|
|
|
|
2020-02-09 15:54:27 +01:00
|
|
|
! The strength of this data structure, 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.
|
|
|
|
|
2020-02-17 11:32:01 +01:00
|
|
|
USING: accessors arrays assocs combinators.short-circuit fry kernel locals make
|
|
|
|
math namespaces parser prettyprint.custom sequences serialize trees
|
|
|
|
trees.private vectors ;
|
2020-02-09 21:28:06 +01:00
|
|
|
IN: trees.cb
|
2020-02-09 01:24:19 +01:00
|
|
|
|
|
|
|
TUPLE: cb < tree ;
|
|
|
|
|
|
|
|
: <cb> ( -- tree ) cb new-tree ; inline
|
|
|
|
|
|
|
|
<PRIVATE
|
|
|
|
|
2020-02-09 21:28:06 +01:00
|
|
|
TUPLE: cb-node { byte# integer } { bits integer } left right ;
|
2020-02-09 01:24:19 +01:00
|
|
|
|
2020-02-09 21:28:06 +01:00
|
|
|
: new-node ( byte# bits class -- node )
|
|
|
|
new
|
2020-02-09 15:54:27 +01:00
|
|
|
swap >>bits
|
|
|
|
swap >>byte# ; inline
|
2020-02-09 01:24:19 +01:00
|
|
|
|
2020-02-09 21:28:06 +01:00
|
|
|
: <cb-node> ( byte# bits -- node )
|
|
|
|
cb-node new-node ;
|
|
|
|
|
2020-02-09 15:54:27 +01:00
|
|
|
: key-side ( bits byte -- side )
|
2020-02-24 15:44:26 +01:00
|
|
|
bitor 1 + -8 shift 0 = left right ? ;
|
2020-02-09 23:05:08 +01:00
|
|
|
|
|
|
|
! 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 ;
|
|
|
|
|
|
|
|
! Calculate the direction and the critical bit for the differing byte.
|
|
|
|
: byte-diff ( newbyte oldbyte -- side bits )
|
|
|
|
swap over
|
|
|
|
bitxor msb0
|
|
|
|
[ key-side ] keep ;
|
|
|
|
|
|
|
|
! For two byte strings, calculate the critical bit, byte and direction of
|
|
|
|
! difference (0 = left, 1 = right).
|
|
|
|
: bytes-diff ( newbytes oldbytes -- side bits byte# )
|
|
|
|
2dup mismatch
|
|
|
|
[
|
|
|
|
[ '[ _ swap nth ] bi@ byte-diff ] keep
|
|
|
|
] [
|
|
|
|
! Equal prefix over full (shorter) byte sequence.
|
|
|
|
[ 1 255 ] 2dip shorter length 1 -
|
|
|
|
] if* ;
|
2020-02-09 01:24:19 +01:00
|
|
|
|
2020-02-09 01:53:52 +01:00
|
|
|
! Keep the byte sequence of the current key in =key-bytes= and provide a working
|
|
|
|
! environment for it with =with-key=.
|
|
|
|
SYMBOL: key-bytes
|
2020-02-09 15:54:27 +01:00
|
|
|
SYMBOL: current-key
|
2020-02-11 22:30:10 +01:00
|
|
|
SYMBOL: new-side
|
2020-02-09 01:53:52 +01:00
|
|
|
|
2020-02-09 23:05:08 +01:00
|
|
|
: key>bytes ( key -- bytes )
|
|
|
|
object>bytes ;
|
|
|
|
|
2020-02-09 01:53:52 +01:00
|
|
|
: with-key ( key quot -- )
|
2020-02-09 15:54:27 +01:00
|
|
|
[
|
2020-02-17 11:32:01 +01:00
|
|
|
{ current-key key-bytes new-side } swap
|
|
|
|
dup key>bytes left 3array zip
|
2020-02-09 15:54:27 +01:00
|
|
|
] dip with-variables ; inline
|
|
|
|
|
2020-02-09 23:05:08 +01:00
|
|
|
! Extract the critical byte
|
2020-02-09 15:54:27 +01:00
|
|
|
: byte-at ( byte# -- byte/0 )
|
|
|
|
key-bytes get ?nth [ 0 ] unless* ;
|
|
|
|
|
2020-02-10 23:24:56 +01:00
|
|
|
! For the current key and cb-node determin which side to go next
|
|
|
|
: select-side ( node -- node side )
|
|
|
|
dup [ bits>> ] [ byte#>> ] bi
|
|
|
|
byte-at key-side ;
|
|
|
|
|
2020-02-09 15:54:27 +01:00
|
|
|
! ** Insertion
|
2020-02-10 23:24:56 +01:00
|
|
|
|
2020-02-09 23:05:08 +01:00
|
|
|
! Tree insertion must be done by traversing the tree from the root, as it is
|
|
|
|
! ordered.
|
|
|
|
|
2020-02-11 22:30:10 +01:00
|
|
|
! ** Walking the tree for the best fit
|
|
|
|
|
2020-02-14 20:48:49 +01:00
|
|
|
GENERIC: cb-best-fit ( node -- node )
|
2020-02-11 22:30:10 +01:00
|
|
|
|
|
|
|
M: f cb-best-fit ;
|
|
|
|
|
|
|
|
M: node cb-best-fit ;
|
|
|
|
|
|
|
|
M: cb-node cb-best-fit
|
|
|
|
select-side [
|
2020-02-14 20:48:49 +01:00
|
|
|
node-link cb-best-fit
|
2020-02-11 22:30:10 +01:00
|
|
|
] with-side ;
|
|
|
|
|
2020-02-14 20:48:49 +01:00
|
|
|
GENERIC: cb-update ( value node -- node created? )
|
2020-02-11 22:30:10 +01:00
|
|
|
|
|
|
|
M: f cb-update
|
2020-02-14 20:48:49 +01:00
|
|
|
drop current-key get swap <node> t ;
|
2020-02-11 22:30:10 +01:00
|
|
|
|
2020-02-14 20:48:49 +01:00
|
|
|
! Attach a new leaf node and record =new-side=. New leaf node is attached
|
|
|
|
! opposite of =new-side=.
|
2020-02-11 22:30:10 +01:00
|
|
|
: attach-node ( value side cb-node -- cb-node )
|
2020-02-14 20:48:49 +01:00
|
|
|
swap [ new-side set ] keep
|
|
|
|
[
|
2020-02-11 22:30:10 +01:00
|
|
|
[ current-key get swap <node> ] dip
|
|
|
|
[ set-node+link ] keep
|
|
|
|
] with-side ;
|
|
|
|
|
2020-02-14 20:48:49 +01:00
|
|
|
! Update the tree by either updating a leaf node with a new key object and value
|
|
|
|
! or create a new split node and attach a fresh leaf node with the new key and
|
|
|
|
! value.
|
2020-02-11 22:30:10 +01:00
|
|
|
M: node cb-update
|
|
|
|
dup key>> current-key get = [
|
|
|
|
current-key get >>key
|
2020-02-14 20:48:49 +01:00
|
|
|
swap >>value f
|
2020-02-09 21:28:06 +01:00
|
|
|
] [
|
2020-02-14 20:48:49 +01:00
|
|
|
key>> key>bytes key-bytes get swap
|
2020-02-11 22:30:10 +01:00
|
|
|
bytes-diff swap <cb-node>
|
|
|
|
attach-node t
|
2020-02-09 21:28:06 +01:00
|
|
|
] if ;
|
2020-02-09 01:24:19 +01:00
|
|
|
|
2020-02-14 20:48:49 +01:00
|
|
|
! Break off the search when:
|
|
|
|
! - the top node is no longer a split node
|
|
|
|
! - the top split node is larger than the new split node (i.e. refers to a later
|
|
|
|
! byte or more significant bit in the current byte)
|
|
|
|
: break? ( new-node node -- ? )
|
|
|
|
{ [ nip cb-node? not ]
|
|
|
|
[ [ byte#>> ] bi@ < ]
|
|
|
|
[ { [ [ byte#>> ] bi@ = ]
|
|
|
|
[ [ bits>> ] bi@ < ]
|
|
|
|
} 2&& ]
|
|
|
|
} 2|| ;
|
|
|
|
|
|
|
|
! Walk the tree and insert =new-node= at the pre-determined best place. We have
|
|
|
|
! to keep track of the parent instead of the current node, as we might need to
|
|
|
|
! relink from the parent to =new-node=.
|
|
|
|
GENERIC: cb-insert ( new-node parent -- )
|
|
|
|
|
|
|
|
M:: cb cb-insert ( n p -- )
|
|
|
|
p root>> :> c
|
|
|
|
n c break?
|
|
|
|
[ n p root<<
|
|
|
|
new-side get [
|
|
|
|
c n set-node-link
|
|
|
|
] with-side
|
|
|
|
]
|
|
|
|
[ n c cb-insert ] if ;
|
|
|
|
|
|
|
|
M:: cb-node cb-insert ( n p -- )
|
|
|
|
p select-side [
|
|
|
|
drop
|
|
|
|
p node-link :> c
|
|
|
|
n c break?
|
|
|
|
[ n p set-node-link
|
|
|
|
new-side get [
|
|
|
|
c n set-node-link
|
|
|
|
] with-side
|
|
|
|
]
|
|
|
|
[ n c cb-insert ] if
|
2020-02-11 22:30:10 +01:00
|
|
|
] with-side ;
|
|
|
|
|
2020-02-09 15:54:27 +01:00
|
|
|
M: cb set-at ( value key cb -- )
|
2020-02-14 20:48:49 +01:00
|
|
|
[ swap [
|
|
|
|
[ root>> cb-best-fit cb-update ]
|
|
|
|
[ swap [ cb-insert t ] [ 2drop f ] if ] bi
|
|
|
|
] with-key ] keep
|
2020-02-09 15:54:27 +01:00
|
|
|
swap [ dup inc-count ] when drop ;
|
2020-02-10 23:24:56 +01:00
|
|
|
|
|
|
|
! ** Deletion
|
|
|
|
|
|
|
|
GENERIC: cb-delete ( node -- node deleted? )
|
|
|
|
|
|
|
|
M: f cb-delete f ;
|
|
|
|
|
|
|
|
M: node cb-delete
|
|
|
|
dup key>> current-key get = [ drop f t ] [ f ] if ;
|
|
|
|
|
|
|
|
M: cb-node cb-delete ( node -- node deleted? )
|
|
|
|
select-side [
|
|
|
|
dup node-link dup cb-delete [
|
|
|
|
! ( node old-child new-child -- )
|
|
|
|
[
|
|
|
|
! ( node old new )
|
|
|
|
! Deleted a split node (received some node)
|
|
|
|
tuck eq? [
|
|
|
|
drop t
|
|
|
|
] [
|
|
|
|
swap tuck set-node-link
|
|
|
|
t
|
|
|
|
] if
|
|
|
|
] [
|
|
|
|
! Deleted a leaf node return other child.
|
|
|
|
drop
|
|
|
|
node+link t
|
|
|
|
] if*
|
|
|
|
f
|
|
|
|
] when drop
|
|
|
|
] with-side ;
|
|
|
|
|
|
|
|
M: cb delete-at ( key cb -- )
|
|
|
|
[ swap [ cb-delete ] with-key swap ] change-root
|
|
|
|
swap [ dup dec-count ] when drop ;
|
2020-02-17 11:32:01 +01:00
|
|
|
|
|
|
|
M: cb new-assoc
|
|
|
|
2drop <cb> ;
|
|
|
|
|
|
|
|
GENERIC: (cb-node>alist) ( node -- )
|
|
|
|
|
|
|
|
M: node (cb-node>alist)
|
|
|
|
entry, ;
|
|
|
|
|
|
|
|
: cb-node>entry ( node -- entry ) [ byte#>> ] [ bits>> ] bi 2array ;
|
|
|
|
|
|
|
|
: cb-entry, ( node -- ) cb-node>entry , ;
|
|
|
|
|
|
|
|
M: cb-node (cb-node>alist)
|
|
|
|
[ left>> (cb-node>alist) ]
|
|
|
|
[ cb-entry, ]
|
|
|
|
[ right>> (cb-node>alist) ]
|
|
|
|
tri ;
|
|
|
|
|
|
|
|
M: cb >alist
|
|
|
|
[ root>> (cb-node>alist) ] { } make ;
|
|
|
|
|
|
|
|
! Post-order traversal
|
|
|
|
!
|
|
|
|
! Assumes =f= in =left= and =right= slots of leaf nodes and ≠ =f= in split
|
|
|
|
! nodes.
|
|
|
|
: each-leaf-node ( node quot: ( ... entry -- ... ) -- ... )
|
|
|
|
[ [ dup left>> ] dip over [ each-leaf-node drop ] [ nip [ node>entry ] dip call ] if ]
|
|
|
|
[ [ right>> ] dip over [ each-leaf-node ] [ 2drop ] if ]
|
|
|
|
2bi ; inline recursive
|
|
|
|
|
|
|
|
: >cb-alist ( tree -- alist )
|
|
|
|
dup assoc-size <vector> [
|
|
|
|
[ push ] curry [ root>> ] dip each-leaf-node
|
|
|
|
] keep ;
|
|
|
|
|
|
|
|
M: cb assoc-clone-like
|
|
|
|
[ dup cb? [ >cb-alist ] when ] dip call-next-method ;
|
|
|
|
|
|
|
|
PRIVATE>
|
|
|
|
|
|
|
|
: >cb ( assoc -- tree )
|
|
|
|
<cb> assoc-clone-like ;
|
|
|
|
|
|
|
|
SYNTAX: CBTREE{
|
|
|
|
\ } [ >cb ] parse-literal ;
|
|
|
|
|
|
|
|
<PRIVATE
|
|
|
|
|
|
|
|
M: cb assoc-like drop dup cb? [ >cb ] unless ;
|
|
|
|
|
|
|
|
M: cb pprint-delims drop \ CBTREE{ \ } ;
|
|
|
|
M: cb >pprint-sequence >alist ;
|
|
|
|
M: cb pprint-narrow? drop t ;
|
|
|
|
|
|
|
|
PRIVATE>
|