159 lines
4.7 KiB
Forth
159 lines
4.7 KiB
Forth
ALSO UTILITY
|
|
|
|
STRUCT
|
|
AA-NODE% FIELD SIMPLE>NODE
|
|
CELL% FIELD SIMPLE>VALUE
|
|
ENDSTRUCT SIMPLE%
|
|
|
|
: NODE>SIMPLE ( aa-node -- simple-node ) CONTAINEROF SIMPLE>NODE ;
|
|
|
|
: MAKE-SIMPLE ( x -- simple-addr )
|
|
SIMPLE% %ALLOCATE TUCK SIMPLE>VALUE ! ;
|
|
|
|
: SHOW-NODE ( rpre cpre lpre rxt node lxt )
|
|
LOCALS| rpre cpre lpre rxt node lxt |
|
|
node AA>RIGHT @ IF
|
|
rpre { " " TYPE } COMPOSE
|
|
rpre { " R-" TYPE } COMPOSE
|
|
rpre { " | " TYPE } COMPOSE
|
|
rxt
|
|
LOCALS| rpre' cpre' lpre' rxt |
|
|
rpre' cpre' lpre' rxt EXECUTE
|
|
lpre' EXECUTE EOL
|
|
rpre' FREE-CLOSURE ▪ cpre' FREE-CLOSURE ▪ lpre' FREE-CLOSURE
|
|
ENDLOCALS
|
|
THEN
|
|
|
|
cpre EXECUTE "(" TYPE node AA>LEVEL @ . ") " TYPE
|
|
node NODE>SIMPLE SIMPLE>VALUE @ . EOL
|
|
|
|
node AA>LEFT @ IF
|
|
lpre { " | " TYPE } COMPOSE
|
|
lpre { " L-" TYPE } COMPOSE
|
|
lpre { " " TYPE } COMPOSE
|
|
lxt
|
|
LOCALS| rpre' cpre' lpre' lxt |
|
|
rpre' EXECUTE EOL
|
|
rpre' cpre' lpre' lxt EXECUTE
|
|
rpre' FREE-CLOSURE ▪ cpre' FREE-CLOSURE ▪ lpre' FREE-CLOSURE
|
|
ENDLOCALS
|
|
THEN
|
|
ENDLOCALS ;
|
|
|
|
: SHOW-NULL ( rpre cpre lpre -- ) DROP NIP EXECUTE "<empty>\n" TYPE ;
|
|
|
|
: SHOW-TREE ( aa-tree -- )
|
|
>R { " " TYPE } DUP DUP [[ ' SHOW-NODE ]] [[ ' SHOW-NULL ]] R>
|
|
EOL AA-TRAVERSE EOL ;
|
|
|
|
: ?NODE-INVARIANTS ( parentn ... parent1 n aa-node -- ) RECURSIVE
|
|
?DUP IF
|
|
DUP AA>LEFT @ NULL= OVER AA>RIGHT @ NULL= AND IF
|
|
DUP AA>LEVEL @ 1 <>
|
|
"FAIL: 1. The level of every leaf node is one." ?FAIL
|
|
THEN
|
|
OVER 0> IF
|
|
2 PICK
|
|
2DUP AA>LEFT @ = IF
|
|
2DUP AA>LEVEL @ 1- SWAP AA>LEVEL @ <>
|
|
"FAIL: 2. The level of every left child is exactly one less than that of its parent." ?FAIL
|
|
THEN
|
|
2DUP AA>RIGHT @ = IF
|
|
2DUP SWAP AA>LEVEL @ SWAP AA>LEVEL @ DUP 1- SWAP 1+ WITHIN 0=
|
|
"FAIL: 3. The level of every right child is equal to or one less than that of its parent." ?FAIL
|
|
THEN
|
|
DROP
|
|
THEN
|
|
OVER 1 > IF
|
|
2 PICK AA>RIGHT @ OVER = IF
|
|
3 PICK AA>RIGHT @ 3 PICK = IF
|
|
DUP AA>LEVEL @ 4 PICK AA>LEVEL @ U>=
|
|
"FAIL: 4. The level of every right grandchild is strictly less than that of its grandparent." ?FAIL
|
|
THEN
|
|
THEN
|
|
THEN
|
|
DUP AA>LEVEL @ 1 > IF
|
|
DUP AA>LEFT @ NULL= ▪ OVER AA>RIGHT @ NULL= ▪ OR
|
|
"FAIL: 5. Every node of level greater than one has two children." ?FAIL
|
|
THEN
|
|
|
|
SWAP 1+
|
|
OVER AA>LEFT @ ?NODE-INVARIANTS
|
|
OVER AA>RIGHT @ ?NODE-INVARIANTS
|
|
1- NIP
|
|
THEN ;
|
|
|
|
: ?INVARIANTS ( aa-tree -- )
|
|
AA>ROOT @ 0 SWAP ?NODE-INVARIANTS DROP ;
|
|
|
|
VARIABLE TREE
|
|
|
|
"creating tree…\n" TYPE
|
|
{ NODE>SIMPLE SIMPLE>VALUE @ } ' <=> NEW-AA-TREE VALUE TREE
|
|
TREE SHOW-TREE
|
|
|
|
0xc43d7de6 CONSTANT SEED
|
|
|
|
{
|
|
20 0 ?DO
|
|
I SEED + HASHCELL 31 AND
|
|
DUP "inserting " TYPE . "…\n" TYPE
|
|
MAKE-SIMPLE TREE AA-INSERT
|
|
TREE SHOW-TREE
|
|
TREE ?INVARIANTS
|
|
LOOP
|
|
} EXECUTE
|
|
|
|
"breaking invariant 1…\n" TYPE
|
|
{ TREE SHOW-TREE ▪ { TREE ?INVARIANTS } CATCH DUP IF REPORT EOL THEN }
|
|
7 ▪ TREE AA>ROOT @ AA>LEFT @ AA>LEFT @ AA>LEFT @ AA>RIGHT @ AA>LEVEL ▪ !LOCALLY
|
|
|
|
"breaking invariant 2…\n" TYPE
|
|
{ TREE SHOW-TREE ▪ { TREE ?INVARIANTS } CATCH DUP IF REPORT EOL THEN }
|
|
4 ▪ TREE AA>ROOT @ AA>LEFT @ AA>LEVEL ▪ !LOCALLY
|
|
|
|
"breaking invariant 3…\n" TYPE
|
|
{ TREE SHOW-TREE ▪ { TREE ?INVARIANTS } CATCH DUP IF REPORT EOL THEN }
|
|
2 ▪ TREE AA>ROOT @ AA>RIGHT @ AA>LEVEL ▪ !LOCALLY
|
|
|
|
"breaking invariant 4…\n" TYPE
|
|
DEFER BREAK-INV-4 ( aa-node -- )
|
|
{
|
|
DUP AA>LEVEL @ 1 = IF
|
|
DROP ▪ TREE SHOW-TREE ▪ { TREE ?INVARIANTS } CATCH ?DUP IF REPORT EOL THEN
|
|
ELSE
|
|
{ { AA>RIGHT @ BREAK-INV-4 } OVER AA>LEVEL 1 SWAP !LOCALLY }
|
|
OVER AA>LEFT NULL SWAP !LOCALLY
|
|
THEN
|
|
} IS BREAK-INV-4
|
|
|
|
TREE AA>ROOT @ BREAK-INV-4
|
|
|
|
"breaking invariant 5…\n" TYPE
|
|
{ TREE SHOW-TREE ▪ { TREE ?INVARIANTS } CATCH DUP IF REPORT EOL THEN }
|
|
NULL ▪ TREE AA>ROOT @ AA>LEFT ▪ !LOCALLY
|
|
|
|
"finding node with value 16…\n" TYPE
|
|
16 TREE AA-LOOKUP
|
|
DUP 0= [IF] "not found\n" TYPE [ELSE]
|
|
"found\nvalue: " TYPE NODE>SIMPLE SIMPLE>VALUE @ . EOL
|
|
[THEN]
|
|
|
|
TREE SHOW-TREE
|
|
{
|
|
10 0 ?DO
|
|
"count before: " TYPE TREE AA-#NODES DUP . EOL
|
|
I SEED + HASHCELL HASHCELL 31 AND
|
|
DUP "deleting " TYPE . "…\n" TYPE
|
|
TREE AA-DELETE DUP FREE NULL<>
|
|
IF 1- "removed\n" ELSE "not found\n" THEN TYPE
|
|
"count after: " TYPE TREE AA-#NODES DUP . EOL
|
|
<> "wrong count" ?FAIL
|
|
TREE SHOW-TREE
|
|
TREE ?INVARIANTS
|
|
LOOP
|
|
} EXECUTE
|
|
|
|
"iterating tree…\n" TYPE
|
|
{ NODE>SIMPLE SIMPLE>VALUE @ . SPACE } TREE AA-ITERATE EOL
|