Programme de consonances 3

INGRA2.HTM Basic consonance program. other versions of the program are: CHORDBAS.HTM and KOGRA6.HTM. None are final.
CONST PI = 3.141592654#
CONST SX = 319
CONST SY = 189
CONST TMAX = 8     'max tones per chord
DIM a#(500)
DIM IA!(500)
DIM IB%(500)

DIM LABF%(350)
DIM IAF!(350)
DIM IBF%(350)
DIM AF#(350)
DIM RAF#(350)
DIM IAEF!(350)
DIM IBEF%(350)
DIM NAM$(350)
DIM BEA!(350)
DIM IVR#(350)

DIM ALB$(350)
DIM ACAR%(250, 8)
DIM ACAR!(250, 8)


DIM GAM%(3)
DIM GAMI%(3)
DIM BG#(2, 11)

DEFINT C-L
DEFDBL N-Z

rdflnm$ = "C:\DB\RAW12.txt"   'raw data output
inflnm$ = "C:\DB\SMOFI12.TXT"  'SMOFI11.TXT" 'interval data input
aaflnm$ = "C:\DB\aafii12.txt"  'ascii art output

GOSUB screZoom

GOSUB struGam
GOSUB inpInt

'zoom box for asciiart overrides
zsf = 1
zxf = 12 * zsf ' x scale factor for entire object ' line 1 of chord file
zxk = 135       ' x displacement of object         ' line 2 of chord file
'use just one kind of scale overrides
GAMAX% = 0
GAMI%(GAMAX%) = 0

'reference fundamental guitar c on fifth string at third fret
FFUN# = 110 * 2 ^ (3 / 12)

'various arbitrary limit values
HMAX% = 25 '45 '10    'max number of harmonics
U = .0000002  'discriminate "perfection"
TOL# = 1.03   'disallow ratios greater than this value

'skip low octaves doesn'd seem very useful for now
QMIN% = 1



'****************************************************************************

'output raw data tables  initialize i/o
OPEN rdflnm$ FOR OUTPUT AS 1
PRINT #1, "chord         scale   T1  H(T1) T2  H(T2)   freq   ratio    beatfreq"

'*******************************************************************

'el main routine

FOR CH% = 1 TO CHMAX%

NJ% = 0
ERASE LABF%
ERASE IAF!
ERASE IBF%
ERASE AF#
ERASE RAF#
ERASE IAEF!
ERASE IBEF%
ERASE IVR#
ERASE NAM$
ERASE BEA!

FOR GA% = 0 TO GAMAX%
LAB% = GAM%(GAMI%(GA%))

'initialize
BJ% = 1
GOSUB makeA
GOSUB sortA
GOSUB makeB
NEXT GA%

GOSUB sortB
GOSUB filA
NEXT CH%
CLOSE #1

'GOSUB aart
'GOSUB maSca

'PRINT "fin"
BEEP
END

'********************** s u b r o u t i n e s ****************************
'*********************************************************************
makeA:
ERASE a#
ERASE IA!
ERASE IB%

'preliminary: override scales if any data point is incompatible
'I've done this a million times and it doesn't work here for some strange reason

osf = 0
FOR H = 1 TO TMAX
sv! = ACAR!(CH%, H)
IF sv! = 99 THEN EXIT FOR
IF INT(sv!) <> sv! THEN osf = 1
IF sv! > 12 THEN osf = 1
IF osf > 0 THEN EXIT FOR
NEXT H
osf = 1 'override city !

'actual process
FOR H = 1 TO TMAX
IF ACAR!(CH%, H) = 99 THEN EXIT FOR

IF osf = 0 THEN
S = BG#(GAMI%(GA%), ACAR!(CH%, H))
ELSE
S = 2 ^ (ACAR!(CH%, H) / 12)
END IF



G = 1

'skip low octaves doesn'd seem very useful for now
DO
IF S * G >= QMIN% THEN EXIT DO
G = G + 1
LOOP

