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


;;; ====================================================
;;; Virtualboogie.lisp / 15 aout 1999 / 21 novembre 1999
;;; ====================================================

;;; Realisation d'une grille dans le style boogie-woogie:
;;; (virtual-boogie '((i) / (i) / (i) / (i 7) / (iv) / (iv) / (i) / (i) / (v) / (v 7) / (i) / (i)))

(defun genere ()
  (let* ((g1 (reecriture *grille-axiome* 4))
         (g2 (reecriture g1 4))
         (g3 (reecriture g2 4))
         (g4 (reecriture g3 4))
         (g5 (reecriture g4 4))
         (g (list *grille-axiome* g1 g2 g3 g4 g5))
         (l (apply #'append (mapcar #'virtual-boogie g))))
    (mapcar #'affiche g '(0 1 2 3 4 5))
    (list (fait-haut l) (fait-onset l) (fait-dur l) (fait-vel l))))

(defun affiche (g k) (format t "~%Etape ~a : " k) (write g))



(defun virtual-boogie (grille) (etat1 (regroupe grille)))

(defun etat1 (grille) 
  (if (null grille) () (etat2 (car grille) (cdr grille))))

(defun etat2 (mesure grille)
  (cond ((null grille) (list (arrange mesure)))
        ((double? mesure (car grille))
         (cons (arrange-double mesure) (etat1 (cdr grille))))
        (t (cons (arrange mesure) 
                 (etat2 (car grille) (cdr grille))))))

(defstruct mesure 
  (taille) (nbaccords) (degre) (degre2) (haut) (onset) (dur) (vel))

(defun regroupe (grille)
  (cond ((null grille) ())
        ((eq (car grille) '/) (regroupe (cdr grille)))
        (t (let ((mesure (decoupe grille)))
             (cons (creer-mesure mesure) 
                   (regroupe (nthcdr (length mesure) grille)))))))

(defun decoupe (grille)
  (if (or (null grille) (eq (car grille) '/)) () 
      (cons (car grille) (decoupe (cdr grille)))))

(defun creer-mesure (liste) 
  (make-mesure :taille 1 :nbaccords (length liste) 
               :degre (sans-marque (car liste))
               :degre2 (if (null (cdr liste)) ()
                           (sans-marque (cadr liste)))))

(defun arrange-double (m) (realise m 'double))
(defun arrange (m) (realise m (if (non-divisee? m) 'mesure 'demi)))

(defun non-divisee? (m)
  (or (= (mesure-nbaccords m) 1) 
      (eq (mesure-degre m) (mesure-degre2 m))))

(defun realise (m type)
  (let* ((d (mesure-degre m)) (d2 (mesure-degre2 m))
         (res (tirage-motif (list d d2 type))))
    (setf (mesure-haut m) (car res) (mesure-onset m) (cadr res)
          (mesure-dur m) (caddr res) (mesure-vel m) (cadddr res))
    (when (eq type 'double) (setf (mesure-taille m) 2))
    m))

(defun double? (m1 m2)
  (let ((a1 (mesure-degre m1)) (a2 (mesure-degre m2)))
    (and (eq a1 a2) (non-divisee? m1) (non-divisee? m2))))

(defun tirage-motif (clef)
  (cdr (assoc clef *table-arrangements* :test #'condition?)))

(defun condition? (clef triplet) 
  (let ((b1 (car triplet)) (b2 (cadr triplet)) 
        (type (caddr triplet))
        (d (car clef)) (d2 (cadr clef)))
    (and (or (null b1) (eq (registre-en-mi d) b1))
         (or (null d2) (null b2) (eq (registre-en-mi d2) b2))
         (eq (caddr clef) type))))

(defun registre-en-mi (deg) 
  (case deg ((v# vi viib vii i) 'b1) 
            ((i# ii iiib iii iv iv# v) 'b2)))

(defun fait-haut (liste-mes) 
  (apply #'append (mapcar #'transpose liste-mes)))

(defun transpose (m)
  (let* ((data (mesure-haut m))
         (d1 (mesure-degre m)) (new-d1 (car data))
         (notes (ajout (int new-d1 d1) (cadr data))))
    (if (null (cddr data)) notes
        (append notes (ajout (int (caddr data) (mesure-degre2 m)) 
                             (cadddr data))))))

(defun ajout (val liste) 
  (mapcar #'(lambda (x) 
              (if (atom x) (+ val x)
                  (mapcar #'(lambda (x) (+ val x)) x))) liste))

(defun int (deg1 deg2) 
  (let ((l '(v iv# iv iii iiib ii i# i vii viib vi v#)))
    (- (length (cdr (member deg2 l))) 
       (length (cdr (member deg1 l))))))

(defun fait-onset (liste-mes) (date liste-mes 11))

(defun date (liste-mes n)
  (cond ((null liste-mes) ())
        (t (let ((m (car liste-mes)))
             (append (ajout n (mesure-onset m))
                     (date (cdr liste-mes) 
                           (+ n (* (mesure-taille m) 12))))))))

(defun fait-dur (liste-mes) 
  (apply #'append (mapcar #'mesure-dur liste-mes)))

(defun fait-vel (liste-mes) 
  (apply #'append (mapcar #'dynamique liste-mes)))

(defun dynamique (m)
  (if (and (= (mesure-taille m) 2) (= (random 2) 0))
      (ajout -15 (mesure-vel m)) (mesure-vel m)))

(setq *table-arrangements* 
'(((b2 b2 demi)      ;;; large + large
(iv# ((68 34 56 62) 46 41 (56 68) 62 44 46) iv (33 (61 55 67) 45 
37)) (0 3 4 4 4 5 6 7 7 9 10) (3 1 1 2 1 1 1 2 1 1 2) (60 64 64 52 
52 56 60 69 50 57 67)) 
((b2 b1 demi)      ;;; large + serre
(iv# ((68 56 34 62) 46 38 (56 68 62) 50) vii (39 (56 68 61) 51 39)) 
(0 3 4 4 6 7 7 9 10) (3 1 2 2 1 2 3 1 2) (50 48 53 40 43 55 45 53 46)) 
((b1 b2 demi)      ;;; serre + large
(i (40 (68 56 62) 52 (68 56 62) 32 44) iv (33 (55 67 61) 45 37)) (0 
0 3 4 4 6 7 7 9 10) (3 3 1 2 2 1 2 3 1 2) (57 46 49 46 50 46 46 46 
51 52)) 
((b1 b1 demi)      ;;; serre + serre
(i ((69 62 57) 40 52 40 (68 56 62) 52) vii ((68 56 39 61) 51 (39 61 
55 67))) (0 0 3 4 4 6 7 9 10) (3 3 1 2 2 1 2 1 2) (60 51 55 60 55 55
51 53 59)) 
((b1 () mesure)    ;;; serre (aigu)
(vii ((39 56 68 61) 51 39 (68 56) 61 51 39 67 (61 55) 51 39)) (0 3 4 
4 4 6 7 7 7 9 10) (3 1 2 2 3 1 2 2 3 1 2) (51 41 56 45 45 44 44 44 
44 60 52)) 
((b2 () mesure)      ;;; large (grave)
(iv# ((34 68 56 63) 46 (34 63 68 56) 46 34 (56 68 62) 46 38)) (0 3 4 
6 7 7 9 10) (3 1 2 1 2 3 1 2) (50 45 44 44 49 49 55 43)) 
((() () double)      ;;; 2 mesures identiques
(i ((59 56 52) 28 40 33 (59 56 52) 40 35 (57 54) 62 40 33 35 (57 54 
62) 28 40 61 (52 57 33) 40 35 (59 52 56) 40 33)) (0 1 3 4 4 6 7 7 7 
9 10 12 12 13 15 16 16 18 19 19 21 22) (3 2 1 2 1 1 2 2 3 1 2 1 3 2 
1 3 2 1 2 2 1 2) (51 51 48 50 50 43 66 43 43 67 56 50 50 51 57 55 55 
54 58 40 72 64))))