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


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


(setq *grille-axiome* '((i) / (i) / (i) / (i 7) / (iv) / (iv) / (i) / (i) / (v) / (v 7) / (i) / (i)))

(defun substitue (k) (reecriture *grille-axiome* k))

(defun reecriture (grille k)
  (let* ((res (tirage-regle grille (mapcar #'car *grammaire*))) 
         (r (car res)) (grille1 (cadr res)))
    (if (or (= k 0) (null r)) grille 
        (reecriture grille1 (if (member r '(1-1 1-2)) k (- k 1))))))

(defun tirage-regle (grille liste-num)
  (if (null liste-num) (list () grille) 
      (let* ((r (nth (random (length liste-num)) liste-num)) 
             (grille1 (moteur grille r)))
        (if (eq grille1 'impossible) 
            (tirage-regle grille (delete r liste-num))
            (list r grille1)))))

(defun moteur (grille r)
  (let ((liste-pos (detecte grille r 1)))
    (if (null liste-pos) 'impossible
        (applique grille r (nth (random (length liste-pos)) 
                                liste-pos)))))

(defun detecte (grille r pos)
  (cond ((null grille) ())
        ((prefixe? (partie-gauche r) grille)
         (cons pos (detecte (cdr grille) r (+ pos 1))))
        (t (detecte (cdr grille) r (+ pos 1)))))

(defun applique (grille r pos)
  (cond ((null grille) 'erreur)
        ((= pos 1)
         (let* ((p1 (partie-gauche r))
                (valeur (fixe-variable p1 grille)))
           (append (actualise valeur (partie-droite r)) 
                   (nthcdr (length p1) grille))))
        (t (cons (car grille) 
                 (applique (cdr grille) r (- pos 1))))))

(defun creer-accord (note chiffre) 
  (cons note (if (null chiffre) () (list chiffre))))
(defun accord-degre (acc) (if (atom acc) () (car acc)))
(defun accord-chiffre (acc) 
  (if (or (atom acc) (null (cdr acc))) () (cadr acc)))
(defun sans-marque (acc) (ote-marque (accord-degre acc)))
(defun ote-marque (deg) (if (atom deg) deg (car deg)))
(defun marque? (acc) 
  (let ((n (accord-degre acc))) (and (listp n) (eq (cadr n) '*))))

(defun prefixe? (p1 grille)
  (compare (actualise (fixe-variable p1 grille) p1) grille ()))

(defun compare (p1 grille res)
  (cond ((null p1) (reverse res))
        ((or (null grille) 
             (not (correct? (car p1) (car grille)))) ())
        (t (compare (cdr p1) (cdr grille) (cons (car grille) res)))))

(defun correct? (acc1 acc2)
  (or (identique? acc1 acc2) 
      (and (eq acc1 'w) (not (eq acc2 '/)) (not (marque? acc2)))))

(defun identique? (acc1 acc2)
  (or (equal acc1 acc2)
      (and (listp acc1) (listp acc2)
           (eq (accord-chiffre acc1) (accord-chiffre acc2))
           (eq (sans-marque acc1) (sans-marque acc2)))))

(defun fixe-variable (p1 grille)
  (cond ((null p1) ())
        ((or (equal (car p1) '/) 
             (equal (car grille) '/) 
             (not (equal (accord-degre (car p1)) 'x))) 
         (fixe-variable (cdr p1) (cdr grille)))
        (t (accord-degre (car grille)))))

(setq x ())

(defun actualise (valeur p)
  (setf x valeur)
  (mapcar #'(lambda (acc) 
              (let ((n (accord-degre acc)))
                (if (and (listp acc) (or (listp n) (eq n 'x)))
                    (creer-accord (eval n) (accord-chiffre acc))
                    acc)))
          p))

(defun fonction (d int) 
  (let ((l '(i i# ii iiib iii iv iv# v v# vi viib vii))) 
    (list (nth int (member d (append l l))) '*)))

(defun D (d) (fonction (ote-marque d) 7))
(defun Stb (d) (fonction (ote-marque d) 1))

(setq *grammaire*
'((1-1 (/ (x) /) (/ (x) (x) /))
(1-2 (/ (x 7) /) (/ (x) (x 7) /))

(3a-1 (w (x 7)) (((D x) 7) (x 7)))

(4-1 (((D x) 7) (x 7)) (((Stb x) 7) (x 7)))
(4-2 (((D x) 7) (x)) (((Stb x)) (x)))

(3a-11 (w / (x 7)) (((D x) 7) / (x 7)))

(4-11 (((D x) 7) / (x 7)) (((Stb x) 7) / (x 7)))
(4-21 (((D x) 7) / (x)) (((Stb x)) / (x)))
))

(defun partie-gauche (r) (cadr (assoc r *grammaire*)))
(defun partie-droite (r) (caddr (assoc r *grammaire*)))