\ Temperaments.f

anew ~Temperament

needs MATRIX.F

\ The following is based on "mills" instead of "cents", i.e. on 1/1000 of the
\ frequency ratio between adjacent semitones.

  20 constant Just_5ths         \ Deviation from Equal-Tempered for pefect 5ths
-137 constant Just_3rds         \ Deviation from E-T for perfect 3rds
 -20 constant Just_4ths         \ Deviation from E-T for perfect 4ths
 156 constant Just_m3rds        \ Deviation from E-T for perfect minor 3rds

\ The above are just approximations in integer form.  In Floating point the
\ errors (in cents) are approximately:
\ J5=1.955  J3=-13.686  J4=-1.954  Jm3=15.641

  0 constant J5                 \ Index to Just5 row
  7 constant delJ5              \ Increment for Just 5ths
  1 constant J3                 \ Index to Just3 row
  4 constant delJ3              \ Increment for Just 3rds
  2 constant Jm3                \ Index to Justm3 row
  3 constant delJm3             \ Increment for Just minor 3rds
  3 constant J4                 \ Index to Just4 row
  5 constant delJ4              \ Increment for Just 4ths
  4 constant JM                 \ Index to max Major chord deviations

 50 constant #Temprmax          \ Maximum number of Temperaments
 72 constant TNamemax           \ Maximum characters of Name string +1

#Temprmax TNamemax byte-matrix Tnames
      #Temprmax 12 word-matrix ETDevs         \ Deviations from Equal Tempered
              6 12 word-matrix JustDevs       \ Deviations from Just Scale
              
variable ETIndex

create Keys ," A    A#     B     C    C#     D    D#     E     F    F#     G    G#"

: .Keys         ( -- )
                cr 14 spaces Keys count type ;

: .Key          ( n -- )
                4 * Keys + 2 + 2 type ;

: R.1           ( n w -- )
                >r s>d 10 sm/rem r> 2 - 1 max .r ascii . emit abs 1 .r ;

: 1TName        ( yindex -<name>- )
                dup >r #Temprmax U< not abort" Index too large"
                [char] " parse TNamemax 1- umin dup r@ 0 Tnames c!
                r> 1 TNames swap cmove ;

: TempFill      ( n0 n1 ... n11 index -- )      \ Fill Temperament
                ETIndex !
                0 11 DO         ETIndex @ I ETDevs W!
                -1 +LOOP ;

: Dev5th        ( yindex key -- )
                2dup DelJ5 + 12 mod ETDevs SW@ >r
                2dup ETDevs SW@ r> swap -
                Just_5ths - >r nip J5 swap JustDevs r> swap W! ;

: Dev5ths       ( yindex -- )
                12 0 DO
                        dup I Dev5th
                LOOP drop ;

: Dev3rd        ( yindex key -- )
                2dup DelJ3 + 12 mod ETDevs SW@ >r
                2dup ETDevs SW@ r> swap -
                Just_3rds - >r nip J3 swap JustDevs r> swap W! ;

: Dev3rds       ( yindex -- )
                12 0 DO
                        dup I Dev3rd
                LOOP drop ;

: Devm3rd       ( yindex key -- )
                2dup DelJm3 + 12 mod ETDevs SW@ >r
                2dup ETDevs SW@ r> swap -
                Just_m3rds - >r nip Jm3 swap JustDevs r> swap W! ;

: Devm3rds       ( yindex -- )
                12 0 DO
                        dup I Devm3rd
                LOOP drop ;

: Dev4th        ( yindex key -- )
                2dup DelJ4 + 12 mod ETDevs SW@ >r
                2dup ETDevs SW@ r> swap -
                Just_4ths - >r nip J4 swap JustDevs r> swap W! ;

: Dev4ths       ( yindex -- )
                12 0 DO
                        dup I Dev4th
                LOOP drop ;

: MajorDevs     ( yindex -- )
                dup Dev5ths dup dev3rds dup devm3rds dev4ths
                12 0 DO
                        J5 I JustDevs SW@ abs
                        J3 I JustDevs SW@ abs max
                        JM I JustDevs W!
                LOOP ;

: .Dev5ths      ( -- )
                cr ." Dev5ths: "
                12 0 DO
                        J5 I JustDevs SW@ 6 r.1
                LOOP ;

