
% CONSONANCE FACTOR


%       mcm(+Int1,+Int2,-Mcm).

% Mcm is the least common multiple of Int1 and Int2.

        mcm(H,K,X):- mcd(H,K,M),!,
                     X is H / M * K.


%      mcd(+Int1,+Int2,-Mcd).

% Mcd is the highest common denominator of Int1 and Int2.

        mcd(X,0,X):-!.
        mcd(X,Y,Z):- R is X mod Y,
                     mcd(Y,R,Z).


%      rfclist(+List,-Fc).

%  If List is a list of frequency ratios, Fc is the consonance factor of List.


        rfclist(X,Fc):- oplist(rmcd,X,Mcd),
	                maplist(int(Mcd),X,Y),
			oplist(mcm,Y,Fc), !.

	fclog(X,Fc):- rfclist(X,F),
		      Fc is round(log(F)).

        int(Mcd,X,Y):- Y is truncate(X / Mcd).


	oplist(_,[X],X).
        oplist(Op,[X,Y|Z],M):- oplist(Op,[Y|Z],N),
                               H =..[Op,X,N,M],
			       call(H).

% rmcd(+Real,+Real,-Mcd).

%  If Real1 and Real2 are rational numbers, Mcd is the highest common
%  denominator of Real1 and Real2

        rmcd(X,Y,Z):- Y > 1e-5,
                      H is X / Y,
                      K is truncate(H),
                      R is Y * (H - K),
                      rmcd(Y,R,Z),!.
        rmcd(X,_,X).


%    frac(+Raz,-Frac).

%  If Raz is a rational number, Frac is the fraction equal to Raz.

      frac(X,Y):- rmcd(X,1,M),
                  N is truncate(X / M),
                  D is truncate(1 / M),
		  Y = N/D,
		  !.


%     fc(+Real,-Fc).

% Fc is the Consonance Factor of the interval Real.

      fc(X,F):- trasp(2,X,H),
		frac(H,Y),
		Y = N/D,
		F is N * D,
		!.


      cons(X):- fc(X,F),
                F < 46.



%     afc(+Real,-Fc).

%  Fc is the consonance factor of the interval Real approximate by
%  continued fractions.

        afc(X,Fc):- trasp(2,X,Y),
		    appr(Y,N,D,22),
	            Fc is N * D.


%       afq(+Real,-Raz).

% Approximates the real Real into the rational number Raz with a
% difference of +/- 22 cents.

	afq(X,Y):- appr(X,N,D,22),
	           Y = N/D.



/*     appr(+Real,-Num,-Den,+Int).

 Num and Den are numerator and denominator of fraction which approximates the real number Real within the difference of +/- Int, with Int expressed in cents.       */

        appr(Real,Num,Den,App):- cont_fract(Real,Num,Den),
                                 Num > 0,  Den > 0,
                                 App > abs(log(Real*Den/Num)) * 1731.23,!.


        cont_fract(_,0,1).
        cont_fract(X,J,K):- F is 1 / X,
                            P is truncate(F),
                            Y is F - P,
                            cont_fract(Y,W,J),
                            K is P * J + W.


% CONVERSION FROM FREQUENCIES TO NOTE NAMES AND VICEVERSA

:- dynamic ott/1.

/*      n_fq(+Atom,-Raz).

 Raz is the frequency's rational number of the note name Atom (in latin
 notation). n_fq remembers the octave rate (an integer from 0 to 9), so
 just state it in Atom only when it changes.
 Ex.
 ?- n_fq(re,X). X = 1.125
 ?- n_fq(re5,X). X = 36.0.
 ?- n_fq('mi-',X). X = 40.0.

 You can declare in Atom every number of sharps or flats and also
 composed intervals. Ex.
 ?- n_fq('sol#--6',X). X = 99.99999999.
 ?- n_fq('labbb+++',X). X = 92.05605486968447.
 ?- n_fq(fafafa4,X). X = 37.925925925925924.		  */


            n_fq('',K):- ott(H),
		         K is 2^H.
             n_fq(X,N):- atom_concat(H,K,X),
			 nota(H,J),
                         n_fq(K,Z),
                         N is Z * J,
			 !.
             n_fq(X,N):- char_type(X,digit(M)),
                         retract(ott(_)),
                         assert(ott(M)),
                         n_fq('',N).

% Pythagorean intonation

	nota(N,X):- nth0(Y,[fa,do,sol,re,la,mi,si],N),
		    H is 4/3 * (1.5 ^ Y),
		    trasp(2,H,X).

	nota('#', 2187/2048).
	nota(b, 2048/2187).

% Syntonic  Comma
	nota('+', 81/80).
	nota('-', 80/81).

% Seventh harmonic
        nota('°', 63/64).
        nota('^', 64/63).

      ott(0).


