diff --git a/jumpforth.S b/jumpforth.S index 4e3e252..df7a163 100644 --- a/jumpforth.S +++ b/jumpforth.S @@ -813,6 +813,16 @@ defcode XCHG push %ebx NEXT +/* ( a-addr1 a-addr2 -- ) Swap the values in two memory locations */ +defcode EXCHANGE + pop %ebx + pop %eax + mov (%eax),%ecx + mov (%ebx),%edx + mov %ecx,(%ebx) + mov %edx,(%eax) + NEXT + defcode TWOSTORE,"2!" pop %ebx popl (%ebx) @@ -1002,6 +1012,12 @@ defcode TWORDROP,"2RDROP" addl $8,%ebp NEXT +/* ( R: xn ... x1 n -- ) */ +defcode NRDROP + POPRSP %eax + lea (%ebp,%eax,4),%ebp + NEXT + /* ( -- a-addr ) Get the data stack pointer (address of cell below a-addr) */ defcode SPFETCH,"SP@" push %esp diff --git a/startup.4th b/startup.4th index d2a2526..f1823cb 100644 --- a/startup.4th +++ b/startup.4th @@ -678,6 +678,10 @@ DEFER QUIT \ Return -1, 0, or 1 if n is respectively negative, zero, or positive : SIGNUM ( n -- -1 | 0 | 1 ) DUP 0<= SWAP 0>= - ; +\ Return -1, 0, or 1 if n1|u1 is less than, equal to, or greater than n2|u2 +: <=> ( n1 n2 -- -1 | 0 | 1 ) 2DUP < -ROT > - ; +: U<=> ( u1 u2 -- -1 | 0 | 1 ) 2DUP U< -ROT U> - ; + \ True if n1 >= n2 && n1 <= n3, false otherwise : WITHIN ( n1|u1 n2|u2 n3|u3 -- flag ) OVER - -ROT - U> ; @@ -689,6 +693,10 @@ DEFER QUIT : DUMAX ( ud1 ud2 -- ud1|ud2 ) 2OVER 2OVER DU< IF 2SWAP THEN 2DROP ; : DSIGNUM ( d -- -1 | 0 | 1 ) 2DUP D0= IF DROP ELSE D0< 2 * 1+ THEN ; +\ Return -1, 0, or 1 if d1|ud1 is less than, equal to, or greater than d2|ud2 +: D<=> ( d1 d2 -- -1 | 0 | 1 ) 2OVER 2OVER D> >R D< R> - ; +: DU<=> ( ud1 ud2 -- -1 | 0 | 1 ) 2OVER 2OVER DU> >R DU< R> - ; + \ Define names for the whitespace characters 8 CONSTANT HT \ Horizontal Tab 10 CONSTANT LF \ Line Feed (newline) @@ -1038,12 +1046,12 @@ CREATE DISPLAY-ITEM-LIMIT 6 , \ Return -1, 0, or 1 if the left string is respectively \ less than, equal to, or greater than the right string : COMPARE ( c-addr1 u1 c-addr2 u2 -- -1 | 0 | 1 ) - ROT SWAP ▪ 2DUP - -ROT 2>R -ROT 2R> ▪ UMIN 0 ?DO + ROT SWAP ▪ 2DUP U<=> -ROT 2>R -ROT 2R> ▪ UMIN 0 ?DO ( S: u1-u2 c-addr1 c-addr2 R: loop-sys ) OVER I + C@ OVER I + C@ ( S: u1-u2 c-addr1 c-addr2 ch1 ch2 ) - - ?DUP IF -ROT 2>R NIP 2R> LEAVE THEN - LOOP ▪ 2DROP SIGNUM ; + U<=> ?DUP IF -ROT 2>R NIP 2R> LEAVE THEN + LOOP ▪ 2DROP ; \ Convert a character to lowercase or uppercase, respectively : TO-LOWER ( ch1 -- ch2 ) @@ -1898,11 +1906,21 @@ DEFER FIND-HOOK ( c-addr u -- c-addr u 0 | xt 1 | xt -1 ) : ALIGNOF ( "" -- size ) IMMEDIATE ' EXECUTE %ALIGNOF STATE @ IF POSTPONE LITERAL THEN ; -\ Product the offset of the subsequent field name as a literal +\ Produce the offset of the subsequent field name as a literal \ The field-name should be a word which adds a field offset to a given address -: OFFSETOF ( "" -- offset ) IMMEDIATE +: OFFSETOF ( "" -- ; -- offset ) IMMEDIATE 0 ' EXECUTE STATE @ IF POSTPONE LITERAL THEN ; +\ At runtime subtract the offset of a named field from the given address +\ As an optimization, if the field offset is zero then this generates no code +: CONTAINEROF ( "" -- ; field-addr -- struct-addr ) IMMEDIATE + 0 ' EXECUTE STATE @ IF ?DUP IF POSTPONE LITERAL POSTPONE - THEN ELSE - THEN ; + +\ Store x at addr, saving the original value, and then execute xt +\ When xt returns normally or THROWs (without CATCH), restore the saved value +: !LOCALLY ( i*x xt x addr -- j*x ) + TUCK XCHG >R >R CATCH 2R> ! RETHROW ; + \ Save the single-cell value at addr and then execute xt \ When xt returns normally or THROWs (without CATCH), restore the saved value : PRESERVED ( i*x xt addr -- j*x ) @@ -2135,7 +2153,7 @@ REVERT \ Run the reporter for the given exception code, or give the default report : REPORT ( n -- ) DUP REPORTER IF - NIP THROWN-STRING 2@ ROT 2@ DROP EXECUTE + NIP 2@ DROP EXECUTE ELSE DROP ▪ "Uncaught exception: " TYPE-ERR DUP ▪ ABS 0 <# #S ROT SIGN #> ▪ TYPE-ERR EOL ; @@ -2442,6 +2460,231 @@ REVERT : MERGE-SORT> ( head1 link-xt compare-xt -- head2 ) [[ ' NEGATE ]] COMPOSE DUP >R MERGE-SORT R> FREE-CLOSURE ; +>> UTILITY + +\ AA Tree, a variation on the Red-Black Tree +\ + +\ Types: +\ aa-tree: address of AA-TREE% +\ aa-node: address of AA-NODE% +\ aa-value-xt: function ( aa-node -- x ) +\ aa-compare-xt: function ( x1 x2 -- -1 | 0 | 1 ) + +STRUCT + CELL% FIELD AA>LEVEL ( u ) + CELL% FIELD AA>LEFT ( aa-node|NULL ) + CELL% FIELD AA>RIGHT ( aa-node|NULL ) +ENDSTRUCT AA-NODE% + +STRUCT + CELL% FIELD AA>ROOT ( aa-node|NULL ) + CELL% FIELD AA>VALUE ( aa-value-xt ) + CELL% FIELD AA>COMPARE ( aa-compare-xt ) +ENDSTRUCT AA-TREE% + +>> SYSTEM + +: AA-INIT-LEAF ( aa-node -- ) + NULL OVER AA>LEFT ! ▪ NULL OVER AA>RIGHT ! ▪ 1 SWAP AA>LEVEL ! ; + +: AA-NODE-LEVEL ( aa-node -- u ) ?DUP 0= IF 0 ELSE AA>LEVEL @ THEN ; +: AA-LEAF? ( aa-node -- t=leaf ) DUP AA>LEFT @ SWAP AA>RIGHT @ OR 0= ; + +: AA-SKEW ( aa-node1|NULL -- aa-node2|NULL ) + DUP IF ▪ DUP AA>LEFT @ IF ▪ DUP AA>LEVEL @ OVER AA>LEFT @ AA>LEVEL @ = IF + DUP AA>LEFT TUCK @ ▪ AA>RIGHT XCHG ▪ SWAP XCHG + THEN ▪ THEN ▪ THEN ; + +: AA-SPLIT ( aa-node1|NULL -- aa-node2|NULL ) + DUP IF ▪ DUP AA>RIGHT @ IF ▪ DUP AA>RIGHT @ AA>RIGHT @ IF + DUP AA>LEVEL @ ▪ OVER AA>RIGHT @ AA>RIGHT @ AA>LEVEL @ ▪ = IF + DUP AA>RIGHT TUCK @ AA>LEFT XCHG SWAP XCHG + 1 OVER AA>LEVEL +! + THEN + THEN ▪ THEN ▪ THEN ; + +\ Insert aa-node1 somewhere under aa-node2 and return the updated subtree +: AA-INSERT-NODE ( aa-node1 aa-node2|NULL aa-tree -- aa-node3 ) RECURSIVE + OVER 0= IF ▪ 2DROP DUP AA-INIT-LEAF ▪ EXIT ▪ THEN + OVER >R ▪ >R 2DUP ▪ R@ AA>VALUE @ EXECUTE SWAP ▪ R@ AA>VALUE @ EXECUTE SWAP + R@ AA>COMPARE @ EXECUTE ▪ 0< IF AA>LEFT ELSE AA>RIGHT THEN + TUCK @ R> AA-INSERT-NODE ▪ SWAP ! ▪ R> AA-SKEW AA-SPLIT ; + +\ Lower level(T) and level(right(T)) to be <= min(level(left(T)), level(right(T))) + 1 +: AA-DECREASE-LEVEL ( aa-node -- ) + DUP AA>LEFT @ AA-NODE-LEVEL ▪ OVER AA>RIGHT @ AA-NODE-LEVEL ▪ UMIN 1+ ▪ SWAP + 2DUP AA>LEVEL @ < IF + 2DUP AA>LEVEL ! + AA>RIGHT @ ▪ DUP IF ▪ 2DUP AA>LEVEL @ < IF 2DUP AA>LEVEL ! THEN ▪ THEN + THEN ▪ 2DROP ; + +\ Swap the fields of two AA nodes +: AA-EXCHANGE ( aa-node1 aa-node2 -- ) + 2DUP AA>LEFT ▪ SWAP AA>LEFT ▪ EXCHANGE + 2DUP AA>RIGHT ▪ SWAP AA>RIGHT ▪ EXCHANGE + AA>LEVEL ▪ SWAP AA>LEVEL ▪ EXCHANGE ; + +\ aa-node1: The root of the current subtree +\ aa-node2: The node that was removed, or NULL if there was no match +\ aa-node3: The new subtree root node, or NULL if the subtree is empty +: AA-DELETE-NODE ( x aa-tree aa-node1|NULL -- aa-node2|NULL aa-node3|NULL ) RECURSIVE + DUP NULL= IF NIP NIP NULL EXIT THEN + LOCALS| x tree node | + x node tree AA>VALUE @ EXECUTE ▪ tree AA>COMPARE @ EXECUTE + DUP 0< IF DROP + x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> ! + ELSE-IF 0> THEN-IF + x tree node AA>RIGHT DUP >R @ AA-DELETE-NODE R> ! + ELSE + node AA-LEAF? IF node NULL UNLOCALS EXIT THEN + node AA>LEFT @ NULL= IF + \ swap current node with its successor in the right subtree + node AA>RIGHT @ AA>LEFT @ NULL= IF + \ right child is the successor + node AA>RIGHT @ + DUP AA>LEVEL node AA>LEVEL EXCHANGE + DUP AA>LEFT node AA>LEFT EXCHANGE + node SWAP AA>RIGHT XCHG node AA>RIGHT XCHG node! + ELSE + \ leftmost descendent of right child is the successor + node AA>RIGHT BEGIN DUP @ AA>LEFT DUP @ WHILE NIP REPEAT DROP + node SWAP XCHG ▪ DUP node AA-EXCHANGE ▪ node! + THEN + \ recurse into right subtree + x tree node AA>RIGHT DUP >R @ AA-DELETE-NODE R> ! + ELSE + \ swap current node with its predecessor in the left subtree + node AA>LEFT @ AA>RIGHT @ NULL= IF + \ left child is the predecessor + node AA>LEFT @ + DUP AA>LEVEL node AA>LEVEL EXCHANGE + DUP AA>RIGHT node AA>RIGHT EXCHANGE + node SWAP AA>LEFT XCHG node AA>LEFT XCHG node! + ELSE + \ rightmost descendent of left child is the predecessor + node AA>LEFT BEGIN DUP @ AA>RIGHT DUP @ WHILE NIP REPEAT DROP + node SWAP XCHG ▪ DUP node AA-EXCHANGE ▪ node! + THEN + \ recurse into left subtree + x tree node AA>LEFT DUP >R @ AA-DELETE-NODE R> ! + THEN + THEN ( S: aa-node2|NULL ) + node + ENDLOCALS + \ Rebalance the tree + DUP AA-DECREASE-LEVEL + AA-SKEW + DUP AA>RIGHT ▪ DUP @ IF + DUP DUP >R @ AA-SKEW R> ! + DUP @ AA>RIGHT DUP >R @ AA-SKEW R> ! + THEN DROP + AA-SPLIT + DUP AA>RIGHT DUP >R @ AA-SPLIT R> ! ; + +: AA-TRAVERSE-NODE ( i*x node-xt null-xt aa-node|NULL -- j*x ) RECURSIVE + DUP NULL= IF DROP NIP EXECUTE EXIT THEN + LOCALS| node-xt null-xt node | + node-xt node + node-xt null-xt node AA>LEFT @ [[ ' AA-TRAVERSE-NODE ]] 3 CLOSURE + node-xt null-xt node AA>RIGHT @ [[ ' AA-TRAVERSE-NODE ]] 3 CLOSURE + ENDLOCALS + LOCALS| node-xt node left-xt right-xt | + right-xt node left-xt node-xt EXECUTE + left-xt FREE-CLOSURE + right-xt FREE-CLOSURE + ENDLOCALS ; + +>> UTILITY + +: NEW-AA-TREE ( aa-value-xt aa-compare-xt -- aa-tree ) + AA-TREE% %ALLOCATE ▪ TUCK AA>COMPARE ! ▪ TUCK AA>VALUE ! ▪ NULL OVER AA>ROOT ! ; + +: FREE-AA-TREE ( aa-tree -- ) + DUP AA>ROOT @ "attempted to free non-empty AA tree" ?FAIL FREE ; + +: AA-EMPTY? ( aa-tree -- t=empty ) + AA>ROOT @ NULL= ; + +: AA-INSERT ( aa-node aa-tree -- ) + DUP >R AA>ROOT TUCK @ R> AA-INSERT-NODE SWAP ! ; + +: AA-DELETE ( x aa-tree -- aa-node|NULL ) + DUP AA>ROOT DUP >R @ AA-DELETE-NODE R> ! ; + +: AA-LOOKUP ( x aa-tree -- aa-node|NULL ) + DUP AA>ROOT @ -ROT ▪ DUP AA>COMPARE @ ▪ SWAP AA>VALUE @ + LOCALS| x compare-xt value-xt | + BEGIN + DUP + WHILE + DUP value-xt EXECUTE ▪ x ▪ SWAP compare-xt EXECUTE ▪ ?DUP + WHILE + 0< IF AA>LEFT ELSE AA>RIGHT THEN @ + REPEAT + ENDLOCALS ; + +\ node-xt: ( i*x right-xt aa-node left-xt -- j*x ) +\ null-xt: ( i*x -- j*x ) +\ left-xt, right-xt: call node-xt or null-xt with params for left or right child node +: AA-TRAVERSE ( i*x node-xt null-xt aa-tree -- j*x ) + AA>ROOT @ AA-TRAVERSE-NODE ; + +: AA-#NODES ( aa-tree -- u ) + >R 0 { NIP >R EXECUTE R> EXECUTE 1+ } [[ ' ▪ ]] R> AA-TRAVERSE ; + +STRUCT + unsigned-long-long% FIELD stat64>dev + unsigned-char% 4 * FIELD stat64>__pad0 + unsigned-long% FIELD stat64>__ino + unsigned-int% FIELD stat64>mode + unsigned-int% FIELD stat64>nlink + unsigned-long% FIELD stat64>uid + unsigned-long% FIELD stat64>gid + unsigned-long-long% FIELD stat64>rdev + unsigned-char% 4 * FIELD stat64>__pad3 + signed-long-long% FIELD stat64>size + unsigned-long% FIELD stat64>blksize + unsigned-long-long% FIELD stat64>blocks + unsigned-long% FIELD stat64>atime + unsigned-long% FIELD stat64>atime_nsec + unsigned-long% FIELD stat64>mtime + unsigned-int% FIELD stat64>mtime_nsec + unsigned-long% FIELD stat64>ctime + unsigned-long% FIELD stat64>ctime_nsec + unsigned-long-long% FIELD stat64>ino +ENDSTRUCT stat64% + +>> FORTH + +ALSO LINUX +O_RDONLY CONSTANT R/O ( -- fam ) +O_WRONLY CONSTANT W/O ( -- fam ) +O_RDWR CONSTANT R/W ( -- fam ) +PREVIOUS + +: BIN ( fam1 -- fam2 ) IMMEDIATE ; + +: CREATE-FILE ( c-addr u fam -- fileid ) ; +: OPEN-FILE ( c-addr u fam -- fileid ) ; +: REPOSITION-FILE ( ud fileid -- ) ; +: FILE-POSITION ( fileid -- ud ) ; +: RESIZE-FILE ( ud fileid -- ) ; +: FILE-SIZE ( fileid -- ud ) ; +: READ-FILE ( c-addr u1 fileid -- u2 ) ; +: READ-LINE ( c-addr u1 fileid -- u2 t=eof ) ; +: WRITE-FILE ( c-addr u fileid -- ) ; +: WRITE-LINE ( c-addr u fileid -- ) ; +: FLUSH-FILE ( fileid -- ) ; +: CLOSE-FILE ( fileid -- ) ; +: RENAME-FILE ( c-addr1 u1 c-addr2 u2 -- ) ; +: DELETE-FILE ( c-addr u -- ) ; + +: INCLUDE-FILE ( i*x fileid -- j*x ) ; +: INCLUDED ( i*x c-addr u -- j*x ) ; + +: FILE-STATUS ( c-addr u -- x ) ; + FORTH-WORDLIST 1 SET-ORDER DEFINITIONS diff --git a/test/aa-tree.4th b/test/aa-tree.4th new file mode 100644 index 0000000..17de7b9 --- /dev/null +++ b/test/aa-tree.4th @@ -0,0 +1,154 @@ +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 "\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 diff --git a/test/aa-tree.exp b/test/aa-tree.exp new file mode 100644 index 0000000..07f23f7 --- /dev/null +++ b/test/aa-tree.exp @@ -0,0 +1,1055 @@ +creating tree… + + + +inserting 11… + + (1) 11 + +inserting 11… + + R-(1) 11 + | + (1) 11 + +inserting 30… + + R-(1) 30 + | + (2) 11 + | + L-(1) 11 + +inserting 30… + + R-(1) 30 + | + R-(1) 30 + | + (2) 11 + | + L-(1) 11 + +inserting 13… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 13 + | + (2) 11 + | + L-(1) 11 + +inserting 2… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 13 + | + (2) 11 + | + | R-(1) 11 + | | + L-(1) 2 + +inserting 26… + + R-(1) 30 + | + R-(2) 30 + | | + | | R-(1) 26 + | | | + | L-(1) 13 + | + (2) 11 + | + | R-(1) 11 + | | + L-(1) 2 + +inserting 21… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + (3) 21 + | + | R-(1) 13 + | | + L-(2) 11 + | + | R-(1) 11 + | | + L-(1) 2 + +inserting 6… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + (3) 21 + | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | L-(1) 11 + | | + L-(2) 6 + | + L-(1) 2 + +inserting 8… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + (3) 21 + | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | | R-(1) 11 + | | | | + | | L-(1) 8 + | | + L-(2) 6 + | + L-(1) 2 + +inserting 17… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + (3) 21 + | + | R-(1) 17 + | | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | | R-(1) 11 + | | | | + | | L-(1) 8 + | | + L-(2) 6 + | + L-(1) 2 + +inserting 4… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + (3) 21 + | + | R-(1) 17 + | | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | | R-(1) 11 + | | | | + | | L-(1) 8 + | | + L-(2) 6 + | + | R-(1) 4 + | | + L-(1) 2 + +inserting 7… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | | R-(1) 13 + | | | + | L-(2) 11 + | | + | L-(1) 11 + | + (3) 8 + | + | R-(1) 7 + | | + L-(2) 6 + | + | R-(1) 4 + | | + L-(1) 2 + +inserting 16… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | | R-(2) 16 + | | | | + | | | L-(1) 13 + | | | + | L-(2) 11 + | | + | L-(1) 11 + | + (3) 8 + | + | R-(1) 7 + | | + L-(2) 6 + | + | R-(1) 4 + | | + L-(1) 2 + +inserting 13… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | | R-(2) 16 + | | | | + | | | | R-(1) 13 + | | | | | + | | | L-(1) 13 + | | | + | L-(2) 11 + | | + | L-(1) 11 + | + (3) 8 + | + | R-(1) 7 + | | + L-(2) 6 + | + | R-(1) 4 + | | + L-(1) 2 + +inserting 15… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | L-(2) 16 + | | + | L-(1) 15 + | + (4) 13 + | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | L-(1) 11 + | | + L-(3) 8 + | + | R-(1) 7 + | | + L-(2) 6 + | + | R-(1) 4 + | | + L-(1) 2 + +inserting 13… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | L-(2) 16 + | | + | | R-(1) 15 + | | | + | L-(1) 13 + | + (4) 13 + | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | L-(1) 11 + | | + L-(3) 8 + | + | R-(1) 7 + | | + L-(2) 6 + | + | R-(1) 4 + | | + L-(1) 2 + +inserting 5… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | L-(2) 16 + | | + | | R-(1) 15 + | | | + | L-(1) 13 + | + (4) 13 + | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | L-(1) 11 + | | + L-(3) 8 + | + | R-(1) 7 + | | + | R-(2) 6 + | | | + | | L-(1) 5 + | | + L-(2) 4 + | + L-(1) 2 + +inserting 1… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | L-(2) 16 + | | + | | R-(1) 15 + | | | + | L-(1) 13 + | + (4) 13 + | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | L-(1) 11 + | | + L-(3) 8 + | + | R-(1) 7 + | | + | R-(2) 6 + | | | + | | L-(1) 5 + | | + L-(2) 4 + | + | R-(1) 2 + | | + L-(1) 1 + +inserting 16… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | | R-(1) 16 + | | | + | L-(2) 16 + | | + | | R-(1) 15 + | | | + | L-(1) 13 + | + (4) 13 + | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | L-(1) 11 + | | + L-(3) 8 + | + | R-(1) 7 + | | + | R-(2) 6 + | | | + | | L-(1) 5 + | | + L-(2) 4 + | + | R-(1) 2 + | | + L-(1) 1 + +breaking invariant 1… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | | R-(1) 16 + | | | + | L-(2) 16 + | | + | | R-(1) 15 + | | | + | L-(1) 13 + | + (4) 13 + | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | L-(1) 11 + | | + L-(3) 8 + | + | R-(1) 7 + | | + | R-(2) 6 + | | | + | | L-(1) 5 + | | + L-(2) 4 + | + | R-(7) 2 + | | + L-(1) 1 + +FAIL: 1. The level of every leaf node is one. + +breaking invariant 2… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | | R-(1) 16 + | | | + | L-(2) 16 + | | + | | R-(1) 15 + | | | + | L-(1) 13 + | + (4) 13 + | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | L-(1) 11 + | | + L-(4) 8 + | + | R-(1) 7 + | | + | R-(2) 6 + | | | + | | L-(1) 5 + | | + L-(2) 4 + | + | R-(1) 2 + | | + L-(1) 1 + +FAIL: 2. The level of every left child is exactly one less than that of its parent. + +breaking invariant 3… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(2) 21 + | | + | | R-(1) 17 + | | | + | | R-(1) 16 + | | | + | L-(2) 16 + | | + | | R-(1) 15 + | | | + | L-(1) 13 + | + (4) 13 + | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | L-(1) 11 + | | + L-(3) 8 + | + | R-(1) 7 + | | + | R-(2) 6 + | | | + | | L-(1) 5 + | | + L-(2) 4 + | + | R-(1) 2 + | | + L-(1) 1 + +FAIL: 3. The level of every right child is equal to or one less than that of its parent. + +breaking invariant 4… + + R-(1) 30 + | + R-(1) 30 + | + R-(1) 21 + | + (1) 13 + +FAIL: 4. The level of every right grandchild is strictly less than that of its grandparent. + +breaking invariant 5… + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | | R-(1) 16 + | | | + | L-(2) 16 + | | + | | R-(1) 15 + | | | + | L-(1) 13 + | + (4) 13 + +FAIL: 5. Every node of level greater than one has two children. + +finding node with value 16… +found +value: 16 + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | | R-(1) 16 + | | | + | L-(2) 16 + | | + | | R-(1) 15 + | | | + | L-(1) 13 + | + (4) 13 + | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | L-(1) 11 + | | + L-(3) 8 + | + | R-(1) 7 + | | + | R-(2) 6 + | | | + | | L-(1) 5 + | | + L-(2) 4 + | + | R-(1) 2 + | | + L-(1) 1 + +count before: 20 +deleting 15… +removed +count after: 19 + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | | R-(1) 16 + | | | + | L-(2) 16 + | | + | L-(1) 13 + | + (4) 13 + | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | L-(1) 11 + | | + L-(3) 8 + | + | R-(1) 7 + | | + | R-(2) 6 + | | | + | | L-(1) 5 + | | + L-(2) 4 + | + | R-(1) 2 + | | + L-(1) 1 + +count before: 19 +deleting 20… +not found +count after: 19 + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | | R-(1) 16 + | | | + | L-(2) 16 + | | + | L-(1) 13 + | + (4) 13 + | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | L-(1) 11 + | | + L-(3) 8 + | + | R-(1) 7 + | | + | R-(2) 6 + | | | + | | L-(1) 5 + | | + L-(2) 4 + | + | R-(1) 2 + | | + L-(1) 1 + +count before: 19 +deleting 5… +removed +count after: 18 + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | | R-(1) 16 + | | | + | L-(2) 16 + | | + | L-(1) 13 + | + (4) 13 + | + | R-(1) 13 + | | + | R-(2) 11 + | | | + | | L-(1) 11 + | | + L-(3) 8 + | + | R-(1) 7 + | | + | R-(1) 6 + | | + L-(2) 4 + | + | R-(1) 2 + | | + L-(1) 1 + +count before: 18 +deleting 13… +removed +count after: 17 + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | | R-(1) 16 + | | | + | L-(2) 16 + | | + | L-(1) 13 + | + (3) 13 + | + | R-(1) 11 + | | + | R-(1) 11 + | | + | R-(2) 8 + | | | + | | | R-(1) 7 + | | | | + | | L-(1) 6 + | | + L-(2) 4 + | + | R-(1) 2 + | | + L-(1) 1 + +count before: 17 +deleting 13… +removed +count after: 16 + + R-(1) 30 + | + R-(2) 30 + | | + | L-(1) 26 + | + R-(3) 21 + | | + | | R-(1) 17 + | | | + | | R-(1) 16 + | | | + | L-(2) 16 + | | + | L-(1) 13 + | + (3) 11 + | + | R-(1) 11 + | | + | R-(2) 8 + | | | + | | | R-(1) 7 + | | | | + | | L-(1) 6 + | | + L-(2) 4 + | + | R-(1) 2 + | | + L-(1) 1 + +count before: 16 +deleting 26… +removed +count after: 15 + + R-(1) 30 + | + R-(1) 30 + | + R-(2) 21 + | | + | | R-(1) 17 + | | | + | L-(1) 16 + | + R-(2) 16 + | | + | L-(1) 13 + | + (3) 11 + | + | R-(1) 11 + | | + | R-(2) 8 + | | | + | | | R-(1) 7 + | | | | + | | L-(1) 6 + | | + L-(2) 4 + | + | R-(1) 2 + | | + L-(1) 1 + +count before: 15 +deleting 3… +not found +count after: 15 + + R-(1) 30 + | + R-(1) 30 + | + R-(2) 21 + | | + | | R-(1) 17 + | | | + | L-(1) 16 + | + R-(2) 16 + | | + | L-(1) 13 + | + (3) 11 + | + | R-(1) 11 + | | + | R-(2) 8 + | | | + | | | R-(1) 7 + | | | | + | | L-(1) 6 + | | + L-(2) 4 + | + | R-(1) 2 + | | + L-(1) 1 + +count before: 15 +deleting 10… +not found +count after: 15 + + R-(1) 30 + | + R-(1) 30 + | + R-(2) 21 + | | + | | R-(1) 17 + | | | + | L-(1) 16 + | + R-(2) 16 + | | + | L-(1) 13 + | + (3) 11 + | + | R-(1) 11 + | | + | R-(2) 8 + | | | + | | | R-(1) 7 + | | | | + | | L-(1) 6 + | | + L-(2) 4 + | + | R-(1) 2 + | | + L-(1) 1 + +count before: 15 +deleting 12… +not found +count after: 15 + + R-(1) 30 + | + R-(1) 30 + | + R-(2) 21 + | | + | | R-(1) 17 + | | | + | L-(1) 16 + | + R-(2) 16 + | | + | L-(1) 13 + | + (3) 11 + | + | R-(1) 11 + | | + | R-(2) 8 + | | | + | | | R-(1) 7 + | | | | + | | L-(1) 6 + | | + L-(2) 4 + | + | R-(1) 2 + | | + L-(1) 1 + +count before: 15 +deleting 12… +not found +count after: 15 + + R-(1) 30 + | + R-(1) 30 + | + R-(2) 21 + | | + | | R-(1) 17 + | | | + | L-(1) 16 + | + R-(2) 16 + | | + | L-(1) 13 + | + (3) 11 + | + | R-(1) 11 + | | + | R-(2) 8 + | | | + | | | R-(1) 7 + | | | | + | | L-(1) 6 + | | + L-(2) 4 + | + | R-(1) 2 + | | + L-(1) 1 + +exit-code: 0