DO
Q = S * G
IF G > HMAX% THEN EXIT DO
a#(BJ%) = Q
IA!(BJ%) = ACAR!(CH%, H)
IB%(BJ%) = G

BJ% = BJ% + 1
G = G + 1
LOOP
NEXT H
BJ% = BJ% - 1
RETURN

'*********************************************************************
sortA:
swf% = 1
FOR C = 1 TO BJ% - 1
DO

FOR D = (C + 1) TO BJ%

IF a#(D) < a#(C) THEN EXIT FOR
NEXT D

IF D > BJ% THEN D = BJ%

IF a#(D) < a#(C) THEN
SWAP a#(D), a#(C)
SWAP IA!(D), IA!(C)
SWAP IB%(D), IB%(C)
ELSE
swf% = 0
END IF


LOOP UNTIL swf% = 0

swf% = 1
NEXT C
RETURN

'*********************************************************************
' analysis
makeB:
FOR C = 1 TO BJ% - 1     '1 TO BJ%

D = C
DO

D = D + 1
RA# = a#(D) / a#(C)
IAE! = IA!(D)
IBE% = IB%(D)

IF RA# < TOL# THEN

NJ% = NJ% + 1

LABF%(NJ%) = LAB%
AF#(NJ%) = a#(C)
RAF#(NJ%) = RA#
NAM$(NJ%) = ALB$(CH%)

'estimate beat rate
HI# = FFUN# * a#(D)
LO# = FFUN# * a#(C)
IF HI# = LO# THEN
BEA!(NJ%) = 0
ELSE
BEA!(NJ%) = HI# ^ 2 / LO# - HI#
END IF

IF IB%(C) > IBE% THEN
IAF!(NJ%) = IAE!
IBF%(NJ%) = IBE%
IAEF!(NJ%) = IA!(C)
IBEF%(NJ%) = IB%(C)
ELSE
IAF!(NJ%) = IA!(C)
IBF%(NJ%) = IB%(C)
IAEF!(NJ%) = IAE!
IBEF%(NJ%) = IBE%
END IF
ELSE
EXIT DO
END IF
IF D = BJ% THEN EXIT DO
LOOP

NEXT C
RETURN

'************************************************************************
sortB:
swf% = 1

'sort criteria

FOR C = 1 TO NJ%
'IVR#(C) = IAF!(C) / 100 + IBF%(C) / 10000 + IAEF!(C) / 1000000 + IBEF%(C) / 100000000
'sort by scale then by harmonics
'IVR#(C) = LABF%(C) + IBF%(C) / 100 + IBEF%(C) / 10000 + IAF!(C) / 1000000 + IAEF!(C) / 100000000

'sort by scale then by tones
IVR#(C) = LABF%(C) + (1 + IAF!(C)) / 100 + (1 + IAEF!(C)) / 10000 + IBF%(C) / 1000000 + IBEF%(C) / 100000000

'sort by harmonics
'IVR#(C) = IBF%(C) * 100 + IBEF%(C) + IAF!(C) / 100 + IAEF!(C) / 10000 + LABF%(C) / 100000000

NEXT C

'sort proper

FOR C = 1 TO NJ% - 1         ' BJ% -  1
DO

FOR D = (C + 1) TO NJ%    ' BJ%

IF IVR#(D) < IVR#(C) THEN EXIT FOR
NEXT D

IF D > NJ% THEN D = NJ% 'BJ%

IF IVR#(D) < IVR#(C) THEN
SWAP IVR#(D), IVR#(C)
SWAP AF#(D), AF#(C)
SWAP IAF!(D), IAF!(C)
SWAP IBF%(D), IBF%(C)
SWAP LABF%(D), LABF%(C)
SWAP RAF#(D), RAF#(C)
SWAP IAEF!(D), IAEF!(C)
SWAP IBEF%(D), IBEF%(C)
SWAP NAM$(D), NAM$(C)
SWAP BEA!(D), BEA!(C)
ELSE
swf% = 0
END IF


