diff implementations/viewpointable/viewpointable.lisp @ 116:b4f4df48337d

Addition of viewpointable classes and methods

These may be in the wrong place, but are designed to facilitate pluggability of viewpoints for well-behaved implementations

darcs-hash:20070726160347-f76cc-6e6da5d488b3f252d0575e42daa566130481f955.gz

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/implementations/viewpointable/viewpointable.lisp	Thu Jul 26 17:03:47 2007 +0100
@@ -0,0 +1,69 @@
+(in-package #:amuse-viewpointing-implementation)
+
+;; A set of classes and methods such that, if the amuse-form methods
+;; are implemented, a viewpointable-composition can be made and have
+;; viewpoint operations carried out without loss of context.
+
+(defclass viewpointable-event (event)
+  ((source-event :initarg :source-event
+		 :accessor %viewpointable-event-source-event)
+   (source-composition :initarg :source-composition
+		       :accessor %viewpointable-event-source-composition)))
+
+(defclass viewpointable-composition (composition) ())
+
+(defmethod timepoint ((event viewpointable-event))
+  (timepoint (%viewpointable-event-source-event event)))
+
+(defmethod duration ((event viewpointable-event))
+  (duration (%viewpointable-event-source-event event)))
+
+(defmethod midi-pitch-number ((event viewpointable-event))
+  (midi-pitch-number (%viewpointable-event-source-event event)))
+
+(defmethod get-applicable-key-signatures ((event viewpointable-event) foo)
+  (declare (ignore foo))
+  (get-applicable-key-signatures (%viewpointable-event-source-event event)
+				 (%viewpointable-event-source-composition event)))
+
+(defmethod get-applicable-time-signatures ((event viewpointable-event) foo)
+  (declare (ignore foo))
+  (get-applicable-time-signatures (%viewpointable-event-source-event event)
+				 (%viewpointable-event-source-composition event)))
+
+
+(defmethod get-applicable-tempi ((event viewpointable-event) foo)
+  (declare (ignore foo))
+  (get-applicable-tempi (%viewpointable-event-source-event event)
+			(%viewpointable-event-source-composition event)))
+
+(defmethod crotchet ((event viewpointable-event))
+  (crotchet (%viewpointable-event-source-event event)))
+
+(defmethod diatonic-pitch ((event viewpointable-event))
+  (diatonic-pitch (%viewpointable-event-source-event event)))
+
+(defmethod amuse-segmentation:ground-truth-segmenter-after ((composition viewpointable-composition))
+  (amuse-segmentation:ground-truth-segmenter-after composition))
+
+(defmethod amuse-segmentation:ground-truth-segmenter-before ((composition viewpointable-composition))
+  (amuse-segmentation:ground-truth-segmenter-before composition))
+
+(defmethod amuse-segmentation:boundary-strength (segmenter (event viewpointable-event) (composition viewpointable-composition))
+  (declare (ignore composition))
+  (amuse-segmentation:boundary-strength segmenter
+					(%viewpointable-event-source-event event)
+					(%viewpointable-event-source-composition event)))
+
+(defun make-viewpointable-composition (composition)
+  (let ((new-comp (make-instance 'viewpointable-composition
+				 :time (timepoint composition)
+				 :interval (duration composition)))
+	(event-list) (i 0))
+    (sequence:dosequence (event composition)
+      (push (make-instance 'viewpointable-event :source-event event
+			   :source-composition composition)
+	    event-list)
+      (incf i))
+    (sequence:adjust-sequence new-comp i :initial-contents (reverse event-list))
+    new-comp))