! * 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 ;