LOOP UNTIL swf% = 0

swf% = 1
NEXT C
RETURN

'*********************************************************************

'record raw data
filA:

FOR C = 1 TO NJ%
PRINT #1, NAM$(C),
PRINT #1, USING "#####"; LABF%(C);
PRINT #1, USING "####.#"; IAF!(C);
PRINT #1, USING "#####"; IBF%(C);
PRINT #1, USING "####.#"; IAEF!(C);
PRINT #1, USING "#####"; IBEF%(C);
PRINT #1, USING "####.####"; AF#(C); RAF#(C); BEA!(C)

GOSUB drawgA

NEXT C
RETURN

'***************************************************************************
drawgA:
'graphics?
t1! = IAF!(C)
t2! = IAEF!(C)
h1 = IBF%(C)
h2 = IBEF%(C)
beat = BEA!(C)
freq = AF#(C)

'td = t1 - t2
td! = t1!
std! = td! * zxf
IF std! < stdmin! THEN stdmin! = std!
IF std! > stdmax! THEN stdmax! = std!

'harmonics could be represented as arc
'ah1 = 2 * PI / h1
'ah2 = 2 * PI / h2

'it doesn't matter which one you use: h1 or h2 are linked
sh2 = h2 * 9 '3
sh1 = h1 * 9  '3

rbeat = rfr / (freq + beat)   '200 / (freq + beat)

x1 = std!
x2 = x1
y1 = 0
y2 = y1 + sh1           'could be + sh1 or 2
'LINE (x1, y1)-(x2, y2)

'could make comb representation not useful with linked data
'SWAP x1, x2
'SWAP y1, y2
'x2 = x1 + sh1 * zsf/10       'could be + sh2
'y2 = y1
'LINE (x1, y1)-(x2, y2)


'CIRCLE (x2, y2 + 30), rbeat, 1                           'worms
'CIRCLE (x2, y2 + 30), rbeat, 1, 3 * PI / 2, PI / 2     'wine flasks
'CIRCLE (x2, y2 + 30), rbeat, 1, PI, 0                  'wine glasses
'CIRCLE (x2, y2 + 30), rbeat, 1, PI / 4, 3 * PI / 4     'clouds
'CIRCLE (x2, y2 + 30), rbeat, 1, PI / 6, 5 * PI / 6     'clouds 2
CIRCLE (x2 - zxk, y2 + 40), rbeat, 1, PI / 12, 11 * PI / 12   'columns
'LINE (x2, y2)-(x2, y2 + 5)

RETURN
'***************************************************************************
maSca:

'    LOCATE 22, 80 'text position of max line and max xposition
'    MyRow% = CSRLIN
'    mycol% = POS(0)
'    PRINT "Position "; mycol%
'    LOCATE (MyRow%), (mycol% + 2)



row% = 22
maxin% = INT(t1!)        'last value should be largest
                        'esx is max screen on current scale
FOR incr% = 1 TO maxin%
xmark% = INT(incr% * zxf)

'IF incr% = 19 OR incr% = 16 OR incr% = 12 OR incr% = 24 THEN
'LINE (xmark%, 0)-(xmark%, esy - 2)
'ELSE
LINE (xmark%, esy)-(xmark%, esy - 2)
'END IF
'tmark% = INT(40 * incr% / maxin%)
'IF tmark% > 40 THEN EXIT FOR
'LOCATE row%, tmark%
'PRINT incr%;
NEXT incr%

RETURN

'***************************************************************************
aart:
'output aascii art to a text file i/o
OPEN aaflnm$ FOR OUTPUT AS 1

   
    FOR y% = 1 TO (esy)
    parr$ = ""
    FOR x% = 1 TO (esx)
            poi% = POINT(x%, y%)
            'PRINT poi%;
            IF poi% > 0 THEN
            poi$ = "8"
            'poi$ = STR$(poi%)
            'poi$ = LTRIM$(poi$)
            'poi$ = RTRIM$(poi$)
            ELSE
            poi$ = " "
            END IF
            parr$ = parr$ + poi$
        NEXT x%

        PRINT #1, parr$
   
    NEXT y%
    CLOSE #1
