WIP Deactivate broken insert code and rewrite
Split into: - walk for best fit - updating leaf / creating new split node and leaf node - insert new split node if necessary (WIP)master
parent
8400602c06
commit
f06eda5f16
|
@ -68,14 +68,15 @@ TUPLE: cb-node { byte# integer } { bits integer } left right ;
|
||||||
! environment for it with =with-key=.
|
! environment for it with =with-key=.
|
||||||
SYMBOL: key-bytes
|
SYMBOL: key-bytes
|
||||||
SYMBOL: current-key
|
SYMBOL: current-key
|
||||||
|
SYMBOL: new-side
|
||||||
|
|
||||||
: key>bytes ( key -- bytes )
|
: key>bytes ( key -- bytes )
|
||||||
object>bytes ;
|
object>bytes ;
|
||||||
|
|
||||||
: with-key ( key quot -- )
|
: with-key ( key quot -- )
|
||||||
[
|
[
|
||||||
{ current-key key-bytes } swap
|
{ current-key key-bytes new-side } swap
|
||||||
dup key>bytes 2array zip
|
dup key>bytes left 3array zip
|
||||||
] dip with-variables ; inline
|
] dip with-variables ; inline
|
||||||
|
|
||||||
! Extract the critical byte
|
! Extract the critical byte
|
||||||
|
@ -92,39 +93,104 @@ SYMBOL: current-key
|
||||||
! Tree insertion must be done by traversing the tree from the root, as it is
|
! Tree insertion must be done by traversing the tree from the root, as it is
|
||||||
! ordered.
|
! ordered.
|
||||||
|
|
||||||
! Insert a node at a leaf-node by first inserting a split node.
|
! ! Insert a node at a leaf-node by first inserting a split node.
|
||||||
: cb-insert ( value leaf-node -- node created? )
|
! : cb-insert ( value leaf-node -- node created? )
|
||||||
[ current-key get swap <node> ] dip
|
! [ current-key get swap <node> ] dip
|
||||||
dup key>> key>bytes key-bytes get swap
|
! dup key>> key>bytes key-bytes get swap
|
||||||
bytes-diff swap <cb-node>
|
! bytes-diff swap <cb-node>
|
||||||
! ( new-leaf old-leaf side cb-node -- )
|
! ! ( new-leaf old-leaf side cb-node -- )
|
||||||
[ swap
|
! [ swap
|
||||||
[ [ set-node-link ] keep
|
! [ [ set-node-link ] keep
|
||||||
set-node+link
|
! set-node+link
|
||||||
] with-side
|
! ] with-side
|
||||||
] keep t ;
|
! ] keep t ;
|
||||||
|
|
||||||
DEFER: cb-set
|
! DEFER: cb-set
|
||||||
|
|
||||||
! Insert a node into a non-empty tree.
|
! ! Insert a node into a non-empty tree.
|
||||||
: (cb-set) ( value parent node -- parent node created? )
|
! : (cb-set) ( value parent node -- parent node created? )
|
||||||
dup cb-node? [
|
! dup cb-node? [
|
||||||
select-side [
|
! select-side [
|
||||||
[ node-link (cb-set) ] keep
|
! [ node-link (cb-set) ] keep
|
||||||
swap [ [ set-node-link ] keep ] dip
|
! swap [ [ set-node-link ] keep ] dip
|
||||||
] with-side
|
! ] with-side
|
||||||
|
! ] [
|
||||||
|
! cb-insert
|
||||||
|
! ] if ;
|
||||||
|
|
||||||
|
! ! Insert a node into the tree
|
||||||
|
! : cb-set ( value node -- node created? )
|
||||||
|
! [ dup (cb-set) ] [ current-key get swap <node> t ] if* ;
|
||||||
|
|
||||||
|
! ** Walking the tree for the best fit
|
||||||
|
|
||||||
|
! We need to remember the parent node as it will be the split node where our new
|
||||||
|
! value starts to differ, should it not be (key-)identical with the current
|
||||||
|
! node. Start with =f= as the parent.
|
||||||
|
|
||||||
|
GENERIC: cb-best-fit ( parent/f node -- node child )
|
||||||
|
|
||||||
|
M: f cb-best-fit ;
|
||||||
|
|
||||||
|
M: node cb-best-fit ;
|
||||||
|
|
||||||
|
M: cb-node cb-best-fit
|
||||||
|
select-side [
|
||||||
|
nip dup node-link cb-best-fit
|
||||||
|
] with-side ;
|
||||||
|
|
||||||
|
GENERIC: cb-update ( value parent/f node -- node created? )
|
||||||
|
|
||||||
|
M: f cb-update
|
||||||
|
2drop current-key get swap <node> t ;
|
||||||
|
|
||||||
|
: attach-node ( value side cb-node -- cb-node )
|
||||||
|
swap [
|
||||||
|
[ current-key get swap <node> ] dip
|
||||||
|
[ set-node+link ] keep
|
||||||
|
] with-side ;
|
||||||
|
|
||||||
|
M: node cb-update
|
||||||
|
dup key>> current-key get = [
|
||||||
|
current-key get >>key
|
||||||
|
nip swap >>value f
|
||||||
] [
|
] [
|
||||||
cb-insert
|
dup key>> key>bytes key-bytes get swap
|
||||||
|
bytes-diff swap <cb-node>
|
||||||
|
attach-node t
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
! Insert a node into the tree
|
GENERIC: cb-insert ( new-node cur-node -- node )
|
||||||
: cb-set ( value node -- node created? )
|
|
||||||
[ dup (cb-set) ] [ current-key get swap <node> t ] if* ;
|
M: f cb-insert drop ;
|
||||||
|
|
||||||
|
M: node cb-insert
|
||||||
|
new-side get [
|
||||||
|
swap [ set-node-link ] keep
|
||||||
|
] with-side ;
|
||||||
|
|
||||||
|
M: cb-node cb-insert
|
||||||
|
2dup
|
||||||
|
[ [ [ byte#>> ] bi@ < ]
|
||||||
|
[ [ [ byte#>> ] bi@ = ]
|
||||||
|
[ [ bits>> ] bi@ <]
|
||||||
|
] 2&&
|
||||||
|
] 2|| [
|
||||||
|
! break
|
||||||
|
select-side [ set-node-link ] with-side
|
||||||
|
] [
|
||||||
|
! step down
|
||||||
|
] if
|
||||||
|
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
M: cb set-at ( value key cb -- )
|
M: cb set-at ( value key cb -- )
|
||||||
[ swap [ cb-set ] with-key swap ] change-root
|
[ swap
|
||||||
|
[ ! ( value root -- new created? root )
|
||||||
|
[ f swap cb-best-fit cb-update ] keep swap
|
||||||
|
[ cb-insert t ] [ 2nip f ] if
|
||||||
|
] with-key swap ] change-root
|
||||||
swap [ dup inc-count ] when drop ;
|
swap [ dup inc-count ] when drop ;
|
||||||
|
|
||||||
! ** Deletion
|
! ** Deletion
|
||||||
|
|
Loading…
Reference in New Issue