From 8400602c06cb0cda7f02de33a5ab489c59b0a5bb Mon Sep 17 00:00:00 2001
From: Michael Raitza <git@spacefrogg.net>
Date: Mon, 10 Feb 2020 23:24:56 +0100
Subject: [PATCH] Implement deletion; break insertion as it is still wrong

---
 {cb => trees/cb}/cb-test.factor |  0
 {cb => trees/cb}/cb.factor      | 55 +++++++++++++++++++++++++++++----
 2 files changed, 49 insertions(+), 6 deletions(-)
 rename {cb => trees/cb}/cb-test.factor (100%)
 rename {cb => trees/cb}/cb.factor (72%)

diff --git a/cb/cb-test.factor b/trees/cb/cb-test.factor
similarity index 100%
rename from cb/cb-test.factor
rename to trees/cb/cb-test.factor
diff --git a/cb/cb.factor b/trees/cb/cb.factor
similarity index 72%
rename from cb/cb.factor
rename to trees/cb/cb.factor
index 4b9a30c..92e5161 100644
--- a/cb/cb.factor
+++ b/trees/cb/cb.factor
@@ -82,8 +82,13 @@ SYMBOL: current-key
 : byte-at ( byte# -- byte/0 )
     key-bytes get ?nth [ 0 ] unless* ;
 
+! 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 ;
+
 ! ** Insertion
-!
+
 ! Tree insertion must be done by traversing the tree from the root, as it is
 ! ordered.
 
@@ -102,11 +107,10 @@ SYMBOL: current-key
 DEFER: cb-set
 
 ! Insert a node into a non-empty tree.
-: (cb-set) ( value node -- node created? )
+: (cb-set) ( value parent node -- parent node created? )
     dup cb-node? [
-        dup [ bits>> ] [ byte#>> ] bi
-        byte-at key-side [
-            [ node-link cb-set ] keep
+        select-side [
+            [ node-link (cb-set) ] keep
             swap [ [ set-node-link ] keep ] dip
         ] with-side
     ] [
@@ -115,10 +119,49 @@ DEFER: cb-set
 
 ! Insert a node into the tree
 : cb-set ( value node -- node created? )
-    [ (cb-set) ] [ current-key get swap <node> t ] if* ;
+    [ dup (cb-set) ] [ current-key get swap <node> t ] if* ;
 
 PRIVATE>
 
 M: cb set-at ( value key cb -- )
     [ swap [ cb-set ] with-key swap ] change-root
     swap [ dup inc-count ] when drop ;
+
+! ** Deletion
+
+<PRIVATE
+
+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 ;
+
+PRIVATE>
+
+M: cb delete-at ( key cb -- )
+    [ swap [ cb-delete ] with-key swap ] change-root
+    swap [ dup dec-count ] when drop ;