/*	n_dec(+Dec,-Atom).

 Opposite of n_fq. If Dec is a rational number whose factorization have
 not prime numbers greater than 7, Atom is the exact note name of Dec, with the
 same notation symbols of n_fq.
 It works for the circle of fifths from labbb+++ to sol##---.          */


   n_dec(Real,Nome):-
		frac(Real,F),
		F = Num/Den,
		scomponi(Num, [_, Vnum, IIInum, VIInum]),
		scomponi(Den, [_, Vden, IIIden, VIIden]),
		V is Vnum - Vden,
		III is IIInum - IIIden,
		VII is VIInum - VIIden,
		Ott is floor(log(Real) / 0.6931471805599),
		Fifths is V + (III * 4) + (VII * 5) + 1,
		U is Fifths mod 7,
		(U >= 0, W = U; W is 7 + (U mod 7)),
		J is floor(Fifths / 7 - VII),
		nth0(W,["fa", "do", "sol", "re", "la", "mi", "si"], Nota),
		monta(Nota, [J,III,VII,Ott], ["#","-","°"], ["b","+","^"],Nome),!.



               monta(X,[T],[],[],Y):- atom_concat(X,T,Y).
       monta(P,[X|H],[L|Z],[K|S],Q):- (X >= 0, Y = X, D = L;
                                       X < 0, Y = -X, D = K),
                                      ripeti(Y,D,T),
                                      atom_concat(P,T,R),
                                      monta(R,H,Z,S,Q).

       ripeti(0,_,''):- !.
        ripeti(N,X,Y):- M is N - 1,
                        ripeti(M,X,K),
                        atom_concat(K,X,Y).


/*     nome(+Real,-Atom).

 Atom is the name of the frequency ratio Real, with 1 = Do0. It
 works for every real number Real. Atom is the name of Real
 approximates into the equal temperament of 19 notes, which
 distinguishes enharmonic notes altered respectively with sharp and
 flat.      */


        nome(X,Y):- H is round(log(X) * 27.4112),
                    K is H mod 19,
                    n19(K,N),
                    T is floor(H / 19),
                    (	atom_concat(N,T,Y),
			retract(ott(_)),
		        assert(ott(T))  ; ott(T), Y = N   ),!.


        n19(0,do).   n19(1,'do#').   n19(2,reb).
        n19(3,re).   n19(4,'re#').   n19(5,mib).
        n19(6,mi).   n19(7,fab).
        n19(8,fa).   n19(9,'fa#').   n19(10,solb).
        n19(11,sol). n19(12,'sol#'). n19(13,lab).
        n19(14,la).  n19(15,'la#').  n19(16,sib).
        n19(17,si).  n19(18,dob).


/*    nomefql(+List1,+List2,-List3).

 Given the list of frequencies List1 and the list of note names List2,
 it produces in List3 the list of frequencies of List1 matching the given names.  */

        nomefql(_,[],[]).
        nomefql(L,[N|M],[Fq|H]):- member(Fq,L),
			          nome(Fq,N),
			          nomefql(L,M,H),!.


% SCALES GENERATORS

%       primo(+Int).

% True if Int is a prime number.

        primo(2).
        primo(X):- integer(X),
                   H is sqrt(X),
                   (  Y = 2; disp(Y)  ),
                   (0 is X mod Y, !, fail; Y > H),
		   !.

        disp(3).
        disp(X):- disp(Y),
                  X is Y + 2.


/*    scomponi(+Int,?List).

 List is the factorization of Int, where every item of List is the
 exponent of nth prime in the prime series.
 Ex.
  ?- scomponi(1200,X). X = [4,1,2].  Indeed: 1200 = 2^4 * 3^1 * 5^2.   */


      scomponi(1,[0]).
        scomponi(X,Y):- integer(X),
			scomp(0,2,X,Y),!.

           scomp(0,_,1,[]).
            scomp(N,F,X,H):- 0 is X mod F,
                             Y is X // F,
                             M is N + 1,
                             scomp(M,F,Y,H).

        scomp(N,F,X,[N|K]):- disp(Y),
                             Y > F,
                             primo(Y),!,
                             scomp(0,Y,X,K).


/*      modo(:Goal,+Int1,+Int2,-List).

 List is a scale of integers from Int to Int2 which satisfy the condition Goal.	   */

        modo(T,M,S,X):- P is S - M,
                        prog('+',P,M,1,H),
		        sublist(T,H,X),!.


% ALLOWED CONDITIONS FOR Goal.


% Pythagorean intonation

        pit(X):- scomponi(X,[_,_]).

% Just intonation, senary sistem.

        senario(X):- scomponi(X,[_,_,_]).

% Just intonation, with exclusion of pythagorean thirds, sixths and sevenths.

        sen(X):- scomponi(X,[_,P,_]),P < 4.

% Diatonic intonantion

	diat(X):- scomponi(X,[_,P,Q]),P < 4, Q < 2.

