diff 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.

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/base/database/charm/constructors.lisp	Thu Sep 30 15:35:15 2010 +0100
@@ -0,0 +1,110 @@
+(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)))