#lang scheme/base
(require (lib "etc.ss")
         (lib "list.ss"))
(provide (all-defined-out))

;; composition = (make-composition tempo (listof trackdata))
(define-struct composition (tempo tracks))
;; tempo = (make-ticks-per-beat nat[0-65535])
;;       | (make-fps nat[24,25,29, or 30] nat[0-511])
(define-struct ticks-per-beat (n))
(define-struct fps (frames ticks))

;; trackdata = (listof timed-event)
;; timed-event = (make-tevt delta event)
;; delta = nat
;; event = (make-evt ...) | (make-metaevent ...)

(define-struct tevt (time e)) 
(define-struct event (type id channel param1 param2))
(define-struct metaevent (type id data))

(define-syntax define-event-types
  (syntax-rules ()
    [(define-event-types
       (table-entry ...) ...)
     (begin
       (define-event-type table-entry ...) ...)]))

(define-syntax define-event-type
  (syntax-rules ()
    [(define-event-type name byte-pattern p1)
     (define (name channel p1) (make-event 'name byte-pattern channel p1 0))]
    [(define-event-type name byte-pattern p1 p2)
     (define (name channel p1 p2) (make-event 'name byte-pattern channel p1 p2))]))

(define-syntax define-metaevent-types
  (syntax-rules ()
    [(define-metaevent-types
       (table-entry ...) ...)
     (begin 
       (define-metaevent-type table-entry ...) ...)]))

(define-syntax define-metaevent-type
  (syntax-rules ()
    [(define-metaevent-type name byte-pattern)
     (define (name contents)
       (make-metaevent 'name 
                       byte-pattern
                       (cond
                         [(bytes? contents)
                          contents]
                         [(byte? contents)
                          (bytes contents)]
                         [else (error 'name)])))]))
       
       
(define-event-types
  (note-off            #x8 note-number velocity)
  (note-on             #x9 note-number velocity)
  (note-aftertouch     #xA note-number aftertouch-value)
  (controller          #xB controller-number controller-value)
  (program-change      #xC program-number)
  (channel-aftertouch  #xD aftertouch-value)
  (pitch-bend          #xE LSB MSB))

(define-metaevent-types
  (text                #x01)
  (copyright-notice    #x02)
  (sequence-name       #x03)
  (instrument-name     #x04)
  (lyrics              #x05)
  (marker              #x06)
  (cue-point           #x07)
  (midi-channel-prefix #x20)
  (end-of-track        #x2F)
  (set-tempo           #x51))

(define END-OF-TRACK (end-of-track #""))

(define (int->vbr n)
  
  (define (cvt n the-rest mask)
    (let ([lsb  (bitwise-and n #b01111111)] ;  get the 7 least-significant bits ...
          [rest (arithmetic-shift n -7)])  ;  ... and the leftover bits
      (if (= rest 0)
          (apply bytes (bitwise-ior mask lsb) the-rest)
          (cvt
           rest
           (cons (bitwise-ior lsb mask) the-rest)
           #b10000000))))
  
  (cvt n '() #b00000000))

(define (event->bytes evt)
  (bytes
   (+ (arithmetic-shift (event-id evt) 4) (event-channel evt))
   (event-param1 evt)
   (event-param2 evt)))

(define (metaevent->bytes evt)
  (let ([length-bytes (int->vbr (bytes-length (metaevent-data evt)))])
    (bytes-append
     (bytes #xFF (metaevent-id evt))
     length-bytes
     (metaevent-data evt))))
    
(define (tevt->bytes tevt)
  (bytes-append 
   (int->vbr (tevt-time tevt))
   (cond
     [(event? (tevt-e tevt))
      (event->bytes (tevt-e tevt))]
     [(metaevent? (tevt-e tevt))
      (metaevent->bytes (tevt-e tevt))])))

(define (int->2bytes n)
  (integer->integer-bytes n 2 #f #t))
(define (int->4bytes n)
  (integer->integer-bytes n 4 #f #t))

(define (track-data->chunk td)
  (let ([the-data (apply bytes-append (map tevt->bytes td))])
    (bytes-append
     #"MTrk"
     (int->4bytes (bytes-length the-data))
     the-data)))

(define (composition->midi comp)
  (apply bytes-append
   #"MThd"
   (int->4bytes 6)
   (int->2bytes 1)
   (int->2bytes (add1 (length (composition-tracks comp))))
   (tempo->bytes (composition-tempo comp))
   (map track-data->chunk (composition-tracks comp))))

(define (tempo->bytes t)
  (cond
    [(ticks-per-beat? t)
     (int->2bytes (ticks-per-beat-n t)) 
     ; automatically has the right mask due to range restriction
     ]
    [else
     (bytes
      (bitwise-ior #b10000000
                   (fps-frames t))
      (fps-ticks t))]))

;; ============================================================

;; pitch ::= (make-pitch pitch-class octave)
;; pitch-class ::= Cf | C | Cs | Df | D | Ds | Ef | E | Es | Ff | F | Fs
;;               | Gf | G | Gs | Af | A | As | Bf | B | Bs
;; octave ::= int ∈ [0,8]
(define-struct pitch (class octave))

(define pitches
  '((Cf -1)
    (C   0)
    (Cs  1)
    (Df  1)
    (D   2)
    (Ds  3)
    (Ef  3)
    (E   4)
    (Es  5)
    (Ff  4)
    (F   5)
    (Fs  6)
    (Gf  6)
    (G   7)
    (Gs  8)
    (Af  8)
    (A   9)
    (As 10)
    (Bf 10)
    (B  11)
    (Bs 12)))


;; music ::= (make-note pitch duration)
;;         | (make-rst duration)
;;         | (seq (listof music))
;;         | (par (listof music))

(define-struct note (pitch duration) #:transparent)
(define-struct rst (duration) #:transparent)
(define-struct seq (elts) #:transparent)
(define-struct par (elts) #:transparent)


;; score ::= (listof score-elt)
;; score-elt ::= (make-start beat note) | (make-stop beat note)
;; INVARIANT: score-elts are sorted by beat
(define-struct score-elt (beat note) #:transparent)
(define-struct (start score-elt) () #:transparent)
(define-struct (stop score-elt) () #:transparent)

;; music -> (values score duration)
(define (music->score m)
  (define (m->s m beat)
    (cond
      [(note? m)
       (values (list (make-start beat m)
                     (make-stop (+ beat (note-duration m)) m)) 
               (+ beat (note-duration m)))]
      [(rst? m)
       (values '()
               (+ beat (rst-duration m)))]
      [(seq? m)
       (let loop ([ms (seq-elts m)]
                  [score '()]
                  [beat beat])
         (cond
           [(null? ms)
            (values (apply append (reverse score)) beat)]
           [else
            (let*-values ([(f) (car ms)]
                          [(s d) (m->s f beat)])
              (loop (cdr ms) (cons s score) d))]))]
      [(par? m)
       (let loop ([ms (par-elts m)]
                  [score '()]
                  [durs '(0)])
         (cond
           [(null? ms)
            (values (merge-scores (reverse score))
                    (apply max durs))]
           [else
            (let*-values ([(f) (car ms)]
                          [(s d) (m->s f beat)])
              (loop (cdr ms) (cons s score) (cons d durs)))]))]))
  (let-values ([(s d) (m->s m 0)])
    s))

(define (merge-scores scores)
  (define (m2 s1 s2)
    (cond
      [(null? s1) s2]
      [(null? s2) s1]
      [(< (score-elt-beat (car s1)) (score-elt-beat (car s2)))
       (cons (car s1) (m2 (cdr s1) s2))]
      [else
       (cons (car s2) (m2 s1 (cdr s2)))]))
  
  (foldl m2 '() scores))

;; score -> trackdata
(define (score->trackdata s)
  (define (s->t s most-recent-beat)
    (cond
      [(null? s) 
       (list (make-tevt 0 END-OF-TRACK))]
      [else
       (let ([n (car s)])
         (cons (make-tevt 
                (- (score-elt-beat n) most-recent-beat)
                ((if (start? n)
                     note-on
                     note-off)
                 1
                 (pitch->notenumber (note-pitch (score-elt-note n)))
                 64))
               (s->t (cdr s) (score-elt-beat n))))]))
  (s->t s 0))

(define (pitch->notenumber p)
  (+ (* 12 (pitch-octave p))
     (cadr (assq (pitch-class p) pitches))))

(define (music->midi m filename)
  (with-output-to-file filename
    (λ ()
      (write-bytes
       (composition->midi
        (make-composition
         (make-ticks-per-beat 1)
         (list (score->trackdata (music->score m)))))))
    #:exists 'truncate))
                                
(define (Gmaj dur)
  (make-par 
   (list (make-note (make-pitch 'G 3) dur)
         (make-note (make-pitch 'C 4) dur)
         (make-note (make-pitch 'D 4) dur))))

(define (Cmaj dur)
  (make-par
   (list (make-note (make-pitch 'C 3) dur)
         (make-note (make-pitch 'E 3) dur)
         (make-note (make-pitch 'G 3) dur))))

(define (Dmaj dur)
  (make-par
   (list (make-note (make-pitch 'D 3) dur)
         (make-note (make-pitch 'A 3) dur)
         (make-note (make-pitch 'Fs 3) dur))))

(define (Dmaj2 dur)
  (make-par
   (list (make-note (make-pitch 'D 3) dur)
         (make-note (make-pitch 'A 3) dur)
         (make-note (make-pitch 'Fs 2) dur))))