# HG changeset patch # User Jamie Forth # Date 1298546598 0 # Node ID b5ffec94ae6dd148e244699c6471951904795dea # Parent b518b9f904e3f89edd71e9cc1f9233f0fa23c4ae some very sketchy Charm constituent code diff -r b518b9f904e3 -r b5ffec94ae6d amuse-charm.asd --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/amuse-charm.asd Thu Feb 24 11:23:18 2011 +0000 @@ -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") + )))))) diff -r b518b9f904e3 -r b5ffec94ae6d base/charm/classes.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/base/charm/classes.lisp Thu Feb 24 11:23:18 2011 +0000 @@ -0,0 +1,117 @@ +(cl:in-package #:amuse-charm) + +;;;===================================================================== +;;; Charm-constituents - experimental implementation +;;;===================================================================== + +;;; This aims to bolt on Charm compliance (including database +;;; versioning) 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 +;;; +;;; Many things I don't like about this. Using the class hiererchly +;;; for these kinds of properties might be nicer. +;;;===================================================================== + +(defclass charm-property-list (amuse-object list-slot-sequence) ()) + +;;; Or should the lists themselves be typed? + +;; (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 the constituent + identifier containing the constituent's database ID, + which is 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 + :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.")) + +(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) + (declare (ignore new-value)) + (amuse::%recompute-standard-composition-period object)) + +(defclass standard-charm-event-constituent (standard-charm-constituent) + () + (:documentation "Base class for constituents using standard time + representation.")) diff -r b518b9f904e3 -r b5ffec94ae6d base/charm/constructors.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/base/charm/constructors.lisp Thu Feb 24 11:23:18 2011 +0000 @@ -0,0 +1,125 @@ +(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))) diff -r b518b9f904e3 -r b5ffec94ae6d base/charm/database-functions.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/base/charm/database-functions.lisp Thu Feb 24 11:23:18 2011 +0000 @@ -0,0 +1,223 @@ +(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 +specify 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 parent) + (let ((impl-package (implementation-package parent))) + (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) +;; "An alternative to above - would select-events-by-ids be useful?" +;; (select-events-by-ids parent +;; (loop for row in particle-rows +;; collect (car row) +;; into ids +;; finally (return ids)))) diff -r b518b9f904e3 -r b5ffec94ae6d base/charm/database-setup.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/base/charm/database-setup.lisp Thu Feb 24 11:23:18 2011 +0000 @@ -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)) diff -r b518b9f904e3 -r b5ffec94ae6d base/charm/example/eg-constituent-constructors.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/base/charm/example/eg-constituent-constructors.lisp Thu Feb 24 11:23:18 2011 +0000 @@ -0,0 +1,128 @@ +(cl:in-package #:amuse-geerdes) + +;;; The idea of Charm constituents here is closely tied up with the +;;; database. The basic constructors below will work without a working +;;; database, but obviously not the store and get stuff. + +(asdf:oos 'asdf:load-op 'amuse-geerdes) +(asdf:oos 'asdf:load-op 'geerdes-tools) +(asdf:oos 'asdf:load-op 'amuse-charm) +(use-package 'amuse-charm) + +(defparameter *charm-database* ; just for testing + (connect-to-database :database-name "amuse_charm" + :username "jamie" + :make-default nil)) +(disconnect-from-database *charm-database*) + +(connect-to-database) ; default amuse connection for getting geerdes data +(disconnect-from-database) + +;(create-charm-db-tables *charm-database*) +;(drop-charm-db-tables *charm-database*) + +(defparameter *composition* + (get-composition (g-id-file-id 1))) + +(defparameter *charm-constituent-composition* + (composition->charm-constituent *composition* + (make-charm-property-list + 'composition) + (make-charm-property-list + 'polyphonic))) + +(defparameter *charm-constituent-composition-identifier* + (store-charm-constituent *charm-constituent-composition* + *charm-database*)) + +(defparameter *charm-constituent-composition-db* + (get-charm-constituent *charm-constituent-composition-identifier* + *charm-database*)) + + +;;; Slice composition into segments + +(defparameter *onset-segments-constituent* + (make-onset-segment-constituent *composition*)) + +(defparameter *onset-segment-constituent-identifier* + (store-charm-constituent *onset-segments-constituent* + *charm-database*)) + +(defparameter *charm-constituent-composition-db* + (get-charm-constituent *onset-segment-constituent-identifier* ;1922 + *charm-database*)) + +;;; Bar segments + +(defparameter *bar-segments-constituent* + (segment-at-bar *composition*)) + + +;;; Part-like constituents. + +(defparameter *lead-vocals* + (geerdes-tools:vocal-part *composition*)) + +(defparameter *charm-vocals* + (composition->charm-constituent *lead-vocals* + (make-charm-property-list 'voice + 'monophonic) + (make-charm-property-list 'song))) + +(defparameter *charm-vocals-identifier* + (store-charm-constituent *charm-vocals* *charm-database*)) + +(defparameter *charm-vocals-db* + (get-charm-constituent *charm-vocals-identifier* + *charm-database*)) + +(defparameter *bass-guitar* + (geerdes-tools:bass-part *composition*)) + +(defparameter *charm-bass* + (composition->charm-constituent *bass-guitar* + (make-charm-property-list 'guitar + 'polyphonic) + (make-charm-property-list 'song))) + +(defparameter *charm-bass-identifier* + (store-charm-constituent *charm-bass* *charm-database*)) + +(defparameter *charm-bass-db* + (get-charm-constituent *charm-bass-identifier* *charm-database*)) + + +;;; Combine above as events. + +(defparameter *bass+vocals-constituent1* + (make-standard-charm-constituent + (append (%list-slot-sequence-data *charm-bass*) + (%list-slot-sequence-data *charm-vocals*)) *composition* + (make-charm-property-list 'vocal 'bass-guitar 'polyphonic) + (make-charm-property-list 'song))) + +(defparameter *bass+vocals-constituent1-identifier* + (store-charm-constituent *bass+vocals-constituent1* *charm-database*)) + +(defparameter *bass+vocals-constituent1-db* + (get-charm-constituent *bass+vocals-constituent1-identifier* + *charm-database*)) + + +;;; Combine above as constituents + +(defparameter *bass+vocals-constituent2* + (make-standard-charm-constituent + (list *charm-bass* *charm-vocals*) + *composition* + (make-charm-property-list 'vocal 'bass-guitar 'polyphonic) + (make-charm-property-list 'song))) + +(defparameter *bass+vocals-constituent2-identifier* + (store-charm-constituent *bass+vocals-constituent2* + *charm-database*)) + +(defparameter *bass+vocals-constituent2-db* + (get-charm-constituent *bass+vocals-constituent2-identifier* + *charm-database*)) diff -r b518b9f904e3 -r b5ffec94ae6d base/charm/functions.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/base/charm/functions.lisp Thu Feb 24 11:23:18 2011 +0000 @@ -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))) diff -r b518b9f904e3 -r b5ffec94ae6d base/charm/generics.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/base/charm/generics.lisp Thu Feb 24 11:23:18 2011 +0000 @@ -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)) diff -r b518b9f904e3 -r b5ffec94ae6d base/charm/methods.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/base/charm/methods.lisp Thu Feb 24 11:23:18 2011 +0000 @@ -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))))) diff -r b518b9f904e3 -r b5ffec94ae6d base/charm/package.lisp --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/base/charm/package.lisp Thu Feb 24 11:23:18 2011 +0000 @@ -0,0 +1,15 @@ +(cl:defpackage #:amuse-charm + (:use #:common-lisp #:amuse #:amuse-database-admin) + (:export #:make-standard-charm-constituent + #:make-charm-constituent-identifier + #:make-charm-property-list + #:composition->charm-constituent + #:make-onset-segment-constituent + #:segment-at-bar + #:store-charm-constituent + #:get-charm-constituent + #:get-charm-parent + #:get-charm-particles + #:cache-charm-particles + #:group-by-onset + ))