\ fsl-util.fth          An auxiliary file for the Forth Scientific Library
\                       For SwiftForth

\                       contains commonly needed definitions.
\ dxor, dor, dand       double xor, or, and
\ sd*                   single * double = double_product
\ v: defines use( &     For defining and settting execution vectors
\ %                     Parse next token as a FLOAT
\ -FROT                 Reverse the effect of FROT
\ INTEGER DOUBLE FLOAT  For setting up ARRAY types
\ ARRAY DARRAY          For declaring static and dynamic arrays
\ }                     For getting an ARRAY or DARRAY element address
\ }MALLOC }FREE         Allocate and free dynamic arrays
\ &!                    For storing ARRAY aliases in a DARRAY
\ PRINT-WIDTH           The number of elements per line for printing arrays
\ }FPRINT               Print out a given array
\ Matrix                For declaring a 2-D array
\ }}                    Gets a Matrix element address
\ }}MALLOC }}FREE       Allocate and free dynamic matrices
\ Public: Private: Reset_Search_Order   Controls the visibility of words
\ FRAME|   |FRAME       Sets up/removes a local variable frame
\ a b c d e f g h           Local FVARIABLE values
\ &a &b &c &d &e &f &g &h   Local FVARIABLE addresses


\ This code conforms with ANS requiring:
\     	1. The Floating-Point word set


\ This code is released to the public domain Everett Carter July 1994

\ CR .( FSL-UTIL.FTH      V1.15           7 October    1995   EFC )


\ ================= compilation control ======================================

\ for control of conditional compilation of test code
TRUE VALUE TEST-CODE?
TRUE VALUE ?TEST-CODE           \ obsolete, for backward compatibility


\ for control of conditional compilation of Dynamic memory
TRUE CONSTANT HAS-MEMORY-WORDS?

\ for control of conditional compilation of dereferencing unallocated array error
FALSE CONSTANT DEBUG-ARRAYS?


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

MAKE-FLOOR   \ Set SwiftForth floating point option to truncate on integer conversion

\ FSL NonANS words

pi  FCONSTANT F=PI
1e0 FCONSTANT f1.0
1e0 FCONSTANT F=1
0e0 FCONSTANT F=0

: FVALUE 
   DFCONSTANT ;

: FTO ( -- )   ( R: float -- )   \ Usage: ( f) FTO <name>
   '  
   STATE @ IF
      POSTPONE LITERAL POSTPONE >BODY POSTPONE DF!
   ELSE
      >BODY DF!
   THEN ; IMMEDIATE


-? : DEFINED   ( c-addr -- t/f )    \ returns definition status of
      FIND SWAP DROP             \ a word
;

: ~DEFINED   ( c-addr -- t/f )    \ returns definition status of
      DEFINED 0=                  \ a word
;


: FTUCK  ( F: x y -- y x y)   FSWAP FOVER ;

: F**2   FDUP F*     ;

: ZDUP    FOVER  FOVER  ;

: E.   FS. ;

: F2DROP    FDROP FDROP ;

: 4DUP   2OVER 2OVER ;

: FSQR  ( F: r -- r^2 ) FDUP F* ;

: F>=   ( F: r1 r2 -- ) ( -- bool ) F< 0= ;

: F<=   ( F: r1 r2 -- ) ( -- bool ) F> 0= ;

: 1/F   1/N ;


\ function vector definition


