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
|
push %ebx
|
||||||
NEXT
|
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!"
|
defcode TWOSTORE,"2!"
|
||||||
pop %ebx
|
pop %ebx
|
||||||
popl (%ebx)
|
popl (%ebx)
|
||||||
|
|
@ -1002,6 +1012,12 @@ defcode TWORDROP,"2RDROP"
|
||||||
addl $8,%ebp
|
addl $8,%ebp
|
||||||
NEXT
|
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) */
|
/* ( -- a-addr ) Get the data stack pointer (address of cell below a-addr) */
|
||||||
defcode SPFETCH,"SP@"
|
defcode SPFETCH,"SP@"
|
||||||
push %esp
|
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
|
\ Return -1, 0, or 1 if n is respectively negative, zero, or positive
|
||||||
: SIGNUM ( n -- -1 | 0 | 1 ) DUP 0<= SWAP 0>= - ;
|
: 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
|
\ True if n1 >= n2 && n1 <= n3, false otherwise
|
||||||
: WITHIN ( n1|u1 n2|u2 n3|u3 -- flag ) OVER - -ROT - U> ;
|
: 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 ;
|
: 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 ;
|
: 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
|
\ Define names for the whitespace characters
|
||||||
8 CONSTANT HT \ Horizontal Tab
|
8 CONSTANT HT \ Horizontal Tab
|
||||||
10 CONSTANT LF \ Line Feed (newline)
|
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
|
\ Return -1, 0, or 1 if the left string is respectively
|
||||||
\ less than, equal to, or greater than the right string
|
\ less than, equal to, or greater than the right string
|
||||||
: COMPARE ( c-addr1 u1 c-addr2 u2 -- -1 | 0 | 1 )
|
: 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 )
|
( S: u1-u2 c-addr1 c-addr2 R: loop-sys )
|
||||||
OVER I + C@ OVER I + C@
|
OVER I + C@ OVER I + C@
|
||||||
( S: u1-u2 c-addr1 c-addr2 ch1 ch2 )
|
( S: u1-u2 c-addr1 c-addr2 ch1 ch2 )
|
||||||
- ?DUP IF -ROT 2>R NIP 2R> LEAVE THEN
|
U<=> ?DUP IF -ROT 2>R NIP 2R> LEAVE THEN
|
||||||
LOOP ▪ 2DROP SIGNUM ;
|
LOOP ▪ 2DROP ;
|
||||||
|
|
||||||
\ Convert a character to lowercase or uppercase, respectively
|
\ Convert a character to lowercase or uppercase, respectively
|
||||||
: TO-LOWER ( ch1 -- ch2 )
|
: 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
|
: ALIGNOF ( "<spaces?><type-name>" -- size ) IMMEDIATE
|
||||||
' EXECUTE %ALIGNOF STATE @ IF POSTPONE LITERAL THEN ;
|
' 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
|
\ 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 ;
|
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
|
\ Save the single-cell value at addr and then execute xt
|
||||||
\ When xt returns normally or THROWs (without CATCH), restore the saved value
|
\ When xt returns normally or THROWs (without CATCH), restore the saved value
|
||||||
: PRESERVED ( i*x xt addr -- j*x )
|
: 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
|
\ Run the reporter for the given exception code, or give the default report
|
||||||
: REPORT ( n -- )
|
: REPORT ( n -- )
|
||||||
DUP REPORTER IF
|
DUP REPORTER IF
|
||||||
NIP THROWN-STRING 2@ ROT 2@ DROP EXECUTE
|
NIP 2@ DROP EXECUTE
|
||||||
ELSE
|
ELSE
|
||||||
DROP ▪ "Uncaught exception: " TYPE-ERR
|
DROP ▪ "Uncaught exception: " TYPE-ERR
|
||||||
DUP ▪ ABS 0 <# #S ROT SIGN #> ▪ TYPE-ERR EOL ;
|
DUP ▪ ABS 0 <# #S ROT SIGN #> ▪ TYPE-ERR EOL ;
|
||||||
|
|
@ -2442,6 +2460,231 @@ REVERT
|
||||||
: MERGE-SORT> ( head1 link-xt compare-xt -- head2 )
|
: MERGE-SORT> ( head1 link-xt compare-xt -- head2 )
|
||||||
[[ ' NEGATE ]] COMPOSE DUP >R MERGE-SORT R> FREE-CLOSURE ;
|
[[ ' 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
|
FORTH-WORDLIST 1 SET-ORDER
|
||||||
DEFINITIONS
|
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