: .Dev3rds      ( -- )
                cr ." Dev3rds: "
                12 0 DO
                        J3 I JustDevs SW@ 6 r.1
                LOOP ;

: .Devm3rds     ( -- )
                cr ." Devm3rds:"
                12 0 DO
                        Jm3 I JustDevs SW@ 6 r.1
                LOOP ;

: .Dev4ths      ( -- )
                cr ." Dev4ths: "
                12 0 DO
                        J4 I JustDevs SW@ 6 r.1
                LOOP ;

: .DevMaj      ( -- )
                cr ." DevMaj:  "
                12 0 DO
                        JM I JustDevs SW@ 6 r.1
                LOOP ;

: .JustDevs     ( -- )
                .Dev5ths .Dev3rds .Devm3rds .Dev4ths .DevMaj ;
        
\ Fill Temperaments Matrix:
\   A   A#    B    C   C#    D   D#    E    F   F#    G   G#

0 1TName User"
   00   50   10   30   50   10   60  -10   40   30   20   70      0 TempFill

1 1TName Equal Tempered"
   00   00   00   00   00   00   00   00   00   00   00   00      1 TempFill

2 1TName Orchestral"
   00  -10   40 -160 -130  -20 -170   30 -170 -160 -120   10      2 TempFill

3 1TName Werkmeister" 
   00  -80  -30  -30  -70   00  -90  -10  -60  -60  -10  -90      3 TempFill

4 1TName 1/5 Meantone (Good Majors for 8 keys, Good minors for 8 keys)"
   00 -180  -50   70  -90   20 -140  -20   90  -70   50 -120      4 TempFill
\ Good Majors: F C G D A E B F#.  Good Minors: D A E B F# C# G# D#. 

5 1TName 1/4 Meantone"
   00 -240  -70  100 -140   30 -210  -30  140 -100   70 -170      5 TempFill

6 1TName Just (Perfect Majors for 5 keys, Perfect minors for 6 keys)"
   00  -77   40  157 -137  -20  -97   20  137 -157  177 -117      6 TempFill
\ This version gives perfect 5ths and Major 3rds for keys of F, C, D, A, and E

7 1TName Arabian"
  -60  450  -20 -120 -500  -90  430  -40  470   00 -100 -490      7 TempFill
\ Note the "Quarter Tones" in this Temperament

8 1TName Natural Harmonic"
   00   00   40   00 -140  -20   00   20   00 -160   00 -120      8 TempFill

9 1TName Mediant"
   00 -190  -60   70 -120   30 -170  -30 -200  -90   50 -150      9 TempFill

10 1TName Praetorius"
   00 -240  -70  100 -140   30 -210  -30 -270 -100   50 -170     10 TempFill

11 1TName Pythagoras"
   00   00   40   00   80  -20   00   20   00   60   00  100     11 TempFill

12 1TName Joung"
   00 -100  -40  -60  -80  -20 -120  -20  -80  -60  -40 -100     12 TempFill

13 1TName Schlick"
   00  140  -50   20 -100   30 -130  -20  -20  -80   20 -120     13 TempFill

14 1TName Well-Tempered Bach"
   00 -100  -40  -60 -130  -20 -120   00  -80  -80  -40 -140     14 TempFill

15 1TName Silbermann 1"
   00 -130   00   80 -100   30 -100   00 -160  -50  -60 -100     15 TempFill

16 1TName Silbermann 2"
   00 -140  -40   60  -80  120 -120  -20 -160  -60   40 -100     16 TempFill

17 1TName Billeter"
   00  -70  -20  -30  -80   10  -90  -10  -50  -50  -10  -80     17 TempFill

18 1TName Kirnberger 1"
   00 -100   40  -60 -140  -20 -100   20  -80  -50  -40 -130     18 TempFill

19 1TName Kirnberger 2" 
   00 -100   40  -60 -140  -20 -100   20  -80  -50  -40 -120     19 TempFill

20 1TName Kirnberger 3"
   00 -100   70  -60 -140  -20 -100  -30  -80 -100  -40 -120     20 TempFill

21 1TName Kellner"
   00 -100  -50  -60 -110  -20 -120  -30  -80  -80  -40  -90     21 TempFill

