ALSO UTILITY

STRUCT         
   AA-NODE% FIELD SIMPLE>NODE
   CELL%    FIELD SIMPLE>VALUE
ENDSTRUCT SIMPLE%

: 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 CONTAINEROF SIMPLE>NODE 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
: SIMPLE-NODE-VALUE CONTAINEROF SIMPLE>NODE SIMPLE>VALUE @ ;
' SIMPLE-NODE-VALUE ' <=> NEW-AA-TREE 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 CONTAINEROF SIMPLE>NODE 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