annotate base/database/charm/database-functions.lisp @ 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.

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