22 1TName Ganassi"
   00 -120 -180 -190 -140  -20  -30   20 -100 -160 -170 -120     22 TempFill

23 1TName Ho Cheng Thien"
   00   10   00  -30  -20  -70  -40  -10   30  -30 -150  -90     23 TempFill

24 1TName Mourig Mediant"
   00 -200  -50   60 -120   20 -180  -10 -210  -90   10 -150     24 TempFill

25 1TName Bach Billeter"
   00  -80   00  -40 -100   00 -100   00  -60  -50  -20 -100     25 TempFill

26 1TName Bob's Just (Perfect Majors for 6 keys, perfect minors for 5 keys)"
   00  117   40  157 -137  197  -97   20  137   60  177 -117     26 TempFill
\ This version gives perfect major chords for the keys of F, C, G, A, E and B.
\ Also, nearly perfect minor chords for A, E, B, C# (or Db) and G# (or Ab).

27 1TName Bob's Meantone #1 (Good Majors for 8 keys, Good minors for 8 keys)"
   00  117  -47   70  -94   23  141  -23   94  -70   47  164     27 TempFill
\ The majority of errors are 4.306 cents for Major thirds and Major fifths.
\ This version equalizes the magnitude of the error for 5ths and 3rds for most
\ keys. Good Major and minors for 5 keys: D A E B F#.  Good Majors for: F C G.
\ Good minors for: C#=Db G#=Ab D#=Eb.

28 1TName Bob's Meantone #2 (Good Majors for 8 keys, Good minors for 8 keys)"
   00  141  -57   85 -113   28  169  -28  113  -85   56  197    28 TempFill
\ Errors are typically 4.8 cents for Major thirds and 2.4 for Major fifths.
\ This version equalizes the beat frequencies for 5ths and 3rds for most keys.

29 1TName Pete's PYTH"
   00  -98   39  -59   78  -20   78  -20  -78   59  -39   98    29 TempFill

30 1TName Pete's JUMA"
   00  333   39  156 -137  196  313   19  137 -156  176 -118    30 TempFill

31 1TName Pete's P5TH"
   00  -19  -19  -19  -17  -17  -26  -26  -24  -24  -24  -24    31 TempFill

32 1TName Pete's MEAN"
   00  176  -64  104 -133   36  207  -33  136  -97   70 -170    32 TempFill

33 1TName Pete's WRK3"
   00   63   39  103    5   34   44   20   83  -15   68   24    33 TempFill

34 1TName Pete's KRN3:"
   00   78   00  117   19   39   58  -20   98   20   78   39    34 TempFill

35 1TName Pete's YONG"
   00   19  -37   58  -40   20  -01  -18   39  -61   39  -20    35 TempFill

36 1TName Bob's Meantone #3 (Good Majors for 8 keys, Good minors for 8 keys)"
   00  117  -90   70 -137   23  141  -23   94 -114   47  164    36 TempFill
\ The above is a modification of Bob's MT #2 to give perfect thirds
\ for G, D, and A.

37 1TName Bob's Meantone #4 (Good Majors for 8 keys, Good minors for 8 keys)"
   00   58  -27   51  -47   17   48  -17   68  -37   34   38    37 TempFill
\   A   A#    B    C   C#    D   D#    E    F   F#    G   G#

: .TName        ( i -- )
                cr 4 spaces ." Temperament: "
                0 TNames count type ;

: .Dev          ( i -- )
                cr ." ETDev:   "
                12 0 DO
                        dup I ETDevs SW@ 6 r.1
                LOOP drop ;

: .Temp         ( i -- )
                cr dup .TName .keys dup .dev MajorDevs .JustDevs .keys ;

: .TempsRange     ( hi lo -- )
                cls
                DO
                        I .temp
                LOOP ;

: .ScrTemps     ( -- )
                cls
                #Temprmax 0 DO
                        I .temp
                LOOP ;

: .AllTemps     ( -- )
                cls
                #Temprmax 0 DO
                        I .temp
                        I 6 mod 5 = IF print-console cls THEN
                LOOP
                print-console ;

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

0x7FFF constant MAX-W           \ largest word-sized number
max-w -1 xor constant MIN-W     \ most negative word-sized number

