WIP: Some code updates...

critbit/critbit.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2019 Michael Raitza
+!
 ! * 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
@@ -12,7 +14,6 @@
 ! pointers. Arbitrary data objects make up its leaves.
 
 USING: accessors fry kernel math sequences serialize ;
-
 IN: critbit
 
 TUPLE: critbit root ;
@@ -32,6 +33,9 @@ PRIVATE>
 
 TUPLE: node left right { byte# integer } { bits integer } ;
 
+: empty? ( tree -- ? )
+    root>> f = ; inline
+
 : new-node ( bits byte# class -- node )
     new
     swap >>byte#
@@ -40,27 +44,32 @@ TUPLE: node left right { byte# integer } { bits integer } ;
 : <node> ( bits byte# -- node )
     node new-node ;
 
-PRIVATE>
+: get-child ( node direction -- child )
+    0 = [ right>> ] [ left>> ] if ;
 
-: empty? ( tree -- ? )
+: set-child ( node child direction -- node )
-    root>> f = ; inline
+    0 = [ >>right ] [ >>left ] if ;
 
-! : walk-crit ( obj node -- ? )
+: set-child-opposite ( node child direction -- node )
-!      ;
+    1 swap - set-child ;
 
 : direction ( byte bits -- direction )
     bitor 1 + -8 shift ;
 
-<PRIVATE
+! ** Walking the tree
+! Extract the split byte number and bit from node and return the proper child the
+! proper child corresponding to the bytestring's prefix.
 
-: successor ( bytes node -- bytes successor )
+: successor ( bytes node -- bytes successor via-direction )
     2dup [ byte#>> ] [ bits>> ] bi
-    [ 2dup swap length < [ swap nth ] [ 2drop 0 ] if ] dip
+    [ swap ?nth [ 0 ] unless* ] dip
-    direction 0 = [ left>> ] [ right>> ] if ;
+    direction [ get-child ] keep ;
 
-: walk-critbit ( obj tree -- bytes treebytes )
+! Walk the tree until we find a leaf.
+
+: walk-critbit ( obj tree -- objbytes leaf )
     [ object>bytes ] [ root>> ] bi*
-    [ dup node? ] [ successor ] while ;
+    [ dup node? ] [ successor drop ] while ;
 
 PRIVATE>
 
@@ -73,36 +82,100 @@ 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 )
+: byte-diff ( 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-diff ] keep ]
-    [ [ '[ _ swap nth ] bi@ byte-params ] keep ]
+    ! Equal prefix over full (shorter) byte sequence.
-    [ 2dup [ length ] bi@ - 0 < [ drop ] [ nip ] if
+    [ [ 1 255 ] 2dip shorter length 1 - ] if* ;
-      [ last ] [ length 1 - ] bi
+
-      [ dup byte-params ] dip
+: derive-node ( obj newbytes leaf -- node direction )
-    ] if* ;
+    object>bytes
+    node-params <node> -rot [ set-child-opposite ] keep ;
+
+: insert-node ( node split-node direction -- successor ? )
+    [
+        [ [ byte#>> ] bi@ - [ 0 < ] [ 0 = ] bi ] 2keep
+        [ bits>> ] > and
+        or
+    ] dip
+    ;
+
+: insertion-walk ( tree split-node new-direction -- tree )
+    ! FIXME Unfinished. We need obj to calculate succession :(
+    rot [
+        root>> dup node?
+        [ ] [ 2over insert-node ] while 3drop
+    ] keep ;
+
+:: walk-on? ( split-node node -- ? )
+    node node? not
+    node byte#>> split-node byte#>> >
+    or
+    node byte#>> split-node byte#>> =
+    node bits>> split-node bits>> >
+    and
+    or
+    not ;
+
+:: insertion-walk ( obj split-node new-direction -- ? )
+    obj obj>bytes :> objbytes
+    tree root>> :> node
+    [ split-node node walk-on? ] [
+        node :> predecessor
+        objbytes node successor :> node-direction :> node drop
+    ] while
+    node split-node new-direction set-child
+    ;
+
+! :: insertion-successor ( objbytes bits byte# node -- split-node )
+!     node node? not
+!     [ node ]
+!     [
+!         node byte#>>
+!         [ byte# > ] keep
+!         byte# = node bits>> bits > and
+!         or
+!         ! objbytes no longer matches prefix?
+!         [ node ]
+!         [
+!             ! FIXME: complete node insertion
+!         ] if
+!     ] if ;
+
+! :: (insert-node) ( obj tree objbytes treebytes direction bits byte# -- tree )
+!     bits byte# <node>
+!     direction 0 = [ obj >>right ] [ obj >>left ] if :> node
+!     tree root>> [ dup node? ] [ insertion-successor]
+!     ;
+
+! : insert-node ( obj tree objbytes treebytes -- tree )
+!     2dup node-params (insert-node)
+!     ;
 
 PRIVATE>
 
+: (put) ( tree obj -- tree )
+    swap dup empty?
+    [ swap >>root ]
+    [ [ 2dup walk-critbit
+        derive-node
+        ! FIXME Unfinished, this node must now be inserted into the tree
+      ] 2keep
+      2drop ! <- remove;
+      ! insert-node
+    ] if ;
+
 : put ( obj tree -- tree )
-    dup critbit?
+    dup critbit? [ (put) ] [ 2drop "Not a critbit tree" throw ] if ;
-    [ 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 ;

playground.factor

@@ -1,7 +1,7 @@
 ! Set up factor UI and editor integration for this project
 ! Use emacs as the editor and switch UI to dark mode
 ! Run this to start development in the UI
-USING: editors.emacs io.backend threads ui ui.theme.switching vocabs.loader ;
+USING: editors.emacs io.backend kernel threads ui ui.theme.switching vocabs.loader ;
 
 ! Add project's root to vocabulary roots and load all project components
 ! current-directory get