: v: CREATE ['] noop , DOES> @ EXECUTE ;
: defines   ' >BODY STATE @ IF POSTPONE LITERAL POSTPONE !
                            ELSE ! THEN ;   IMMEDIATE

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



WORDLIST CONSTANT hidden-wordlist

: Reset-Search-Order
	FORTH-WORDLIST 1 SET-ORDER
	FORTH-WORDLIST SET-CURRENT
;

: Public:
	FORTH-WORDLIST hidden-wordlist 2 SET-ORDER
	FORTH-WORDLIST SET-CURRENT
;

: Private:
	FORTH-WORDLIST hidden-wordlist 2 SET-ORDER
	hidden-wordlist SET-CURRENT
;

: Reset_Search_Order   Reset-Search-Order ;     \ these are
\ : reset-search-order   Reset-Search-Order ;	\ for backward compatibility
\ : private:              Private: ;
\ : public:               Public:  ;

CREATE fsl-pad	84 CHARS ( or more ) ALLOT

\ umd/mod     ( uquad uddiv -- udquot udmod ) unsigned quad divided by double
\ umd*        ( ud1 ud2 -- qprod )            unsigned double multiply
\ d*          ( d1 d2   -- dprod )            double multiply

: dxor       ( d1 d2 -- d )             \ double xor
	ROT XOR >R XOR R>
;

: dor       ( d1 d2 -- d )              \ double or
	ROT OR >R OR R>
;

: dand     ( d1 d2 -- d )               \ double and
	ROT AND >R AND R>
;

: d>
         2SWAP D<
;

\ single * double = double
: sd*   ( multiplicand  multiplier_double  -- product_double  )
             2 PICK * >R   UM*   R> +
;


0 VALUE TYPE-ID               \ for building structures
FALSE VALUE STRUCT-ARRAY?

\ for dynamically allocating a structure or array

TRUE  VALUE is-static?     \ TRUE for statically allocated structs and arrays
: dynamic ( -- )     FALSE TO is-static? ;

\ size of a regular integer
1 CELLS CONSTANT INTEGER

\ size of a double integer
2 CELLS CONSTANT DOUBLE

\ size of a regular float
1 FLOATS CONSTANT FLOAT

\ size of a pointer (for readability)
1 CELLS CONSTANT POINTER

-? : % BL WORD COUNT >FLOAT 0= ABORT" NAN"
   STATE @ IF POSTPONE FLITERAL THEN ; IMMEDIATE
                  
 : -FROT    FROT FROT ;


\ 1-D array definition
\    -----------------------------
\    | cell_size | data area     |
\    -----------------------------

: MARRAY ( n cell_size -- | -- addr )             \ monotype array
     CREATE
       DUP , * ALLOT
     DOES> CELL+
;

\    -----------------------------
\    | id | cell_size | data area |
\    -----------------------------

: SARRAY ( n cell_size -- | -- id addr )          \ structure array
     CREATE
       TYPE-ID ,
       DUP , * ALLOT
     DOES> DUP @ SWAP [ 2 CELLS ] LITERAL +
;

: ARRAY
     STRUCT-ARRAY? IF   SARRAY FALSE TO STRUCT-ARRAY?
                   ELSE MARRAY
                   THEN
;


\ : Array   ARRAY ;
\ : 1ARRAY   ARRAY ;


\ word for creation of a dynamic array (no memory allocated)

\ Monotype
\    ------------------------
\    | data_ptr | cell_size |
\    ------------------------

: DMARRAY   ( cell_size -- )   CREATE  0 , ,
                              DOES>
                                    @ CELL+
;

\ Structures
\    ----------------------------
\    | data_ptr | cell_size | id |
\    ----------------------------

: DSARRAY   ( cell_size -- )  CREATE  0 , , TYPE-ID ,
                              DOES>
                                    DUP [ 2 CELLS ] LITERAL + @ SWAP
                                    @ CELL+
;


: DARRAY   ( cell_size -- )
     STRUCT-ARRAY? IF   DSARRAY FALSE TO STRUCT-ARRAY?
                   ELSE DMARRAY
                   THEN
;


\ 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 -- )               \ | size | data area
                                      \ ---------------------
          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 !
;


v: do-align
v: do-aligned

: default-alignments  & ALIGN defines do-align  & ALIGNED defines do-aligned ;
: float-alignments    & FALIGN defines do-align  & FALIGNED defines do-aligned ;

: XINTEGER  1 CELLS  default-alignments ;

: XDOUBLE   2 CELLS  default-alignments ;

