recognizers
A collection of recognizers
\
\ separate stacks for cell sized data
\
\ Date: Oct 15, 2016
\ Author: Matthias Trute
\ License: Public Domain
\ with ideas from Jenny Brien
\ allocate a stack region with at most
\ size elements
: STACK ( size -- stack-id )
1+ ( size ) CELLS HERE SWAP ALLOT
0 OVER ! \ empty stack
;
\ replace the stack content with data from
\ the data stack.
: SET-STACK ( rec-n .. rec-1 n recstack-id -- )
DUP 0< IF -4 THROW THEN \ underflow check
2DUP ! CELL+ SWAP CELLS BOUNDS
?DO I ! CELL +LOOP
;
\ read the whole stack to the data stack
: GET-STACK ( recstack-id -- rec-n .. rec-1 n )
DUP @ >R R@ CELLS + R@ BEGIN
?DUP
WHILE
1- OVER @ ROT CELL - ROT
REPEAT
DROP R>
;
\ execute XT for earch element of the stack
\ leave the loop if the XT returns TRUE
: MAP-STACK ( i*x XT stack-id -- j*y f )
DUP CELL+ SWAP @ CELLS BOUNDS ?DO
( -- i*x XT )
I @ SWAP DUP >R EXECUTE
?DUP IF R> DROP UNLOOP EXIT THEN
R> CELL +LOOP
DROP 0
;
\ add an item as new top of the stack
: >STACK ( x stack-id -- )
2DUP 2>R NIP GET-STACK 2R> ROT 1+ SWAP SET-STACK
;
\ destructivly get Top Of Stack
: STACK> ( stack-id -- x )
DUP >R GET-STACK 1- R> ROT >R SET-STACK R>
;
\ add an item at the bottom of a stack
: >BACK ( x stack-id -- )
DUP >R GET-STACK 1+ R> SET-STACK
;
: BACK> ( stack-id -- x )
DUP >R GET-STACK 1- R> SET-STACK
;
\ ------------- Test Cases ------------
4 STACK constant test
: s1 1 0 ; \ 0 means continue with map-stack
: s2 2 0 ;
: s3 3 0 ;
: s4 4 -1 ; \ -1 means premature exit from map-stack
\ set and get methods
T{ 0 test SET-STACK -> }T
T{ test GET-STACK -> 0 }T
T{ ' s1 1 test SET-STACK -> }T
T{ test GET-STACK -> ' s1 1 }T
T{ ' s2 ' s1 2 test SET-STACK -> }T
T{ test GET-STACK -> ' s2 ' s1 2 }T
T{ ' s1 ' s2 ' s3 3 test SET-STACK -> }T
T{ test GET-STACK -> ' s1 ' s2 ' s3 3 }T
\ testing map-stack
\ the whole stack is used for execute
T{ ' EXECUTE test MAP-STACK -> 3 2 1 0 }T
T{ ' s1 ' s2 ' s4 3 test SET-STACK -> }T
\ only the 1st element is executed
T{ ' EXECUTE test MAP-STACK -> 4 -1 }T
\ append and prepend methods
T{ ' s1 1 test SET-STACK -> }T
T{ ' s2 test >STACK -> }T
T{ test GET-STACK -> ' s1 ' s2 2 }T
T{ test STACK> -> ' s2 }T
T{ test GET-STACK -> ' s1 1 }T
T{ ' s1 1 test SET-STACK -> }T
T{ ' s2 test >BACK -> }T
T{ test GET-STACK -> ' s2 ' s1 2 }T
T{ test BACK> -> ' s2 }T
T{ test GET-STACK -> ' s1 1 }T
by mtrute
Versions
2.1.0, 2.0.0, 1.4.5, 1.4.4, 1.4.3, 1.4.2, 1.4.1, 1.4.0, 1.3.2, 1.3.1, 1.3.0, 1.2.1, 1.2.0, 1.1.0, 1.0.1, 1.0.0
Download current as zip
Tags
recognizer, recognizerstack, stack
Dependencies
ttester 1.x.x, stack 1.x.x
Dependents
None