Mercurial > hg > amuse

changeset 111:f49aa290b5c3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
diatonic pitch intervals Implement diatonic pitch intervals. In the process, the pitch-foo methods have been slightly rearranged: the system currently should reject attempts to add chromatic intervals to diatonic pitches and vice versa. Complain (or, preferably, fix) if any breakage results... darcs-hash:20070726151244-dc3a5-3587adb88c494f7074c5e36a3983fde1a3d69da1.gz
author c.rhodes <c.rhodes@gold.ac.uk>
date Thu, 26 Jul 2007 16:12:44 +0100
parents ea542c06c364
children 034ef8412ddb
files base/classes.lisp base/constructors.lisp base/methods.lisp base/package.lisp
diffstat 4 files changed, 125 insertions(+), 53 deletions(-) [+]
line wrap: on
line diff
--- a/base/classes.lisp	Thu Jul 26 15:19:40 2007 +0100
+++ b/base/classes.lisp	Thu Jul 26 16:12:44 2007 +0100
@@ -57,8 +57,11 @@
 an integer representing the morphetic pitch (An0 = 0, middle C =
 23)."))
 
-(defclass pitch-interval (pitch-interval-designator) 
-  ((span :accessor %pitch-interval-span :initarg :span)))
+(defclass chromatic-pitch-interval (pitch-interval-designator) 
+  ((span :accessor %chromatic-pitch-interval-span :initarg :span)))
+
+(defclass diatonic-pitch-interval (pitch-interval-designator)
+  ((span :accessor %diatonic-pitch-interval-span :initarg :span :reader span)))
 
 ;; events
 
