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