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

(defun ecrire-midifile (signature tempo liste-couples fich)
  (sauve-midifile (conversion-midifile signature tempo liste-couples) 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")))

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



;;; Conversion d'un Midifile: 
;;; ------------------------- 
;;; EXEMPLE: signature = (4 4)  ;;; 4/4 
;;;          tempo = 120     ;;; nbre de noires/60 secondes 
;;;          liste-couples ( ) = ((60 96) (62 96) (64 192)))    
;;; -> do3 "noire" 96 ticks, re3 "noire" 96 ticks, mi3 "blanche" 192 ticks 
;;; 1 "tick" = "division" de la pulsation (donnee par le header)        
;;; donne: 
;;; (#x4D #x54 #x68 #x64            ;;; M T h d 
;;;  #x00 #x00 #x00 #x06            ;;; longueur = 6 octets 
;;;  #x00 #x01 #x00 #x04 #x00 #x60  ;;; format=1, 4 tracks, division=96 
;;;  #x4D #x54 #x72 #x6B                         ;;; M T r k 
;;;  #x00 #x00 #x00 #x2C                         ;;; longueur 
;;;  #x00 #xFF #x58 #x04 #x04 #x02 #x18 #x08     ;;; signature 
;;;  #x00 #xFF #x51 #x03 #x07 #xA1 #x20          ;;; tempo 
;;;  #x00 #x90 #x3C #x3C #x60 #x80 #x3C #x00     ;;; do3 
;;;  #x00 #x90 #x3E #x3C #x60 #x80 #x3E #x00     ;;; re3 
;;;  #x00 #x90 #x40 #x3C #x81 #x40 #x80 #x40     ;;; mi3 
;;;  #x00 #x00 #xFF #x2F #x00)                   ;;; end of track

(defun conversion-midifile (signature tempo liste-couples)
  (append (creer-header-chunk 1 4 96) (creer-track-chunk signature tempo liste-couples)))

(defun creer-header-chunk (format nbre-tracks division)
  (append (mapcar #'char-code (list #\M #\T #\h #\d))
          (list #x00 #x00 #x00 #x06)    ;;; longueur = 6 octets
          (list #x00 format)    ;;; format 1
          (list #x00 nbre-tracks)    ;;; nbre de track chunks = 4
          (list #x00 division)))  ;;; "division" (nbre de "ticks"/pulsation) = 96


(defun creer-track-chunk (signature tempo liste-couples)
  (append (mapcar #'char-code (list #\M #\T #\r #\k))
          (let ((liste-octets (calcul-octets signature tempo liste-couples)))
            (append (calcul-longueur (+ (length liste-octets) 4)) 
                    liste-octets
                    (list #x00 #xFF #x2F #x00)))))   ;;; end of track

(defun calcul-octets (signature tempo liste-couples)
  (append (calcul-signature signature) (calcul-tempo tempo) (calcul-liste-notes liste-couples)))

;;; Meta-evenement signature FF 58: a l'instant 0, par defaut 4/4

(defun calcul-signature (couple) 
  (list #x00 #xFF #x58 #x04 (car couple) (round (log (cadr couple) 2)) #x18 #x08))

;;; Meta-evenement tempo FF 51: a l'instant 0, duree noire en microsecondes sur 3 octets

(defun calcul-tempo (tempo)
  (let ((n (/ (* 60 1000000) tempo)))
    (list #x00 #xFF #x51 #x03 
          (logand (floor n #x10000) #xFF)
          (logand (floor n #x100) #xFF)
          (logand n #xFF))))

(defun calcul-liste-notes (liste-couples)
  (if (null liste-couples) ()
      (append (calcul-note (car liste-couples))
              (calcul-liste-notes (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

;;; Deltatime a longueur variable, sur octets de 7 bits avec 1 en tete 
;;; sauf le dernier octet (0 en tete) 
;;; EXEMPLE: 159 ticks = 128+16+8+4+2+1 
;;; donne (1)000 0001  (0)001 1111 = #x81 #x1F

(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)))))

;;; Longueur du track chunk sur 4 octets:

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