view base/database/charm/constructors.lisp @ 318:c4e792b9b898

Add some ideas for charm constituents.

Not particularly useful in its own right, but contains some possibly
useful ideas related to the generalisation of db-compositions.

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

(defun make-charm-property-list (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 make to call an 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)
  "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 make to call an backend specific
constructor specialised on the parent-identifier."
  (make-instance 'standard-charm-event-constituent
		 :identifier constituent-identifier
		 :parent parent
		 :time start		; FIXME: naming conventions?
		 :interval duration
		 :extrinsic-properties extrinsic-properties
		 :intrinsic-properties intrinsic-properties
		 :%data (copy-list 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)
  (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)))