comparison base/charm/constructors.lisp @ 253:b5ffec94ae6d

some very sketchy Charm constituent code

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