: XFLOAT   1  FLOATS    float-alignments ;


: XARRAY ( n size -- | -- addr )       \ experimental array with alignment
     CREATE
       DUP , DO-ALIGN * ALLOT
     DOES> CELL+ DO-ALIGNED
;


\ word for aliasing arrays,
\  typical usage:  a{ & b{ &!  sets b{ to point to a{'s data

: &!    ( addr_a &b -- )
        SWAP CELL- SWAP >BODY  !
;

DEBUG-ARRAYS? [IF]
: unallocated? ( array-address - array-address )
( Use ABORT" or THROW as you like. )
  DUP 0=
\ IF -9 THROW THEN
  ABORT" Array or matrix is not allocated"
  ;
[THEN]


: }   ( addr n -- addr[n])       \ word that fetches 1-D array addresses
          OVER CELL-  @
          * SWAP +
;

VARIABLE print-width      6 print-width !

: }fprint ( n addr -- )       \ print n elements of a float array
        SWAP 0 DO I print-width @ MOD 0= I AND IF CR THEN
                  DUP I } F@ F. LOOP
        DROP
;

: }iprint ( n addr -- )       \ print n elements of an integer array
        SWAP 0 DO I print-width @ MOD 0= I AND IF CR THEN
                  DUP I } @ . LOOP
        DROP
;

: }fcopy ( 'src 'dest n -- )         \ copy one array into another

     0 DO
                OVER I } F@
                DUP  I } F!
          LOOP

          2DROP
;

\ 2-D array definition,

\ Monotype
\    ------------------------------
\    | m | cell_size |  data area |
\    ------------------------------

: MMATRIX  ( n m size -- )           \ defining word for a 2-d matrix
        CREATE
           OVER , DUP ,
           * * ALLOT
        DOES>  [ 2 CELLS ] LITERAL +
;

\ Structures
\    -----------------------------------
\    | id | m | cell_size |  data area |
\    -----------------------------------

-? : SMATRIX  ( n m size -- )           \ defining word for a 2-d matrix
        CREATE TYPE-ID ,
           OVER , DUP ,
           * * ALLOT
        DOES>  DUP @ TO TYPE-ID
               [ 3 CELLS ] LITERAL +
;


: MATRIX  ( n m size -- )           \ defining word for a 2-d matrix
     STRUCT-ARRAY? IF   SMATRIX FALSE TO STRUCT-ARRAY?
                   ELSE MMATRIX
                   THEN

;


\  : DMATRIX ( size -- )      DARRAY ;


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


\ Dynamic 2-D array definition,
\    ------------------------------
\    | data_ptr | cell_size | (id) |
\    ------------------------------

\ word for creation of a dynamic array (no memory allocated)

\ Monotype
\    ------------------------
\    | data_ptr | cell_size |
\    ------------------------

\ : DMMATRIX   ( cell_size -- )
\  CREATE  0 , ,
\  DOES>  @ [ 2 CELLS ] LITERAL +
\ ;

: DMMATRIX   ( cell_size -- )
  CREATE  0 , ,
  DOES>  @ CELL+ ;
;

\ Structures
\    ----------------------------
\    | data_ptr | cell_size | id |
\    ----------------------------

: DSMATRIX   ( cell_size -- )
  CREATE  0 , , TYPE-ID ,
  DOES>  DUP [ 2 CELLS ] LITERAL + @ SWAP @ [ 2 CELLS ] LITERAL +
;


: DMATRIX   ( cell_size -- )
     STRUCT-ARRAY? IF   DSMATRIX FALSE TO STRUCT-ARRAY?
                   ELSE DMMATRIX
                   THEN
;

AKA }FREE }}FREE

