;;; ================================ 
;;; Ecriremidifile.drs / 23 mai 2002 
;;; ================================

;;; EXEMPLE: 
;;; (ecrire-midifile '(4 4) 120 '((60 96) (62 96) (64 192)) "essai.mid")

(define (ecrire-midifile signature tempo liste-couples fich)
  (sauve-midifile (conversion-midifile signature tempo liste-couples) fich))

(define (sauve-midifile liste-octets fich)
  (when (file-exists? fich) (delete-file fich)
    (let ((p (open-output-file fich)))
      (ecrire-liste liste-octets p)
      (close-output-port p))))

(define (ecrire-liste liste-octets port)
  (cond ((null? liste-octets) 'stop)
        (else (write-char (integer->char (car liste-octets)) port)
           (ecrire-liste (cdr liste-octets) port))))


;;; Conversion d'un Midifile: 
;;; ------------------------- 
;;; EXEMPLE: (conversion-midifile '(4 4) 120 '((60 96) (62 96) (64 192))) 
;;;          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 #x00 #x00 #x01 #x00 #xC0  ;;; format=0, 1 track, division=192 
;;;  #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  #x00  ;;; mi3 
;;;  #x00 #xFF #x2F #x00)                           ;;; end of track

(define (conversion-midifile signature tempo liste-couples)
  (append (creer-header-chunk 0 1 192) (creer-track-chunk signature tempo liste-couples)))

(define (creer-header-chunk format nbre-tracks division)
  (append (map char->integer (list #\M #\T #\h #\d))
          (list #x00 #x00 #x00 #x06)    ;;; longueur = 6 octets
          (list #x00 format)    ;;; format 0
          (list #x00 nbre-tracks)    ;;; nbre de track chunks = 1
          (list #x00 division)))  ;;; "division" (nbre de "ticks"/pulsation) = 192

;;; Ascii: (char->integer #\a) -> 97, (integer->char 97) -> #\a


(define (creer-track-chunk signature tempo liste-couples)
  (append (map char->integer (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

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

(define (calcul-signature couple) 
  (list #x00 #xFF #x58 #x04 (car couple) (inexact->exact (truncate (/ (log (cadr couple)) (log 2)))) #x18 #x08))

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

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

(define (calcul-liste-notes liste-couples)
  (if (null? liste-couples) ()
      (append (calcul-note (car liste-couples))
              (calcul-liste-notes (cdr liste-couples)))))

(define (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 1 ou 2 octets de 7 bits 
;;; (0 en tete s'il y en a un, 1 et 0 en tete s'il y a en a deux) 
;;; EXEMPLE: 159 ticks = 128+16+8+4+2+1 
;;; donne (1)000 0001  (0)001 1111 = #x81 #x1F 
;;; La valeur max avec deux octets = 16383 ticks = 85 noires (div de 192) 

(define (calcul-deltatime duree)
  (let* ((new-octet (logand duree #x7F))
         (liste-octets (list new-octet)))
    (do ((d (quotient duree #x80) (quotient d #x80)))
        ((= d 0) liste-octets)
      (set! new-octet (logand d #x7F))   ;;; 7 derniers bits
      (set! liste-octets (cons (logior #x80 new-octet) liste-octets)))))

(define (logand n1 n2)
  (cond ((or (= n1 0) (= n2 0)) 0)
        (else (+ (* (remainder n1 2) (remainder n2 2))
                 (* 2 (logand (quotient n1 2) (quotient n2 2)))))))

(define (logior n1 n2)
  (cond ((and (= n1 0) (= n2 0)) 0)
        (else (+ (min (+ (remainder n1 2) (remainder n2 2)) 1)
                 (* 2 (logior (quotient n1 2) (quotient n2 2)))))))

;;; Longueur du track chunk sur 4 octets:

(define (calcul-longueur n)
  (list (logand (quotient n #x1000000) #xFF)
        (logand (quotient n #x10000) #xFF)
        (logand (quotient n #x100) #xFF)
        (logand n #xFF)))