RETURN
'****************************************************************************
screZoom:
' screen and zoom initialization

SCREEN 1 '2 '1

'proportional zoom factor: logical screen
zsf = 1

'logical screen rect
esx = zsf * SX
esy = zsf * SY
LINE (0, 0)-(0, esy)
LINE (0, 0)-(esx, 0)
LINE (0, esy)-(esx, esy)
LINE (esx, 0)-(esx, esy)

'zoom box for asciiart
zxf = 120 * zsf  ' x scale factor for entire object ' line 1 of chord file
zxk = 400  ' x displacement of object         ' line 2 of chord file
'zyf = 120 * zsf  'y scale factor for entire object ' line 3 of chord file
'zyk = 400 * zsf  'y displacement of object         ' line 4 of chord file

'radius factor
rfr = 130 * zsf


RETURN

'********************************************************************
struGam:

'les noms des gammes sont indiqués par un code basé sur les degrés tempérés
GAM%(0) = 1234      'tempérée
GAM%(1) = 5555      'quartes
GAM%(2) = 4747      'diatonique

'les fréquences pour 3 gammes

'la construction de la gamme à tempérament égale est unique

'il y a 12 gammes des quartes possibles
'pour une gamme des quartes il y a toujours une construction par quintes
'équivalente
'les consonances obtenues dépendent du ton de référence que l'on choisit
'j'ai choisi arbitrairement une construction par quartes partant de do

'j'ai choisi arbitrairement une construction par quartes et quintes
'autour de do et la gamme diatonique  choisie est donc do majeur
'il y a 12 gammes autres gammes diatoniques de même construction

'j'ai choisi une extension arbitraire pour boucher les trous
'et obtenir une gamme chromatique par des nouvlles tierces et quartes
'cette gamme se veut diatonique par l'esprit


'tempérée
BG#(0, 1) = 2 ^ (1 / 12)             'dod
BG#(0, 2) = 2 ^ (2 / 12)             'ré
BG#(0, 3) = 2 ^ (3 / 12)             'mib
BG#(0, 4) = 2 ^ (4 / 12)             'mi
BG#(0, 5) = 2 ^ (5 / 12)             'fa
BG#(0, 6) = 2 ^ (6 / 12)             'fad
BG#(0, 7) = 2 ^ (7 / 12)             'sol
BG#(0, 8) = 2 ^ (8 / 12)             'lab
BG#(0, 9) = 2 ^ (9 / 12)             'la
BG#(0, 10) = 2 ^ (10 / 12)           'sib
BG#(0, 11) = 2 ^ (11 / 12)           'si
BG#(0, 0) = 1                        'do

'quartes
BG#(1, 5) = 4 / 3               'fa
BG#(1, 10) = (4 / 3) ^ 2        'sib
BG#(1, 3) = (4 / 3) ^ 3 / 2     'mib
BG#(1, 8) = (4 / 3) ^ 4 / 2     'lab
BG#(1, 1) = (4 / 3) ^ 5 / 4     'réb
BG#(1, 6) = (4 / 3) ^ 6 / 4     'fad
BG#(1, 11) = (4 / 3) ^ 7 / 4    'si
BG#(1, 4) = (4 / 3) ^ 8 / 8     'mi
BG#(1, 9) = (4 / 3) ^ 9 / 8     'la
BG#(1, 2) = (4 / 3) ^ 10 / 16   'ré
BG#(1, 7) = (4 / 3) ^ 11 / 16   'sol
BG#(1, 0) = 1                   'do

