comparison base/charm/database-functions.lisp @ 253:b5ffec94ae6d

some very sketchy Charm constituent code

+(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))))