j@318: (cl:in-package #:amuse-charm)
j@318: 
j@318: (defun make-charm-property-list (properties)
j@318:   (make-instance 'charm-property-list
j@318: 		 :%data properties))
j@318: 
j@318: (defun make-charm-constituent-identifier (id)
j@318:   (make-instance 'charm-constituent-identifier
j@318: 		 :constituent-id id))
j@318: 
j@318: (defun make-standard-charm-constituent (particles parent
j@318: 					extrinsic-properties
j@318: 					intrinsic-properties &key
j@318: 					start duration
j@318: 					constituent-identifier owner
j@318: 					version creation-timestamp
j@318: 					deletion-timestamp)
j@318:   "Properties should be charm-property-lists. FIXME: enforce this?
j@318: What about time? Should we be using implementation time data-types?
j@318: Particles by definition are identifiers - BUT this seemed to cause
j@318: unnecessary pain, so particales are now either events or
j@318: constituents. This could be make to call an backend specific
j@318: constructor specialised on the parent-identifier."
j@318:   (make-instance 'standard-charm-constituent
j@318: 		 :identifier constituent-identifier
j@318: 		 :parent parent
j@318: 		 :time start		; FIXME: naming conventions?
j@318: 		 :interval duration
j@318: 		 :extrinsic-properties extrinsic-properties
j@318: 		 :intrinsic-properties intrinsic-properties
j@318: 		 :%data particles
j@318: 		 :owner owner
j@318: 		 :version version
j@318: 		 :creation-timestamp creation-timestamp
j@318: 		 :deletion-timestamp deletion-timestamp))
j@318: 
j@318: (defun make-standard-charm-event-constituent (particles parent
j@318: 					      extrinsic-properties
j@318: 					      intrinsic-properties
j@318: 					      &key start duration
j@318: 					      constituent-identifier
j@318: 					      owner version
j@318: 					      creation-timestamp
j@318: 					      deletion-timestamp)
j@318:   "Properties should be charm-property-lists. FIXME: enforce this?
j@318: What about time? Should we be using implementation time data-types?
j@318: Particles by definition are identifiers - BUT this seemed to cause
j@318: unnecessary pain, so particales are now either events or
j@318: constituents. This could be make to call an backend specific
j@318: constructor specialised on the parent-identifier."
j@318:   (make-instance 'standard-charm-event-constituent
j@318: 		 :identifier constituent-identifier
j@318: 		 :parent parent
j@318: 		 :time start		; FIXME: naming conventions?
j@318: 		 :interval duration
j@318: 		 :extrinsic-properties extrinsic-properties
j@318: 		 :intrinsic-properties intrinsic-properties
j@318: 		 :%data (copy-list particles)
j@318: 		 :owner owner
j@318: 		 :version version
j@318: 		 :creation-timestamp creation-timestamp
j@318: 		 :deletion-timestamp deletion-timestamp))
j@318: 
j@318: (defun composition->charm-constituent (composition
j@318: 				       extrinsic-properties
j@318: 				       intrinsic-properties)
j@318:   "This is currently the bridge that takes us from AMuSE compositions
j@318: to Charm constituents."
j@318:   (make-standard-charm-event-constituent (%list-slot-sequence-data
j@318: 					  composition)
j@318: 					 composition
j@318: 					 extrinsic-properties
j@318: 					 intrinsic-properties
j@318: 					 :start (timepoint
j@318: 						 composition)
j@318: 					 :duration (duration
j@318: 						    composition)))
j@318: 
j@318: (defun make-onset-segment-constituent (composition)
j@318:   (let ((grouped-events (group-by-onset composition))
j@318: 	(parent-constituent
j@318: 	 (make-standard-charm-constituent nil composition
j@318: 					  (make-charm-property-list
j@318: 					  '("sequence-class"))
j@318: 					  (make-charm-property-list
j@318: 					   '("sequence-class"))
j@318: 					  :start (timepoint
j@318: 						  composition)
j@318: 					  :duration (duration
j@318: 						     composition))))
j@318:     (loop for beat-events in grouped-events
j@318:        collect (make-standard-charm-event-constituent
j@318: 		beat-events
j@318: 		parent-constituent
j@318: 		(make-charm-property-list '("segment"))
j@318: 		(make-charm-property-list '("onset-segment")))
j@318:        into constituents
j@318:        finally (progn
j@318: 		 (setf (%list-slot-sequence-data parent-constituent)
j@318: 		       constituents)
j@318: 		 (return parent-constituent)))))
j@318: 
j@318: (defun group-by-onset (composition)
j@318:   (loop for event in (reverse (%list-slot-sequence-data composition))
j@318:      with grouped-events
j@318:      do (if (and grouped-events
j@318: 		 (time= (onset event) (onset (car (car grouped-events)))))
j@318: 	    (push event (car grouped-events))
j@318: 	    (push (list event) grouped-events))
j@318:      finally (return grouped-events)))