Mercurial > hg > amuse
changeset 106:8528c316fbcc
delete diatonic-pitch (as was)
Delete the diatonic-pitch class, in preparation for MIPS pitch being our single
representation. Add a DIATONIC-PITCH-OCTAVE generic, and make OCTAVE return
the octave based on a MIDI-PITCH-NUMBER (and make sure that it returns an
integer, too).
darcs-hash:20070726121235-dc3a5-4cbd1058145163eecbfc84384234904e2353fead.gz
| author | c.rhodes <c.rhodes@gold.ac.uk> |
|---|---|
| date | Thu, 26 Jul 2007 13:12:35 +0100 |
| parents | 7f139c81752e |
| children | 6bc5542fa9fa |
| files | base/classes.lisp base/constructors.lisp base/generics.lisp base/methods.lisp base/package.lisp |
| diffstat | 5 files changed, 51 insertions(+), 121 deletions(-) [+] |
line wrap: on
line diff
--- a/base/classes.lisp Thu Jul 26 10:29:52 2007 +0100 +++ b/base/classes.lisp Thu Jul 26 13:12:35 2007 +0100 @@ -49,18 +49,6 @@ ((number :accessor %chromatic-pitch-number :initarg :number)) (:documentation "A pitch represented as a number, with higher values representing high pitches.")) -(defclass diatonic-pitch (pitch) - ((name :accessor %diatonic-pitch-name :initarg :name) - (accidental :accessor %diatonic-pitch-accidental :initarg :accidental) - (octave :accessor %diatonic-pitch-octave :initarg :octave)) - (:documentation "NAME is an integer between 0-6, representing the -note name A-G; ACCIDENTAL is an integer where negative values indicate -numbers of flats, 0 indicates natural and positive values indicate -numbers of sharps; and octave is an integer indicating the ASA octave -number (the lowest full octave of the piano starting with C is octave -1, so the lowest note on the piano is A0; middle C is C4, and -the note just below it is B3).")) - (defclass mips-pitch (pitch) ((cp :initarg :cp :accessor %p-pc) (mp :initarg :mp :accessor %p-pm))
--- a/base/constructors.lisp Thu Jul 26 10:29:52 2007 +0100 +++ b/base/constructors.lisp Thu Jul 26 13:12:35 2007 +0100 @@ -24,10 +24,19 @@ (make-instance 'chromatic-pitch :number pitch-number)) (defun make-diatonic-pitch (name accidental octave) - (make-instance 'diatonic-pitch - :name name - :accidental accidental - :octave octave)) + (flet ((asa-string (name accidental octave) + (with-output-to-string (s) + (write-char name s) + (if (zerop accidental) + (write-char #\n s) + (let ((achar (if (plusp accidental) #\s #\f))) + (dotimes (i (abs accidental)) + (write-char achar s)))) + (write octave :stream s :base 10 :radix nil :pretty nil)))) + (let* ((name (if (numberp name) (elt "ABCDEFG" name) name)) + (asa-string (asa-string name accidental octave)) + (p (mips:pn-p asa-string))) + (make-instance 'mips-pitch :cp (first p) :mp (second p))))) (defun make-mips-pitch (cp mp) (make-instance 'mips-pitch :cp cp :mp mp))
--- a/base/generics.lisp Thu Jul 26 10:29:52 2007 +0100 +++ b/base/generics.lisp Thu Jul 26 13:12:35 2007 +0100 @@ -39,9 +39,8 @@ (defgeneric pitch (object &key kind)) ; ? Maybe this returns the pitch ; in its ur form? -(defgeneric chromatic-pitch (pitch-designator)) ; How simple are these -(defgeneric diatonic-pitch (pitch-designator)) ; if has to be computed? -(defgeneric mips-pitch (pitch-designator)) +(defgeneric chromatic-pitch (pitch-designator)) +(defgeneric diatonic-pitch (pitch-designator)) (defgeneric frequency (object)) ;? (defgeneric octave (pitch-designator) @@ -49,6 +48,10 @@ pitch-designator where middle c is defined to be the lowest pitch in octave 4.")) +(defgeneric diatonic-pitch-octave (pitch-designator) + (:documentation "Return an integer representing the diatonic octave +of PITCH-DESIGNATOR.")) + (defgeneric diatonic-pitch-accidental (pitch-designator) (:documentation "Return an integer representing the inflection of a diatonic pitch where where negative values indicate numbers of flats, @@ -62,16 +65,6 @@ event) and returns an integer between 0 and 127 representing the chromatic pitch designated (60=middle C, 48 the C below that, etc.)")) -(defgeneric meredith-chromatic-pitch-number (pitch-designator) - (:documentation "Takes a pitch-designator (usually a pitched - event) and returns an integer representing the chromatic pitch - designated (39=middle C, 27 the C below that, etc.)") - ;; David Meredith's PhD and ps13 code. FIXME: What is the legal - ;; range of this? - (:method (p) (- (midi-pitch-number p) 21))) -(defgeneric meredith-morphetic-pitch-number (pitch-designator) - (:documentation "Returns an integer representing the morphetic pitch -(7 per octave, An0 = 0, An1 = 7, middle c = 23) designated.")) (defgeneric asa-pitch-string (pitch-designator) (:documentation "Returns a string representing the designated ASA pitch name which has three parts: a letter name in the set
--- a/base/methods.lisp Thu Jul 26 10:29:52 2007 +0100 +++ b/base/methods.lisp Thu Jul 26 13:12:35 2007 +0100 @@ -12,115 +12,54 @@ (unless (or (before e1 e2) (meets e1 e2)) (setf result nil)))))) -;;; diatonic pitch - -(defmethod octave ((dp diatonic-pitch)) - (%diatonic-pitch-octave dp)) - -(defmethod diatonic-pitch-accidental ((dp diatonic-pitch)) - (%diatonic-pitch-accidental dp)) - -(defmethod pitch= ((p1 diatonic-pitch) (p2 diatonic-pitch)) - (let ((n1 (%diatonic-pitch-name p1)) - (a1 (%diatonic-pitch-accidental p1)) - (o1 (%diatonic-pitch-accidental p1)) - (n2 (%diatonic-pitch-name p2)) - (a2 (%diatonic-pitch-accidental p2)) - (o2 (%diatonic-pitch-accidental p2))) - (and n1 n2 (= n1 n2) - a1 a2 (= a1 a2) - o1 o2 (= o1 o2)))) - -(defmethod middle-c ((dp diatonic-pitch)) - (make-diatonic-pitch 2 0 4)) - -(defmethod diatonic-pitch ((dp diatonic-pitch)) - dp) - -(defmethod diatonic-pitch-name ((dp diatonic-pitch)) - (elt "ABCDEFG" (%diatonic-pitch-name dp))) - -(defmethod asa-pitch-string ((dp diatonic-pitch)) - (concatenate 'string - (diatonic-pitch-name dp) - (let ((a (%diatonic-pitch-accidental dp))) - (cond ((plusp a) - (make-sequence 'string a :initial-element "s")) - ((minusp a) - (make-sequence 'string (abs a) :initial-element "f")) - (t "n"))) - (%diatonic-pitch-octave dp))) - -(defmethod mips-pitch ((dp diatonic-pitch)) - (let ((mips-pitch (mips:pn-p (asa-pitch-string dp)))) - (make-mips-pitch (first mips-pitch) (second mips-pitch)))) -(defmethod midi-pitch-number ((dp diatonic-pitch)) - (midi-pitch-number (mips-pitch dp))) -(defmethod chromatic-pitch ((dp diatonic-pitch)) - (make-chromatic-pitch (midi-pitch-number dp))) -(defmethod meredith-chromatic-pitch-number ((dp diatonic-pitch)) - (meredith-chromatic-pitch-number (mips-pitch dp))) -(defmethod meredith-morphetic-pitch-number ((dp diatonic-pitch)) - (meredith-morphetic-pitch-number (mips-pitch dp))) - ;;; MIPS pitch -(defmethod octave ((mp mips-pitch)) - (octave (diatonic-pitch mp))) +(defmethod asa-pitch-string ((mp mips-pitch)) + (mips:p-pn (list (%p-pc mp) (%p-pm mp)))) + +(defmethod diatonic-pitch-octave ((mp mips-pitch)) + (let* ((asa-string (asa-pitch-string mp)) + (start (position-if #'digit-char-p asa-string))) + (values (parse-integer asa-string :start start)))) (defmethod diatonic-pitch-accidental ((mp mips-pitch)) - (diatonic-pitch-accidental (diatonic-pitch mp))) + (let* ((asa-string (asa-pitch-string mp)) + (start 1) + (end (position-if #'digit-char-p asa-string)) + (malist '((#\n . 0) (#\s . +1) (#\f . -1))) + (multiplier (cdr (assoc (char asa-string 1) malist)))) + (* multiplier (- end start)))) + +(defmethod diatonic-pitch-name ((mp mips-pitch)) + (elt (asa-pitch-string mp) 0)) (defmethod pitch= ((p1 mips-pitch) (p2 mips-pitch)) - (let ((c1 (meredith-chromatic-pitch-number p1)) - (m1 (meredith-morphetic-pitch-number p1)) - (c2 (meredith-chromatic-pitch-number p2)) - (m2 (meredith-morphetic-pitch-number p2))) + (let ((c1 (%p-pc p1)) (m1 (%p-pm p1)) + (c2 (%p-pc p2)) (m2 (%p-pm p2))) (and c1 c2 (= c1 c2) m1 m2 (= m1 m2)))) (defmethod middle-c ((mp mips-pitch)) (make-mips-pitch 39 23)) -(defmethod mips-pitch ((mp mips-pitch)) +(defmethod midi-pitch-number ((mp mips-pitch)) + (+ (%p-pc mp) 21)) + +(defmethod octave ((mp mips-pitch)) + (1- (floor (midi-pitch-number mp) 12))) + +(defmethod diatonic-pitch ((mp mips-pitch)) mp) -(defmethod diatonic-pitch ((mp mips-pitch)) - (let ((asa-pitch (mips:p-pn (list (%p-pc mp) (%p-pm mp)))) - (accidental-count nil)) - (make-diatonic-pitch - (position (elt asa-pitch 0) "ABCDEFG") - (ecase (elt asa-pitch 1) - (#\n 0) - (#\s - (let ((c (count #\s asa-pitch))) - (setf accidental-count c) - c)) - (#\f - (let ((c (count #\f asa-pitch))) - (setf accidental-count c) - (- c)))) - (parse-integer - asa-pitch :start (if accidental-count (1+ accidental-count) 2))))) - -(defmethod meredith-chromatic-pitch-number ((mp mips-pitch)) - (%p-pc mp)) -(defmethod meredith-morphetic-pitch-number ((mp mips-pitch)) - (%p-pm mp)) -(defmethod midi-pitch-number ((mp mips-pitch)) - (+ (meredith-chromatic-pitch-number mp) 21)) -(defmethod chromatic-pitch ((mp mips-pitch)) - (make-chromatic-pitch (midi-pitch-number mp))) -(defmethod asa-pitch-string ((mp mips-pitch)) - (mips:p-pn (list (meredith-chromatic-pitch-number mp) - (meredith-morphetic-pitch-number mp)))) -(defmethod diatonic-pitch-name ((mp mips-pitch)) - (elt (asa-pitch-string mp) 0)) +(defmethod print-object ((o mips-pitch) stream) + (print-unreadable-object (o stream :type t) + (let ((asa-string (asa-pitch-string o))) + (write asa-string :stream stream)))) ;;; Chromatic pitch (defmethod octave ((cp chromatic-pitch)) - (1- (/ (%chromatic-pitch-number cp) 12))) + (1- (floor (%chromatic-pitch-number cp) 12))) (defmethod middle-c ((cp chromatic-pitch)) (make-chromatic-pitch 60))