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