% Just intonation, with inclusion of seventh harmonic.

	dec(X):- scomponi(X,[_,_,_,_]).


/*     scala(:Goal,+Int,+Raz1,+Raz2,+Raz3,-List).

 List is the scale of rational numbers from Raz1 to Raz2 built
 on the harmonics from Int to Int * Raz3, that meets the condition Goal.
 With Raz3 < 2 are obtained "limited transposition scales".

  Ex. D natural minor scale from D3 to G6:
  ?- scala(diat,40,9,96,2,X),maplist(n_dec,X,N).
  X = [9.0,10.125, 10.8, 12.15, 13.5, 14.4, 16.2, 18.0, 20.25|...],
  N = [re3, mi3, 'fa+3', 'sol+3', la3, 'sib+3', 'do+4', re4, mi4|...].   */


        scala(Tipo,Modo,Tonica,Lsup,Trasp,X):-
                    N is truncate(Modo * Trasp),
                    modo(Tipo,Modo,N,Y),
                    maplist(per(Tonica/Modo),Y,K),
                    sup(Trasp,Lsup,K,X).


% Slonimsky's patterns.

        slonim_patt(T,Ott,Parts,Intp,Trasp,X):-
		   Inc is 2^(Ott/Parts),
		   N is Parts + 1,
                   prog('*',N,1,Inc,L),
		   maplist(afq,L,A),
		   maplist(trasp(Trasp),A,J),
		   maplist(per(T),J,Z),
                   interp([1|Intp],Z,H),
                   reverse(H,[_|K]),
                   append(H,K,X),
                   !.


           interp(_,[X],[X]).
         interp(Int,[X|Y],J):- maplist(per(X),Int,H),
                               interp(Int,Y,K),
                               append(H,K,J).


/*      prog(+Op,+Nint,+Preal,+Ireal,-List).

 Produces in List a geometric or arithmetic progression given: Op =
 arithmetic operator (+,-,*,/),Nint = number of terms of
 progression, Preal = first term, Ireal = increment.          */

        prog(_,0,_,_,[]).
        prog(Op,N,P,I,[P|Z]):- M is N - 1,
                               Q =.. [Op,P,I],
                               S is Q,
                               prog(Op,M,S,I,Z),!.



        sup(_,Sup,X,Y):- append(Y,[M|_],X), M > Sup,!.

        sup(E,Sup,X,Y):- maplist(per(E),X,D),
                         append(X,D,H),
                         N is E * E,
                         sup(N,Sup,H,Y).


        trasp(T,X,X):- X < T,!.
        trasp(T,X,Y):- H is X / T,
	               trasp(T,H,Y).

	per(A,B,X):- X is A * B.


        scala2(Modo,Ton,Sup,S):- H is Modo * 2,
			         modo(senario,Modo,H,Y),
		                 maplist(per(Ton/Modo),Y,K),
			         diat(a,K,J),
				 sup(2,Sup,J,X1),
				 diat(b,K,Z),
		                 sup(2,Sup,Z,S2),
				 reverse(S2,[_|X]),
				 append(X1,X,S).

	     diat(_,[],[]).
     diat(a,[A,B|H],[B|K]):- 1 < 16/15 * (A / B),
			     diat(a,H,K),!.
     diat(b,[A,B|H],[A|K]):- 1 < 16/15 * (A / B),
		             diat(b,H,K),!.
       diat(T,[A|H],[A|K]):- diat(T,H,K),!.



	arpeggio(_,[B],[B]).
arpeggio(I,[A,B|S],[A,B|X]):- 1 >= I *(A / B),
		              arpeggio(I,[B|S],[B|X]),!.
      arpeggio(I,[A,_|S],X):- arpeggio(I,[A|S],X).



% JUST INTONATION

:- dynamic ton/1,otv/2.