'quintes  rectifiées pour do
BG#(1, 7) = 3 / 2                       'sol
BG#(1, 2) = (3 / 2) ^ 2 / 2             'ré
BG#(1, 9) = (3 / 2) ^ 3 / 2             'la
BG#(1, 4) = (3 / 2) ^ 4 / 4             'mi
BG#(1, 11) = (3 / 2) ^ 5 / 4            'si
BG#(1, 6) = (3 / 2) ^ 6 / 8             'fad
BG#(1, 1) = (3 / 2) ^ 7 / 16            'do#
BG#(1, 8) = (3 / 2) ^ 8 / 16            'sol#
BG#(1, 3) = (4 / 3) ^ 3 / 2             'mib
BG#(1, 10) = (4 / 3) ^ 2                'sib
BG#(1, 5) = 4 / 3                       'fa
BG#(1, 0) = 1                           'do

'diatonique
BG#(2, 5) = 4 / 3                    'fa
BG#(2, 9) = (4 / 3) * (5 / 4)        'la
BG#(2, 0) = 1                        'do
BG#(2, 4) = 5 / 4                    'mi
BG#(2, 7) = 3 / 2                    'sol
BG#(2, 11) = (3 / 2) * (5 / 4)       'si
BG#(2, 2) = (3 / 2) * (3 / 2) / 2    'ré
BG#(2, 8) = 8 / 5                      'sol# de do
BG#(2, 1) = 16 / 15                    'do#  de fa
BG#(2, 3) = 6 / 5                      'mib  de sol
BG#(2, 10) = 16 / 9                    'sib  de fa
BG#(2, 6) = (15 / 8) * (3 / 2) / 2     'fa# de si

RETURN

'****************************************************************************
inpInt:
'chords input data
OPEN inflnm$ FOR INPUT AS 1

'zoom box for asciiart in file
'                  x scale factor for object      ' line 1 of chord file
LINE INPUT #1, CHO$
zxf = VAL(CHO$)  ' tinker '7 '6 '10 '12
'                  x displacement of object       ' line 2 of chord file
LINE INPUT #1, CHO$
zxk = VAL(CHO$)  ' tinker '7 '6 '10 '12


'parse scale definitions numbers on spaces          ' line 3 of file
LINE INPUT #1, CHO$
CHO$ = LTRIM$(CHO$)
CHO$ = RTRIM$(CHO$)

I = 0
AC$ = ""
DO
T$ = LEFT$(CHO$, 1)
CHO$ = RIGHT$(CHO$, (LEN(CHO$) - 1))

IF ASC(T$) = 32 OR LEN(CHO$) = 0 THEN
IF LEN(CHO$) = 0 THEN AC$ = AC$ + T$
GAMI%(I) = VAL(AC$)
CHO$ = LTRIM$(CHO$)
I = I + 1
AC$ = ""
ELSE
AC$ = AC$ + T$
END IF

IF LEN(CHO$) = 0 THEN EXIT DO
LOOP
GAMAX% = I - 1



'labeled chords or intervals remaining lines
J = 0
DO
J = J + 1
LINE INPUT #1, CHO$
IF LEN(CHO$) = 0 THEN EXIT DO

CHO$ = LTRIM$(CHO$)
CHO$ = RTRIM$(CHO$)

I = 0
AC$ = ""
DO
T$ = LEFT$(CHO$, 1)
CHO$ = RIGHT$(CHO$, (LEN(CHO$) - 1))

IF ASC(T$) = 32 OR LEN(CHO$) = 0 THEN
IF LEN(CHO$) = 0 THEN AC$ = AC$ + T$
IF I = 0 THEN ALB$(J) = AC$ ELSE ACAR!(J, I) = VAL(AC$)
CHO$ = LTRIM$(CHO$)
I = I + 1
AC$ = ""
ELSE
AC$ = AC$ + T$
END IF

IF LEN(CHO$) = 0 THEN EXIT DO
LOOP
ACAR!(J, I) = 99

LOOP UNTIL (EOF(1))

CLOSE #1
CHMAX% = J
RETURN

'****************************************************************************