d@116: (in-package #:amuse-viewpointing-implementation)
d@116: 
d@116: ;; A set of classes and methods such that, if the amuse-form methods
d@116: ;; are implemented, a viewpointable-composition can be made and have
d@116: ;; viewpoint operations carried out without loss of context.
d@116: 
d@117: (defclass viewpointable-event (amuse::event)
d@116:   ((source-event :initarg :source-event
d@116: 		 :accessor %viewpointable-event-source-event)
d@116:    (source-composition :initarg :source-composition
d@116: 		       :accessor %viewpointable-event-source-composition)))
d@116: 
d@117: (defclass viewpointable-composition (monody) ())
d@116: 
j@293: (defclass standard-viewpointable-composition (standard-monody) ())
j@293: 
d@116: (defmethod timepoint ((event viewpointable-event))
d@116:   (timepoint (%viewpointable-event-source-event event)))
d@116: 
d@116: (defmethod duration ((event viewpointable-event))
d@116:   (duration (%viewpointable-event-source-event event)))
d@116: 
d@116: (defmethod midi-pitch-number ((event viewpointable-event))
d@116:   (midi-pitch-number (%viewpointable-event-source-event event)))
d@116: 
d@116: (defmethod get-applicable-key-signatures ((event viewpointable-event) foo)
d@116:   (declare (ignore foo))
d@116:   (get-applicable-key-signatures (%viewpointable-event-source-event event)
d@116: 				 (%viewpointable-event-source-composition event)))
d@116: 
d@116: (defmethod get-applicable-time-signatures ((event viewpointable-event) foo)
d@116:   (declare (ignore foo))
d@116:   (get-applicable-time-signatures (%viewpointable-event-source-event event)
d@116: 				 (%viewpointable-event-source-composition event)))
d@116: 
d@116: 
d@116: (defmethod get-applicable-tempi ((event viewpointable-event) foo)
d@116:   (declare (ignore foo))
d@116:   (get-applicable-tempi (%viewpointable-event-source-event event)
d@116: 			(%viewpointable-event-source-composition event)))
d@116: 
d@116: (defmethod crotchet ((event viewpointable-event))
d@116:   (crotchet (%viewpointable-event-source-event event)))
d@116: 
d@116: (defmethod diatonic-pitch ((event viewpointable-event))
d@116:   (diatonic-pitch (%viewpointable-event-source-event event)))
d@116: 
d@116: (defmethod amuse-segmentation:ground-truth-segmenter-after ((composition viewpointable-composition))
d@116:   (amuse-segmentation:ground-truth-segmenter-after composition))
d@116: 
d@116: (defmethod amuse-segmentation:ground-truth-segmenter-before ((composition viewpointable-composition))
d@116:   (amuse-segmentation:ground-truth-segmenter-before composition))
d@116: 
d@116: (defmethod amuse-segmentation:boundary-strength (segmenter (event viewpointable-event) (composition viewpointable-composition))
d@116:   (declare (ignore composition))
d@116:   (amuse-segmentation:boundary-strength segmenter
d@116: 					(%viewpointable-event-source-event event)
d@116: 					(%viewpointable-event-source-composition event)))
d@116: 
j@293: (defun make-standard-viewpointable-composition (composition)
j@293:   (let ((new-comp (make-instance 'standard-viewpointable-composition
d@116: 				 :time (timepoint composition)
d@116: 				 :interval (duration composition)))
d@116: 	(event-list) (i 0))
d@116:     (sequence:dosequence (event composition)
d@116:       (push (make-instance 'viewpointable-event :source-event event
d@116: 			   :source-composition composition)
d@116: 	    event-list)
d@116:       (incf i))
d@116:     (sequence:adjust-sequence new-comp i :initial-contents (reverse event-list))
d@116:     new-comp))