KOGRA6.HTM Basic consonance program.
other versions of the program are: CHORDBAS.HTM and INGRA2.HTM. None are final.
CONST PI = 3.141592654#
CONST SX = 310
CONST SY = 185
CONST EC = .8 '1 '.5
DIM a#(500)
DIM IA!(500)
DIM IB%(500)
DIM LABF%(250)
DIM IAF!(250)
DIM IBF%(250)
DIM AF#(250)
DIM RAF#(250)
DIM IAEF!(250)
DIM IBEF%(250)
DIM NAM$(250)
DIM BEA!(250)
DIM IVR#(250)
DIM ALB$(100)
DIM ACAR%(100, 8)
DIM ACAR!(100, 8)
DIM GAM%(3)
DIM GAMI%(3)
DIM BG#(2, 11)
DEFINT C-L
DEFDBL N-Z
SCREEN 1 '2 '1
esx = EC * SX
esy = EC * SY
'LINE (0, 0)-(0, esy)
'LINE (0, 0)-(esx, 0)
'LINE (0, esy)-(esx, esy)
'LINE (esx, 0)-(esx, esy)
'GOSUB masca
'********************************************************************
'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
'********************************************************************
'gammes différentes à calculer
'maximum GAMAX% = 2 soit 3 gammes 0, 1 et 2
'*******************************************************************
'chords i/o
flnm$ = "C:\DB\SMOFI1.TXT" ' CHOFI4.TXT
OPEN flnm$ FOR INPUT AS 1
LINE INPUT #1, CHO$
'harmoniques à prendre en compte
HMAX% = VAL(CHO$) ' tinker '7 '6 '10 'VAL(CHO$) '10 '6 '12 '6 '7
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
J = 0
DO
J = J + 1
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$
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
'*******************************************************************
'accords différents à calculer
CHMAX% = J
'PRINT J, GAMAX%
'adaptation continue non général cas particluier do
'FOR bla = 1 TO (J - 1)
'BG#(0, bla) = 2 ^ (ACAR!(bla, 2) / 12)
'PRINT BG#(0, bla);
'NEXT bla
' END
'*******************************************************************
'tinker aart
HMAX% = 50
GAMAX% = 0
GAMI%(GAMAX%) = 0
'end tinker
'i/o
flnm$ = "C:\DB\chordsa2.txt"
OPEN flnm$ FOR OUTPUT AS 1
PRINT #1, "chord scale T1 H(T1) T2 H(T2) freq ratio beatfreq"
'*******************************************************************
'constants
'reference fundamental guitar c on fifth string at third fret
FFUN# = 110 * 2 ^ (3 / 12)
U = .0000002
TB% = 1
TE% = 100 '20 '1 '50
TS% = 1
TOL# = 1.03
'octaves
QMIN% = 1
'tons par accord (maxi)
TMAX% = 8
FOR CH% = 1 TO CHMAX%
'PRINT ALB$(CH%),
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
GDEL! = 0
GOSUB makeA
GOSUB sortA
GOSUB makeB
NEXT GA%
GOSUB sortB
GOSUB filA
NEXT CH%
CLOSE #1
GOSUB aart
'PRINT "fin"
BEEP
END
'********************** s u b r o u t i n e s ****************************
'*********************************************************************
makeA:
ERASE a#
ERASE IA!
ERASE IB%
FOR H = 1 TO TMAX%
IF ACAR!(CH%, H) = 99 THEN EXIT FOR
'S = BG#(GAMI%(GA%), ACAR!(CH%, H))
S = 2 ^ (ACAR!(CH%, H) / 12)
G = 1
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) + IAF!(C) / 100 + 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
'*********************************************************************
'i/o record data
filA:
FOR C = 1 TO NJ%
PRINT #1, NAM$(C),
PRINT #1, USING "#####"; LABF%(C); IAF!(C); IBF%(C); IAEF!(C); 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 * 120 * EC - 400
ah1 = 2 * PI / h1
ah2 = 2 * PI / h2
'sh1 = 4 * h1
'sh2 = h2 '5 * h2
sh1 = h1 * EC
sh2 = 5 * h2 * EC
rbeat = 130 * EC / (freq + beat) '200 / (freq + beat)
x1 = std
x2 = x1
y1 = 0 'GDEL!
GDEL! = GDEL! + 1
y2 = y1 + sh2 * EC '+ sh1
'LINE (x1, y1)-(x2, y2)
'SWAP x1, x2
'SWAP y1, y2
'x2 = x1 + sh1 * SIN(ah2)
'y2 = y1 + sh1 * COS(ah2)
'x2 = x1 + sh1 * EC
'y2 = y1
'LINE (x1, y1)-(x2, y2)
'IF beat > 0 THEN
'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, y2 + 20), rbeat, 1, PI / 12, 11 * PI / 12 'columns
'ELSE
'LINE (x2, y2)-(x2, y2 + 5)
'END IF
RETURN
'***************************************************************************
masca:
degy = 0
DO
degy = degy + 5 * EC
IF degy >= esy THEN EXIT DO
LINE (esx, degy)-(esx + 5, degy)
LOOP
degx = 0
DO
degx = degx + 25 * EC
IF degx >= esx THEN EXIT DO
LINE (degx, esy)-(degx, esy + 5)
LOOP
RETURN
'***************************************************************************
'next phase
'file as ascii art
aart:
'i/o
flnm$ = "C:\DB\aafi6.txt"
OPEN flnm$ FOR OUTPUT AS 1
FOR y% = 1 TO (esy + 2)
parr$ = ""
FOR x% = 1 TO (esx + 2)
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