\ FSL_UTIL.FS           An auxiliary file for the Forth Scientific Library
\                       contains commonly needed definitions for Gforth.
\                       All inessentials removed, only runs MM.FS
\ Based on code by Skip Carter and PHA

\ S>F                Conversion between (single) integer and float
\ INTEGER DOUBLE FLOAT  For setting up ARRAY types
\ }MALLOC }FREE         Allocate and free dynamic arrays
\ MATRIX                For declaring a 2-D array
\ }}                    gets a Matrix element address
\ }}MALLOC }}FREE       Allocate and free dynamic matrices


: CELL- 1 CELLS - ;

: S>F ( n -- | f: -- x )        \ integer to float
        S>D  D>F ;

\ size of a regular integer
1 cells CONSTANT INTEGER
\ size of a double integer / 64-bit FLOAT
2 cells CONSTANT DOUBLE
\ size of a regular float
1 floats CONSTANT FLOAT

\ memory allocation status variable, 0 for OK
0 VALUE malloc-fail?

: cell_size ( addr -- n ) >BODY CELL+ @ ; \ gets array cell size

\ word for allocation of a dynamic 1-D array memory
\ typical usage:  & a{ #elements }malloc
: }MALLOC ( addr n -- ) 
          OVER cell_size DUP >R *     \ save extra cell_size on rstack
          \ now add space for the cell_size entry
          CELL+ ALLOCATE
          TO malloc-fail?
          OVER >BODY !
          \ now store the cell size in the beginning of the block
          >BODY @ R> SWAP ! ;

\ word to release dynamic array memory, typical usage:  & a{ }free
: }FREE ( addr -- )
        >BODY DUP
        @ FREE
        TO malloc-fail?
        0 SWAP ! ;

\ 1-D array definition
\    -------------------------
\    | cell_size | data area |
\    -------------------------
: ARRAY ( n cell_size -- | -- addr )
        CREATE  DUP , * ALLOT
        DOES>   CELL+ ;

\ Monotype
\    ------------------------
\    | data_ptr | cell_size |
\    ------------------------
: DARRAY   ( cell_size -- )   
        CREATE  0 , ,
        DOES>   @ CELL+ ;

: }  ( addr n -- addr[n]) OVER CELL- @ *  SWAP + ;


\ 2-D array definition,
\    -----------------------------------
\    | m | cell_size |  data area |
\    -----------------------------------
: MATRIX  ( n m size -- )               \ defining word for a 2-d matrix
        CREATE  OVER , DUP ,
                * * ALLOT
        DOES>   [ 2 CELLS ] LITERAL + ;

: }} ( addr i j -- addr[i][j] )         \ word to fetch 2-D array addresses
        >R >R                           \ indices to return stack temporarily
        DUP CELL- CELL-
        2@                              \ &a[0][0] size m
        R> *  R> + *  + ;

\ Dynamic 2-D array definition,
\    -------------------------------
\    | data_ptr | cell_size | (id) |
\    -------------------------------
: DMATRIX ( cell_size -- )
        CREATE  0 , ,
        DOES>   @ [ 2 CELLS ] LITERAL + ;

: }}FREE  }FREE ;

