\ Audio GUI
\
\ $Id: audio-gui.fs 1251 2009-12-11 13:56:00Z berndp $

\ uncomment for test gui:

\ : fake-spi ;

\needs float import float
include fft.fb
include fileop.fb
[IFUNDEF] float-action
forth include minos-float.fs
[THEN]
Onlyforth float also complex also editor also minos also forth

\ SPI update tracking

true Value do-check
true Value do-16bit
false Value do-single
false Value direct-coeff
true Value check-ok
true Value do-spi
false Value verbose-spi
false Value verbose-spi@
false Value new-eq
true Value record-spi

Sema spi%

[IFUNDEF] holds
    : holds ( addr u -- )  pad cell- over negate over +!
	@ swap move ;
[THEN]

: r*/ ( a b c -- n )  swap 2* swap */ 1+ 2/ ;
: r'*/ ( a b c -- n )  2/ */ 1+ 2/ ;
[IFUNDEF] bit!
    : bit! ( bit addr u -- )  rot IF  +bit  ELSE  -bit  THEN ;
[THEN]

\needs arg#  Variable arg# 1 arg# !

also minos
: ?shift  kbshift @ 1 and ;
: ?caps   kbshift @ 2 and ;
: ?ctrl   kbshift @ 4 and ;
: ?alt    kbshift @ 8 and ;
previous

Variable audio-guis

$1000 cells Constant spi#

Create spi-buf spi# allot

: spi-empty  spi-buf spi# -1 fill ;

spi-empty

: >spi ( data addr -- )
    record-spi 0= IF  2drop  EXIT  THEN
    spi-buf spi# bounds ?DO
	dup I @ = I @ -1 = or  IF  I 2!  unloop EXIT  THEN
    2 cells +LOOP  2drop ." No space in SPI" cr ;
: spi> ( addr -- data )
    spi-buf spi# bounds ?DO
	dup I @ = IF  drop I cell+ @ unloop  EXIT  THEN
    2 cells +LOOP  drop  0 ;

: .? IF  ." true "  ELSE ." false "  THEN ;

Forward reg>name
: .addr ( addr -- )  reg>name type space ;

: .version ( -- )
    ." \ SPI setup saved by audio-gui rev. 4.0" cr ;
: .spi ( -- ) base push hex
    do-check .? ." to do-check" cr
    do-16bit .? ." to do-16bit" cr
    do-single .? ." to do-single" cr
    spi-buf spi# bounds ?DO
	I @ -1 = ?LEAVE
	I 2@ swap '$ emit u. .addr ." spi!" cr
    2 cells +LOOP ;

: hex. base push hex '$ emit u. ;
: $. base push hex ." $" . ;
: .d&t time&date 0 .r '/ emit 0 .r '/ emit . 2 .r ': emit 2 .r ': emit 2 .r ;
: .ok  verbose-spi@ check-ok 0= and  IF  ." crc error" cr  THEN ;

\ global counter for update

Variable update#

$1234 update# !

[IFUNDEF] fake-spi
also dos
[IFDEF] win32
library ftdi ftd2xx.dll
[ELSE]
[IFDEF] osx
library ftdi libftd2xx.dylib
[ELSE] \ other unixes
library ftdi libftd2xx.so
[THEN]
[THEN]

legacy off

ftdi FT_Open ptr int (int) FT_Open ( port handleaddr -- r )
ftdi FT_Close ptr int (int) FT_Close ( handle -- r )
ftdi FT_SetBitMode int int int (int) FT_SetBitMode ( handle io mode -- r )
ftdi FT_GetBitMode int int (int) FT_GetBitMode ( handle addr -- r )
ftdi FT_SetBaudRate int int (int) FT_SetBaudRate ( handle baud -- r )
ftdi FT_Write ptr int ptr int (int) FT_Write ( handle addr n &count -- r )
ftdi FT_Read ptr int ptr int (int) FT_Read ( handle addr n &count -- r )
ftdi FT_GetQueueStatus ptr int (int) FT_GetQueueStatus ( handle &count -- r )
ftdi FT_SetLatencyTimer int int (int) FT_SetLatencyTimer ( handle lateny -- r )

previous
[THEN]

Variable ftdev
Variable ftcount
$8000 allocate throw Value buffer
$8000 allocate throw Value inbuffer
$2000 allocate throw Value csbuffer
Variable inptr
Variable checksum
2Variable csptr
&6000000 Value baud

