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


;;; ================================= 
;;; Vademecum.midi / 21 novembre 1999 
;;; ================================= 
;;; EXEMPLE: 
;;; (vademecum-midi 10 "Marc giga:Desktop Folder:Grammaires:Barbaud:toto.mid") 
;;; - Calcule une sequence de 10 mesures (fichiers Vademecum.lisp, Vademecum.data) 
;;; - Sauvegarde la sequence dans un midifile "toto.mid"


(defun vademecum-midi (n fich)
  (let* ((accord-init (make-accord :mode 'h :hauteur 0 :fonction 0))
         (mesure-init (make-mesure :accord accord-init :ton 0 :position 1))
         (liste-mesures (vademecum mesure-init n)))
    (faire-midifile liste-mesures fich)))

(defun faire-midifile (liste-vademecum fich)
  (let ((liste-voix (croisements (calcul-notes liste-vademecum))))
    (sauve-midifile (conversion-binaire liste-voix) fich)))

(defun sauve-midifile (liste-octets fich)
  (delete-file fich)
  (with-open-file (midi-stream fich :direction :output :if-does-not-exist :create :if-exists :supersede
                     :element-type 'unsigned-byte)
    (ecrire-stream liste-octets midi-stream)
    (set-mac-file-type fich "Midi")))                ;;; pour Macintosh

(defun ecrire-stream (liste-octets flot)
  (cond ((null liste-octets) 'stop)
        (t (write-byte (car liste-octets) flot)
           (ecrire-stream (cdr liste-octets) flot))))


;;; Calcul des codes midi: 
;;; ---------------------- 
;;; Placement a l'octave, prolongation des notes repetees, accord initial = (48 60 64 67)

(defun calcul-notes (liste-mesures)
  (list (controle-bornes-soprano (place-octaves (calcul-durees-voix liste-mesures 3) 67))
        (place-octaves (calcul-durees-voix liste-mesures 2) 64)
        (place-octaves (calcul-durees-voix liste-mesures 1) 60)
        (controle-bornes-basse (place-octaves-basse (calcul-durees-voix liste-mesures 0) 48))))

(defun calcul-durees-voix (liste-mesures voix)
  (if (null liste-mesures) ()
      (append (deployer-motif-durees (car liste-mesures) voix) (calcul-durees-voix (cdr liste-mesures) voix))))

(defun deployer-motif-durees (mesure voix) (prolonger-durees (nth voix (mesure-position mesure)) 48))

(defun prolonger-durees (l duree)
  (cond ((null (cdr l)) (list (list (car l) duree)))
        ((= (car l) (cadr l)) (prolonger-durees (cdr l) (+ duree 48)))
        (t (cons (list (car l) duree) (prolonger-durees (cdr l) 48)))))

;;; Placement a l'octave: choix systematique de la note la plus proche (Vademecum p. 103) 
;;; PROBLEMES: Bornes -> basse rapidement trop aigu, soprano stable, alto-tenor lentement vers le grave 
;;; Croisements -> basse > alto-tenor + parfois soprano < alto-tenor, MAIS jamais alto > tenor

(defun place-octaves (liste-mod12 note-initiale) 
  (cons (list note-initiale (cadr (car liste-mod12))) 
        (distance-minimale liste-mod12 (floor note-initiale 12) 1))) ;;; 1 = voix autre que basse

(defun distance-minimale (liste-mod12 octave voix)
  (cond ((null (cdr liste-mod12)) ())
        (t (let ((couple1 (car liste-mod12))
                 (couple2 (cadr liste-mod12)))
             (when (> (car couple2) (+ (car couple1) 6)) (setq octave (- octave 1)))
             (when (< (car couple2) (- (car couple1) 6)) (setq octave (+ octave 1)))
             (when (= voix 0) (setq octave (quarte-quinte (car couple1) (car couple2) octave))) ;;; basse
             (cons (list (+ (* 12 octave) (car couple2)) (cadr couple2)) (distance-minimale (cdr liste-mod12) octave voix))))))

;;; Placement octaves propre a la basse: choix aleatoire pour 4te et 5te

(defun place-octaves-basse (liste-mod12 note-initiale) 
  (cons (list note-initiale (cadr (car liste-mod12))) 
        (distance-minimale liste-mod12 (floor note-initiale 12) 0))) ;;; 0 = basse

(defun quarte-quinte (n1 n2 octave)
  (if (= (random 2) 0) octave (case (- n2 n1) (5 (- octave 1)) (-5 (+ octave 1)) (t octave))))


;;; Controle des bornes: octaves de 2 a 4 pour la basse, de 5 a 7 pour le soprano 
;;; En cas de depassement, passage a l'octave sup ou inf pour les notes longues (duree au moins 192)

(defun controle-bornes-basse (liste) (controle-bornes liste 2 4)) 
(defun controle-bornes-soprano (liste) (controle-bornes liste 4 7))

(defun controle-bornes (liste borne-inf borne-sup)
  (if (null liste) ()
      (let* ((octave (floor (caar liste) 12)) (duree (cadar liste)))
        (cond ((or (and (>= octave borne-inf) (<= octave borne-sup)) (< duree 192)) 
               (cons (car liste) (controle-bornes (cdr liste) borne-inf borne-sup)))
              ((< octave borne-inf) (controle-bornes (mapcar #'octave-sup liste) borne-inf borne-sup))
              ((> octave borne-sup) (controle-bornes (mapcar #'octave-inf liste) borne-inf borne-sup))))))

(defun octave-sup (couple) (list (+ (car couple) 12) (cadr couple))) 
(defun octave-inf (couple) (list (- (car couple) 12) (cadr couple)))


;;; Suppression des croisements basse > alto-tenor: remontee des 2 voix alto et tenor d'une octave

(defun croisements (liste-voix)
  (let ((new-tenor-alto (remonte-alto-tenor (cadddr liste-voix) (caddr liste-voix) (cadr liste-voix))))
    (list (car liste-voix) (cadr new-tenor-alto) (car new-tenor-alto) (cadddr liste-voix))))

(defun remonte-alto-tenor (basse tenor alto)
  (let ((new-tenor ()) (new-alto ()))
    (do ((l0 basse l0) (duree0 (cadar basse) duree0) 
         (l1 tenor l1) (duree1 (cadar tenor) duree1) 
         (l2 alto l2) (duree2 (cadar alto) duree2))
        ((or (null l0) (null l1) (null l2)) (list (reverse new-tenor) (reverse new-alto)))
      (when (< (caar l1) (caar l0)) (setq l1 (mapcar #'octave-sup l1)) (setq l2 (mapcar #'octave-sup l2)))
      (cond ((= duree0 48) (setq l0 (cdr l0)) (setq duree0 (cadar l0)))
            (t (setq duree0 (- duree0 48))))
      (cond ((= duree1 48) (push (car l1) new-tenor) (setq l1 (cdr l1)) (setq duree1 (cadar l1)))
            (t (setq duree1 (- duree1 48))))
      (cond ((= duree2 48) (push (car l2) new-alto) (setq l2 (cdr l2)) (setq duree2 (cadar l2)))
            (t (setq duree2 (- duree2 48)))))))


;;; Calcul des octets au format "midifile": 
;;; ---------------------------------------

(defun conversion-binaire (liste-voix)
  (append header-chunk
          (creer-track-chunk (car liste-voix))   ;;; soprano
          (creer-track-chunk (cadr liste-voix))
          (creer-track-chunk (caddr liste-voix))
          (creer-track-chunk (cadddr liste-voix))))

(setq header-chunk             ;;; format 1, 4 tracks, division = 96
  '(#x4D #x54 #x68 #x64 #x00 #x00 #x00 #x06 #x00 #x01 #x00 #x04 #x00 #x60))

(defun creer-track-chunk (liste-couples)
  (let* ((signature '(#x00 #xFF #x58 #x04 #x02 #x02 #x18 #x08))  ;;; 2/4
         (tempo '(#x00 #xFF #x51 #x03 #x07 #xA1 #x20))           ;;; tempo=120
         (liste-octets (append signature tempo (calcul-octets liste-couples))))
    (append '(#x4D #x54 #x72 #x6B)     ;;; "MTrk"
            (calcul-longueur (+ (length liste-octets) 4)) 
            liste-octets
            (list #x00 #xFF #x2F #x00))))   ;;; end of track

(defun calcul-octets (liste-couples)
  (if (null liste-couples) ()
      (append (calcul-note (car liste-couples))
              (calcul-octets (cdr liste-couples)))))

(defun calcul-note (couple)
  (append (list #x00 #x90 (car couple) #x3C)   ;;; NoteOn
          (append (calcul-deltatime (cadr couple)) 
                  (list #x80 (car couple) #x00))))   ;;; NoteOff

(defun calcul-deltatime (duree)
  (let* ((new-octet (logand duree #x7F))
         (liste-octets (list new-octet)))
    (do ((d (floor duree #x80) (floor d #x80)))
        ((= d 0) liste-octets)
      (setq new-octet (logand d #x7F))   ;;; 7 derniers bits
      (setq liste-octets (cons (logior #x80 new-octet) liste-octets)))))

(defun calcul-longueur (n)
  (list (logand (floor n #x1000000) #xFF)
        (logand (floor n #x10000) #xFF)
        (logand (floor n #x100) #xFF)
        (logand n #xFF)))