Mark: 1 revision(s)

2008-11-03T05:27:41Z

1 revision(s)

New page

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

SE701:April 11 - Revision history

Mark: 1 revision(s)