;;; =================================== 
;;; Liremidifile.lisp / 26 octobre 1998 
;;; ===================================

;;; GRAMMAIRE REGULIERE: 
;;; ==================== 
;;; header chunk = 14 octets 
;;; track chunk = entete ( deltatime evenement )* 
;;; entete = 8 octets 
;;; deltatime = ( octet1 )* octet0 
;;; evenement = note ou meta-evenement 
;;; note = #x90 ou #x80 + 2 octets 
;;; meta-evenement =  signature ou tempo ou end-of-track 
;;; signature = #xFF #x58 + 4 octets 
;;; tempo = #xFF #x51 + 3 octets 
;;; end-of-track = #xFF #x2F + 1 octet 

;;; EXEMPLE: 
;;; ((4D 54 68 64 0 0 0 6 0 1 0 4 0 60) ;;; M T h d + entete 
;;;  (4D 54 72 6B 0 0 0 2C)             ;;; M T r k + entete 
;;;  (0 FF 58 4 4 2 18 8)               ;;; signature 
;;;  (0 FF 51 3 7 A1 20)                ;;; tempo 
;;;  (0 90 3C 3C) (60 80 3C 0)          ;;; do3 
;;;  (0 90 3E 3C) (60 80 3E 0)          ;;; re3 
;;;  (0 90 40 3C) (81 40 80 40 0)       ;;; mi3 
;;;  (0 FF 2F 0)) Midifile accepté

;;; Chaque fonction de lecture ramene 
;;;    un booleen nil si fin de fichier et t sinon, 
;;;    une liste d'octets lus par la fonction


(setq resultat " Midifile accepté")

(defun lecture-midifile (fich)
  (setq resultat " Midifile non reconnu")
  (with-open-file (flot fich :direction :input)
    (let* ((res1 (lecture-header-chunk flot))
           (bool (car res1)))
      (when bool 
        (let ((res2 (lecture-track-chunk flot)))
          (write (cons (cadr res1) (cadr res2)) :base 16)
          (format t resultat))))))

(defun lecture-header-chunk (flot) (lire-n-octets 14 flot))

(defun lecture-track-chunk (flot)
  (let* ((res1 (lecture-entete-track-chunk flot))
         (bool (car res1))
         (res-notes ()))
    (until (not bool)
      (let ((res2* (lecture-evenement-track-chunk flot)))
        (setq bool (car res2*))
        (when bool (push (cadr res2*) res-notes))))
    (list bool (cons (cadr res1) (reverse res-notes)))))

(defun lecture-entete-track-chunk (flot) (lire-n-octets 8 flot))

(defun lecture-evenement-track-chunk (flot)
  (let* ((res1 (lecture-deltatime flot))
         (bool (car res1)))
    (when bool
          (let ((res2 (lecture-evenement flot)))
            (setq bool (car res2))
            (list bool (append (cadr res1) (cadr res2)))))))
  
(defun lecture-deltatime (flot)
  (let* ((octet (read-octet flot ()))
         (res (list octet)))
    (when (not octet) (setq resultat " Midifile accepté"))   ;;; ETAT TERMINAL
    (until (or (not octet) (< octet #x80))
      (setq octet (read-octet flot ()))
      (push octet res))
    (list octet (reverse res))))

(defun lecture-evenement (flot)
  (let ((statut (read-octet flot ())))
    (cond ((= statut #xFF) (lecture-meta-evenement flot))
          ((or (= statut #x90) (= statut #x80)) (lecture-note statut flot)))))

(defun lecture-note (statut flot)
  (let ((res (lire-n-octets 2 flot)))
    (list (car res) (cons statut (cadr res)))))

(defun lecture-meta-evenement (flot)
  (let ((type (read-octet flot ())))
    (case type
      (#x58 (let ((res (lire-n-octets 5 flot)))  ;;; signature
              (list (car res) (append (list #xFF #x58) (cadr res)))))
      (#x51 (let ((res (lire-n-octets 4 flot)))  ;;; tempo
              (list (car res) (append (list #xFF #x51) (cadr res)))))
      (#x2F (let ((res (lire-n-octets 1 flot)))  ;;; end-of-track
              (list (car res) (append (list #xFF #x2F) (cadr res))))))))

;;; Lecture des n premiers octets dans le flot:

(defun lire-n-octets (n flot)
  (let* ((octet (read-octet flot ()))
         (res (list octet)))
    (do ((i n (- i 1)))
        ((or (= i 1) (not octet)) (list octet (reverse res)))
     (setq octet (read-octet flot ()))
     (push octet res))))

;;; Ascii: (char-code #\a) = 97, (code-char 97) = #\a

(defun read-octet (flot bool) 
  (let ((x (read-char flot bool)))
    (if (not x) x (char-code x))))