--- a/base/constructors.lisp	Thu Jul 26 15:19:40 2007 +0100
+++ b/base/constructors.lisp	Thu Jul 26 16:12:44 2007 +0100
@@ -44,6 +44,9 @@
 (defun make-chromatic-pitch-interval (span)
   (make-instance 'pitch-interval :span span))
 
+(defun make-mips-pitch-interval (cspan mspan)
+  (make-instance 'diatonic-pitch-interval :span (list cspan mspan)))
+
 ;; Events
 
 (defun make-chromatic-pitched-event (pitch-number onset duration)
--- a/base/methods.lisp	Thu Jul 26 15:19:40 2007 +0100
+++ b/base/methods.lisp	Thu Jul 26 16:12:44 2007 +0100
@@ -33,12 +33,6 @@
 (defmethod diatonic-pitch-name ((mp diatonic-pitch))
   (elt (asa-pitch-string mp) 0))
 
-(defmethod pitch= ((p1 diatonic-pitch) (p2 diatonic-pitch))
-  (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 diatonic-pitch))
   (make-diatonic-pitch 39 23))
 
@@ -56,6 +50,14 @@
     (let ((asa-string (asa-pitch-string o)))
       (write asa-string :stream stream))))
 
+(defmethod asa-interval-string ((mpi diatonic-pitch-interval))
+  (mips:pi-pin (%diatonic-pitch-interval-span mpi)))
+
+(defmethod print-object ((o diatonic-pitch-interval) stream)
+  (print-unreadable-object (o stream :type t)
+    (let ((asa-string (asa-interval-string o)))
+      (write asa-string :stream stream))))
+
 ;;; Chromatic pitch 
 
 (defmethod octave ((cp chromatic-pitch))
@@ -73,8 +75,8 @@
 (defmethod midi-pitch-number ((pitch-designator pitch))
   (%chromatic-pitch-number (chromatic-pitch pitch-designator)))
 
-(defmethod span ((pitch-interval-designator pitch-interval))
-  (%pitch-interval-span pitch-interval-designator))
+(defmethod span ((pitch-interval-designator chromatic-pitch-interval))
+  (%chromatic-pitch-interval-span pitch-interval-designator))
 
 (defmethod duration ((period-designator period))
   (%period-interval period-designator))
@@ -214,65 +216,127 @@
 (defmethod duration/ ((object1 period) (object2 number))
   (make-floating-period (/ (duration object1) object2)))
 
-;; Pitch protocol
+;;;; Pitch protocol
 
-(defmethod pitch+ ((object1 pitch-designator)
-		   (object2 pitch-designator))
-  (error 'undefined-action :operation 'pitch+
-	 :datatype (list (class-of object1) (class-of object2))))
+;;; Some catch-all methods for undefined operations and cases where we
+;;; don't have enough information:
+(macrolet ((def (name class1 class2)
+             `(defmethod ,name ((object1 ,class1) (object2 ,class2))
+               (error 'undefined-action :operation ',name
+                :datatype (list (class-of object1) (class-of object2))))))
+  (def pitch+ pitch-designator pitch-designator)
+  (def pitch- pitch-interval-designator pitch-designator))
 
-(defmethod pitch+ ((object1 pitch-designator)
-		   (object2 pitch-interval)) ; or should I check the
-					     ; pitch/interval types?
-  (make-chromatic-pitch (+ (midi-pitch-number object1)
-			   (span object2))))
+(macrolet ((def (name class1 class2)
+             `(defmethod ,name ((object1 ,class1) (object2 ,class2))
+               (error 'insufficient-information :operation ',name
+                :datatype (list (class-of object1) (class-of object2))))))
+  (def pitch+ pitch-designator pitch-interval-designator)
+  (def pitch+ pitch-interval-designator pitch-designator)
+  (def pitch+ pitch-interval-designator pitch-interval-designator)
+  (def pitch- pitch-designator pitch-designator)
+  (def pitch- pitch-designator pitch-interval-designator)
+  (def pitch- pitch-interval-designator pitch-interval-designator))
 
-(defmethod pitch+  ((object1 pitch-interval)
-		    (object2 pitch-designator)) ;?
-  (pitch+ object2 object1))
+;;; chromatic pitch intervals
 
-(defmethod pitch+ ((object1 pitch-interval)
-		   (object2 pitch-interval))
+(defmethod pitch+ ((object1 chromatic-pitch)
+		   (object2 chromatic-pitch-interval))
+  (make-chromatic-pitch (+ (midi-pitch-number object1) (span object2))))
+
+(defmethod pitch+  ((object1 chromatic-pitch-interval)
+		    (object2 chromatic-pitch))
+  (make-chromatic-pitch (+ (span object1) (midi-pitch-number object2))))
+
+(defmethod pitch+ ((object1 chromatic-pitch-interval)
+		   (object2 chromatic-pitch-interval))
   (make-chromatic-pitch-interval (+ (span object1) (span object2))))
 
-(defmethod pitch- ((object1 pitch-designator)
-		   (object2 pitch-designator))
-  (make-chromatic-pitch-interval 
+(defmethod pitch- ((object1 chromatic-pitch) 
+                   (object2 chromatic-pitch))
+  (make-chromatic-pitch-interval
    (- (midi-pitch-number object1) (midi-pitch-number object2))))
 
-(defmethod pitch- ((object1 pitch-designator)
-		   (object2 pitch-interval))
+(defmethod pitch- ((object1 chromatic-pitch)
+                   (object2 chromatic-pitch-interval))
   (make-chromatic-pitch (- (midi-pitch-number object1) (span object2))))
 
-(defmethod pitch- ((object1 pitch-interval)
-		   (object2 pitch-interval))
+(defmethod pitch- ((object1 chromatic-pitch-interval)
+		   (object2 chromatic-pitch-interval))
   (make-chromatic-pitch-interval (- (span object1) (span object2))))
 
-(defmethod pitch- ((object1 pitch-interval)
-		   (object2 pitch-designator))
-  (error 'undefined-action :operation 'pitch-
-	 :datatype (list (class-of object1) (class-of object2))))
+(defmethod pitch> ((object1 chromatic-pitch)
+		   (object2 chromatic-pitch))
+  (> (midi-pitch-number object1) (midi-pitch-number object2)))
 
-(defmethod pitch> ((object1 pitch-designator)
-		   (object2 pitch-designator))
-  (> (midi-pitch-number object1)
-     (midi-pitch-number object2)))
+(defmethod pitch= ((object1 chromatic-pitch)
+		   (object2 chromatic-pitch))
+  (= (midi-pitch-number object1) (midi-pitch-number object2)))
 
-(defmethod pitch= ((object1 pitch-designator)
-		   (object2 pitch-designator))
-  (= (midi-pitch-number object1)
-     (midi-pitch-number object2)))
+(defmethod interval> ((object1 chromatic-pitch-interval)
+                      (object2 chromatic-pitch-interval))
+  (> (span object1) (span object2)))
 
-(defmethod interval> ((object1 pitch-interval)
-                      (object2 pitch-interval))
-  (> (span object1)
-     (span object2)))
+(defmethod interval= ((object1 chromatic-pitch-interval)
+                      (object2 chromatic-pitch-interval))
+  (= (span object1) (span object2)))
 
-(defmethod interval= ((object1 pitch-interval)
-		   (object2 pitch-interval))
-  (= (span object1)
-     (span object2)))
+;;; diatonic pitch intervals
 
+(defmethod pitch+ ((object1 diatonic-pitch) (object2 diatonic-pitch-interval))
+  (let* ((cp (%p-pc object1))
+         (mp (%p-pm object1))
+         (span (span object2))
+         (cps (first span))
+         (mps (second span)))
+    (make-mips-pitch (+ cp cps) (+ mp mps))))
+
+(defmethod pitch+ ((object1 diatonic-pitch-interval) (object2 diatonic-pitch))
+  (let* ((cp (%p-pc object2))
+         (mp (%p-pm object2))
+         (span (span object1))
+         (cps (first span))
+         (mps (second span)))
+    (make-mips-pitch (+ cp cps) (+ mp mps))))
+
+(defmethod pitch+ ((object1 diatonic-pitch-interval)
+		   (object2 diatonic-pitch-interval))
+  (let* ((span1 (span object1))
+         (span2 (span object2)))
+    (make-mips-pitch-interval (+ (first span1) (first span2))
+                              (+ (second span1) (second span2)))))
+
+(defmethod pitch- ((object1 diatonic-pitch) (object2 diatonic-pitch))
+  (let ((cp1 (%p-pc object1))
+        (mp1 (%p-pm object1))
+        (cp2 (%p-pc object2))
+        (mp2 (%p-pm object2)))
+    (make-mips-pitch-interval (- cp1 cp2) (- mp1 mp2))))
+
+(defmethod pitch- ((object1 diatonic-pitch) (object2 diatonic-pitch-interval))
+  (let* ((cp (%p-pc object1))
+         (mp (%p-pm object1))
+         (span (span object2))
+         (cps (first span))
+         (mps (second span)))
+    (make-mips-pitch (- cp cps) (- mp mps))))
+
+(defmethod pitch- ((object1 diatonic-pitch-interval)
+		   (object2 diatonic-pitch-interval))
+  (let ((span1 (span object1))
+        (span2 (span object2)))
+    (make-mips-pitch-interval (- (first span1) (first span2))
+                              (- (second span1) (second span2)))))
+
+(defmethod pitch> ((p1 diatonic-pitch) (p2 diatonic-pitch))
+  (error 'undefined-action :operation 'pitch>
+         :datatype (list (class-of p1) (class-of p2))))
+
+(defmethod pitch= ((p1 diatonic-pitch) (p2 diatonic-pitch))
+  (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))))
 
 
 ;; Allen
--- a/base/package.lisp	Thu Jul 26 15:19:40 2007 +0100
+++ b/base/package.lisp	Thu Jul 26 16:12:44 2007 +0100
@@ -17,7 +17,8 @@
 	   #:pitch
 	   #:chromatic-pitch 
 	   #:diatonic-pitch   
-	   #:pitch-interval
+	   #:chromatic-pitch-interval
+           #:diatonic-pitch-interval
 	   #:pitched-event
 	   #:chromatic-pitched-event
 	   #:percussive-event
@@ -115,6 +116,7 @@
            #:diatonic-pitch-name 
            #:middle-c 
            #:make-mips-pitch
+           #:make-mips-pitch-interval
            #:octave
            #:diatonic-pitch-octave 
            #:diatonic-pitch-accidental