SE701:April 11

;;; File:    music.lisp
;;; Author:  John Hamer
;;; Date:    11 April 2008
;;; Purpose: Illustrate Common Lisp generic functions and classes

(defclass music () ())

(defgeneric duration (music))

;; A single note
(defclass note (music)
  ((key     :initarg :key
	     :initform (error "Must specify the note key")
	     :reader note-key)
   (duration :initarg :duration
	     :initform (error "Must specify the note duration")
	     :reader duration)))


;; Silence
(defclass music-rest (music)
  ((duration :initarg :duration :initform 0 :reader duration)))



;; Sequential and parallel composition   
(defclass music-composite (music)
  ((terms :initarg :terms :reader music-terms)))

(defclass par (music-composite) ())
(defclass seq (music-composite) ())

(defmethod duration ((m seq))
  (reduce #'+ (music-terms m) :key #'duration))
(defmethod duration ((m par))
  (reduce #'max (music-terms m) :key #'duration))

(defun seq (&rest terms)
  (make-instance 'seq :terms (collect-all-terms terms)))
(defun par (&rest terms)
  (make-instance 'par :terms (collect-all-terms terms)))

(defgeneric collect-terms (terms result))

(defmethod collect-terms ((terms list) result)
  (mapcar #'(lambda (term) (collect-terms term result)) terms))
(defmethod collect-terms ((terms vector) result)
  (loop for term across terms
     do (collect-terms term result)))
(defmethod collect-terms ((term t) result)
  (vector-push-extend term result))

(defun collect-all-terms (terms)
  (let ((result (make-array 5 :fill-pointer 0 :adjustable t)))
    (collect-terms terms result)
    result))


;;; Musical decorators

(defclass music-decorator (music)
  ((term :initarg :term
	 :initform (error "Must specify the music term")
	 :reader music-term)))

(defmethod duration ((m music-decorator))
  (duration (music-term m)))



;; Tempo
(defclass music-tempo (music-decorator)
  ((tempo :initarg :tempo :reader music-tempo)))

(defmethod duration ((m music-tempo))
  (* (duration (music-term m)) (music-tempo m)))

(defun change-tempo (m r)
  (make-instance 'music-tempo :term m :tempo r))


;; Transpose
(defclass music-transpose (music-decorator)
  ((transpose :initarg :transpose :reader music-transpose)))

(defun transpose (m d)
  (make-instance 'music-transpose :term m :transpose d))




;; Instrument
(defclass music-instrument (music-decorator)
  ((instrument :initarg :instrument :reader instrument)))

(defun use-instrument (m i)
  (make-instance 'instr :term m :instrument i))


;; Phrase
(defclass music-phrase (music-decorator)
  ((phrase :initarg :phrase :reader music-phrase)))

(defun phrasing (m p)
  (make-instance 'phrase :term m :phrase p))



;;; Musical performance

(defparameter *current-time* 0)
(defparameter *current-tempo* 1)
(defparameter *current-transpose* 0)
(defparameter *current-instrument* "piano")
(defparameter *current-volume* 100)

(defclass Event ()
  ((time    :initarg :time :reader event-time)
   (key     :initarg :key)
   (length  :initarg :length)
   (instr   :initarg :instr)
   (volume  :initarg :volume)))

(defmethod print-object ((e Event) stream)
  (with-slots (time key length instr volume) e
    (format stream "#[Event :time ~a :key ~a :length ~a :instr ~a :volume ~a]"
            time key length instr volume)))

(defun mkEvent (time k l i v)
  (make-instance 'Event :time time :key k :length l :instr i :volume v))



(defun do-perform (music)
  (let ((events (make-array 0 :adjustable t :fill-pointer t)))
    (perform music 0 events)
    (sort events #< :key #'event-time)
    events))

(defgeneric perform (music time events))

(defmethod perform ((m note) time events)
  (with-slots (key duration) m
    (vector-push-extend (mkEvent time
				 (+ key *current-transpose*)
				 (* duration *current-tempo*)
				 *current-instrument*
				 *current-volume*)
			events)
    duration))

(defmethod perform ((m music-rest) time events)
  (duration m))

(defmethod perform ((m seq) time events)
  (let ((dur 0))
    (loop for mt across (music-terms m)
       do (incf dur (perform mt (+ time dur) events)))
    dur))

(defmethod perform ((m par) time events)
  (let ((dur 0))
    (loop for e across (music-terms m)
       do (setf dur (max dur (perform e time events))))
    dur))

(defmethod perform ((m music-tempo) time events)
  (let ((*current-tempo* (* *current-tempo* (music-tempo m))))
    (perform (music-term m) time events)))
  
(defmethod perform ((m music-instrument) time events)
  (let ((*current-instrument* (instrument m)))
    (perform (music-term m) time events)))
  

;;; Retro
(defgeneric retro (music)
  (:documentation "MUSIC played backwards"))

(defmethod retro ((m music))
  m)
(defmethod retro ((p par))
  (par (mapcar #'retro (music-terms p))))
(defmethod retro ((s seq))
  (seq (nreverse (mapcar #'retro (music-terms s)))))
(defmethod retro ((m music-tempo))
  (change-tempo (retro (music-term m)) (music-tempo m)))
(defmethod retro ((m music-transpose))
  (transpose (retro (music-term m)) (music-transpose m)))
(defmethod retro ((m music-instrument))
  (use-instrument (retro (music-term m)) (instrument m)))
(defmethod retro ((m music-phrase))
  (phrasing (retro (music-term m)) (music-phrase m)))


;;; Reading and writing

;; Print using initialize-instance syntax: "#[type init-args]"

(defun read-music-object (stream char n)
  (declare (ignore char n))
  (apply #'make-instance (read stream t) (read-delimited-list #\] stream t)))

(set-syntax-from-char #\] #\))
(set-dispatch-macro-character #\# #\[ #'read-music-object)


(defmethod print-object ((obj note) stream)
  (with-slots (key duration) obj
    (format stream "#[note :key ~a :duration ~a]" key duration)))

(defmethod print-object ((obj music-rest) stream)
  (with-slots (duration) obj
    (format stream "#[music-rest :duration ~a]" duration)))

(defmethod print-object ((obj music-composite) stream)
  (with-slots (terms) obj
    (format stream "#[~a :terms ~a]" (type-of obj) terms)))


(defgeneric print-decoration (music-decorator stream))

(defmethod print-object ((obj music-decorator) stream)
  (format stream "#[~a :term ~a " (type-of obj) (music-term obj))
  (print-decoration obj stream)
  (format stream "]"))


(defmethod print-decoration ((obj music-tempo) stream)
  (format stream ":tempo ~a" (music-tempo obj)))
(defmethod print-decoration ((obj music-transpose) stream)
  (format stream ":transpose ~a" (music-transpose obj)))
(defmethod print-decoration ((obj music-instrument) stream)
  (format stream ":instr ~a" (instrument obj)))
(defmethod print-decoration ((obj music-phrase) stream)
  (format stream ":phrase ~a" (music-phrase obj)))


(defun key-code (name)
  (ccase name
    (:A 0)
    ((:As :Bf) 1)
    (:B 2)
    (:C 3)
    ((:Cs :Df) 4)
    (:D 5)
    ((:Ds :Ef) 6)
    (:E 7)
    (:F 8)
    ((:Fs :Gf) 9)
    (:G 10)
    ((:Gs :Af) 11)))


(defun note (name octave duration)
  (make-instance 'note :key (+ (* octave 12) (key-code name)) :duration duration))

(defun repeat (n mus)
  (seq (make-array n :initial-element mus)))

;;; Example
(defvar *three-blind-mice*
  (let* ((qn 1/4)
         (en 1/8)
         (en3 3/8)
         (en6 6/8)
         (qnr (make-instance 'music-rest :duration qn))
         (t1 (seq (note :D 4 en3) (note :C 4 en3) (note :Bf 3 en6)))
         (t2 (seq (note :F 4 en3) (note :Ef 4 qn) (note :Ef 4 en)))
         (t3 (seq (note :F 4 en)  (note :Bf 4 qn) (note :Bf 4 en) (note :A 4 en) (note :G 4 en) (note :A 4 en) (note :Bf 4 qn) (note :F 4 en) (note :F 4 qn))))
    (seq (repeat 2 t1)
         t2 (note :D 4 en6)
         t2 (note :D 4 en3)
         qnr
         (repeat 3 t3)
         (note :Ef 4 en) t1)))