\ word for allocation of a dynamic 2-D array memory
\ typical usage:  & a{{ #rows #cols }}malloc
                                       \  -------------------------
: }}malloc ( addr n m -- )             \  | m | size | data area 
                                       \  -------------------------
          2 PICK cell_size DUP
          >R OVER >R         \ save extra cell_size and m on rstack
          * *                \ calculate the space needed
          \ now add space for the cell_size entry and m
          CELL+ CELL+ ALLOCATE
          TO malloc-fail?

          SWAP OVER CELL+ SWAP >BODY !    \ store pointer to allocated space
                                          \ Note: pointing to size field not m

          \ now store m and cell size in the beginning of the block
          R> OVER !
          R> SWAP CELL+ !

;


: }}fprint ( n m addr -- )       \ print nXm elements of a float 2-D array
        ROT ROT SWAP 0 DO
                         DUP 0 DO
                                  OVER J I  }} F@ F.
                         LOOP

                         CR
                  LOOP
        2DROP
;


: }}iprint ( n m 'addr -- )       \ print n×m elements of a float 2-D array
  ROT ROT SWAP 0 DO
    DUP 0 DO
      OVER J I  }} @ .
    LOOP
    CR
  LOOP
  2DROP
;

: }}fcopy ( 'src 'dest n m  -- )      \ copy n×m elements of 2-D array src to dest
        SWAP 0 DO
                 DUP 0 DO
                            2 PICK J I  }} F@
                            OVER J I }} F!
                        LOOP
                  LOOP
        DROP 2DROP
;


\
\ Code for local fvariables, loosely based upon Wil Baden's idea presented
\ at FORML 1992.
\ The idea is to have a fixed number of variables with fixed names.
\
\  example:  : test  2e 3e FRAME| a b |  a f. b f. |FRAME ;
\           test <cr> 3.0000 2.0000 ok
\
\  PS: Don't forget to use |FRAME before an EXIT .
\

8 CONSTANT /flocals

: (frame) ( n -- ) FLOATS ALLOT ;

: FRAME|
        0 >R
        BEGIN   BL WORD  COUNT  1 =
                SWAP C@  [CHAR] | =
                AND 0=
        WHILE   POSTPONE F,  R> 1+ >R
        REPEAT
        /FLOCALS R> - DUP 0< ABORT" too many flocals"
        POSTPONE LITERAL  POSTPONE (frame) ; IMMEDIATE

: |FRAME ( -- ) [ /FLOCALS NEGATE ] LITERAL (FRAME) ;

: &h            HERE [ 1 FLOATS ] LITERAL - ;
: &g            HERE [ 2 FLOATS ] LITERAL - ;
: &f            HERE [ 3 FLOATS ] LITERAL - ;
: &e            HERE [ 4 FLOATS ] LITERAL - ;
: &d            HERE [ 5 FLOATS ] LITERAL - ;
: &c            HERE [ 6 FLOATS ] LITERAL - ;
: &b            HERE [ 7 FLOATS ] LITERAL - ;
: &a            HERE [ 8 FLOATS ] LITERAL - ;

: a             &a F@ ;
-? : b             &b F@ ;
: c             &c F@ ;
: d             &d F@ ;
: e             &e F@ ;
: f             &f F@ ;
-? : g             &g F@ ;
-? : h             &h F@ ;

\ --------------------------------------------------------------------------------------------------------------------------
\ --- Tools, mhx Sunday, June 16, 2002 9:24 AM

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

9 CONSTANT TAB

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

0 VALUE [S]
0 VALUE [T]

: HTAB ( n -- ) DROP 20 SPACES ;

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

\ uses EDX:EAX
CODE TICKS-GET ( -- d )
	8 # EBP SUB
	EBX 4 [EBP] MOV
	$0F C, $31 C, \ RDTSC
	EAX 0 [EBP] MOV
	EDX EBX MOV
	RET
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 ;

[DEFINED] ENDIF 0= [IF] : ENDIF POSTPONE THEN ; IMMEDIATE [THEN]

CREATE tmp2 256 CHARS ALLOT

: +PLACE  APPEND ;
: 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]		  

[DEFINED] DFVARIABLE 0= [IF]  : DFVARIABLE CREATE 0e F, ; [THEN]