/*    Just intonation system based over harmonic mode 240, namely the subset of
 integers from 240 to 480 in whitch the factorization of every item does not
 contain prime numbers over 5. This mode constitutes a chromatic scale in just
 intonation, in whitch misses one term: the raised fourth from tonic. Here the 240
 mode appear transposed in three enlarged tonalities: E flat 240, D 240 and
 C sharp 240. Each one contains five diatonic tonalities for a whole of 15
 tonalities from C flat major to C sharp major. To re-tune a song in just
 intonation, you need to declare the main tonality (default: ton(re240)). If,
 and only if, the note to tune is not contained in the tonality (in D 240, the G#)
 the system modulates to another tonality.     */



 just(mib240,0,1).
 just(mib240,0,81/80).
 just(mib240,1,27/25).
 just(mib240,2,9/8).
 just(mib240,3,6/5).
 just(mib240,3,243/200).
 just(mib240,4,5/4).
 just(mib240,4,32/25).
 just(mib240,5,27/20).
 just(mib240,6,36/25).
 just(mib240,7,3/2).
 just(mib240,8,8/5).
 just(mib240,8,81/50).
 just(mib240,10,9/5).
 just(mib240,11,15/8).
 just(mib240,11,48/25).

 just(re240,0,81/80).
 just(re240,1,135/128).
 just(re240,2,9/8).
 just(re240,2,729/640).
 just(re240,3,75/64).
 just(re240,3,6/5).
 just(re240,4,81/64).
 just(re240,5,27/20).
 just(re240,6,45/32).
 just(re240,7,3/2).
 just(re240,7,243/160).
 just(re240,9,27/16).
 just(re240,10,225/128).
 just(re240,10,9/5).
 just(re240,11,15/8).
 just(re240,11,243/128).

 just(dod240,0,2025/2048).
 just(dod240,1,135/128).
 just(dod240,1,2187/2048).
 just(dod240,2,1125/1024).
 just(dod240,2,9/8).
 just(dod240,3,1215/1024).
 just(dod240,4,81/64).
 just(dod240,5,675/512).
 just(dod240,6,45/32).
 just(dod240,6,729/512).
 just(dod240,8,405/256).
 just(dod240,9,3375/2048).
 just(dod240,9,27/16).
 just(dod240,10,225/128).
 just(dod240,10,3645/2048).
 just(dod240,11,243/128).


 nome12(do,0).	       nome12('si#',0).
 nome12('do#',1).      nome12(reb,1).
 nome12(re,2).
 nome12('re#',3).      nome12(mib,3).
 nome12(mi,4).         nome12(fab,4).
 nome12(fa,5).	       nome12('mi#',5).
 nome12('fa#',6).      nome12(solb,6).
 nome12(sol,7).
 nome12('sol#',8).     nome12(lab,8).
 nome12(la,9).
 nome12('la#',10).     nome12(sib,10).
 nome12(si,11).        nome12(dob,11).


n_eq12(Nome,Eq):- otv(1,Q),
		  nome12(Nome,H),
		  Eq is (Q * 12) + H.
n_eq12(Nome,Eq):- name(Nome,X),
		  append(H,[K],X),
	          name(Z,H),
		  name(Y,[K]),
		  integer(Y),
	          retract(otv(1,_)),
		  assert(otv(1,Y)),
		  n_eq12(Z,Eq).


    ton(re240).

    otv(1,0).
    otv(2,0).
    otv(3,0).
    otv(4,0).
    otv(5,0).
    otv(6,0).


/*    n_just(+Atom,-Raz).

 If Atom is a note name as defined in nome12(?Nome,?Int), Raz is the
 rational number of its frequency. Like n_fq, n_just remembers
 the last octave rate declared.

    Ex. ?- n_just(sol5,X). X = 48.0
        ?- n_just(mi,X). X = 40.0

 It tune the notes on the main enlarged tonality of D:240 (D major + D minor),
 but automatically modulates to the tonalities of C#:240 or Eb:240,
 when necessary. Raz has therefore different solutions depending on
 the main tonality declared = ton(?Atom).       */


	  n_just(N,Fq):- n_just(N,1,Fq).


       n_just(N,V,Fq):- ton(T), n_j(N,V,T,Fq).

       n_just(N,V,Fq):- atom_concat('sol#',_,N),
		        retract(ton(re240)),
                        assert(ton(dod240)),
			!,
	                n_j('sol#',V,dod240,Fq).

       n_just(N,V,Fq):- atom_concat(lab,_,N),
			retract(ton(re240)),
                        assert(ton(mib240)),
			!,
                        n_j(lab,V,mib240,Fq).

       n_just(N,V,Fq):- n_j(N,V,T,Fq),
	                retract(ton(_)),
	                assert(ton(T)).


       n_j(N,V,T,Fq):- nome12(N,J),
	               just(T,J,F),
	               otv(V,Z),
	               Fq is 2^Z * F.

       n_j(N,V,T,Fq):- name(N,X),
	               append(H,[K],X),
	               name(Z,H),
	               name(Y,[K]),
		       integer(Y),
		       retract(otv(V,_)),
		       assert(otv(V,Y)),
		       n_j(Z,V,T,Fq).



           ch_just(T,N,X):- (ton(T); member(T,[mib240,re240,dod240])),
			    ch_just(1,T,N,X).

       ch_just(_,_,[],[]).
 ch_just(V,T,[N|C],[X|Y]):- V1 is V + 1,
		            n_j(N,V,T,X),
                            ch_just(V1,T,C,Y).


        eq12_just(E,F):- ton(T),
			 X is E mod 12,
			 Y is E // 12,
		         just(T,X,J),
		         F is 2^Y * J.


