view implementations/viewpointable/viewpointable.lisp @ 117:0190c6ad759e

Fixes for viewpointable classes

darcs-hash:20070726161039-f76cc-e9be0dd8f1ea1366b127547df97b6f55056cd70e.gz

(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 (amuse::event)
  ((source-event :initarg :source-event
		 :accessor %viewpointable-event-source-event)
   (source-composition :initarg :source-composition
		       :accessor %viewpointable-event-source-composition)))

(defclass viewpointable-composition (monody) ())

(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))