(proclaim '(optimize (speed 3 safety 0)))
(defparameter *WARN-ON-FLOATING-POINT-CONTAGION* nil)

(defun write-wave (sample-rate samples)
  (declare (type (simple-array float (*)) samples))
  (with-open-file (s "c:/tmp/test.wav"
                     :direction :output
                     :if-exists :supersede
                     :element-type '(unsigned-byte 8))
    (flet ((write-uint-16 (uint-16)
             (write-byte (ldb (byte 8 0) uint-16) s)
             (write-byte (ldb (byte 8 8) uint-16) s))
           (write-uint-32 (uint-32)
             (write-byte (ldb (byte 8 0) uint-32) s)
             (write-byte (ldb (byte 8 8) uint-32) s)
             (write-byte (ldb (byte 8 16) uint-32) s)
             (write-byte (ldb (byte 8 24) uint-32) s)))
      (write-uint-32 #x46464952)
      (write-uint-32 (+ (* 2 (length samples)) 36))
      (write-uint-32 #x45564157)
      (write-uint-32 #x20746d66)
      (write-uint-32 16)
      (write-uint-16 1)
      (write-uint-16 1)
      (write-uint-32 (round sample-rate))
      (write-uint-32 (round (* 2.0 sample-rate)))
      (write-uint-16 2)
      (write-uint-16 16)
      (write-uint-32 #x61746164)
      (write-uint-32 (* 2 (length samples)))
      (map nil (lambda (elt)
                 (declare (float elt) (inline write-unit-16))
                 (write-uint-16 (round (* 32767 elt))))
           samples))))

(defun mix (target-samples source-samples start sample-rate)
  (declare (type (simple-array float (*)) target-samples source-samples)
           (float start sample-rate))
  (let ((ofs (round (* sample-rate start))))
    (dotimes (i (length source-samples))
      (incf (aref target-samples (+ ofs i))
            (aref source-samples i)))))

(defun normalize (samples)
  (declare (type (simple-array float (*)) samples))
  (let ((max-sample 0.0s0)
        (min-sample 0.0s0))
    (declare (float max-sample min-sample))
    (dotimes (i (length samples))
      (let ((sample (aref samples i)))
        (declare (float sample))
        (when (< sample min-sample) (setf min-sample sample))
        (when (> sample max-sample) (setf max-sample sample))))
    (setf max-sample (max (- min-sample) max-sample))
    (dotimes (i (length samples))
      (setf (aref samples i) (/ (aref samples i) max-sample)))))

(defun make-samples-array (sample-rate seconds &optional function)
  (declare (float sample-rate seconds))
  (let* ((sample-count (round (* sample-rate seconds)))
         (samples (make-array sample-count
                              :element-type 'float
                              :initial-element 0.0s0)))
    (when function
      (dotimes (i sample-count)
        (setf (aref samples i)
              (funcall function (float (* (/ seconds sample-count) 
                                          (float i)))))))
    samples))

(defun make-adsr-function (sustain-time
                           attack-time
                           decay-time
                           sustain-factor
                           release-time)
  (declare (float time sustain-time
                  attack-time decay-time sustain-factor release-time))
  (lambda (time)
    (cond ((< time 0.0s0) 0.0s0)
          ((<= time attack-time) (/ time attack-time))
          (t
           (let* ((t1 attack-time)
                  (t2 (+ t1 decay-time))
                  (t3 (+ t2 sustain-time))
                  (t4 (+ t3 release-time)))
             (declare (float t2 t3 t4))
             (cond ((<= time t2) (+ 1.0s0
                                    (* (/ (- 1.0s0 sustain-factor) decay-time)
                                       (- t1 time))))
                   ((<= time t3) sustain-factor)
                   ((<= time t4) (+ sustain-factor
                                    (* (/ sustain-factor release-time)
                                       (- t3 time))))
                   (t 0.0s0)))))))

(defun make-wave-function (freq duration)
  (declare (float time freq))
  (let ((adsr (make-adsr-function duration 0.03 0.3 0.4 0.2)))
    (lambda (time) 
      (let* ((waves (* freq time))
             (interval (- waves (truncate waves)))
             (trunced-triangle (if (< 0.5 interval) 
                                   interval 
                                 (- 1 interval))))
        (when (> trunced-triangle 0.8) (setf trunced-triangle 0.8))
        (float (* (funcall adsr time) trunced-triangle))))))

(defun make-tone (sample-rate freq duration)
  (declare (float sample-rate freq))
  (make-samples-array sample-rate 2.0 (make-wave-function freq duration)))

(defun music (beats-per-minute notes)
  (let* ((scale (float (/ 240 beats-per-minute)))
         (seconds (float (+ 2 (* scale 
                                 (reduce #'+ 
                                         (mapcar #'(lambda (x) (/ (cadr x))) 
                                                 notes))))))
         (note-exp (expt 2 (/ 1 12)))
         (note-base 220)
         (sample-rate 22050.0s0)
         (samples (make-samples-array sample-rate seconds))
         (offset 0)
         (tones (make-hash-table :test 'equal)))
    (dolist (note notes)
      (let* ((pitch (car note))
             (duration (* scale (/ (cadr note))))
             (freq (float (* note-base (expt note-exp pitch))))
             (tone (gethash note tones)))
        (unless tone
          (setf tone (setf (gethash note tones) 
                           (make-tone sample-rate 
                                      (float freq) 
                                      (float duration)))))
        (mix samples tone (float offset) (float sample-rate))
        (incf offset duration)))
    (normalize samples)
    (write-wave sample-rate samples)))

(defun test ()
  (let ((notes '((19 8)
                 (18 8)
                 (19 8)
                 (18 8)
                 (19 8)
                 (14 8)
                 (17 8)
                 (15 8)
                 (12 4)
                 (3 8)
                 (7 8)
                 (12 8)
                 (14 4)
                 (7 8)
                 (11 8)
                 (14 8)
                 (15 4)
                 (7 8)
                 (19 8)
                 (18 8)
                 (19 8)
                 (18 8)
                 (19 8)
                 (14 8)
                 (17 8)
                 (15 8)
                 (12 4)
                 (3 8)
                 (7 8)
                 (12 8)
                 (14 4)
                 (7 8)
                 (15 8)
                 (14 8)
                 (12 4))))
    (music 130 notes)))