Projets d'informatique musicale
Licence-Maîtrise d'informatique - Université de Caen
Marc Chemillier


;;; =================================
;;; Vademecum.lisp / 21 novembre 1999
;;; =================================
;;; D'apres P. BARBAUD, "Vademecum de l'ingenieur en musique", Springer, 1993, chap. 3-4

;;; EXEMPLE: Calcul de 3 mesures avec pour mesure initiale accord do-mi-sol
;;; (vademecum (make-mesure :accord (make-accord :mode 'h :hauteur 0 :fonction 0) :ton 0 :position 1) 
               3  ;;;)

(defun vademecum (m n)
  (if (= n 1) (list (completer-mesure-finale m))
      (let ((couple-mesures (calcul-transition m)))
        (cons (car couple-mesures)
              (vademecum (cadr couple-mesures) (- n 1))))))


(defstruct mesure
  (accord)
  (ton)         ;;; de 0 a 11
  (position))   ;;; numero de position, ou couple de positions, ou quadruplet basse/tenor/alto/sopran

(defstruct accord
  (mode)       ;;; h ou k ("majeur" ou "mineur")
  (hauteur)    ;;; de 0 a 11 (codes midi modulo 12: do=0, do#=1, re=2, etc.)
  (fonction))  ;;; EXEMPLE: (h 5 0) -> (h 5) fa-la-do fonction 0 dans "ton" Fa Maj


(defun calcul-transition (m1)
  (let ((m2 (choisir-transition-matrice m1)))
    (ajouter-transition-positions m1 m2)
    (ajouter-transition-agrement m1 m2)
    (list m1 m2)))

(defun completer-mesure-finale (m) (remplir-mesure m) m)


;;; Recherche generale dans une table:
;;; ----------------------------------

(defun recherche (clef table condition?)
  (cond ((null table) ())
        ((funcall condition? clef (car table))
         (cons (nthcdr (length clef) (car table)) (recherche clef (cdr table) condition?)))
        (t (recherche clef (cdr table) condition?))))

(defun tirage (liste-choix) (if (null liste-choix) () (nth (random (length liste-choix)) liste-choix)))

(defun tirage-ligne-proba (ligne cumule proba)
  (let ((new-cumule (+ cumule (* (cadar ligne) 100))))
    (if (<= proba new-cumule) (caar ligne)
        (tirage-ligne-proba (cdr ligne) new-cumule proba))))


;;; ENCHAINEMENT DE TRIADES
;;; -----------------------
;;; Calcul d'une nouvelle mesure m2 succedant a une mesure donnee m1
;;; a partir d'une matrice de transition des triades
;;; (h 0) = do majeur do-mi-sol, (k 2) = re mineur re-fa-la, etc.
;;; Lignes de la forme: ((k 5) ((h 0) .30) ((h 7) .70))
;;; -> successeurs de la triade (k 5): (h 0) proba=.30, ou (h 7) proba=.70
;;; Possibilite de "moduler" a la quarte ou quinte pour les transitions de la diagonale

(defun choisir-transition-matrice (m1)
  (let* ((accord-en-do (list (accord-mode (mesure-accord m1)) (accord-fonction (mesure-accord m1))))
         (accord-choix (chercher-triade accord-en-do))
         (ton2 (if (equal accord-choix accord-en-do) (+mod (mesure-ton m1) (if (= (random 2) 0) 5 7))
                   (mesure-ton m1))))
    (make-mesure :accord (make-accord :mode (car accord-choix) 
                                      :hauteur (+mod (cadr accord-choix) ton2)
                                      :fonction (cadr accord-choix)) 
                 :ton ton2)))

(defun chercher-triade (accord-en-do)
  (tirage-ligne-proba (car (recherche (list accord-en-do) *matrice-triades* #'condition-triade?)) 0 (1+ (random 100))))

(defun condition-triade? (clef ligne) (equal (car clef) (car ligne)))

(defun +mod (x y) (mod (+ x y) 12))
(defun -mod (x y) (mod (- x y) 12))



;;; POSITIONS
;;; ---------
;;; Complete les positions dans les mesures successives m1 et m2
;;; en fonction de la position initiale dans la mesure m1
;;; a partir d'une table de triplets de positions
;;; Lignes de la forme: ((9) ((h k)) (3 3 2))
;;; -> intervalle=9, modes=(h k), triplet-positions=(3 3 2)
;;; Numerotation des positions pour un accord a-b-c:
;;;    Etat fond: 1 = a-a-b-c, 2 = a-b-c-a, 3 = a-c-a-b
;;;    Sixte:  4 = b-a-c-a, 5 = b-c-a-c, 6 = b-b-c-a, 7 = b-c-a-b
;;; (il y a peu d'enchainements pour 6 et 7, donc le calcul peut avorter)


(defun ajouter-transition-positions (m1 m2)
  (let* ((intervalle (-mod (accord-hauteur (mesure-accord m2))
                           (accord-hauteur (mesure-accord m1))))
         (mode (list (accord-mode (mesure-accord m1)) (accord-mode (mesure-accord m2))))
         (triplet-choix (chercher-positions intervalle mode (mesure-position m1))))
    (setf (mesure-position m1) (list (car triplet-choix) (cadr triplet-choix)))
    (setf (mesure-position m2) (caddr triplet-choix))))

(defun chercher-positions (i m p)
  (let ((liste-choix (tirage (mapcan #'(lambda (ligne) (filtrer p ligne))
                                     (recherche (list i m) *table-positions* #'condition-position?)))))
    (when (null liste-choix) (message-avorte i m p))
    liste-choix))

(defun message-avorte (i m p)
  (print p) (format t " = position") (print m) (format t " = modes") 
  (print i) (format t " = intervalle, bloque!!!") (format t "~%"))

(defun filtrer (p l)
  (cond ((null l) ())
        ((= p (caar l)) (cons (car l) (filtrer p (cdr l))))
        (t (filtrer p (cdr l)))))

(defun condition-position? (clef ligne)
  (and (member (car clef) (car ligne)) (or (null (cadr ligne)) (member (cadr clef) (cadr ligne)))))



;;; AGREMENTS 
;;; ---------
;;; Remplace quand c'est possible les positions de la mesure m1 par des agrements
;;; (= elements melodiques pour basse, tenor, alto, soprano) 
;;; en fonction d'une table d'agrements
;;; Lignes de la forme: (2 1 1 3 (0 0 8 0) (0 0 2 0) (3 3 4 3) (5 5 5 5))
;;; -> intervalle=2, position1 = (1 1), position2 = 3
;;;    agrement: basse=(0 0 8 0), tenor=(0 0 2 0), alto=(3 3 4 3), soprano=(5 5 5 5)
;;; ATTENTION: Les numeros de notes ne sont pas des codes midi, mais des 
;;; places dans la gamme (sauf cas particulier des numeros 0 et 8)
;;; Exemple: dans la gamme = do re mi fa sol la si
;;; (3 3 4 3) -> mi mi fa mi
;;; (5 5 5 5) -> sol sol sol sol

(defun ajouter-transition-agrement (m1 m2) 
  (let* ((intervalle (-mod (accord-hauteur (mesure-accord m2))
                           (accord-hauteur (mesure-accord m1))))
         (position1 (mesure-position m1))
         (position1-1 (if (numberp position1) position1 (car position1)))
         (position1-2 (if (numberp position1) position1 (cadr position1)))
         (agrement (chercher-agrement intervalle position1-1 position1-2 (mesure-position m2))))
    (if (null agrement) (remplir-mesure m1) (fabriquer-agrement m1 agrement))))

(defun fabriquer-agrement (m agrement)
  (let* ((accord (mesure-accord m))
         (ton (mesure-ton m))
         (basse (melodiser (car agrement) accord ton))
         (tenor (melodiser (cadr agrement) accord ton))
         (alto (melodiser (caddr agrement) accord ton))
         (sopran (melodiser (cadddr agrement) accord ton)))
    (setf (mesure-position m) (list basse tenor alto sopran))))


(defmethod remplir-mesure ((m mesure))
  (let* ((accord (mesure-accord m))
         (position (mesure-position m))
         (couple-position (if (numberp position) (list position position) position))
         (bloc1 (dispose accord (car couple-position)))
         (bloc2 (dispose accord (cadr couple-position)))
         (basse (list (car bloc1) (car bloc1) (car bloc2) (car bloc2)))
         (tenor (list (cadr bloc1) (cadr bloc1) (cadr bloc2) (cadr bloc2)))
         (alto (list (caddr bloc1) (caddr bloc1) (caddr bloc2) (caddr bloc2)))
         (sopran (list (cadddr bloc1) (cadddr bloc1) (cadddr bloc2) (cadddr bloc2))))
    (setf (mesure-position m) (list basse tenor alto sopran))))

(defun chercher-agrement (i position1-1 position1-2 position2)
  (tirage (recherche (list i position1-1 position1-2 position2) *table-agrements* #'condition-agrement?)))

(defun condition-agrement? (clef ligne)
  (equal clef (list (car ligne) (cadr ligne) (caddr ligne) (cadddr ligne))))

;;; Reconstitution de la mesure a partir des positions et agrements:

(defun melodiser (motif accord tonalite)
  (let ((gamme (fabrique-gamme accord tonalite)))
    (list (fabrique-note (car motif) gamme)
          (fabrique-note (cadr motif) gamme)
          (fabrique-note (caddr motif) gamme)
          (fabrique-note (cadddr motif) gamme))))

(defun fabrique-note (n gamme)
  (case n
    (0 (car gamme))
    (8 (if (= (-mod (cadr gamme) (car gamme)) 1) (-mod (car gamme) 2) (-mod (car gamme) 1)))
     ;;; si sustonique = tonique + 1 ton -> diezer soustonique (Ex: re mi fa sol... -> do# sous re)
    (t (nth (- n 1) gamme))))

(defun fabrique-gamme (accord ton)
  (let ((degre (-mod (accord-hauteur accord) ton))
        (gamme 
          (list ton (+mod ton 2) (+mod ton 4) (+mod ton 5) (+mod ton 7) (+mod ton 9) (+mod ton 11))))
    (case degre
      (0 gamme)
      (2 (permute gamme 1))
      (4 (permute gamme 2))
      (5 (permute gamme 3))
      (7 (permute gamme 4))
      (9 (permute gamme 5))
      (11 (permute gamme 6)))))

(defun permute (gamme n) 
  (if (= n 0) gamme (permute (append (cdr gamme) (list (car gamme))) (- n 1))))

(defun dispose (accord position)
  (let ((a (accord-hauteur accord))
        (b (+mod (accord-hauteur accord) (if (eq (accord-mode accord) 'h) 4 3)))   ;;; tierce
        (c (+mod (accord-hauteur accord) 7)))                                      ;;; quinte
    (case position
      (1 (list a a b c))   ;;; etat fond
      (2 (list a b c a))
      (3 (list a c a b))
      (4 (list b a c a))   ;;; sixte
      (5 (list b c a c))
      (6 (list b b c a))
      (7 (list b c a b)))))