/*   justtuneMidi(+Metro,+Bpm,+Term).

 Tunes the symbolic score Term in Just Intonation in the most
 consonant way possible, modulating when necessary, then translate the
 score in a MIDI file, given Metro and Bmp (see: midifile).          */


       justtuneMidi(Metro,Bpm,Term):- call(Term),
	                              Term =.. [File,H],
	                              maplist(melPro,H,Y),
				      mel_arm(Y,A),
	                              maplist(bestch,A,J),
				      mel_arm(J,X),
				      lega(H,X,K),
	                              midifile(mis,Metro,Bpm,File,pura,K).



               melPro([],[]).
	 melPro([A,'-'|H],K):- melPro([A,A|H],K).
         melPro([X|H],[X|K]):- melPro(H,K),!.



		   lega([],[],[]).
      lega(['-'|H],[_|K],['-'|J]):- lega(H,K,J).
          lega([X|H],[Y|K],[Y|J]):- atom(X),
				    lega(H,K,J).
          lega([A|H],[X|K],[Y|J]):- lega(A,X,Y),
		                    lega(H,K,J).



/*    bestch(+List1,-List2).

 Tunes the chord List1 in List2 in the most consonant way, then
 write the exact name of chord notes, its Consonance Factor and
 the enlarged tonality used for that chord.      */


      bestch(X,Z):- member(M,[5,7,9,10,11]),
	            ch_just(T,X,Z),
		    fclog(Z,Fc),
		    M >= Fc,
	            maplist(n_dec,Z,N),
	            write(N),
		    writef('\t\t%w%w\t%w%w\n\n',['fc  =  ',Fc,'ton  =  ',T]).



/*     mel_arm(+List1,-List2).

 If List1 is a list of chords, List2 will be the list of melodic
 voices and viceversa.
 Ex. ?-
 mel_arm([[sop1,ten1,bas1],[sop2,ten2,bas2],[sop3,ten3,bas3]],X).
   X = [[sop1,sop2,sop3],[ten1,ten2,ten3],[bas1,bas2,bas3]].         */


             mel_arm([[]|_],[]).
	       mel_arm(X,[H|K]):- ma(X,H,Y),
                                  mel_arm(Y,K).

                  ma([],[],[]).
     ma([[A|X]|Y],[A|H],[X|K]):- ma(Y,H,K).



% CHORD GENERATORS


/*	chord0(+Atom,+Vint,+Slist,-Clist).

 Produces in Clist a chord of Vint voices, given Atom, and the scale
 Slist. If Atom = a in the chord are not allowed unisons,
 if Atom = b unison is allowed between adjoining voices.          */


            chord0(_,0,_,[]):-!.
	chord0(a,V,Sc,[X|Y]):- V1 is V - 1,
		               append(_,[X|S],Sc),
		               chord0(a,V1,S,Y).
	chord0(b,V,Sc,[X|Y]):- V1 is V - 1,
			       append(_,[X|S],Sc),
			       chord0(b,V1,[X|S],Y).



        chord(_,1,_,[_]):-!.

	chord(a,V,Sc,[X,H|Y]):-
	             V1 is V - 1,
		     append(_,[H|S],Sc),
		     H > X,
		     chord(a,V1,S,[H|Y]).

	chord(b,V,Sc,[X,H|Y]):-
	             V1 is V - 1,
		     append(_,[H|S],Sc),
		     H >= X,
		     chord(b,V1,S,[H|Y]).



/*  n_chord(+List,+Nome).

 Produces in Nome the name of the chord given as a list of frequencies
 in List, otherwise, given a name of chord in Nome, check if List
 matches Nome. n_chord recognizes all the chords declared in
 n_ch(-L,-N,Fc), in every arrangement, with any doubling or inversion.
 The inversions of chords are marked according with the international
 convention: first inversion of D minor chord = 're_min/fa'.           */


    n_chord([F|Ch],Nome):- append(A,B,[F|Ch]),
		           append(B,A,[T|C]),
		           maplist(per(1/T),[T|C],X),
		           maplist(eqmod(12),X,Y),
		           sort(Y,H),
		           n_ch(H,M,_),
		           eqmod(12,T,E),
                           nome12(N,E),
		           atomic_list_concat([N,M],'_',Q),
		          (   T == F, Nome = Q  ;
			      T =\= F,
		              eqmod(12,F,Z), nome12(J,Z),
		              atomic_list_concat([Q,J],'/',Nome)   ).


     n_ch([0,4,7],maj,4).
     n_ch([0,3,7],min,4).
     n_ch([0,4,7,10],'7',7).
     n_ch([0,4,7,11],maj7,5).
     n_ch([0,2,4,7,11],maj9,6).
     n_ch([0,3,7,10],min7,5).
     n_ch([0,3,7,11],minMaj7,7).
     n_ch([0,3,6,10],min7b5,7).
     n_ch([0,3,6,9],'7°',11).
     n_ch([0,3,6],dim,7).
     n_ch([0,4,8],'+',7).
     n_ch([0,4,8,10],'7#5',9).
     n_ch([0,4,6,10],'7b5',9).
     n_ch([0,1,4,7,10],'7b9',10).
     n_ch([0,2,5,10],sus7,7).
     n_ch([0,2,5,7,10],sus7,7).
     n_ch([0,1,5,7],susb9,7).
     n_ch([0,1,5,7,10],sus7b9,8).