: MAX-MIN-W     ( n1 -- n1 )
        dup min-w max-w between 0=
        abort" Wave amplitude out of range" ;

256 constant MaxPieces

Maxpieces word-vector Swave
Maxpieces word-vector Mywave

5 constant HMAX                 \ maximum number of harmonics
18200 hmax / constant Wamp       \ Maximum amplitude of any component

: R/REM         ( lo hi div -- rem quot )       \ rounded division
        dup>r fm/mod over 2* r@ < 0=
        IF      1+ swap r> - swap
        ELSE    r>drop
        THEN ;

: MSine         ( P n -- val )  \ P is the maximum count for a full period.
        over >r 0 rot r/rem drop dup abs 2* r@ swap - * 8 *
        Wamp m* r@ r/rem nip s>d r> r/rem nip ;

: Fill-Sine     ( -- )
        MaxPieces 0 DO
                MaxPieces I Msine I Swave w!
        LOOP ;

: Fill-MyWave   ( -- )
        Fill-Sine
        MaxPieces 0 DO
                0 Hmax 1+ 2 DO
                        J I * MaxPieces 1- and Swave sw@ +
\                        I 1 and IF + ELSE - THEN
                LOOP
                2/ I Swave sw@ + I MyWave w!
        LOOP ;

\ : Fill-MyWave   ( -- )
\        Fill-Sine
\        MaxPieces 0 DO
\                0 Hmax 1+ 1 DO
\                        J I * MaxPieces 1- and Swave sw@
\                        I 1 and IF + ELSE - THEN
\                LOOP
\                I MyWave w!
\        LOOP ;

Fill-MyWave

: Fill-MySine     ( -- )
        MaxPieces 0 DO
                MaxPieces I Msine 3 * I Mywave w!
        LOOP ;

\ The following is a temporary pseudo-graphical dump.

 : WDump1        ( val -- )
        cr 40 32768 */ 40 + abs spaces [char] * emit ;

 : WDump         ( addr cnt -- )
        0 DO
                dup I 2 * + sw@ WDump1
        LOOP drop ;

: fmills>ratio  ( f: mills -- ratio )
        f2.0 fswap 12000.0e0 f/ f** ;

: mills>fratio  ( imills -- )  ( f: -- fratio )
        s>f fmills>ratio ;

: f>rnd         ( -- n ) ( f: fn -- )
        f2.0 f* f>s s>d 2 sm/rem + ;

fvariable fPer1           \ Period of Tonic in terms of (1/44100) seconds
fvariable fPer2           \ Period of second note
fvariable fPer3           \ Period of third note

44100 constant Samples/sec

Samples/sec s>f fconstant fSamples/sec

fSamples/sec 440.0e0 f/ fPer1 f!   \ Initialize Per1

: mills>ratio   ( mills -- ) ( f: -- fratio )
        f2.0 s>f 120000e0 f/ f** ;

: mills>fper2   ( mills -- )    \ Set fPer2
        fper1 f@ mills>fratio f/ fper2 f! ;

: mills>fper3   ( mills -- )    \ Set fPer3
        fper1 f@ mills>fratio f/ fper3 f! ;

: fsamp>w       ( paddr -- val ) ( F: fsamp -- )
        f@ f/ f>rnd 255 and mywave sw@ ;

: T>val12       ( ndx -- val )
        s>f 256.0e0 f* fdup
        fper1 fsamp>w
        fper2 fsamp>w + max-min-w ;

: T>val123      ( ndx -- val )
        s>f 256.0e0 f* fdup fdup
        fper1 fsamp>w
        fper2 fsamp>w +
        fper3 fsamp>w + max-min-w ;

: T>val1        ( ndx -- val )            \ uses only fper1
        s>f 256.0e0 f* fper1 fsamp>w max-min-w ;

: T>val2        ( ndx -- val )            \ uses only fper2
        s>f 256.0e0 f* fper2 fsamp>w max-min-w ;

: T>val3        ( ndx -- val )            \ uses only fper3
        s>f 256.0e0 f* fper3 fsamp>w max-min-w ;

