add AA tree implementation
This commit is contained in:
parent
4eb3fad278
commit
73de579da0
16
jumpforth.S
16
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
|
||||
|
|
|
|||
255
startup.4th
255
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 ( "<spaces?><type-name>" -- 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 ( "<spaces?><field-name>" -- offset ) IMMEDIATE
|
||||
: OFFSETOF ( "<spaces?><field-name>" -- ; -- 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 ( "<spaces?><field-name>" -- ; 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
|
||||
\ <https://en.wikipedia.org/wiki/AA_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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 "<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
|
||||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue