changeset 81:4e1538df0d10

base/: add an implementation of diatonic pitch.

darcs-hash:20070717120206-c0ce4-b18278ab07116658e58839c4fd18972508da6658.gz

--- a/amuse.asd	Mon Jul 16 17:33:37 2007 +0100
+++ b/amuse.asd	Tue Jul 17 13:02:06 2007 +0100
@@ -2,7 +2,7 @@
   :name "amuse"
   :description ""
   :serial t
-  :depends-on ("midi")
+  :depends-on ("midi" "mips")
   :components 
   ((:module base 
             :components 

--- a/base/classes.lisp	Mon Jul 16 17:33:37 2007 +0100
+++ b/base/classes.lisp	Tue Jul 17 13:02:06 2007 +0100
@@ -40,8 +40,22 @@
 (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)))
-  
+   (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))
+  (:documentation "A MIPS pitch: cp is an integer representing
+chromatic pitch (An0 = 0, middle C = 39); mp is an integer
+representing the morphetic pitch (An0 = 0, middle c = 23)."))
+
 (defclass pitch-interval (pitch-interval-designator) 
   ((span :accessor %pitch-interval-span :initarg :span)))
 

--- a/base/constructors.lisp	Mon Jul 16 17:33:37 2007 +0100
+++ b/base/constructors.lisp	Tue Jul 17 13:02:06 2007 +0100
@@ -29,6 +29,9 @@
 		 :accidental accidental
 		 :octave octave))
 
+(defun make-mips-pitch (cp mp)
+  (make-instance 'mips-pitch :cp cp :mp mp))
+
 (defun make-pitch-interval (span)
   (make-instance 'pitch-interval :span span))
 

--- a/base/generics.lisp	Mon Jul 16 17:33:37 2007 +0100
+++ b/base/generics.lisp	Tue Jul 17 13:02:06 2007 +0100
@@ -36,7 +36,12 @@
 				      ; 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 frequency (object)) ;?
+
+(defgeneric middle-c (pitch-designator) 
+  (:documentation "Returns the value of middle C in the particular
+representation of pitch used by PITCH-DESIGNATOR."))
 (defgeneric midi-pitch-number (pitch-designator)
   (:documentation "Takes a pitch-designator (usually a pitched
   event) and returns an integer between 0 and 127 representing
@@ -49,6 +54,18 @@
   ;; 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,B,C,D,E,F,G}, an inflection in the set {n,f,s,ff,ss,fff,sss,...}
+and an octave number. E.g., Cn4 = Middle C."))
+(defgeneric diatonic-pitch-name (pitch-designator)
+  (:documentation "Returns a char in the set
+{#\A,#\B,#\C,#\D,#\E,#\F,#\G}, representing the pitch name of
+PITCH-DESIGNATOR."))
 (defgeneric pitch-class (pitch-designator)
   (:documentation "Takes a pitch-designator (usually a pitched
   event) and returns an integer between 0 and 12 representing
@@ -266,4 +283,4 @@
 
 ;;; Dynamics 
 ;;; Voice 
-;;; Boundary Strength (phrasing) 
\ No newline at end of file
+;;; Boundary Strength (phrasing) 

--- a/base/methods.lisp	Mon Jul 16 17:33:37 2007 +0100
+++ b/base/methods.lisp	Tue Jul 17 13:02:06 2007 +0100
@@ -1,5 +1,84 @@
 (cl:in-package #:amuse) 
 
+;;; diatonic pitch 
+
+(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 middle-c ((mp mips-pitch))
+  (make-mips-pitch 39 23))
+
+(defmethod mips-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))
+
+;;; Chromatic pitch 
+
+(defmethod middle-c ((cp chromatic-pitch))
+  (make-chromatic-pitch 60))
+
 (defmethod chromatic-pitch ((pitch-designator chromatic-pitch))
   pitch-designator)
 

--- a/base/package.lisp	Mon Jul 16 17:33:37 2007 +0100
+++ b/base/package.lisp	Tue Jul 17 13:02:06 2007 +0100
@@ -31,8 +31,6 @@
 	   #:time-signatures
 	   #:tempi
 	   #:key-signatures
-	   #:chromatic-pitch
-	   #:diatonic-pitch
 	   #:midi-pitch-number
 	   #:meredith-chromatic-pitch-number
 	   #:pitch-class
@@ -114,4 +112,10 @@
            #:tempo-equal
 	   #:insufficient-information
 	   #:undefined-action
+           #:meredith-morphetic-pitch-number 
+           #:asa-pitch-string  
+           #:mips-pitch 
+           #:diatonic-pitch-name 
+           #:middle-c 
+           #:make-mips-pitch
 	   ))