changeset 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/amuse-charm.asd	Thu Sep 30 15:35:15 2010 +0100
@@ -0,0 +1,20 @@
+(asdf:defsystem amuse-charm
+  :name "amuse-charm"
+  :description ""
+  :depends-on ("amuse" "amuse-database-admin")
+  :components
+  ((:module base
+            :components
+            ((:module charm
+		      :components
+		      ((:file "classes" :depends-on ("package"))
+		       (:file "constructors" :depends-on ("classes"))
+		       (:file "database-functions" :depends-on ("functions"))
+		       (:file "database-setup" :depends-on ("package"))
+		       (:file "functions" :depends-on ("package"))
+		       (:file "generics" :depends-on ("package"))
+		       (:file "methods" :depends-on ("classes"
+						     "functions"
+						     "generics"))
+		       (:file "package")
+		       ))))))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/base/database/charm/classes.lisp	Thu Sep 30 15:35:15 2010 +0100
@@ -0,0 +1,109 @@
+(cl:in-package #:amuse-charm)
+
+;;;=====================================================================
+;;; Charm-constituents - experimental implementation
+;;;=====================================================================
+
+;; This aims to bolt on Charm compliance to AMuSE constituents, as
+;; they are currently implmented (i.e. compositions
+;; primarily). However, in order to avoid breaking existing code, this
+;; is not the most tidy of solutions.
+
+;;;=====================================================================
+;;; Charm property lists
+;;;=====================================================================
+
+(defclass charm-property-list (amuse-object list-slot-sequence) ())
+
+;; (defclass charm-property (amuse-object) ()
+;;   (:documentation "Base class for charm property objects."))
+
+;; (defclass extrinsic-property (charm-property)  
+;;   ((property :reader property
+;; 	     :initarg :property
+;; 	     :documentation "String specifiying extrinsic property."))
+;;   (:documentation "Base class for charm extrinsic properties."))
+
+;; (defclass intrinsic-property (charm-property)
+;;   ((property :reader property
+;; 	     :initarg :property
+;; 	     :documentation "String describing intrinsic property."))
+;;   (:documentation "Base class for charm intrinsic properties."))
+
+
+;;;=====================================================================
+;;; Charm constituent identifier
+;;;=====================================================================
+
+(defclass charm-constituent-identifier (constituent-identifier)
+  ((constituent-id :reader constituent-id
+		   :initarg :constituent-id))
+  (:documentation "Class to represent Charm constituent identifiers."))
+
+;;;=====================================================================
+;;; Charm constituents
+;;;=====================================================================
+
+(defclass charm-constituent (list-slot-sequence anchored-period)
+  ((identifier :accessor identifier
+	       :initarg :identifier
+	       :initform nil
+	       :documentation "Slot to store database ID, allocated
+	       automatically when inserted into the database.")
+;;    (parent-identifier :reader parent-identifier
+;; 		      :initarg :parent-identifier
+;; 		      :documentation "Slot to store the identifer for
+;; 		      the constituent from which the particles of this
+;; 		      constituent are also members. May either be
+;; 		      another Charm constituent or an AMuSE
+;; 		      composition.")
+   (parent :reader parent
+	   :initarg :parent
+	   :documentation "Slot to store the constituent from which
+	   the particles of this constituent are also members. May
+	   either be another Charm constituent or an AMuSE
+	   composition.")
+   (extrinsic-properties :reader extrinsic-properties
+			 :initarg :extrinsic-properties
+			 :documentation "Slot for the specification of
+			 extrinsic properties.")
+   (intrinsic-properties :reader intrinsic-properties
+			 :initarg :intrinsic-properties
+			 :documentation "Slot for the description of
+			 intrinsic properties.")
+;;    (particles-cache :accessor particles-cache ;; FIXME: why bother?
+;; 		    :initarg :particles-cache
+;; 		    :initform nil
+;; 		    :documentation "Slot to store the objects
+;; 		   identifier by the particles-identifiers.")
+   (owner :accessor owner ;FIXME: these slots should be inherited.
+	  :initarg :owner
+	  :initform nil)
+   (version :accessor version
+	    :initarg :version
+	    :initform nil)
+   (creation-timestamp :accessor creation-timestamp
+		       :initarg :creation-timestamp
+		       :initform nil)
+   (deletion-timestamp :accessor deletion-timestamp
+		       :initarg :deletion-timestamp
+		       :initform nil))
+   (:documentation "Base class for constituents"))
+
+(defclass standard-charm-constituent (charm-constituent
+				      standard-anchored-period) ()
+  (:documentation "Base class for constituents using standard time
+   representation."))
+
+(defclass standard-charm-event-constituent (standard-charm-constituent) ()
+  (:documentation "Base class for constituents using standard time
+   representation."))
+
+(defmethod initialize-instance :after ((constituent
+					standard-charm-constituent) &key)
+  (amuse::%recompute-standard-composition-period constituent))
+
+(defmethod (setf %list-slot-sequence-data) :after (new-value object)
+  "FIXME: :after is right, right? What is :around for again?"
+  (declare (ignore new-value))
+  (amuse::%recompute-standard-composition-period object))

--- /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)))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/base/database/charm/database-functions.lisp	Thu Sep 30 15:35:15 2010 +0100
@@ -0,0 +1,221 @@
+(cl:in-package #:amuse-charm)
+
+;;;=====================================================================
+;;; API for inserting and retrieving constituents
+;;;=====================================================================
+
+(defun store-charm-constituent (constituent database)
+  "Given a charm-constituent, store it in the database (after first
+checking for a previously added identical constituent - this needs
+doing properly), and then update the database related
+slots (identifier, owner, version, and timestamps).
+
+FIXME: What to do about constituent start and duration slots?
+Currently all implementations use integer time in the database, but
+then typically convert to a real number line in Lisp, e.g. geerdes
+divides by the MIDI timebase. So what should the start and duration
+slots mean? Should they be the real values or the database integer
+values? If the latter, then each implementation should provide a
+'convert-to-integer-time' function. Or the other extreme, do we
+specift these database columns as string so that we can store what
+ever we want (e.g. Lisp ratios instead of forcing conversion to
+floating point). For the moment, I'm ignoring this."
+  (unless nil ;(constituent-header-exists-p constituent database)
+    (%insert-new-constituent constituent database)
+    (format t "New constituent added: id ~A."
+	    (id constituent))
+    (identifier constituent)))
+
+(defun get-charm-constituent (constituent-identifier database)
+  (let ((header (%get-constituent-header constituent-identifier
+					 database)))
+    (destructuring-bind (parent ext-properties int-properties owner
+				version creation-timestamp
+				deletion-timestamp) header
+      (make-standard-charm-constituent (%get-constituent-particles
+					constituent-identifier parent
+					database) parent
+					ext-properties int-properties
+				       :constituent-identifier
+				       constituent-identifier
+				       :owner owner
+				       :version version
+				       :creation-timestamp creation-timestamp
+				       :deletion-timestamp
+				       deletion-timestamp))))
+
+;; (defun cache-charm-particles (charm-constituent)
+;;   "This could/should also re-compute the time and duration slots. Or,
+;; unless we can come up with a general way of storing these values in
+;; the constituent headers."
+;;   (%cache-charm-particles (implementation-package (parent-identifier
+;; 						   charm-constituent))
+;; 			  charm-constituent))
+
+;(defun delete-constituent (constituent-identifier database)
+  
+
+(defun constituent-header-exists-p (constituent database)
+  (with-slots (time interval extrinsic-properties
+		    intrinsic-properties)
+      constituent
+    (let ((exists
+	   (car
+	    (clsql:query (format nil "
+SELECT constituent_header_exists(~S, ~S, '~A', '~A')"
+				 time
+				 interval
+				 (object->db-string
+				 extrinsic-properties)
+				 (object->db-string
+				 intrinsic-properties))
+			 :database database
+			 :flatp t
+			 :field-names nil))))
+      (if (eq exists 1)
+	  (progn (setf exists t)
+		 (format t "Constituent header exists.~%"))
+	  (progn (setf exists nil)
+		 (format t "Constituent header does not exist.~%")))
+      exists)))
+
+;(defun constituent-particle-list-exists-p (constituent) nil)
+
+
+;;;=====================================================================
+;;; Helper functions
+;;;=====================================================================
+
+(defun %insert-new-constituent (constituent database)
+  "Constituent-identifier, owner, version, and timestamps are added as
+side effects."
+  (clsql:with-transaction (:database database)
+    (%insert-constituent-header constituent database)
+    (%insert-particles constituent database)))
+
+(defun %insert-constituent-header (constituent database)
+  (with-slots (parent extrinsic-properties intrinsic-properties)
+      constituent
+    (clsql:execute-command (concatenate 'string "
+INSERT INTO charm_constituent_headers SET
+implementation_id := (SELECT get_impl_id('" (implementation-namestring
+					     parent) "')),
+parent_id := " (princ-to-string (id parent)) ",
+ext_properties := '" (object->db-string extrinsic-properties) "',
+int_properties := '" (object->db-string intrinsic-properties) "';")
+			   :database database)
+    (%update-header-slots constituent database)))
+
+(defun %update-header-slots (constituent database)
+  (let ((db-row-data (clsql:query "
+SELECT last_insert_id(), owner, version, creation_timestamp, deletion_timestamp
+FROM charm_constituent_headers
+WHERE constituent_id = last_insert_id();"
+				  :database database
+				  :flatp t
+				  :field-names nil)))
+    (destructuring-bind (const-id own ver create delete) (car db-row-data)
+      (setf (identifier constituent) (make-charm-constituent-identifier
+				      const-id)
+	    (owner constituent) own
+	    (version constituent) ver
+	    (creation-timestamp constituent) create
+	    (deletion-timestamp constituent) delete)))
+  constituent)
+
+(defgeneric %insert-particles (constituent database))
+
+(defmethod %insert-particles ((constituent standard-charm-event-constituent)
+			       database)
+  (if (write-particles constituent)
+      (clsql:execute-command
+       "LOAD DATA LOCAL INFILE '/tmp/particles'
+INTO TABLE charm_constituent_particles"
+       :database database)
+      (error "file not written"))
+  (delete-file "/tmp/particles"))
+
+(defmethod %insert-particles ((constituent standard-charm-constituent)
+					   database)
+  (sequence:dosequence (particle constituent t)
+    (store-charm-constituent particle database)))
+
+(defun write-particles (constituent)
+  (with-open-file (particle-stream (pathname "/tmp/particles")
+		  :direction :output
+		  :if-exists :supersede)
+    (loop for particle in (%list-slot-sequence-data constituent)
+       do (write-sequence (concatenate
+			   'string ;;FIXME SET @constituent_id server side?
+			   (princ-to-string (id constituent))
+			   '(#\tab)
+			   (princ-to-string (id particle))
+			   '(#\tab)
+			   (object->db-string (identifier particle)) ; type
+			   '(#\tab)
+			   "1"		; version - defaults to 1
+			   '(#\nl))
+			  particle-stream)
+       finally (return t))))
+
+
+;;;=====================================================================
+;;; Retrieving
+;;;=====================================================================
+
+(defun %get-constituent-header (constituent-identifier database)
+  "Basic low-level retrieval of constituents. Just takes an identifier
+and returns a header without any checking of version or deletion
+fields."
+  (let ((header-row (clsql:query (concatenate 'string "
+SELECT implementation_name, parent_id, ext_properties, int_properties,
+owner, version, creation_timestamp, deletion_timestamp
+FROM charm_constituent_headers
+LEFT JOIN amuse_implementations
+USING (implementation_id)
+WHERE constituent_id = " (princ-to-string (id constituent-identifier)))
+				 :flatp t
+				 :field-names nil
+				 :database database)))
+    (%init-header (car header-row))))
+
+(defun %init-header (header-row)
+  (destructuring-bind (impl-name parent ext-properties int-properties
+				 owner version creation-timestamp
+				 deletion-timestamp) header-row
+    (setf ext-properties (make-charm-property-list (read-from-string
+						    ext-properties)))
+    (setf int-properties (make-charm-property-list (read-from-string
+						    int-properties)))
+    (setf impl-name (find-package impl-name))
+    (setf parent
+	  (get-charm-parent
+	   (make-charm-parent-identifier impl-name parent)))
+    ;; FIXME: probable should turn timestamps into objects
+    (list parent ext-properties int-properties owner version
+	  creation-timestamp deletion-timestamp)))
+
+(defun %get-constituent-particles (constituent-identifier parent
+				   database)
+  (let ((particle-rows (clsql:query (concatenate 'string "
+SELECT particle_id, version_added, version_removed
+FROM charm_constituent_particles
+WHERE constituent_id = " (princ-to-string
+			  (id constituent-identifier)))
+	       :database database
+	       :flatp t
+	       :field-names nil)))
+    (%init-particle-rows particle-rows parent)))
+
+;; (defun %init-particle-rows (particle-rows impl-package)
+;;   (loop for row in particle-rows
+;;      collect (make-charm-particle-identifier impl-package (car row))
+;;      into particles
+;;      finally (return particles)))
+
+(defun %init-particle-rows (particle-rows parent)
+  (select-events-by-ids parent
+			(loop for row in particle-rows
+			   collect (car row)
+			   into ids
+			   finally (return ids))))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/base/database/charm/database-setup.lisp	Thu Sep 30 15:35:15 2010 +0100
@@ -0,0 +1,100 @@
+(cl:in-package #:amuse-charm)
+
+;;;=====================================================================
+;;; CHARM database setup functions
+;;;=====================================================================
+
+(defun create-charm-db-tables (database)
+  (%create-constituent-header-table database)
+  (%create-constituent-particle-table database)
+  (%create-constituent-stored-routines database))
+
+(defun drop-charm-db-tables (database)
+  (%drop-constituent-header-table database)
+  (%drop-constituent-particle-table database)
+  (%drop-constituent-stored-routines database))
+
+
+;;;=====================================================================
+;;; Helper functions
+;;;=====================================================================
+
+(defun %create-constituent-header-table (database)
+  (clsql:execute-command "
+CREATE TABLE charm_constituent_headers (
+constituent_id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY,
+implementation_id SMALLINT UNSIGNED NOT NULL,
+parent_id INT UNSIGNED NOT NULL,
+#start_time INTEGER UNSIGNED NOT NULL,
+#duration INTEGER UNSIGNED NOT NULL,
+ext_properties VARCHAR(255) NOT NULL,
+int_properties VARCHAR(255) NOT NULL,
+owner CHAR(16) NULL,
+version SMALLINT UNSIGNED NOT NULL DEFAULT 1,
+creation_timestamp TIMESTAMP NULL,
+deletion_timestamp TIMESTAMP NULL,
+INDEX impl_comp_index (implementation_id, parent_id))
+engine = innodb;"
+			 :database database)
+  (%create-constituent-header-triggers database))
+
+(defun %create-constituent-header-triggers (database)
+  (clsql:execute-command "
+CREATE TRIGGER pre_insert BEFORE INSERT ON charm_constituent_headers
+FOR EACH ROW
+BEGIN
+SET NEW.owner = SUBSTRING_INDEX(USER(),'@',1);
+SET NEW.creation_timestamp = CURRENT_TIMESTAMP;
+#SET NEW.implementation_id = @current_impl;
+END;"
+			 :database database))
+
+(defun %create-constituent-particle-table (database)
+  (clsql:execute-command "
+CREATE TABLE charm_constituent_particles (
+constituent_id BIGINT UNSIGNED NOT NULL,
+particle_id BIGINT UNSIGNED NOT NULL,
+particle_type SET('e', 'c') NOT NULL,
+version_added SMALLINT UNSIGNED NOT NULL,
+version_removed SMALLINT UNSIGNED NULL,
+INDEX particle_index (constituent_id))
+engine = innodb;"
+			 :database database))
+
+(defun %drop-constituent-header-table (database)
+  (clsql:drop-table "charm_constituent_headers"
+		    :database database
+		    :if-does-not-exist :ignore))
+
+(defun %drop-constituent-particle-table (database)
+  (clsql:drop-table "charm_constituent_particles"
+		    :database database
+		    :if-does-not-exist :ignore))
+
+(defun %drop-constituent-stored-routines (database)
+  (clsql:execute-command "
+DROP FUNCTION constituent_header_exists"
+			 :database database))
+
+
+;;;=====================================================================
+;;; Other server-side routines
+;;;=====================================================================
+
+(defun %create-constituent-stored-routines (database)
+  (clsql:execute-command "
+CREATE FUNCTION constituent_header_exists (
+#start int unsigned,
+#dur int unsigned,
+impl_id SMALLINT UNSIGNED,
+par_id INT UNSIGNED,
+external varchar(255),
+intrinsic varchar(255))
+RETURNS boolean
+RETURN EXISTS(SELECT constituent_id
+FROM charm_constituent_headers
+WHERE implementation_id = impl_id
+AND parent_id = par_id
+AND ext_properties = external
+AND int_properties = intrinsic);"
+			 :database database))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/base/database/charm/functions.lisp	Thu Sep 30 15:35:15 2010 +0100
@@ -0,0 +1,33 @@
+(in-package #:amuse-charm)
+
+;;;=====================================================================
+;;; Helpful functions
+;;;=====================================================================
+
+(defun find-first-onset (events)
+  (reduce #'min events :key #'timepoint))
+
+(defun find-last-offset (events)
+  (reduce #'max events :key #'(lambda (event)
+				(timepoint (cut-off event)))))
+
+(defgeneric object->db-string (o))
+
+(defmethod object->db-string ((o charm-property-list))
+  (format nil "~S" (%list-slot-sequence-data o)))
+
+(defmethod object->db-string ((o event-identifier))
+  "This was an earlier approach, that was probably bad."
+  "e")
+
+(defmethod object->db-string ((o constituent-identifier))
+  "This was an earlier approach, that was probably bad."
+  "c")
+
+(defun recompute-constituent-timepoint (constituent)
+  (setf (timepoint constituent)
+	(reduce #'min constituent :key 'timepoint)))
+
+(defun recompute-constituent-duration (constituent)
+  (setf (duration constituent)
+	(reduce #'max constituent :key 'timepoint)))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/base/database/charm/generics.lisp	Thu Sep 30 15:35:15 2010 +0100
@@ -0,0 +1,15 @@
+(cl:in-package #:amuse-charm)
+
+(defgeneric id (object)
+  (:documentation "Generic id function."))
+
+(defgeneric make-charm-parent-identifier (implementation-package id))
+
+(defgeneric make-charm-particle-identifier (implementation-package id))
+
+;; (defgeneric %cache-charm-particles (implementation-package
+;; 				    charm-constituent))
+
+(defgeneric get-charm-particles (constituent-identifier ids parent))
+
+(defgeneric get-charm-parent (constituent-identifier))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/base/database/charm/methods.lisp	Thu Sep 30 15:35:15 2010 +0100
@@ -0,0 +1,91 @@
+(cl:in-package #:amuse-charm)
+
+;;;=====================================================================
+;;; identifiers
+;;;=====================================================================
+
+(defmethod id ((o constituent-identifier))
+  (constituent-id o))
+
+(defmethod id ((o constituent))
+  (constituent-id (identifier o)))
+
+(defmethod id ((o event-identifier))
+  (event-id o))
+
+(defmethod id ((o event))
+  (event-id o))
+
+(defmethod id ((o composition-identifier))
+  (composition-id o))
+
+(defmethod id ((o composition))
+  (composition-id o))
+
+
+;;;=====================================================================
+;;; Specialised constructors
+;;;=====================================================================
+
+(defmethod make-charm-parent-identifier ((implementation
+					  (eql *package*)) id)
+  "A Charm constituent parent in this context is just another Charm
+constituent, i.e. a constituent has been defined which as a subset of
+another (parent) constituent."
+  (make-charm-constituent-identifier id))
+
+(defmethod make-charm-parent-identifier ((implementation
+					  (eql (find-package
+						"AMUSE-GEERDES"))) id)
+  "FIXME: This should be in amuse-geerdes"
+  (amuse-geerdes::g-id-file-id id))
+
+(defmethod make-charm-particle-identifier ((impl-package
+					    (eql *package*)) id)
+  "A CHARM particle in this context is just another CHARM constituent,
+i.e. a constituent has been defined which is the union of other
+previously defined constituents."
+  (make-charm-constituent-identifier id))
+
+(defmethod make-charm-particle-identifier ((impl-package
+					    (eql (find-package
+						  "AMUSE-GEERDES")))
+					   id)
+  "FIXME: This should be in amuse-geerdes"
+  (amuse-geerdes::make-geerdes-event-identifier id))
+
+(defmethod get-charm-particles (constituent-identifier ids
+				 (parent amuse-geerdes::composition))
+  "FIXME: This should be in amuse-geerdes"
+  (amuse-geerdes::select-events-by-ids parent ids))
+
+(defmethod get-charm-parent ((constituent-identifier
+			      amuse-geerdes::constituent-identifier))
+  (amuse-geerdes::get-composition constituent-identifier))
+
+;; (defmethod %cache-charm-particles ((impl-package (eql *package*))
+;; 				   constituent)
+;;   "hierarchy of constituents not yet implemented!")
+
+;; (defmethod %cache-charm-particles ((impl-package (eql (find-package
+;; 						       "AMUSE-GEERDES")))
+;; 				   constituent)
+;;   "FIXME: This should be in amuse-geerdes. This relies on identifier
+;; and particles being in the same order! Better to have generic
+;; functions within each implementation that can take a list of event
+;; identifiers and return a list of events from the database? Or maybe
+;; better still to make compositions proper CHARM constituents so that we
+;; can use 'make-sequence-like'?"
+;;   (let ((composition (amuse-geerdes::get-composition
+;; 		      (parent-identifier constituent))))
+;;     (loop with events = (%list-slot-sequence-data composition)
+;;        for identifier in (%list-slot-sequence-data constituent)
+;;        for event = (loop for events-head on events
+;; 		      until (eq (event-id (car events-head))
+;; 				(event-id identifier))
+;; 		      finally (progn (setf events events-head)
+;; 				     (return (car events-head))))
+;;        collect event into cached-events
+;;        finally (progn (setf (particle-cache constituent)
+;; 			    cached-events)
+;; 		      (return constituent)))))

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/base/database/charm/package.lisp	Thu Sep 30 15:35:15 2010 +0100
@@ -0,0 +1,14 @@
+(cl:defpackage #:amuse-charm
+  (:use #:common-lisp #:amuse #:amuse-database-admin)
+  (:export #:make-charm-constituent
+	   #:make-charm-constituent-identifier
+	   #:make-charm-property-list
+	   #:composition->charm-constituent
+	   #:make-onset-segment-constituent
+	   #:store-charm-constituent
+	   #:get-charm-constituent
+	   #:get-charm-parent
+	   #:get-charm-particles
+	   #:cache-charm-particles
+	   #:group-by-onset
+	   ))