WIP Initial code

critbit/critbit-tests.factor

@@ -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

critbit/critbit.factor

@@ -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 ;