% HARMONIZERS

       arm1(T,V,[B|Sc],D,_):- chord(T,V,[B|Sc],[B|C]),
			      once(n_chord(C,_)),
		              once(chord(Fch)),
                              once(check(D,Fch,[B|C])),
		              asserta(chord([B|C])),
			      fail.
            arm1(_,_,_,_,X):- recall(H,[]),
	                      mel_arm(H,[_|K]),
			      reverse(K,X).


             recall(X,Y):- retract(chord(C)),
	                   recall(X,[C|Y]).
	     recall(X,X).



/*  arm_chord(+Voci,+A,+Inf,+Sup,+Q,+Chords,-Arm).

 Produces in Arm (list of lists of melodic voices) the harmonization
 in Just Intonation of the progression of chords Chords, given as names,
 given:
 Voci = number of voices,
 A. With A = a the unison between two voices is not allowed, with A = b
 unison is allowed.
 Inf = lower limit of harmonization,
 Sup = higher limit of harmonization,
 Q = factor related to the consonance of the whole: (6 = very consonant,
     >10 = dissonant).          */


   arm_chord(V,A,Inf,Sup,Q,[C|Cs],Z):- sc_chord(Inf,Sup,[C|Cs],[S|Sc]),
	                               chord0(A,V,S,F),
	                               n_chord(F,C),
				       arm_ch(V,A,Q,Sc,Cs,[F|K]),
		                       mel_arm([F|K],J),
		                       reverse(J,Z).

             arm_ch(_,_,_,[],[],[_]).
    arm_ch(V,A,Q,Sc,['-'|K],[X,X|Y]):- arm_ch(V,A,Q,Sc,K,[X|Y]).
arm_ch(V,A,Q,[S|Sc],[Nch|N],[X,Y|Z]):- chord0(A,V,S,Y),
				       n_chord(Y,Nch),
				       check(Q,X,Y),
				       arm_ch(V,A,Q,Sc,N,[Y|Z]).

                 sc_chord(_,_,[],[]).
	   sc_chord(I,S,[N,'-'|C],X):- sc_chord(I,S,[N|C],X).
 sc_chord(Inf,Sup,[N|Nc],[[P|R]|Sc]):- atomic_list_concat([F,H],'_',N),
		                       atomic_list_concat([J|A],'/',H),
				       n_ch(D,J,Fc),
				       nome12(F,Q),
				       (   true ; just(T,Q,_),
				           retract(ton(_)),
				           assert(ton(T))    ),
				       maplist(plus(Q),D,C),
				       maplist(eq12_just,C,[L|Z]),
				       fclog([L|Z],Fc),
				       sup(2,Sup,[L|Z],E),
				       append(_,[P|R],E),
				       P >= Inf,
				       trasp(2,P,G),
				       (   A = [], G is L ;
				           A =[A1],
				           nome12(A1,B),
				           eq12_just(B,L1),
				           G is L1   ),
				       !,
				       sc_chord(Inf,Sup,Nc,Sc).



/*
voce(1,0,[S1,S2,S1,S3,S4,S3]).
voce(1,1,[S1,S2,S3,S4,S5,S6]).
voce(1,2,[S1,-,-,S2,-,-]).
voce(1,_,[S1,-,-,-,-,-]).
voce(2,_,[A,-,-,z,-,-]).
voce(3,_,[A1,-,-,z,-,-]).
voce(4,_,[T,-,-,z,-,-]).
voce(5,_,[B,-,-,-,-,-]).
*/

 rhythm_arm(Bass,Voci,Scala,X):- nomefql(Scala,Bass,B),
		                 rit_arm(B,Voci,Scala,nul,0,Y),
		                 mel_arm(Y,H),
			         reverse(H,X).

        rit_arm([],_,_,_,_,[]).
rit_arm([B|A],V,Sc,D,N,[[B|Ch]|X]):- N1 is N + 1,
		                 M is N mod 4,
		                 rhyth_patt(V,M,R),
			         chord0(a,V,Sc,[B|Ch]),
				 n_chord([B|Ch],_),
				 not([B|Ch] == D),
			         check(6,D,[B|Ch]),
		                 mel_arm(R,[[B|Ch]|H]),
			         arm(Sc,[[B|Ch]|H],J),
		                 rit_arm(A,V,Sc,J,N1,Z),
			         append([[B|Ch]|H],Z,[[B|Ch]|X]).


         rhyth_patt(N,M,[H|Y]):- N1 is N - 1,
		                 voce(N,M,X),
		                 melPro(X,H),
			         rhyth_patt(N1,M,Y).
            rhyth_patt(0,_,[]):- !.


                arm(_,[Ch],Ch).
            arm(Sc,[X,Y|Z],Ch):- chord3(Sc,X,Y),
		                 check(6,X,Y),
		                 arm(Sc,[Y|Z],Ch).

               chord3(_,[],[]).
        chord3(Sc,[X|H],[Y|K]):- var(Y),
	                         append(_,[Y|S],Sc),
		                 Y =\= X,
			         chord3(S,H,K).
        chord3(Sc,[_|H],[Y|K]):- nonvar(Y),
                                 append(_,[Y|S],Sc),
			         chord3(S,H,K).




