\ MATRIX.F

anew ~matrices

true constant RANGE-CHECK               \ Enable range checking

: sb@   ( addr -- n )                   \ Signed byte
        c@ dup 128 >= -128 and or ;

variable ~dimY
variable ~dimX
variable ~Y
variable ~X

RANGE-CHECK #IF
: byte-matrix   ( dimY dimX -<name>- )  \ compile time
                ( y x <name> -- a1 )    \ runtime
                create 2dup swap , ,    \ dimY dimX just before actual matrix
                * here over allot swap erase
                does> dup @ ~dimy !
                cell+ dup @ ~dimx !
                cell+ >r ~x !  ~y !
                ~y @ ~dimY @ u<
                ~x @ ~dimX @ u< and 0=
                abort" Dimension out of range"
                r> ~y @ ~dimx @ * ~x @ + + ;
#ELSE
: byte-matrix   ( dimY dimX -<name>- )  \ compile time
                ( y x <name> -- a1 )    \ runtime
                create 2dup swap , ,    \ dimY dimX just before actual matrix
                * here over allot swap erase
                does> dup @ ~dimy !
                cell+ dup @ ~dimx !
                cell+ >r ~x !  ~y !
\                ~y @ ~dimY @ u<
\                ~x @ ~dimX @ u< and 0=
\                abort" Dimension out of range"
                r> ~y @ ~dimx @ * ~x @ + + ;
#THEN

\ Typical use:
\       5 10 byte-matrix AA
\       n1 3 6 AA C!        \ store n1 at AA[3,5]
\       3 6 AA SB@          \ recover (signed) value

RANGE-CHECK #IF
: long-matrix   ( dimY dimX -<name>- )  \ compile time
                ( y x <name> -- a1 )    \ runtime
                create 2dup swap , ,    \ dimY dimX just before matrix
                * cells here over allot swap erase
                does> dup @ ~dimy ! cell+ dup @ ~dimx !
                cell+ >r
                ~x !  ~y !
                ~y @ ~dimY @ u<
                ~x @ ~dimX @ u< and 0=
                abort" Dimension out of range"
                r> ~y @ ~dimx @ * ~x @ + cells+ ;
#ELSE
: long-matrix   ( dimY dimX -<name>- )  \ compile time
                ( y x <name> -- a1 )    \ runtime
                create 2dup swap , ,    \ dimY dimX just before matrix
                * cells here over allot swap erase
                does> dup @ ~dimy ! cell+ dup @ ~dimx !
                cell+ >r ~x !  ~y !
\                ~y @ ~dimY @ u<
\                ~x @ ~dimX @ u< and 0=
\                abort" Dimension out of range"
               r> ~y @ ~dimx @ * ~x @ + cells+ ;
#THEN

\ Typical use:
\       5 10 long-matrix AA \ Each element holds a 32-bit = 1-cell value
\       n1 3 6 AA !         \ store n1 at AA[3,5]
\       3 6 AA @            \ recover (signed) value


RANGE-CHECK #IF
: word-matrix   ( dimY dimX -<name>- )  \ compile time
                ( y x <name> -- a1 )    \ runtime
                create 2dup swap , ,    \ dimY dimX just before matrix
                * 2* here over allot swap erase
                does> dup @ ~dimy ! cell+ dup @ ~dimx !
                cell+ >r ~x !  ~y !
                ~y @ ~dimY @ u<
                ~x @ ~dimX @ u< and 0=
                abort" Dimension out of range"
                r> ~y @ ~dimx @ * ~x @ + 2* + ;
#ELSE
: word-matrix   ( dimY dimX -<name>- )  \ compile time
                ( y x <name> -- a1 )    \ runtime
                create 2dup swap , ,    \ dimY dimX just before matrix
                * 2* here over allot swap erase
                does> dup @ ~dimy ! cell+ dup @ ~dimx !
                cell+ >r ~x !  ~y !
\                ~y @ ~dimY @ u<
\                ~x @ ~dimX @ u< and 0=
\                abort" Dimension out of range"
                r> ~y @ ~dimx @ * ~x @ + 2* + ;
