j@253: (cl:in-package #:amuse-charm)
j@253: 
j@253: (defun make-charm-property-list (&rest properties)
j@253:   (make-instance 'charm-property-list
j@253: 		 :%data properties))
j@253: 
j@253: (defun make-charm-constituent-identifier (id)
j@253:   (make-instance 'charm-constituent-identifier
j@253: 		 :constituent-id id))
j@253: 
j@253: (defun make-standard-charm-constituent (particles parent
j@253: 					extrinsic-properties
j@253: 					intrinsic-properties &key
j@253: 					start duration
j@253: 					constituent-identifier owner
j@253: 					version creation-timestamp
j@253: 					deletion-timestamp)
j@253:   "Properties should be charm-property-lists. FIXME: enforce this?
j@253: What about time? Should we be using implementation time data-types?
j@253: Particles by definition are identifiers - BUT this seemed to cause
j@253: unnecessary pain, so particales are now either events or
j@253: constituents. This could be made to call a backend specific
j@253: constructor specialised on the parent-identifier."
j@253:   (make-instance 'standard-charm-constituent
j@253: 		 :identifier constituent-identifier
j@253: 		 :parent parent
j@253: 		 :time start		; FIXME: naming conventions?
j@253: 		 :interval duration
j@253: 		 :extrinsic-properties extrinsic-properties
j@253: 		 :intrinsic-properties intrinsic-properties
j@253: 		 :%data particles
j@253: 		 :owner owner
j@253: 		 :version version
j@253: 		 :creation-timestamp creation-timestamp
j@253: 		 :deletion-timestamp deletion-timestamp))
j@253: 
j@253: (defun make-standard-charm-event-constituent (particles parent
j@253: 					      extrinsic-properties
j@253: 					      intrinsic-properties
j@253: 					      &key start duration
j@253: 					      constituent-identifier
j@253: 					      owner version
j@253: 					      creation-timestamp
j@253: 					      deletion-timestamp)
j@255:   (let ((constituent-class (cond
j@255: 			     ((every #'amuse-utils:pitchedp particles)
j@255: 			      'standard-charm-pitched-event-constituent)
j@255: 			     ((every #'amuse-utils:unpitchedp particles)
j@255: 			      'standard-charm-unpitched-event-constituent)
j@255: 			     (t 'standard-charm-event-constituent))))
j@255:     (make-instance constituent-class
j@255: 		   :identifier constituent-identifier
j@255: 		   :parent parent
j@255: 		   :time start		; FIXME: naming conventions?
j@255: 		   :interval duration
j@255: 		   :extrinsic-properties extrinsic-properties
j@255: 		   :intrinsic-properties intrinsic-properties
j@255: 		   :%data particles
j@255: 		   :owner owner
j@255: 		   :version version
j@255: 		   :creation-timestamp creation-timestamp
j@255: 		   :deletion-timestamp deletion-timestamp)))
j@253: 
j@253: (defun composition->charm-constituent (composition
j@253: 				       extrinsic-properties
j@253: 				       intrinsic-properties)
j@253:   "This is currently the bridge that takes us from AMuSE compositions
j@253: to Charm constituents."
j@253:   (make-standard-charm-event-constituent (%list-slot-sequence-data
j@253: 					  composition) composition
j@253: 					  extrinsic-properties
j@253: 					  intrinsic-properties
j@253: 					  :start (timepoint
j@253: 						  composition)
j@253: 					  :duration (duration
j@253: 						     composition)))
j@253: 
j@253: (defun make-onset-segment-constituent (composition)
j@253:   "So this makes a constituent for each set of events with the same
j@253: onset, and adds all of those as particles to a parent constituent. To
j@253: two levels are created, maybe it's better to only return a list of
j@253: onset-constituents, and the user can group them together within
j@253: another constituent if necessary?"
j@253:   (let ((grouped-events (group-by-onset composition))
j@253: 	(parent-constituent
j@253: 	 (make-standard-charm-constituent nil composition
j@253: 					  (make-charm-property-list
j@253: 					  'sequence-class)
j@253: 					  (make-charm-property-list
j@253: 					   'sequence-class)
j@253: 					  :start (timepoint
j@253: 						  composition)
j@253: 					  :duration (duration
j@253: 						     composition))))
j@253:     (loop for beat-events in grouped-events
j@253:        collect (make-standard-charm-event-constituent
j@253: 		beat-events
j@253: 		parent-constituent
j@253: 		(make-charm-property-list 'segment)
j@253: 		(make-charm-property-list 'onset-segment))
j@253:        into constituents
j@253:        finally (progn
j@253: 		 (setf (%list-slot-sequence-data parent-constituent)
j@253: 		       constituents)
j@253: 		 (return parent-constituent)))))
j@253: 
j@253: (defun group-by-onset (composition)
j@253:   (loop for event in (reverse (%list-slot-sequence-data composition))
j@253:      with grouped-events
j@253:      do (if (and grouped-events
j@253: 		 (time= (onset event) (onset (car (car grouped-events)))))
j@253: 	    (push event (car grouped-events))
j@253: 	    (push (list event) grouped-events))
j@253:      finally (return grouped-events)))
j@253: 
j@253: (defun segment-at-bar (composition)
j@253:   "Returns a list of bar-constituents."
j@255:   (loop with current-bar = (current-bar (elt composition 0) composition)
j@255:      and current-events
j@253:      for event in (%list-slot-sequence-data composition)
j@253:      if (time= current-bar (current-bar event composition))
j@253:      do (push event current-events)
j@253:      else
j@253:      collect (make-standard-charm-event-constituent
j@253: 	      (reverse current-events)
j@253: 	      composition
j@253: 	      (make-charm-property-list)
j@253: 	      (make-charm-property-list 'segment 'bar))
j@253:      into constituents
j@253:      and do (setf current-bar (current-bar event composition))
j@253:      and do (setf current-events nil)
j@253:      finally (return constituents)))