/*     check(+list1,+List2).

 It checks if between two consecutive chords List1 e List2 there are
 no parallel or hidden octaves or fifths for contrary motion too, and
 the dissonances are prepared and resolved: how much more an
 harmonic interval is dissonant, all the more small have to do the
 melodic interval formed by the higher voice, and a dissonant harmonic
 interval have to solve in a consonant one.          */


               check(_,nul,_).
             check(_,[_],[_]).
         check(Q,[z|Y],[_|B]):- check(Q,Y,B).
         check(Q,[_|Y],[z|B]):- check(Q,Y,B).
     check(Q,[X,z|Y],[A,_|C]):- check(Q,[X|Y],[A|C]).
     check(Q,[X,_|Y],[A,z|C]):- check(Q,[X|Y],[A|C]).
     check(Q,[X,Y|Z],[A,B|C]):- !,
	                       noPar(X,Y,A,B),
	                       afc(Y/X,F1),
		               afc(B/A,F2),
		               Q > abs(log(B/Y) * F2),
		               Q * 1.4 > log(F1 * F2),
			       check(Q,[X|Z],[A|C]),
			       check(Q,[Y|Z],[B|C]).


       noPar(A,B,A,B).
       noPar(_,_,X,Y):- eqmod(12,Y/X,K),
	                K =\= 0, K =\= 7,!.
       noPar(A,B,X,Y):- not(eqmod(12,Y/X * A/B, 0)),
                       (  X / A >= 1, Y / B =< 9/8 ;
                          X / A =< 1, Y / B >= 8/9   ),!.

       eqmod(Cy,X,Y):- Y is round(log(X) * 1.4426950409 * Cy) mod Cy.



% SYMBOLIC NOTATION SYSTEM

/* mis(+List,-Note,-Ist).

 Produces in Note the list of notes and in Ist the list of instants of
 beginning of notes of the symbolic score List. List represent a
 melodic line in Prolog. Every item of the list is a unit time
 (1/1,1/2,1/4,etc., depending on time signature), and it can contain a
 note name, its frequency ratio, the duration symbol = '-', the
 repetition symbol = '%', a pause = z or a list. In this case it
 represents the division of unit time. For ex. in 4/4 the triplet of
 eighths = [do,re,mi], the eighth with the point and sixteenth =
 [do,[-,re]]. You can use nested lists and any irregular group.          */


   mis(X,N,Ist):- mis(a,X,0,1,N,Ist),!.

            mis(a,[],J,_,[end],[J]).
                mis(b,[],_,_,[],[]).
           mis(Q,['-'|Y],H,K,N,Ist):- J is H + K,
                                      mis(Q,Y,J,K,N,Ist).
           mis(Q,[A,'%'|Y],H,K,N,I):- mis(Q,[A,A|Y],H,K,N,I).
       mis(Q,[X|Y],H,K,[X|N],[H|T]):- atomic(X),
                                      J is H + K,
                                      mis(Q,Y,J,K,N,T).
               mis(Q,[X|Y],H,K,N,I):- is_list(X),
				      J is H + K,
	                              mis(Q,Y,J,K,N2,I2),
		                      length(X, L),
                                      D is K / L,
	                              mis(b,X,H,D,N1,I1),
	                              append(N1,N2,N),
	                              append(I1,I2,I).


/*   mis2(+List).

 As mis(+List,-Note,-Ist), but it makes a tie between consecutive equal notes.
 mis2 does not allow lists as items of List.     */


   mis2(X,N,I):- mis2([n|X],0,N,I),!.

               mis2([_],H,[end],[H]).
                 mis2([A,B|X],H,N,I):- ( A = B; B = '-'),
				       H1 is H + 1,
			               mis2([A|X],H1,N,I).
         mis2([_,B|X],H,[B|N],[H|I]):- H1 is H + 1,
				       mis2([B|X],H1,N,I).