: cs+ ( n -- n ) dup $FF and checksum +! ;
: (cs, ( -- )  checksum @ csbuffer csptr @ + c! 1 csptr +! ;
: cs? ( -- ) csbuffer csptr cell+ @ + c@ checksum ! 1 csptr cell+ +! ;
: b, ( n -- )  cs+ buffer @ c! 1 buffer +! ;
: br, ( n -- )  buffer @ c! 1 buffer +! ;
: wb, ( n -- )  dup 8 rshift b, b, ;
: wxbr, ( n -- )  dup br, 8 rshift br, ;
: wxb, ( n -- )  dup b, 8 rshift b, ;
: lb, ( n -- )  dup 16 rshift wb, wb, ;
: b-off ( -- )  buffer cell+ buffer !  inbuffer off  0. csptr 2!
    inptr off true to check-ok ;
: b@ ( -- addr u ) buffer @+ tuck - ;
: i@ ( -- addr u ) inbuffer @+ swap ;
: ib, ( n -- n' )  i@ inptr @ /string
    IF  c@ cs+ 1 inptr +!   ELSE  drop 0  THEN  swap 8 lshift or ;
: ics? ( -- )
    do-check IF
	checksum @ invert $FF and 0 ib, =
	check-ok and to check-ok  checksum off  THEN ;
: il, ( -- n )  cs? 0 ib, ib, ib, ib, ;
: iw, ( -- w )  cs? 0 ib, ib, ;
: il? ( -- n )  il, ics? ;
: iw? ( -- n )  iw, ics? ;
b-off

[IFUNDEF] fake-spi
: bflush ( -- )  ftdev @ b@ ftcount FT_Write drop b-off ;
: bcheck ( -- )  ftdev @ ftcount FT_GetQueueStatus drop
    ftcount @ IF
        ftdev @ inbuffer cell+ inbuffer @ dup >r + ftcount @
        inbuffer FT_Read drop r> inbuffer +!
    THEN ;
[ELSE]
    : bflush ;
    : bcheck ;
[THEN]

\ chip select 1, chip select 0, data out tristate

[IFDEF] cs_high
: cs1 ( -- )  $80 br, $08 br, $0B br, ;
: cs0 ( -- )  $80 br, $00 br, $0B br, ;
: doz ( -- )  $80 br, $08 br, $09 br, ;
[ELSE]
: cs1 ( -- )  $80 br, $00 br, $0B br, ;
: cs0 ( -- )  $80 br, $08 br, $0B br, ;
: doz ( -- )  $80 br, $00 br, $09 br, ;
[THEN]

: write, ( n -- )  cs1 $11 br, wxbr, ;
: read, ( n -- )  doz $24 br, wxbr, cs0 ;

\ addresses and data

2Variable cs-inject 0 0 cs-inject 2!

: cs, ( -- ) checksum @ invert
    cs-inject 2@ 0= IF xor ELSE  -1 cs-inject +! drop THEN
    b, (cs, checksum off ;
: cs,s ( n -- )  0 ?DO  (cs, checksum off  LOOP ;
: addr, ( addr cmd -- ) \ over $.
    2 write, checksum off b, wb, ;
: w32 ( data32 addr -- ) 6 write, $03 b, wb, lb, cs0 ;
: w32c ( data32 addr -- ) 7 write, checksum off $23 b,
    wb, lb, cs, cs0 ;
: w32s ( spiaddr dataaddr n -- ) >r swap
    2 r@ cells + write, $03 b, wb,
    r> cells bounds DO  I @ lb, cell +LOOP  cs0 ;
: w32cs ( spiaddr dataaddr n -- ) >r swap
    2 r@ 5 * + write,
    checksum off $23 b, wb,
    r> cells bounds ?DO  I @ lb, cs, checksum off
    cell +LOOP  cs0 ;
: w16 ( data16 addr -- ) 4 write, $13 b, wb, wb, cs0 ;
: w16c ( data16 addr -- ) 5 write, checksum off $33 b,
    wb, wb, cs, cs0 ;
: w16s ( spiaddr dataaddr n -- ) >r swap
    2 r@ 2* + write, $13 b, wb,
    r> cells bounds DO  I @ 16 rshift wb, cell +LOOP  cs0 ;
: w16cs ( spiaddr dataaddr n -- ) >r swap
    2 r@ 3 * + write,
    checksum off $33 b, wb,
    r> cells bounds ?DO  I @ 16 rshift wb, cs, checksum off
    cell +LOOP  cs0 ;
: r32s ( addr n -- )  swap $02 addr, cells 1- read, ;
: r32cs ( addr n -- ) swap $22 addr, dup cs,s 5 * 1- read, ;
: r32 ( addr -- )    1 r32s ;
: r32c ( addr -- )   1 r32cs ;
: r16 ( addr -- )  $12 addr, 1 read, ;
: r16c ( addr -- ) $32 addr, 1 cs,s 2 read, ;
: rstatus ( addr -- )  0 write, $05 b, 0 read, ;

: r32s? ( addr n -- )     do-check IF  r32cs  ELSE  r32s  THEN ;

\ open the bus

also dos

: fast-spi  do-spi 0= ?EXIT  b-off doz $86 b, 2 wxb, cs0 bflush ;
: slow-spi  do-spi 0= ?EXIT  b-off doz $86 b, 5 wxb, cs0 bflush ;
: slow2-spi  do-spi 0= ?EXIT  b-off doz $86 b, 2 wxb, cs0 bflush ;

0 Value spi-dev#

[IFUNDEF] fake-spi
: open-spi ( -- )
\    S" rmmod ftdi_sio usbserial" system drop
    do-spi 0= ?EXIT
    10 0 DO  I ftdev FT_Open WHILE  LOOP
    true abort" Can't open FTDI" ELSE  I to spi-dev# UNLOOP  THEN
\    ftdev @ 0 0 FT_SetBitMode drop
    ftdev @ 0 2 FT_SetBitMode drop
    [IFDEF] osx  20 ms  fast-spi [ELSE] fast-spi [THEN] ;
[ELSE]
    : open-spi ( -- ) false to do-spi  true to direct-coeff ;
[THEN]

previous

Variable timeout

also minos

forward check-version

: ?open ( -- )
    do-spi 0= ?EXIT
    ftdev @ 0= IF ['] open-spi catch
	IF
	    false to do-spi
	    true  to direct-coeff
	ELSE
	    true  to do-spi
	    false to direct-coeff
	    check-version
	THEN
    THEN  &2000 after timeout ! ;

previous

\ ?open

\ spi read write

: we ( -- )  ?open 0 write, 6 b, cs0 bflush ;
: wd ( -- )  ?open 0 write, 4 b, cs0 bflush ;

: waitx  10 ms timeout @ 0 after - 0< ;

\ raw byte

: check-read ( n -- flag )  bflush
    BEGIN  bcheck inbuffer @ over < WHILE  waitx  UNTIL
    false  ELSE  true  THEN  nip [IFDEF] osx 10 ms [THEN] ;

: pins@ ( -- x )  & check-ok push
    do-spi 0= IF  0   EXIT  THEN  spi% lock
    ?open $81 b, bflush
    BEGIN  bcheck inbuffer @ 1 < WHILE  waitx drop  REPEAT
    i@ drop c@  spi% unlock ;

: nad
    false to do-check \ no CRC
    false to do-16bit \ no 16 bit access
    true to do-single \ decompose multiple accesses
;

also fileop ' fhandle Alias fhandle previous

: spi! ( data addr -- )  spi% lock  1 update# +!
    fhandle @ IF  2dup swap hex. .addr ." spi! \ " .d&t cr  THEN
    verbose-spi IF  2dup swap hex. .addr ." spi!" cr  THEN
    2dup >spi do-spi 0= IF  2drop EXIT  THEN ?open
    do-check IF  w32c  ELSE  w32  THEN  bflush spi% unlock ;

: spi@ ( addr -- data )  spi% lock  b-off
    verbose-spi@ 0> IF  dup .addr ." spi@ "  THEN
    do-spi 0= IF  spi>  EXIT  THEN  ?open
    BEGIN  dup do-check IF  r32c  ELSE  r32  THEN
	4 do-check - check-read  UNTIL  drop
    il?  verbose-spi@ IF  dup $. cr THEN  .ok spi% unlock ;

: spiw! ( data addr -- ) spi% lock  1 update# +!
    fhandle @ IF  2dup swap $. .addr ." spiw! \ " .d&t cr  THEN
    do-16bit do-spi and  IF
	verbose-spi IF  base push hex 2dup swap $. .addr ." spiw!" cr  THEN
	over 16 lshift over >spi ?open
	do-check IF  w16c  ELSE  w16  THEN  bflush
    ELSE
	& verbose-spi dup push off
	swap 16 lshift swap spi!
    THEN  spi% unlock ;
: spiw@ ( addr -- data )  spi% lock
    b-off  do-16bit do-spi and  IF
	?open
	BEGIN  dup do-check  IF  r16c  ELSE  r16  THEN
	    2 do-check - check-read  UNTIL  drop
	iw?  verbose-spi@ IF  dup $. cr THEN
    ELSE
	spi@ 16 rshift 
    THEN  .ok  spi% unlock ;
: status@ ( -- data )  & check-ok push
    do-spi 0= IF  0  EXIT  THEN  spi% lock  ?open
    BEGIN  rstatus 1 check-read  UNTIL
    0 i@ bounds ?DO  8 lshift I c@ or  LOOP  spi% unlock ;

\ Array access

Code bswap  AX bswap  Next end-code

Variable a-buff $100 allot

: [[ depth a-buff ! a-buff cell+ $100 erase ;
: ]] ( -- addr ) depth a-buff @ - dup a-buff !
    0 ?DO  a-buff I' I - cells + !  LOOP
    a-buff cell+ ;

forward cf>s

also float

: F[[ ['] f# IS notfound  fdepth a-buff ! ;
: ]]F ( -- addr ) fdepth a-buff @ - dup a-buff !
    0 ?DO
	cf>s a-buff I' I - cells + !  LOOP
    a-buff cell+ ;

previous

: dswap ( -- )  i@ bounds ?DO  I @ bswap I !  cell +LOOP ;

: spi@s ( spiaddr dataaddr n -- )  spi% lock  b-off
    verbose-spi@ IF  over2 .addr ." spi@ " THEN
    do-spi 0= IF  cells bounds ?DO  dup spi@ I ! 1+ cell +LOOP  drop
	EXIT  THEN  ?open
    do-single IF
	BEGIN  over2 over 0 DO  dup r32 1+ LOOP  drop
	dup cells check-read UNTIL
    ELSE
	BEGIN  over2 over r32s? dup 1 cells do-check - * check-read  UNTIL
    THEN  rot drop
    verbose-spi@ IF  ." [[ "  THEN
    cells bounds ?DO il?
	verbose-spi@ IF  dup hex. ?cr  THEN
    I !  cell +LOOP
    verbose-spi@ IF ." ]]" cr  THEN  .ok  spi% unlock ;

: spi@1 ( addr1 addr2 -- )  swap 1 spi@s ;
: spi@2 ( addr1 addr2 -- )  swap 2 spi@s ;
: spi@4 ( addr1 addr2 -- )  swap 4 spi@s ;
: spi@8 ( addr1 addr2 -- )  swap 8 spi@s ;
: spi@A ( addr1 addr2 -- )  swap 10 spi@s ;
: spi@16 ( addr1 addr2 -- )  swap 16 spi@s ;
: spi@20 ( addr1 addr2 -- )  swap 20 spi@s ;

: spi!s ( spiaddr dataaddr n -- )  spi% lock 1 update# +!
    fhandle @ IF  over2 hex. ." [[ "
	2dup cells bounds ?DO  I @ $. cell +LOOP ." ]] "
        dup .addr ." spi!s \ " .d&t cr
    THEN
    verbose-spi IF  base push hex ." [[ "
	2dup cells bounds ?DO  I @ $. ?cr  cell +LOOP ." ]] "
	over2 .addr ." spi!" dup . cr THEN
    do-single do-spi 0= or IF  & verbose-spi dup push off
	cells bounds ?DO  I @ over spi! 1+  cell +LOOP  drop
    ELSE
	over2 over2 over2
	cells bounds DO  I @ over >spi 1+  cell +LOOP  drop
	?open  do-check  IF  w32cs  ELSE  w32s  THEN  bflush
    THEN  spi% unlock ;

: spi!8 ( addr1 addr2 -- )  swap 8 spi!s ;
: spi!4 ( addr1 addr2 -- )  swap 4 spi!s ;
: spi!5 ( addr1 addr2 -- )  swap 5 spi!s ;
: spi!A ( addr1 addr2 -- )  swap $A spi!s ;

: spiw!s ( spiaddr dataaddr n -- )  spi% lock  1 update# +!
    fhandle @ IF  over2 hex. ." [[ "
	2dup 2* bounds ?DO  I w@ $. 2 +LOOP ." ]] "
        dup .addr ." spiw!s \ " .d&t cr
    THEN
    do-single do-spi 0= or IF  & verbose-spi dup push off
	>r swap r>  0 ?DO
	    over @ over spiw! 1+ swap cell+ swap  LOOP  2drop
    ELSE
	over2 over2 over2
	bounds DO  I @ over >spi 1+ cell +LOOP  drop
	?open  do-check  IF  w16cs  ELSE  w16s  THEN  bflush
    THEN spi% unlock ;

\ : spiw!A ( addr1 addr2 -- )  swap $A spiw!s ;

: spi-dumps ( addr n -- ) base push hex
    >r dup inbuffer cell+ r@ spi@s
    dup 4 u.r space
    0 inbuffer cell+ r> cells bounds ?DO
	I @ 0 <# # # # #  # # # # #> type
	I' I cell+ <> IF
	    1+ dup 7 and 0= IF  cr >r 8 + dup 4 u.r r> THEN  space
	THEN
    cell +LOOP  2drop cr ;

: spi-dump8   ( addr -- )   8 spi-dumps ;
: spi-dump16  ( addr -- )  16 spi-dumps ;
: spi-dump32  ( addr -- )  32 spi-dumps ;
: spi-dump128 ( addr -- ) 128 spi-dumps ;
: spi-dump256 ( addr -- ) 256 spi-dumps ;

2Variable save-channels 8 0 save-channels 2!
Variable save-xo save-xo on
Variable save-eq save-eq on
Variable save-ic save-ic on

: save? ( n -- flag )
    dup 4 < IF  drop save-xo @  ELSE
	&12 < IF save-eq @ ELSE save-ic @ THEN THEN ;

also float

: addr>n ( addr -- n )
    dup $400 and IF  7  ELSE  9  THEN  rshift
    dup 1 and >r 3 rshift 6 and r> or ;
: addr>n,m ( addr -- n m )  dup $7F and $14 - 5 / >r addr>n r> ;
: n,m>addr ( n m -- addr )
    5 * $14 + >r dup 6 and 3 lshift swap 1 and or 9 lshift r> or ;
: n,m>addr' ( n m -- addr )
    5 * $14 + >r dup 6 and 3 lshift swap 1 and or 7 lshift $400 or r> or ;
: save-addr? ( addr -- flag )
    addr>n,m save? >r save-channels 2@ within 0= r> and ;

: spi-dump@ ( spi-addr -- spi-addr addr u )
    i@ over2 $80 and cells /string $5A cells min $14 cells /string ;

: spi-dump-coeffs ( addr -- ) base push decimal
    spi-dump@ bounds
    ?DO dup save-addr?
	IF  ." F[[ "
	    I 5 cells bounds DO
		I @ bswap [ 1e $10000000 fm/ ] Fliteral fm* fe.
	    cell +LOOP ." ]]F " dup .addr ." coeff!" cr  THEN  5 +
    5 cells +LOOP drop cr ;

: spi-dump-coeffsh ( addr -- ) base push decimal
    spi-dump@ bounds
    ?DO dup save-addr?
	IF  ." [[ "
	    I 5 cells bounds DO
		I @ bswap $.
	    cell +LOOP ." ]] " dup .addr ." coeff!" cr  THEN  5 +
    5 cells +LOOP drop cr ;

: read-cmem ( addr -- addr ) spi% lock  do-spi IF  ?open
	BEGIN  dup 256 r32s $400 check-read  UNTIL
    ELSE  $400 inbuffer !  dup inbuffer cell+ $100 spi@s dswap  THEN
    spi% unlock ;

: spi-dump-cmem ( addr -- )  read-cmem
    6 set-precision
    dup $14 + spi-dump-coeffs
    dup $94 + spi-dump-coeffs drop ;

: spi-dump-cmemh ( addr -- )  read-cmem
    dup $14 + spi-dump-coeffsh
    dup $94 + spi-dump-coeffsh drop ;

previous

&28 Value cfraction
1 cfraction lshift 1- Constant cfmask
&28 Value fraction
1 fraction lshift 1- Constant fmask
$7FFFFFFF Constant pmask

Variable overflow
: fmin' ( a b -- min )
    funder fmin funder f= overflow @ or overflow ! ;
: fmax' ( a b -- min )
    funder fmax funder f= overflow @ or overflow ! ;

: cf>s 7.999999999e fmin' -8e fmax' cfmask 1+ fm* f>s $80 + $FFFFFF00 and ;
: s>cf s>f cfmask 1+ fm/ ;
: f>s, fmask 1+ fm* f>s , ;

&14 Constant eqs
: eq: ( -- )  Create &8 eqs * 0 DO  dup ,  LOOP  drop  DOES> swap eqs * cells + ;

Create coeffs'  8 0 [DO] eqs 0 [DO]  0 , 0 , 1e cf>s , 0 , 0 ,  [LOOP] [LOOP]
0 eq: fslider
0 eq: fgain
&111 eq: fq
&440 eq: ffreq
0 eq: ftype
0 eq: fgain2
0 eq: fgain3
Create cbuffs  &15 0 [DO]  0 , 0 , 1e f>s, 0 , 0 ,  [LOOP]
coeffs' Value coeffs
coeffs Value coeff
cbuffs Value cbuff
Variable channel

: #c ( n -- )  5 cells * dup coeffs + to coeff cbuffs + to cbuff ;
: #ch ( n -- )  dup channel ! eqs 5 * cells * coeffs' + to coeffs ;

$DAA11000 Value version

include regmap.fs

: old-version? ( -- flag )
    version $DAA10000 = ;
: check-version ( -- )
\    $47F spi@ to version
    old-version? IF  old-audiofmt  THEN  ;

Code >w< ( -- ) AH AL xchg  Next end-code macro 
Code >l< ( -- ) AX 16 # ror  Next end-code macro

Variable volbuffer 4 5 * cells allot
Variable eqbuffer 8 4 * cells allot
Variable stampbuffer $14 4 * cells allot
Variable databuffer 4 4 * cells allot
Variable statebuffer 4 2 * cells allot
Variable easybuffer 4 5 * cells allot
&77 [IFDEF] osx 8 * [THEN] constant volafter
Variable old-update# -1 old-update# !
: timeout-off ( -- )
    volafter negate after
    dup volbuffer !
    dup eqbuffer !
    dup stampbuffer !
    dup databuffer !
    dup statebuffer !
        easybuffer ! ;
timeout-off

: timeout? ( time -- flag )
    volafter after 0 after within ftdev @ 0= or
    update# @ old-update# @ <> or update# @ old-update# ! ;
: vol@ ( n -- )  spi% lock  volbuffer @ timeout? IF
	?open
	do-single do-spi 0= or  IF
	    NOVAMASK0 VOLT0 volbuffer cell+ 16 cells bounds ?DO
		dup I           2 spi@s $800 + swap
		dup I 2 cells + 2 spi@s $800 + swap
	    4 cells +LOOP  2drop
	    volbuffer cell+ 16 cells + MVOLT spi@4
	ELSE
	    BEGIN  b-off
		VOLT0 2 r32s? NOVAMASK0 2 r32s?
		VOLT1 2 r32s? NOVAMASK1 2 r32s?
		VOLT2 2 r32s? NOVAMASK2 2 r32s?
		VOLT3 2 r32s? NOVAMASK3 2 r32s?
		MVOLT 4 r32s?
	    4 5 * cells do-check 4 5 * * - check-read  UNTIL
	    volbuffer cell+ 4 5 * cells bounds DO
		il? check-ok IF  I !  ELSE  drop  THEN
	    cell +LOOP  .ok
	THEN  check-ok IF  volafter after volbuffer !  THEN
    THEN
    dup $4000 and IF  3 and $10 +
    ELSE  dup 1 and over 4 and 2/ + swap 9 rshift $C and +
    THEN  cells cell+ volbuffer + @  spi% unlock ;
: eq@ ( addr -- n )  spi% lock  eqbuffer @ timeout? IF
	?open  do-single do-spi 0= or  IF
	    eqbuffer cell+             CONF0 spi@8
	    eqbuffer cell+ $08 cells + CONF1 spi@8
	    eqbuffer cell+ $10 cells + CONF2 spi@8
	    eqbuffer cell+ $18 cells + CONF3 spi@8
	ELSE
	    BEGIN  b-off
		CONF0 8 r32s?  CONF1 8 r32s?  CONF2 8 r32s?  CONF3 8 r32s?
	    $80 do-check $10 * - check-read  UNTIL
	    eqbuffer cell+ $80 bounds DO
		il? check-ok IF  I !  ELSE  drop  THEN
	    cell +LOOP  .ok
	THEN  check-ok IF  volafter after eqbuffer !  THEN
    THEN
    dup 7 and swap &8 rshift $18 and + cells
    eqbuffer cell+ + @  spi% unlock ;
: stamp@ ( addr -- n )  spi% lock  stampbuffer @ timeout? IF
	?open  do-single do-spi 0= or  IF
	    stampbuffer cell+             STCTL0 spi@20
	    stampbuffer cell+ $14 cells + STCTL1 spi@20
	    stampbuffer cell+ $28 cells + STCTL2 spi@20
	    stampbuffer cell+ $3C cells + STCTL3 spi@20
	ELSE
	    BEGIN
		STCTL0 20 r32s?  STCTL1 20 r32s?  STCTL2 20 r32s?  STCTL3 20 r32s?
	    $140 do-check $28 * - check-read  UNTIL
	    stampbuffer cell+ $140 bounds DO
		il? check-ok IF  I !  ELSE  drop  THEN
	    cell +LOOP  .ok
	THEN  check-ok IF  volafter after stampbuffer !  THEN
    THEN
    dup $1F and swap &7 rshift $30 and dup 2 rshift + + cells
    stampbuffer cell+ + @  spi% unlock ;
: stamp@4 ( addr1 addr2 -- ) swap
    4 0 DO  over stamp@ over ! 1 cell d+  LOOP  2drop ;
: state@ ( addr -- n )  spi% lock  statebuffer @ timeout? IF
	?open  do-single do-spi 0= or  IF
	    statebuffer cell+             STSTATE0 spi@4
	    statebuffer cell+ $04 cells + STEVENT0 spi@4
	ELSE
	    BEGIN  b-off
		STSTATE0 4 r32s?  STEVENT0 4 r32s?
	    $20 do-check $8 * - check-read  UNTIL
	    statebuffer cell+ $20 bounds DO
		il? check-ok IF  I !  ELSE  drop  THEN
	    cell +LOOP  .ok
	THEN  check-ok IF  volafter after statebuffer !  THEN
    THEN
    dup 3 and swap 1 rshift 4 and + cells
    statebuffer cell+ + @  spi% unlock ;
: state@4 ( addr1 addr2 -- ) swap
    4 0 DO  over state@ over ! 1 cell d+  LOOP  2drop ;
: easy@ ( addr -- n ) spi% lock  easybuffer @ timeout? IF
	?open  do-single do-spi 0= or  IF
	    stampbuffer cell+             STCTL0 spi@1
	    stampbuffer cell+ $01 cells + STCTL1 spi@1
	    stampbuffer cell+ $02 cells + STCTL2 spi@1
	    stampbuffer cell+ $03 cells + STCTL3 spi@1
	    stampbuffer cell+ $04 cells + STSETUP0 spi@2
	    stampbuffer cell+ $06 cells + STSETUP1 spi@2
	    stampbuffer cell+ $08 cells + STSETUP2 spi@2
	    stampbuffer cell+ $0A cells + STSETUP3 spi@2
	    statebuffer cell+ $0C cells + STSTATE0 spi@4
	    statebuffer cell+ $10 cells + STEVENT0 spi@4
	ELSE
	    BEGIN  b-off
		STCTL0    4 0 ?DO  dup 1 r32s?  $800 +  LOOP  drop
		STSETUP0  4 0 ?DO  dup 2 r32s?  $800 +  LOOP  drop
		STSTATE0 4 r32s?  STEVENT0 4 r32s?
	    $50 do-check $14 * - check-read  UNTIL
	    easybuffer cell+ $50 bounds DO
		il? check-ok IF  I !  ELSE  drop  THEN
	    cell +LOOP  .ok
	THEN  check-ok IF  volafter after easybuffer !  THEN
    THEN
    dup $1800 invert and dup STCTL0 =
    IF  drop #11 rshift 3 and
    ELSE  -2 and STSETUP0 =
	IF  dup #10 rshift 6 and swap 1 and or 4 +
	ELSE  dup 3 and swap 1 rshift 4 and + #12 +
	THEN
    THEN  cells
    easybuffer cell+ + @  spi% unlock ;
: easy@4 ( addr1 addr2 -- ) swap
    4 0 DO  over easy@ over ! 1 cell d+  LOOP  2drop ;

: crc?  true ( status@ 1 and 0= ) ;
: sr-invalid? ( addr -- flag )  $1800 and CONF0 + eq@ 7 and 7 = ;
: >coeff-addr ( addr n -- addr' val ) >r
    dup $007F and r> &12 lshift or >r $FF80 and
    dup $600 and $400 = IF  dup $80 and dup 2* 2* or xor $F800 and or  THEN
    $70 + r> ;
: >direct-coeff ( addr -- addr' )
    dup sr-invalid? direct-coeff or
    IF    dup $200 and dup 2/ 2/ or xor  $400 or
    ELSE  dup  $80 and dup 2* 2* or xor  $400 invert and  THEN ;
: cwait ( -- )  4 timer@ + till ;
: coeff! ( coeff addr -- )
    & record-spi dup push off
    dup addr>n,m swap #ch #c
    over coeff 5 cells move  >direct-coeff
    dup $600 and $400 = IF  spi!5  cwait  EXIT  THEN
    5 >coeff-addr >r >r 
    BEGIN  dup r@ 1 +  spi!5 crc?  UNTIL  drop
    r> r> swap
    BEGIN  2dup spiw! crc?  UNTIL
    2drop
    ( fast-spi ) cwait ;
: coeff2! ( coeff addr -- )
    & record-spi dup push off
    >direct-coeff
    dup $600 and $400 = IF  spi!A  cwait  EXIT  THEN
    $A >coeff-addr >r >r 
    BEGIN  dup r@ 1 + spi!A crc?  UNTIL  drop
    r> r> swap
    BEGIN  2dup spiw! crc?  UNTIL
    2drop
    ( fast-spi ) cwait ;

also minos    
[IFUNDEF] SC*/
    : sc*/ 2drop ;
[IFUNDEF] digit+
    : max10 >r &1000000000
        BEGIN  tuck mod dup r@ u> WHILE
                swap &10 / REPEAT  nip rdrop ;
    : digit+  &10 * rot '0 - over 0< IF - ELSE + THEN ;

vscaler implements
   : #>text ( n -- addr u )  offset @ + base push decimal
     5 * extend tuck dabs  <# # '. hold #S rot sign #> ;
   : o+ offset @ 1+ 2/ + ;
   : o- offset @ 1+ 2/ - ;
   : keyed ( k s -- k s )  over '0 '9 1+ within
          IF  drop get >r - 2/ r> offset @ + 2/
              &10 * rot '0 - over 0< IF  -  ELSE  +  THEN
              2* swap 2* swap
              offset @ - swap max10 reslide
              EXIT  THEN  :: keyed ;
class;
[ELSE]
vscaler implements
   : #>text ( n -- addr u )  base push decimal
     5 * extend tuck dabs  <# # '. hold #S rot sign #> ;
   : o+ offset @ 1+ 2/ + ;
   : o- offset @ 1+ 2/ - ;
   : keyed ( k s -- k s )  over '0 '9 1+ within
     IF  drop get >r - 2/ r> 2/  digit+
         dup 0< IF  nip negate 0 o- max10 negate
         ELSE  swap o+ max10  THEN  2* swap 2* swap
         reslide  EXIT  THEN  :: keyed ;
class;
[THEN]
[THEN]
previous

\ FFT tool

get-order

Variable vi

1 &28 lshift Constant ofscale

$100 points

\ : .absvalues ( -- )
\     #points 2/ 0 DO  I values z@ |z| fdup f0> IF  fln  THEN f. cr  LOOP ;

[IFUNDEF] fake-spi
: spi-fft-in256 ( addr -- )  ?open  dup 256 r32s bflush
    BEGIN  bcheck inbuffer @ $400 < WHILE  5 ms  REPEAT
    i@ bounds ?DO
        0  I cell bounds ?DO  8 lshift I c@ or  LOOP
        s>f ofscale fm/ 0e vi @ values z!  1 vi +!
    cell +LOOP  drop ;
[ELSE]
    : spi-fft-in256 ( addr -- ) drop
        $100 0 DO  0e 0e vi @ values z!  1 vi +!  LOOP ;
[THEN]
: spi-fft ( start -- )  vi off  $100 points
    $100 bounds DO  I spi-fft-in256   $100 +LOOP
\    $100 0 DO  I values z@ pi I $100 fm*/ zscale fsin f**2 I values z!  LOOP
    fft ;

: values@ ( i -- n )
    values z@ |z| fdup f0> IF
	fln 10e fln f/ 128 fm* 256e f+  THEN
    f>s ;

: fft> ( addr -- )
    $100 0 DO  I values@ swap !+  LOOP  drop ;

: >ln ( n1 n2 -- d3 )
    swap s>f flb s>f flb f- $10000 fm* f>d ;

set-order

: !? ( u addr -- )
    2dup @ = >r ! r> IF  rdrop  THEN ;
: c!? ( u addr -- )
    2dup c@ = >r c! r> IF  rdrop  THEN ;
: w!? ( u addr -- )
    2dup w@ = >r w! r> IF  rdrop  THEN ;

\ Filter calculation

also float

: [FP  also float ; immediate
: FP]  previous ; immediate

: dump-generic { addr u xt }
    save-channels 2@ DO  ." [[ "
	eqs 0 DO  J xt execute Ith .  LOOP  ." ]] " I . addr u type cr
    LOOP ;

: dump-slider ( -- ) s" slider!" ['] fslider dump-generic ;
: dump-gain   ( -- ) s" gain!"   ['] fgain   dump-generic ;
: dump-q      ( -- ) s" q!"      ['] fq      dump-generic ;
: dump-freq   ( -- ) s" freq!"   ['] ffreq   dump-generic ;
: dump-type   ( -- ) s" type!"   ['] ftype   dump-generic ;
: dump-filter ( -- )
    save-channels 2@ DO
	eqs 0 DO
	    I save?  IF
		." [[ "  J fgain Ith . J fq Ith . J ffreq Ith . J ftype Ith .
		         J fgain2 Ith . J fgain3 Ith .
		." ]] "
		J I n,m>addr' .addr ." filter!" cr THEN
	LOOP cr
    LOOP ;
: dump-coeff ( -- )
    save-channels 2@ DO  I #ch
	eqs 0 DO
	    I save? IF
		I #c
		." [[ " coeff 5 cells bounds ?DO  I @ $. cell +LOOP ." ]] "
		J I n,m>addr' .addr ." coeff!" cr  THEN
	LOOP cr
    LOOP ;

forward slider>gain
: slider! ( addr n -- )  fslider tuck 14 cells move slider>gain drop ;
: gain!   ( addr n -- )  fgain   14 cells move ;
: q!      ( addr n -- )  fq      14 cells move ;
: freq!   ( addr n -- )  ffreq   14 cells move ;
: type!   ( addr n -- )  ftype   14 cells move ;
: filter! ( addr spiaddr -- )  over cell - @ 4 =
    IF  over 4 cells + 2 cells erase  THEN
    addr>n,m cells { n m }
    @+ swap n fgain  m + !
    @+ swap n fq     m + !
    @+ swap n ffreq  m + !
    @+ swap n ftype  m + !
    @+ swap n fgain2 m + !
    @+ swap n fgain3 m + !
    drop ;

\ old gain factors

new-eq 0= [IF]

[[ 31 31 62 125 250 500 1000 2000 4000 8000 16000 16000 440 440 ]]
8 0 [DO] dup [I] freq! [LOOP] drop
[[ 1 0 0 0 0 0 0 0 0 0 0 2 0 0 ]]
8 0 [DO] dup [I] type! [LOOP] drop
[[ 55 78 78 78 78 78 78 78 78 78 78 55 100 100 ]]
8 0 [DO] dup [I] q! [LOOP] drop

\ new gain factors

[ELSE]

[[ 440 440 440 440 31 125 500 2000 8000 440 440 440 440 440 ]]
8 0 [DO] dup [I] freq! [LOOP] drop
[[ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 ]]
8 0 [DO] dup [I] type! [LOOP] drop
[[ 100 100 100 100 100 100 100 100 100 100 100 100 100 100 ]]
8 0 [DO] dup [I] q! [LOOP] drop

[THEN]

fvariable b0
fvariable b1
fvariable b2
fvariable a0
fvariable a1
fvariable a2
fvariable k
fvariable q
fvariable v
fvariable alpha
fvariable w0

fvariable sample-rate  96000e sample-rate f!
FVariable gain2
FVariable gain3

$8CA0 Constant dummy-sr

: >srate ( addr -- )
    dup sr-invalid? IF  drop dummy-sr
    ELSE
	$1800 and STSRCNT0 + stamp@ 16 rshift
	dup 0= IF  drop dummy-sr  THEN
	dup $FFFF = IF  drop dummy-sr  THEN
    THEN
    108e6 16e f* s>f f/ sample-rate f! ;

: >param ( freq q gain -- )
    v f! q f! pi f* sample-rate f@ f/ fdup f2* w0 f!
    ftan k f!
    w0 f@ fsin q f@ f2* f/ alpha f! ;

: >param2 ( freq q gain -- )
    v f! q f! f2* pi f* sample-rate f@ f/ fdup f2* w0 f!
    pi fswap f- f2/ ftan k f! ;

: gain>f ( gain -- f ) s>f &200 fm/  10e fln f*  fexp ;

: gain3@ ( -- f )  b0 f@ b2 f@ f+ f0= IF  gain3 f@ EXIT  THEN
    b0 f@ b2 f@ f+ gain3 f@ f* b1 f@ 1e gain3 f@ f- f* f-
    b0 f@ b2 f@ f+ f/ ;

: >coeff ( -- )  overflow off  a0 f@ 1/f
    fdup gain2 f@ f* gain3@ f>r
    fdup b2 f@ f* fr@ f* cf>s
    fdup b1 f@ f* cf>s
    fdup b0 f@ f* fr> f* cf>s
    fdrop fnegate
    fdup a2 f@ f* cf>s
         a1 f@ f* cf>s
    overflow @ IF  2drop 2drop drop
    ELSE  4 FOR  coeff I cells + !  NEXT
    THEN ;
    
: coeff> ( -- b2 b1 b0 a2 a1 )
    coeff 5 0 DO  @+ >r s>cf r>  LOOP  drop ;
     
: f>coeff ( b2 b1 b0 a2 a1 -- )
    cf>s coeff 4 cells + !
    cf>s coeff 3 cells + !
    cf>s coeff 2 cells + !
    cf>s coeff 1 cells + !
    cf>s coeff 0 cells + ! ;

: v*  v f@ f* ;
: a02!  fover fover f+ a0 f! f- a2 f! ;
: b02!  fover fover f+ b0 f! f- b2 f! ;

: flat ( freq q gain -- )  fdrop fdrop fdrop
    coeff 5 cells erase gain2 f@ cf>s coeff 2 cells + !
    0e fdup b1 f! b2 f! 1e b0 f!
    0e fdup a1 f! a2 f! 1e a0 f! ;

: ?0gain  ( freq q gain -- )  fdup 1e f= gain3 f@ 1e f= and
    IF  flat rdrop  THEN ;

1e FConstant qfactor

Variable normalize-q  normalize-q on

: lpf-old ( freq q gain -- )  >param
    1e w0 f@ fcos f- v* fdup f2/ fdup b0 f! b2 f! b1 f!
    1e alpha f@ a02!
    w0 f@ fcos f2* fnegate a1 f!
    >coeff ;

: lpf ( freq q gain -- )  >param
    1e w0 f@ fcos f- v* f2*
    fdup w0 f@ 1/f pi f* f2* 1/f fdup f**2 f>r
    fdup 1e f+ f/ fsqrt
    f*
    fdup 1e fr@ f- f* b0 f! fdup fr> f* b2 f! f- b1 f!
    1e alpha f@ a02!
    w0 f@ fcos f2* fnegate a1 f!
    >coeff ;

: >coeff1 ( -- )
    0e fdup b2 f! a2 f! 1e a0 f!
    >coeff ;

: lpf1  ( freq q gain -- ) >param
    w0 f@ 1/f 1e f+ 1/f fdup b0 f!  0e b1 f!  1e f- a1 f!
    >coeff1 ;

: hpf ( freq q gain -- )  >param
    w0 f@ fcos 1e f+ v* fdup f2/ fdup b0 f! b2 f! fnegate b1 f!
    1e alpha f@ a02!
    w0 f@ fcos f2* fnegate a1 f!
    >coeff ;

: hpf1  ( freq q gain -- ) >param
    w0 f@ 1/f 1e fover f+ f/ fdup b0 f! fnegate fdup b1 f! a1 f!
    >coeff1 ;

: bpf ( freq q gain -- )  >param
    alpha f@ v* fdup b0 f! fnegate b2 f! 0e b1 f!
    1e alpha f@ a02!
    w0 f@ fcos f2* fnegate a1 f!
    >coeff ;

\ APF
\ b0 =   1 - alpha
\ b1 =  -2*cos(w0)
\ b2 =   1 + alpha
\ a0 =   1 + alpha
\ a1 =  -2*cos(w0)
\ a2 =   1 - alpha

: apf ( freq q gain )  >param
    1e alpha f@ fover fover fnegate b02! a02!
    w0 f@ fcos f2* fnegate fdup b1 f! a1 f!
    >coeff ;

: peaking ( freq q gain -- )  ?0gain  fsqrt >param
    1e alpha f@ v* b02!
    1e alpha f@ v f@ f/ a02!
    w0 f@ fcos f2* fnegate fdup b1 f! a1 f!
    >coeff ;

: notch ( freq q gain -- )  fsqrt >param
    1e 0e b02!
    1e alpha f@ v f@ f/ a02!
    w0 f@ fcos f2* fnegate fdup b1 f! a1 f!
    >coeff ;

\ b0 =    A*( (A+1) - (A-1)*cos(w0) + 2*sqrt(A)*alpha )
\ b1 =  2*A*( (A-1) - (A+1)*cos(w0)                   )
\ b2 =    A*( (A+1) - (A-1)*cos(w0) - 2*sqrt(A)*alpha )
\ a0 =        (A+1) + (A-1)*cos(w0) + 2*sqrt(A)*alpha
\ a1 =   -2*( (A-1) + (A+1)*cos(w0)                   )
\ a2 =        (A+1) + (A-1)*cos(w0) - 2*sqrt(A)*alpha

: shelf ( feq q gain -- x0 cosw v+1 v-1 )
    >param
    v f@ fsqrt f2* alpha f@ f*  w0 f@ fcos
    v f@ 1e f+  v f@ 1e f- ;

: lowshelf ( freq q gain -- )
    ?0gain fsqrt shelf { f: x0 f: cosw f: v+1 f: v-1 }
    v+1 v-1 cosw f* f- v* x0      v* b02!
    v-1 v+1 cosw f* f-   f2*      v* b1 f!
    v+1 v-1 cosw f* f+ x0            a02!
    v-1 v+1 cosw f* f+   fnegate f2* a1 f!
    >coeff ;

: highshelf ( freq q gain -- )
    ?0gain fsqrt shelf { f: x0 f: cosw f: v+1 f: v-1 }
    v+1 v-1 cosw f* f+ v* x0       v* b02!
    v-1 v+1 cosw f* f+ fnegate f2* v* b1 f!
    v+1 v-1 cosw f* f- x0             a02!
    v-1 v+1 cosw f* f-            f2* a1 f!
    >coeff ;

: tilt ( freq q gain -- )
    ?0gain shelf { f: x0 f: cosw f: v+1 f: v-1 }
    v+1 v-1 cosw f* f+ x0             b02!
    v-1 v+1 cosw f* f+ fnegate f2*    b1 f!
    v+1 v-1 cosw f* f- x0             a02!
    v-1 v+1 cosw f* f-            f2* a1 f!
    >coeff ;

Create filters T] peaking lowshelf highshelf tilt lpf hpf bpf apf notch lpf-old lpf1 hpf1 [
Create filter-flags 2 ,   3 ,      3 ,       3 ,  2 , 2 , 2 , 4 , 0 ,   3 ,     2 ,  2 ,

: bw>q? ( f -- f' )
    fdup f0< IF  fabs 2e fswap f** fdup fsqrt fswap 1e f- f/  THEN ;

: q>bw? ( f -- f' )
    fdup f0> IF  f2* 1/f fasinh 2e fdup fln f/ f* fnegate  THEN ;

: filt>coeff ( n m -- )   over #ch dup #c
    over fgain2 over cells + @  gain>f gain2 f!
    over fgain3 over cells + @  gain>f gain3 f!
    over ffreq  over cells + @  s>f
    over fgain  over cells + @  >r
    over ftype  over cells + @  r> swap cells filter-flags + @ >r
    r@ 2 and IF  0<  THEN  r@ 1 and IF  0=  THEN
    r@ 4 and  IF  drop r@ 1 and 0=  THEN  rdrop
    IF  gain3 f@ fsqrt f/  THEN
    over fq     over cells + @  s>f &100 fm/ bw>q?
    over fgain  over cells + @  gain>f
    swap ftype swap  cells + @  cells filters +  perform ;

: srate>coeff ( srate -- )
    sample-rate f! 8 0 DO  eqs 0  DO  J I filt>coeff  LOOP  LOOP ;

Create matrix
1.16E0 f, -490.E-3 f, 53.1E-3 f, -10.5E-3 f, 1.62E-3 f, -282.E-6 f, 44.8E-6 f, -6.19E-6 f, 1.25E-6 f, 299.E-9 f, 273.E-9 f, 660.E-9 f, 
-360.E-3 f, 1.15E0 f, -433.E-3 f, 69.7E-3 f, -11.8E-3 f, 1.85E-3 f, -303.E-6 f, 46.6E-6 f, -7.49E-6 f, 1.04E-6 f, -109.E-9 f, -25.7E-9 f, 
61.1E-3 f, -371.E-3 f, 1.16E0 f, -424.E-3 f, 65.2E-3 f, -11.0E-3 f, 1.73E-3 f, -281.E-6 f, 43.8E-6 f, -6.10E-6 f, 735.E-9 f, 292.E-9 f, 
-21.0E-3 f, 52.3E-3 f, -411.E-3 f, 1.15E0 f, -408.E-3 f, 63.1E-3 f, -10.7E-3 f, 1.67E-3 f, -265.E-6 f, 37.1E-6 f, -3.69E-6 f, -104.E-9 f, 
2.87E-3 f, -9.18E-3 f, 65.3E-3 f, -412.E-3 f, 1.15E0 f, -410.E-3 f, 63.6E-3 f, -10.7E-3 f, 1.62E-3 f, -235.E-6 f, 22.5E-6 f, -125.E-9 f, 
283.E-6 f, 1.61E-3 f, -10.7E-3 f, 64.4E-3 f, -410.E-3 f, 1.15E0 f, -410.E-3 f, 63.1E-3 f, -10.3E-3 f, 1.42E-3 f, -141.E-6 f, 427.E-9 f, 
-228.E-6 f, -308.E-6 f, 1.61E-3 f, -11.0E-3 f, 63.4E-3 f, -410.E-3 f, 1.15E0 f, -407.E-3 f, 61.0E-3 f, -9.07E-3 f, 854.E-6 f, -301.E-9 f, 
86.0E-6 f, 60.6E-6 f, -243.E-6 f, 1.73E-3 f, -10.6E-3 f, 63.2E-3 f, -407.E-3 f, 1.15E0 f, -396.E-3 f, 53.5E-3 f, -5.51E-3 f, 479.E-9 f, 
-25.5E-6 f, -12.4E-6 f, 32.8E-6 f, -282.E-6 f, 1.62E-3 f, -10.4E-3 f, 61.3E-3 f, -398.E-3 f, 1.12E0 f, -357.E-3 f, 32.6E-3 f, -313.E-9 f, 
7.09E-6 f, 2.59E-6 f, -3.41E-6 f, 41.6E-6 f, -237.E-6 f, 1.46E-3 f, -9.29E-3 f, 54.7E-3 f, -363.E-3 f, 1.06E0 f, -243.E-3 f, 348.E-9 f, 
-107.E-9 f, -120.E-9 f, 602.E-9 f, -4.07E-6 f, 24.4E-6 f, -154.E-6 f, 928.E-6 f, -5.98E-3 f, 35.2E-3 f, -257.E-3 f, 1.00E0 f, 875.E-9 f, 
-1.68E-6 f, -386.E-9 f, -753.E-9 f, -233.E-9 f, -3.50E-6 f, 17.2E-6 f, -106.E-6 f, 708.E-6 f, -3.86E-3 f, 31.2E-3 f, -400.E-3 f, 1.00E0 f,

: matrix@ 12 * + floats matrix + f@ ;

new-eq 0= [IF]

: slider>gain ( addr -- ch ) dup 0 fslider - eqs / cell/ tuck fgain swap
    12 0 DO  0e
	12 0 DO
	    dup I cells + @ s>f J I matrix@ f* f+
	LOOP
	over f>s swap I cells + !
    LOOP  2drop ;
: gain>coeff ( ch -- )
    eqs 0 DO  dup I filt>coeff  LOOP  drop ;

[ELSE]

: slider>gain ( addr -- ch )  0 fslider - eqs / cell/ { ch }
    ch fslider  2 cells + @ dup    ch fgain2 4 cells + !
    ch fslider  1 cells + @ over - ch fgain  4 cells + !
    ch fslider  0 cells + @ over - ch fgain3 4 cells + !
    3 0 DO
	ch fslider  I 2* 4 + cells + @ tuck - dup  ch fgain3 I 5 + cells + !
                                       dup negate  ch fgain2 I 5 + cells + !
	ch fslider  I 2* 3 + cells + @ nip         ch fgain  I 5 + cells + !
    LOOP
    drop ch ;
: gain>coeff ( ch -- ) eqs 0 DO  dup I filt>coeff  LOOP  drop ;

[THEN]

\ test stuff

also complex

$0 value fill-in

: cbuff! ( n -- )  cbuff 2 cells + ! ;

Variable seed  $3f98c5ac seed !

: xorshift ( n -- n' )
    dup 1 lshift xor $FFFFFFFF and
    dup 3 rshift xor
    dup 10 lshift xor $FFFFFFFF and ;
: rnd  seed @ xorshift dup seed ! ;

: 5mac ( vals coeff -- macsum )
    0. 2swap 5 cells bounds  DO
	I @ swap dup cell+ >r @ m* d+ r>
    cell +LOOP  drop ;
: round ( d -- n ) rnd cfmask and 0 d+
    [ 8 cells cfraction - ] Literal lshift swap cfraction rshift or
    dup 0< IF   negate pmask and negate  ELSE  pmask and  THEN ;
: biquad ( -- n )  cbuff coeff  5mac round
    cbuff cell+  cbuff 4 cells move
    dup cbuff 4 cells + ! fill-in cbuff! ;

: impulse-response ( n -- )
    here >r cbuffs dp !
    &15 0 DO  0 , 0 , 1e cf>s , 0 , 0 ,  LOOP  r> dp !
    0 ?DO  biquad s>f fmask 1+ fm/ 0e I values z!  LOOP ;

: impulse-responses ( n -- ) channel @ drop
    eqs 1+ 0 DO  I #c  cbuff 5 cells erase  1e cf>s cbuff!  LOOP
    0 ?DO
	eqs 0 DO  i #c biquad  i 1+ #c cbuff!  LOOP
	cbuff 2 cells + @ s>f fmask 1+ fm/ 0e I values z!
    LOOP ;

: p/2  #points 2/ to #points ;

\ : .absvalues ( -- )  18 set-precision
\     #points 0 DO  I values z@ |z| f. cr  LOOP ;

toss toss minos

\ helper word

Variable rename$

also dos

: check-file ( addr u -- addr u t / f )
    rename$ $!
    rename$ $@ file-status nip 0= IF
	s" File already exist:"
	rename$ $@
	2 s" Overwrite" s" Cancel" 2 2 minos alert
	1 = IF  false
	ELSE
	    s" ~" rename$ $+! rename$ $@ delete-file drop
	    rename$ $@ 1- 2dup 1+ rename-file drop
	    rename$ $@ 1- true  THEN
    ELSE  rename$ $@ true  THEN ;

previous

\ internationalization

[IFDEF] locale@

also dos

: localize ( -- )
    [ [IFDEF] win32 also win32api ]
	GetUserDefaultLCID $3FF and 7 =
    [ toss [ELSE] ]
	s" LANG" env$ s" de" string-prefix?
    [ [THEN] ]
    IF
	s" locale de de" evaluate
	s" audio-gui.de" ['] included-locale catch drop  THEN ;

toss

[ELSE]
    ' s" alias x" immediate
    : localize ;
[THEN]

\ reference file

: Chan-var ( -- )  Create 8 0 DO 0 , LOOP
    DOES>  channel @ cells + ;

Chan-var freqs
Chan-var dbVs
Chan-var phases
FVariable add-float

: +freq ( r -- )  add-float f!
    add-float 1 floats freqs $+! ;
: +dbV ( r -- )  add-float f!
    add-float 1 floats dbVs  $+! ;
: +phase ( r -- )  add-float f!
    add-float 1 floats phases $+! ;

: freq ( -- ) base push decimal
    s" " 2dup freqs $!  2dup dbVs $!  phases $!
    BEGIN  refill  WHILE
	    bl word count >float IF +freq THEN
	    bl word count >float IF +dbV THEN
	    bl word count >float IF +phase THEN
    REPEAT ;

\ helper words for canvas drawing

: i>d ( n -- inc )
    dup &100 > IF
	dup &1000 > IF  &2000 > IF $20 ELSE $10 THEN  EXIT  THEN
	&500 >  IF  8  ELSE  4  THEN
    ELSE  &20 >  IF  2  ELSE  1  THEN   THEN ;

also float also complex
canvas with
F : square path 0 -2 to 2 0 to 0 2 to -2 0 to ;
F : plot-db { f: n }
    0 1 textpos
    2000 100 DO
	0 I home! $E0 dup dup rgb>pen drawcolor
	path dup 0 to stroke
	I &1000 - &2 * s>f n f/ fround f>s extend dnegate tuck dabs
	0 I home!  $D0 $A0 $A0 rgb>pen drawcolor
	<# s" dB" holds #S rot sign #> text
    100 +LOOP ;
F : plot-deg ( n -- n )
    2 1 textpos
    2000 100 DO
	dup I home!  $A0 $D0 $A0 rgb>pen drawcolor
	I &1000 - &4 &10 */ extend dnegate tuck dabs
	<# s" °" holds #S rot sign #> text
    100 +LOOP ;
F : plot-khz ( -- )
    16000e sample-rate f@ f/ $2000 fm* f>s
    dup $2 >ln drop over 2/ $2 >ln drop over - swap $3 $2 >ln drop -
    16000 -rot  1 2 textpos
    10 0 DO  dup 0 home!
	$E0 dup dup rgb>pen drawcolor path 0 -2000 to stroke
	$C0 $C0 $80 rgb>pen drawcolor
	rot dup &1000 >= IF
	    dup &1000 / 0 <# s" kHz" holds #S #> text
	ELSE
	    dup 0 <# s" Hz" holds #S #> text
	THEN  2/ -rot
	over +  LOOP  2drop 2drop ;
F : ref-plot ( n -- ) { f: n }
    freqs @ 0= IF  EXIT  THEN
    freqs $@len 0= IF  EXIT  THEN
    $80 $C0 $80 rgb>pen drawcolor
    0 1000 home!  path 0
    freqs $@len 0 DO
	phases $@ drop I + f@ &450 &180 fm*/ f>s
	tuck -
	dup  &450 > IF  &900 -  THEN
	dup -&450 < IF  &900 +  THEN
	negate
	I 0= IF  sample-rate f@ 3 8192 fm*/ flb
	    freqs $@ drop f@ flb f-
	ELSE  freqs $@ drop I +
	    dup 1 floats - f@ flb f@ flb f-  THEN
	-$10000 fm* f>d
	rot extend dto
	I $1FC and $180 = IF  stroke path  THEN
    1 floats +LOOP  drop stroke
    $C0 $80 $80 rgb>pen drawcolor
    0 1000 home!  path 0
    freqs $@len 0 DO
	dbVs $@ drop I + f@ f2/ n f* f>s tuck -
	negate
	I 0= IF  sample-rate f@ 3 8192 fm*/ flb
	    freqs $@ drop f@ flb f-
	ELSE  freqs $@ drop I +
	    dup 1 floats - f@ flb f@ flb f-  THEN
	-$10000 fm* f>d
	rot extend dto
	I $1FC and $180 = IF  stroke path  THEN
    1 floats +LOOP  drop stroke ;
F : fft-plot ( n -- ) { f: n } decimal
    #points 2/ 1+ $2 >ln drop 3 2 >ln drop - dup 2000 steps
    n plot-db plot-deg drop plot-khz  n ref-plot
    0 $7F 0 rgb>pen drawcolor
    0 1000 home!  path 0
    #points 2/ 2 DO  I F values z@ >polar fnip
	pi f/ 450 fm* f>s
	tuck -
	dup  &450 > IF  &900 -  THEN
	dup -&450 < IF  &900 +  THEN
	negate I dup I i>d + swap >ln
	I 2 = IF $3 $2 >ln d- THEN  rot extend dto
	I $1FC and $180 = IF  stroke path  THEN
    I i>d +LOOP  drop stroke
    $7F 0 0 rgb>pen drawcolor
    0 1000 home!  path 0
    #points 2/ 2 DO  I F values z@ |z| #points I - F values z@ |z| f+ f2/
	fdup f0= IF  fdrop -200e
	ELSE  fln 10e fln f/ n f* THEN &10 fm* f>s tuck -
	negate I dup I i>d + swap >ln
	I 2 = IF $3 $2 >ln d- THEN  rot extend dto
	I $1FC and $180 = IF  stroke path  THEN
    I i>d +LOOP  drop stroke ;
F : state-plot ( addr straddr u -- )  >r >r >r
    r@ @ $FFF and
    64 over $FFF xor home!
    path r@ 4 cells + 63 4 * cells bounds DO
	I @ $FFF and tuck - negate 0 swap
	-1 0 canvas to canvas to 
    4 cells +LOOP drop -1 0 canvas to stroke
    32 2048 home!
    r> @ $FFF and 0 <# #S r> r> holds #> text ;
F : fft-plot2 ( addr -- )  $0 $280 home!
    path $0 $80 0 ?DO
	over I cells + @ $27f min 0 max tuck - negate
	$3 I + dup 1- >ln  I 0= IF  3 2 >ln d-  THEN
	rot extend dto
    LOOP 2drop stroke ;
endwith
toss toss