CHORDBAS.HTM Basic consonance program. other versions of the program are: KOGRA6.HTM and INGRA2.HTM. None are final.
' I try to use standard BASIC whenever possible but some modifications 
' will probably be necessary to run with your BASIC.
' The reason for publishing this source code is to show  
' detailed procedures and not to provide a ready-to-run application.
' This is a resonable approach because you probably don't use BASIC anyway.

' The data used to define scales are stored in the program, which is a bit sloppy
' but it works.

' The < and > symbols are replaced by html entities and should obviously be restored
' before attempting to adapt the program for a real compiler.

' Written with msdos qbasic interpreter v. 1.1 on an antique
' computer by Randy Ayling in July 2002

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

'all arrays and variables are global
'non-array variables are not declared
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 GAM%(3)
DIM GAMI%(3)
DIM BG#(2, 11)

DEFINT C-L
DEFDBL N-Z


'********************************************************************
'les noms des gammes sont indiqués par un code basé sur les degrés tempérés
'les gammes à considérer figurent dans la ligne 2 du fichier des 
'accords chofi

GAM%(0) = 1234      'tempérée
GAM%(1) = 5555      'quartes
GAM%(2) = 4747      'diatonique


'********************************************************************
'les fréquences pour 3 gammes

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

'quartes
'pour une gamme des quartes il y a toujours une construction par quintes
'équivalente
'il y a 12 gammes des quartes possibles, 1 pour chaque ton de référence
'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

'diatonique
'j'ai choisi arbitrairement une construction par quartes et quintes
'autour de do et j'ai ensuite construit les tierces comme superstructure 
'sur les premier tons
'la gamme diatonique à 7 tons obtenue est donc do majeur
'il y a 12 gammes autres gammes diatoniques de même construction

'diatonique étendu
'j'ai choisi une extension arbitraire pour boucher les trous et obtenir 
'une sorte de gamme chromatique par des nouvelles tierces et quartes
'cette gamme reste diatonique par l'esprit
'il y a un nombre que je n'ai pas déterminé (qui est peut-être grand)
'de constructions possibles pour cette gamme étendue, toutes différentes

'méthode
'C'est un défaut de cette méthode que de confiner toutes les gammes
'dans l'octave. En effet on ne peut pas alors représenter de manière
'réaliste les accords multi-octaves tels que 9, 11 et 13.
'Ce défaut ne m'a pas semblé corrigible dans la mesure où il faudrait
'aussi représenter des accords multi-gammes pour être vraiment fidèle à
'la guitare. Fait qui n'est pas rare dans la programmation, la demande 
'réclamerait un nouveau programme avec une nouvelle nomenclature des tons et
'un propos radicalement différent puisqu'il ne s'agirait plus de comparer
'plusieurs gammes théoriques mais d'examiner les harmonies "réelles"
'de la guitare particulièrement. Le programme présent se contente de donner
'à la gamme son expression la plus simple en supposant implicitement
'des octaves toujours parfaitement justes. Un peu de simplicité au départ
'révèle aussi des choses plus compréhensibles et plus communicables. Les
'choses, en l'occurence, sont loin d'être simples à l'arrivée !



'********************************************************************
'tempérée
BG#(0, 1) = 2 ^ (1 / 12)             'do#
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)             'fa#
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     'fa#
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
'********************************************************************
'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

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

'chords i/o

'le nom du fichier des accords est saisi ici pour chaque nouveau calcul
'je n'ai pas consacré de temps à démêler les idiosyncrasies ms pour
'tenter de corriger ce défaut d'interface

'la première ligne du fichier des accords contient le nombre maxi
'd'harmoniques à considérer

'la deuxième ligne contient la liste espacée des gammes à considérer
'le plus souvent 0 1 2

'le corps du fichier est constitué de lignes d'items espacés
'le premier item est le nom de l'accord et les suivants sont les
'degrés chromatiques correspondant aux tons de l'accord

'voici le "journal" des exécutions rapportées dans le texte
'Résultats                               flnm$
'Accords (harmoniques <= 6)              CHOFI1.TXT
'Accords (harmoniques <= 10)             CHOFI2.TXT
'Intervalles (harmoniques <= 6)          CHOFI3.TXT
'Intervalles (6 < harmoniques <= 10)     CHOFI4.TXT

flnm$ = "C:\DB\CHOFI1.TXT"     'adapt pathname and filename to your system!
OPEN flnm$ FOR INPUT AS 1

'harmoniques à prendre en compte
LINE INPUT #1, CHO$
HMAX% = VAL(CHO$)    '10 '6 '12 '6 '7

'gammes à prendre en compte
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



'accords à calculer
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

'*******************************************************************
'afficher une indication de l'étendue des calculs
CHMAX% = J
PRINT J, GAMAX%

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

'i/o output sortie

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
GOSUB makeA
GOSUB sortA
GOSUB makeB

NEXT GA%
GOSUB sortB
GOSUB filA
NEXT CH%

CLOSE #1
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))
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

'J'utilise une routine de tri antique (1962) un peu modernisée (sans goto).

'*********************************************************************
' 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 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)
NEXT C
RETURN