: }}MALLOC ( &matrix{{ rows cols )
( Allocates a matrix. The element size is known at compile time
  and is stored at &matrix{{; the array dimensions are specified
  at runtime. )
  2 PICK }}FREE                         ( deallocate the array to prevent memory leaks )
  2 PICK >BODY CELL+ @                  ( get the element size )
  2DUP 2>R * *  2 CELLS +               ( add room to store the element size and row length )
  ALLOCATE DUP TO malloc-fail? IF       ( there was an error)
    2R> 2DROP DROP 0 SWAP >BODY !       ( store 0 in the array pointer )
  ELSE
    R> R> 2 PICK 2!                     ( store the element size and row length )
    SWAP >BODY !                        ( store the array location )
  THEN ;

: use(  STATE @ IF POSTPONE ['] ELSE ' THEN ;  IMMEDIATE
: &     [COMPILE] use( ; IMMEDIATE


: F2DUP FOVER FOVER ;

\ TOOLS =============================================================================== 

123 VALUE seed
: RANDOM        seed  $107465 *  $234567 +      \ <> --- <u>
                DUP TO seed ;                   \ will this work for 16 bits?
: CHOOSE        RANDOM UM* NIP ;                \ <n> ---  0 <= u < n

CHAR x CONSTANT 'x'
CHAR n CONSTANT 'n'
CHAR v CONSTANT 'v'
CHAR u CONSTANT 'u'
CHAR p CONSTANT 'p'
CHAR t CONSTANT 't'
CHAR i CONSTANT 'i'
CHAR b CONSTANT 'b'
CHAR m CONSTANT 'm'
CHAR r CONSTANT 'r'
CHAR w CONSTANT 'w'
CHAR s CONSTANT 's'
CHAR : CONSTANT ':'
CHAR . CONSTANT '.'
CHAR , CONSTANT ','

9 CONSTANT TAB

: 2+       ( n -- m )  2 + ;
: 2^x      ( x -- 2^x )  1 SWAP 0 ?DO  1 LSHIFT  LOOP ;
: DFLOAT[] ( addr ix -- addr' ) DFLOATS + ;
: 3DUP     ( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 )  2 PICK 2 PICK 2 PICK ;

0 VALUE [S]
0 VALUE [T]

\ Not portable. 
: HTAB ( n -- ) 
        DROP 20 SPACES ;

166 VALUE PROCESSOR-CLOCK  
2VARIABLE _ticks_  ( counts clock ticks )
2VARIABLE _timer_

CODE TICKS-GET ( -- d )
     RDTSC
 .d 8 # bx sub
 .d ax 4 bx D) mov
 .d dx 0 bx D) mov
     NEXT
END-CODE

0 CONSTANT U>D

: TICKS-RESET  ( -- ) TICKS-GET _ticks_ 2! ;
: TICKS>US ( d -- u ) PROCESSOR-CLOCK UM/MOD NIP ;
: TICKS?     ( -- u ) TICKS-GET _ticks_ 2@  D- ;
: US?       ( -- us ) TICKS?  TICKS>US ;
: CALIBRATE    ( -- ) TICKS-RESET  1000 MS  TICKS? 1000000 UM/MOD NIP  TO PROCESSOR-CLOCK ; CALIBRATE

: TIMER-RESET  ( -- ) TICKS-GET _timer_ 2! ;
: TICKS>MS ( d -- u ) PROCESSOR-CLOCK UM/MOD NIP 1000 / ;
: MS?        ( -- u ) TICKS-GET _timer_ 2@ D- TICKS>MS ;
: ?MS        ( -- u ) TICKS-GET TICKS>MS ;
: n.ELAPSED  ( u -- ) . ." ms elapsed" ;
: .ELAPSED   (   -- ) MS? n.ELAPSED ;


CREATE tmp2 256 CHARS ALLOT

: S~      0 tmp2 C!  [char] ~ WORD COUNT tmp2 +PLACE  tmp2 COUNT POSTPONE SLITERAL ; IMMEDIATE
: []CELL  S" SWAP CELLS + " EVALUATE ; IMMEDIATE
: CELL[]  S"      CELLS + " EVALUATE ; IMMEDIATE
: DEC.    BASE @ >R DECIMAL . R> BASE ! ;

DEFINED DF+!  0= [IF] : DF+!                                DUP DF@ F+ DF! ;  [THEN]
DEFINED DF@+  0= [IF] : DF@+  ( addr -- addr' ) ( F: -- r ) DUP DF@ DFLOAT+ ; [THEN]
DEFINED DF!+  0= [IF] : DF!+  ( addr -- addr' ) ( F: r -- ) DUP DF! DFLOAT+ ; [THEN]
DEFINED DF+!+ 0= [IF] : DF+!+ ( addr -- addr' ) ( F: r -- ) DUP DF@ F+ DF!+ ; [THEN]

DEFINED DDOT 0=
  [IF] : DDOT ( addr1 inc1 addr2 inc2 count -- ) ( F: -- n )
                SWAP DFLOATS >R  ROT DFLOATS R> LOCALS| inc2 inc1 |
                0e 0 ?DO  SWAP DUP DF@ inc1 +  
                          SWAP DUP DF@ inc2 +  
                          F* F+   
                    LOOP  2DROP ;
[THEN]

DEFINED DAXPY 0=
  [IF]  : DAXPY ( addr1 inc1 addr2 inc2 count -- ) ( F: a -- )
                SWAP DFLOATS >R  ROT DFLOATS R> LOCALS| inc2 inc1 |
                0 ?DO   FDUP 
                        SWAP DUP DF@ F* inc1 +  
                        SWAP DUP DF+!   inc2 +  
                 LOOP   2DROP FDROP ;   
[THEN]            

: DFVARIABLE CREATE 0e F, ;

\ =====================================================================================