: 4CHAR         ( -- n )
        bl word count swap ( ulong) @ swap dup 4 <
        IF      CASE 0  OF      Abort" *** Zero length character string ***"
                                                                ENDOF
                     1  OF      0x000000FF and 0x20202000 +       ENDOF
                     2  OF      0x0000FFFF and 0x20200000 +       ENDOF
                     3  OF      0x00FFFFFF and 0x20000000 +       ENDOF
                ENDCASE
        ELSE    drop
        THEN ;

create WAVEHEAD
        4char RIFF ,                                    \ RIFF
        0 ,                                             \ Space for RIFF count
        4char WAVE ,                                    \ WAVE
        4char fmt  ,                                    \ fmt  (with space)
        16 , 1 w, 1 w, 44100 , 88200 , 2 w, 16 w,       \ format information
        4char data ,                                    \ data
        0 ,                                             \ space for data count

here wavehead - constant WvHdCnt

0 value WFileStart                      \ Name of Wave File buffer
0 value WFileSize                       \ File size in BYTES
0 value WData
0 value WDataSize                       \ Data size in BYTES
0 value MaxSecs                         \ Maximum time in seconds

: SetRIFFcnt    ( -- )
        WFileSize 8 - WFileStart cell+ ! ;

: SetWdatacnt   ( -- )
        WFileSize 44 - dup WFileStart 40 + !
        to WDataSize ;

: SetWData      ( -- )
        WFileStart 44 + to WData ;

: SetMaxSecs    ( -- )
        WdataSize 2/ Samples/sec / to MaxSecs ;

: InitWFile     ( -- )
        WAVEHEAD WFileStart WvHdCnt move
        SetRIFFcnt SetWDatacnt SetWData SetMaxSecs ;

970250 to WfileSize                     \ About 11 seconds worth of data in file
WfileSize malloc to WFileStart
InitWFile

: Sec>Ndx       ( seconds -- index )
        Samples/sec * WDataSize 2/ umin ;

: TSec>Ndx       ( tenth-seconds -- index )
        Samples/sec * 10 /  WDataSize 2/ umin ;

: Fill-Wave1    ( starttime endtime -- )
        sec>Ndx swap Sec>Ndx
        ?DO     I T>val1 WData I 2* + w!
        LOOP ;

: Fill-Wave2    ( starttime endtime mills -- )
        mills>fper2 Sec>Ndx swap Sec>Ndx
        ?DO
                I T>val2 WData I 2* + w!
        LOOP ;

: Fill-Wave3    ( starttime endtime mills -- )
        mills>fper3 Sec>Ndx swap Sec>Ndx
        ?DO
                I T>val3 WData I 2* + w!
        LOOP ;

: Fill-Wave12   ( starttime endtime mills2 -- )
        mills>fper2 Sec>Ndx swap Sec>Ndx
        ?DO
                I  T>val12 WData I 2* + w!
        LOOP ;

: Fill-Wave123   ( starttime endtime mills2 mills3 -- )
        mills>fper3 mills>fper2 Sec>Ndx swap Sec>Ndx
        ?DO
                I  T>val123 WData I 2* + w!
        LOOP ;

variable mills2
variable mills3

: Demo-2note    ( mills2 -- )
        mills2 !
        0 1 Fill-Wave1
        1 2 mills2 @ Fill-Wave2
        2 11 Mills2 @ Fill-Wave12 ;

: Demo-3note    ( mills2 mills3 -- )
        mills3 !  mills2 !
        0 1 Fill-Wave1
        1 2 mills2 @ Fill-Wave2
        2 3 mills3 @ Fill-Wave3
        3 11 mills2 @ mills3 @ Fill-Wave123 ;

create WFileName 256 allot
variable WFileID

: Make-File     ( -- )
        cr ." Enter Name of Wave File: "
        WFileName 1+ 255 accept WFileNAme c! cr
        WfileName count r/w bin create-file abort" Cannot create File!!"
        WFileID !
        WFileSize s>d WFileID @ resize-file
        abort" Can't resize file"
        0 0 WFileID @ reposition-file
        abort" Can't reposition file"
        WFileStart WFileSize WFileID @ write-file
        abort" *** Problems writing file *** "
        WFileID @ flush-file abort" Can't flush the file"
        WfileID @ close-file abort" Can't close the file" ;