/*   eq(+Atomic1,+Atomic2,-Number).

 Converter for MIDI format.
 Atomic1 is the operation to do on the note Atomic2.
 Number is the exact value of the note in equal temperament. Atomic2
 can be a frequency ratio or an atom written by the notation of n_fq or
 n_just. Atomic1 can be equal to:
 nfq : call n_fq(Atomic2,H),
 pura: produces in Number the just intonation of Atomic2,
 an integer = N, indicating the equal temperament of N degrees in
 whitch will be turned Atomic2 after:
 n_just(Atomic2,X), eq(N,X,Number).

 with N = 12 equal temperament
 with N = 19 mesotonic temperament 1/3 of comma
 with N = 31 mesotonic temperament 1/4 of comma
 with N = 43 mesotonic temperament 1/5 of comma
 with N = 53 Mercator's temperament               */


      eq(Cy,X,Y):- number(X),
                   integer(Cy),
	           Y is round(log(X) / 0.6931471805599 * Cy)/ Cy * 12.

    eq(pura,X,Y):- number(X),
	           Y is log(X) * 17.31234049067.

     eq(nfq,X,Y):- n_fq(X,H),
	           eq(pura,H,Y).

       eq(T,X,Y):- atom(X),
		   n_just(X,H),
		   eq(T,H,Y).



% RENDERING IN STANDARD MIDI FILE

:- dynamic sme/4.

/* midifile(+Mis,+Metro,+Bpm,+File,+Op,+List).

 Writes the MIDI file of symbolic score List given Mis, that can be
 equal to mis or mis2, Metro, the fraction of the meter (for ex. 3/4),
 the metronomic time Bpm, the name of file File and the operation to do
 on the notes of the score Op (see: eq(+Atomic1,+Atomic2,-Number) ).
 List is a list of lists, so if the score is made of one single
 melodic line List1, List must be equal to [List1].         */


   midifile(Mis,Metro,Bpm,File,Cy,X):-
	                         length(X,Nvoci),
	                         concat(File,'.mid',G),
                                 open(G,write,Str,[type(binary)]),
                                 tell(Str),
                                 write("MThd"),
				 N is Nvoci + 1,
	                         put_b([0,0,0,6,0,1,0,N,1,128]),
	                         write("MTrk"),
				 Metro = Num/Den,
				 put_b([0,0,0,19,0,255,88,4,Num]),
			         D is truncate(log(Den)/log(2)),
	                         put_b([D,96,8,0,255,81,3]),
	                         H is 60000000 // Bpm,
	                         put_t(3,H),
				 put_b([0,255,47,0]),
	                         polif(Mis,144,Num,Den,Cy,X),
	                         told,!.

           polif(_,_,_,_,_,[]).
    polif(Mis,Ch,N,D,Cy,[X|Y]):- H =.. [Mis,X,Nota,Ist],
                                 call(H),
		                 write_Sme(Ch,N,D,0,Cy,0,Nota,Ist),
                                 put_sme,
		                 C is Ch + 1,
			         polif(Mis,C,N,D,Cy,Y).


	       write_Sme(_,_,_,_,_,Nev,[end],[_]):-
			        Y is Nev + 4,
			        write("MTrk"),
			        put_t(4,Y).

  write_Sme(Ch,Mnum,Mden,_,Cy,Nev,[z|J],[I,I2|K]):-
			        Dt is round((I2 - I) * 1536 / Mden),
			        Nev1 is Nev - 1 + ceiling(log(Dt) * 0.2061),
			        write_Sme(Ch,Mnum,Mden,Dt,Cy,Nev1,J,[I2|K]).

  write_Sme(Ch,Mnum,Mden,D,Cy,Nev,[N|J],[I,I2|K]):-
			        Dt is round((I2 - I) * 1536 / Mden),
				Ndt is  ceiling(log(Dt) * 0.2061),
		                eq(Cy,N,X),
			        Y is round(X),
			        Ch1 is Ch + 80,
			        P is 8192 + truncate(4096 * (X - Y)),
		                D2 is P // 128,
		                D1 is P mod 128,
			        assertz(sme(D,Ch1,D1,D2)),
			        Nev1 is Nev + 11 + Ndt,
                                ( integer(I), T is I mod Mnum, vol(T,V); V = 80 ),
			        assertz(sme(0,Ch,Y,V)),
                                Ch2 is Ch - 16,
			        assertz(sme(Dt,Ch2,Y,100)),
			        write_Sme(Ch,Mnum,Mden,0,Cy,Nev1,J,[I2|K]),!.

     vol(0,98).
     vol(3,95).
     vol(_,90).


    put_b([]).
 put_b([X|Y]):- put_byte(X),
                put_b(Y).

  put_t(0,_).
  put_t(N,D):- X is D // 256,
               Y is D mod 256,
               M is N - 1,
	       put_t(M,X),
	       put_byte(Y).

  putDt(b,0).
  putDt(a,X):- H is X // 128,
               K is X mod 128,
               putDt(b,H),
	       put_byte(K).
  putDt(b,X):- H is X // 128,
               K is (X mod 128) + 128,
               putDt(b,H),
	       put_byte(K).

     put_sme:- retract(sme(I,C,N,V)),
               putDt(a,I),
	       put_b([C,N,V]),
	       put_sme.
     put_sme:- put_b([0,255,47,0]),!.
































