#THEN
\ Typical use:
\       5 10 word-matrix AA \ Each element holds a 2-byte "word"
\       n1 3 6 AA w!        \ store n1 at AA[3,5]
\       3 6 AA Sw@          \ recover (signed) value

RANGE-CHECK #IF
: double-matrix ( dimY dimX -<name>- )  \ compile time
                ( y x <name> -- a1 )    \ runtime
                create 2dup swap , ,    \ dimY dimX just before matrix
                * cells 2* here over allot swap erase
                does> dup @ ~dimy ! cell+ @ dup ~dimx !
                cell+ >r ~x !  ~y !
                ~y @ ~dimY @ u<
                ~x @ ~dimX @ u< and 0=
                abort" Dimension out of range"
                r> ~y @ ~dimx @ * ~x @ + cells 2* + ;
#ELSE
: double-matrix ( dimY dimX -<name>- )  \ compile time
                ( y x <name> -- a1 )    \ runtime
                create 2dup swap , ,    \ dimY dimX just before matrix
                * cells 2* here over allot swap erase
                does> dup @ ~dimy ! cell+ @ dup ~dimx !
                cell+ >r ~x !  ~y !
\                ~y @ ~dimY @ u<
\                ~x @ ~dimX @ u< and 0=
\                abort" Dimension out of range"
                r> ~y @ ~dimx @ * ~x @ + cells 2* + ;
#THEN
\ Typical use:
\       5 10 double-matrix AA
\       lo hi 3 6 AA D!     \ store (hi,lo) at AA[3,5]
\       3 6 AA D@           \ recover (signed) value

RANGE-CHECK #IF
: byte-vector   ( n -<name>- )        \ compile time
                ( n <name> -- addr )    \ runtime
                create dup , here over allot swap erase
                does> swap >r
                dup @ r@ u> 0=
                abort" Vector dimension out of range"
                cell+ r> + ;
#ELSE
: byte-vector   ( n -<name>- )        \ compile time
                ( n <name> -- addr )    \ runtime
                create dup , here over allot swap erase
                does> swap >r
\                dup @ r@ u> 0=
\                abort" Vector dimension out of range"
                cell+ r> + ;
#THEN

\ Typical use:
\       20 byte-vector VV       \ Declare a byte vector
\       n1 15 VV C!             \ Store n1 at VV[15]
\       15 VV C@                \ Retrieve n1 from VV[15]

RANGE-CHECK #IF
: word-vector   ( n -<name>- )          \ Compile time
                ( n <name> -- addr )    \ runtime
                create dup , 2* here over allot swap erase
                does> swap >r
                dup @ r@ u> 0=
                abort" Vector dimension out of range"
                cell+ r> 2* + ;
#ELSE
: word-vector   ( n -<name>- )          \ Compile time
                ( n <name> -- addr )    \ runtime
                create dup , 2* here over allot swap erase
                does> swap >r
\                dup @ r@ u> 0=
\                abort" Vector dimension out of range"
                cell+ r> 2* + ;
#THEN

RANGE-CHECK #IF
: long-vector   ( n -<name>- )          \ Compile time
                ( n <name> -- addr )    \ runtime
                create dup , cells here over allot swap erase
                does> swap >r
                dup @ r@ u> 0=
                abort" Vector dimension out of range"
                cell+ r> cells + ;
#ELSE
: long-vector   ( n -<name>- )          \ Compile time
                ( n <name> -- addr )    \ runtime
                create dup , cells here over allot swap erase
                does> swap >r
\                dup @ r@ u> 0=
\                abort" Vector dimension out of range"
                cell+ r> cells + ;
#THEN

RANGE-CHECK #IF
: double-vector ( n -<name>- )          \ Compile time
                ( n <name> -- addr )    \ runtime
                create dup , cells 2* here over allot swap erase
                does> swap >r
                dup @ r@ u> 0=
                abort" Vector dimension out of range"
                cell+ r> cells 2* + ;
#ELSE
: double-vector ( n -<name>- )          \ Compile time
                ( n <name> -- addr )    \ runtime
                create dup , cells 2* here over allot swap erase
                does> swap >r
\                dup @ r@ u> 0=
\                abort" Vector dimension out of range"
                cell+ r> cells 2* + ;
#THEN

\S