annotate base/charm/constructors.lisp @ 255:f1e6d10fdb11

pitched and unpitched Charm event constituent classes

(cl:in-package #:amuse-charm)

(defun make-charm-property-list (&rest properties)
  (make-instance 'charm-property-list
		 :%data properties))

(defun make-charm-constituent-identifier (id)
  (make-instance 'charm-constituent-identifier
		 :constituent-id id))

(defun make-standard-charm-constituent (particles parent
					extrinsic-properties
					intrinsic-properties &key
					start duration
					constituent-identifier owner
					version creation-timestamp
					deletion-timestamp)
  "Properties should be charm-property-lists. FIXME: enforce this?
What about time? Should we be using implementation time data-types?
Particles by definition are identifiers - BUT this seemed to cause
unnecessary pain, so particales are now either events or
constituents. This could be made to call a backend specific
constructor specialised on the parent-identifier."
  (make-instance 'standard-charm-constituent
		 :identifier constituent-identifier
		 :parent parent
		 :time start		; FIXME: naming conventions?
		 :interval duration
		 :extrinsic-properties extrinsic-properties
		 :intrinsic-properties intrinsic-properties
		 :%data particles
		 :owner owner
		 :version version
		 :creation-timestamp creation-timestamp
		 :deletion-timestamp deletion-timestamp))

(defun make-standard-charm-event-constituent (particles parent
					      extrinsic-properties
					      intrinsic-properties
					      &key start duration
					      constituent-identifier
					      owner version
					      creation-timestamp
					      deletion-timestamp)
  (let ((constituent-class (cond
			     ((every #'amuse-utils:pitchedp particles)
			      'standard-charm-pitched-event-constituent)
			     ((every #'amuse-utils:unpitchedp particles)
			      'standard-charm-unpitched-event-constituent)
			     (t 'standard-charm-event-constituent))))
    (make-instance constituent-class
		   :identifier constituent-identifier
		   :parent parent
		   :time start		; FIXME: naming conventions?
		   :interval duration
		   :extrinsic-properties extrinsic-properties
		   :intrinsic-properties intrinsic-properties
		   :%data particles
		   :owner owner
		   :version version
		   :creation-timestamp creation-timestamp
		   :deletion-timestamp deletion-timestamp)))

(defun composition->charm-constituent (composition
				       extrinsic-properties
				       intrinsic-properties)
  "This is currently the bridge that takes us from AMuSE compositions
to Charm constituents."
  (make-standard-charm-event-constituent (%list-slot-sequence-data
					  composition) composition
					  extrinsic-properties
					  intrinsic-properties
					  :start (timepoint
						  composition)
					  :duration (duration
						     composition)))

(defun make-onset-segment-constituent (composition)
  "So this makes a constituent for each set of events with the same
onset, and adds all of those as particles to a parent constituent. To
two levels are created, maybe it's better to only return a list of
onset-constituents, and the user can group them together within
another constituent if necessary?"
  (let ((grouped-events (group-by-onset composition))
	(parent-constituent
	 (make-standard-charm-constituent nil composition
					  (make-charm-property-list
					  'sequence-class)
					  (make-charm-property-list
					   'sequence-class)
					  :start (timepoint
						  composition)
					  :duration (duration
						     composition))))
    (loop for beat-events in grouped-events
       collect (make-standard-charm-event-constituent
		beat-events
		parent-constituent
		(make-charm-property-list 'segment)
		(make-charm-property-list 'onset-segment))
       into constituents
       finally (progn
		 (setf (%list-slot-sequence-data parent-constituent)
		       constituents)
		 (return parent-constituent)))))

(defun group-by-onset (composition)
  (loop for event in (reverse (%list-slot-sequence-data composition))
     with grouped-events
     do (if (and grouped-events
		 (time= (onset event) (onset (car (car grouped-events)))))
	    (push event (car grouped-events))
	    (push (list event) grouped-events))
     finally (return grouped-events)))

(defun segment-at-bar (composition)
  "Returns a list of bar-constituents."
  (loop with current-bar = (current-bar (elt composition 0) composition)
     and current-events
     for event in (%list-slot-sequence-data composition)
     if (time= current-bar (current-bar event composition))
     do (push event current-events)
     else
     collect (make-standard-charm-event-constituent
	      (reverse current-events)
	      composition
	      (make-charm-property-list)
	      (make-charm-property-list 'segment 'bar))
     into constituents
     and do (setf current-bar (current-bar event composition))
     and do (setf current-events nil)
     finally (return constituents)))