comparison base/methods.lisp @ 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

       (let ((e1 (elt m i))
             (e2 (elt m (1+ i))))
         (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))
 
 (defmethod chromatic-pitch ((pitch-designator chromatic-pitch))