;;;; Copyright (C) 2006-2008 David Patrick Mullen
;;;;
;;;; This file is part of Kira.
;;;;
;;;; Kira is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License
;;;; as published by the Free Software Foundation; either version 2
;;;; of the License, or (at your option) any later version.
;;;;
;;;; Kira is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with Kira; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.

(in-package :odb)

(defvar +inline-count+ 32)
(defvar *print-id* t)
(defvar *make-proxy* nil)
(defvar *reify* t)
(defvar *mark* t)
(defvar *database* nil)
(defvar *transaction* nil)
(defvar *dummy-transaction* nil)
(defvar *btrees* nil)
(defvar *id* nil)
(defvar *lock* (make-lock :name "read"))
(defvar *update-lock* (make-lock :name "update"))
(defvar *keys* nil)

(defclass transaction ()
  ((handle :accessor handle :initarg :handle :initform 0)
   (cached-objects :accessor cached-objects :initarg :cached-objects :initform (cached-objects *transaction*))
   (deleted-objects :accessor deleted-objects :initform nil)
   (dirty-objects :accessor dirty-objects :initform nil)))

(defclass database-object ()
  ((id :accessor id :initarg :id :initform nil)))

(defclass proxy (database-object)
  ())

(defclass node (database-object)
  ((dirtyp :accessor dirtyp :initform nil)))

(defclass database ()
  ((handle :accessor handle :initarg :handle :initform 0)))

(defclass main-database (database)
  ())

(defclass btree (database-object)
  ((dirtyp :accessor dirtyp :initform nil)
   (new-objects :accessor new-objects :initform nil)
   (new-kv-pairs :accessor new-kv-pairs :initform nil)
   (removed-keys :accessor removed-keys :initform nil)))

(defclass oblist ()
  ((new-objects :accessor new-objects :initform nil)
   (new-kv-pairs :accessor new-kv-pairs :initform nil)))

(defclass collection-wrapper ()
  ((collection :accessor collection :initarg :collection :initform nil)))

(defclass cursor ()
  ((handle :accessor handle :initarg :handle :initform 0)))

(defclass database-cursor (cursor)
  ())

(defclass btree-cursor (cursor)
  ((id :accessor id :initarg :id :initform nil)
   (initialized-p :accessor cursor-initialized-p :initform nil)))

(defmacro with-database ((&key &allow-other-keys) &body body)
  `(with-lock (*lock* :read)
     (db-init)
     (let* ((*database* (make-instance 'main-database :handle (db-open "objects.db" :key-type 'integer)))
	    (*btrees* (make-instance 'database :handle (db-open "btrees.db")))
	    (*dummy-transaction* (make-instance 'transaction))
	    (*transaction* *dummy-transaction*))
       (unwind-protect (progn ,@body)
	 (db-close (handle *btrees*))
	 (db-close (handle *database*))
	 (db-finish)))))

(defun fresh-id ()
  (if *id*
      (incf *id*)
      (setf *id*
            (with-cursor (cursor *database*)
              (multiple-value-bind (present-p key) (cursor-last cursor)
                (if present-p (1+ key) 0))))))

(defun odb-get (database key)
  (db-get
   (handle database)
   (let ((*print-id* :bare))
     (prin1-to-string key))))

(defun odb-put (database key value)
  (db-put
   (handle database)
   (let ((*print-id* :bare))
     (prin1-to-string key))
   (let ((*print-id* t))
     (prin1-to-string value))))

(defun odb-cursor-move (cursor flags &optional (key cursor))
  (db-cursor-move
   (handle cursor)
   flags
   (unless (eq key cursor)
     (let ((*print-id* :bare))
       (prin1-to-string key)))))

(defun datum->object (&optional (datum *db-value*))
  (string-to-object (copy-seq datum)))

(defun commit (&optional (transaction *transaction*))
  (with-lock (*lock* nil)
    (with-lock (*lock* :write)
      (dolist (object (dirty-objects transaction))
        (unless (id object)
          (setf (id object) (fresh-id))))
      (dolist (object (dirty-objects transaction))
        (when (typep object 'btree)
	  (let ((*print-id* t))
	    (let ((*print-id* :bare))
	      (loop for k in (removed-keys object)
		    do (db-delete (handle *btrees*) (prin1-to-string (cons (id object) k)))))
	    (loop for new-object in (new-objects object)
		  do (odb-put *btrees* (cons (id object) (id new-object)) new-object))
	    (loop for (k . v) in (new-kv-pairs object)
		  do (odb-put *btrees* (cons (id object) k) v))))
	(let ((*print-id* nil))
	  (odb-put *database* (id object) object))
	(let ((*mark* nil))
	  (setf (dirtyp object) nil)))
      (dolist (id (deleted-objects transaction))
        (db-delete (handle *database*) (prin1-to-string id)))
      (db-sync (handle *database*))
      (db-sync (handle *btrees*))))
  (setf (dirty-objects transaction)
	'()))

(defun rollback (&optional (transaction *transaction*))
  (let ((*mark* nil))
    (dolist (object (dirty-objects transaction))
      (setf (dirtyp object) nil)))
  (setf (dirty-objects transaction)
	'()))

(defmethod cached-objects ((transaction null))
  (make-hash-table))

(defmacro cached-object (id object)
  (rebinding (id object)
    `(or (gethash ,id (cached-objects *transaction*))
         (setf (gethash ,id (cached-objects *transaction*))
	       ,object))))

(defun reload-cached-objects (&optional (transaction *transaction*))
  (loop for object being the hash-values
	of (cached-objects transaction) do
        (change-class object 'proxy)
        (reify object)))

(defun execute-transaction (fn args)
  (if (eq *transaction* *dummy-transaction*)
      (let ((*transaction* (make-instance 'transaction)))
	(with-lock (*lock* nil)
	  (with-lock (*update-lock* :write)
	    (with-lock (*lock* :read)
	      (multiple-value-prog1
		  (progn
		    (reload-cached-objects)
		    (apply fn args))
		(commit))))))
      ;; Already in a transaction.
      (apply fn args)))

(defmacro with-transaction ((&key &allow-other-keys) &body body)
  `(execute-transaction #'(lambda () ,@body)))

(defmacro deftransaction (name lambda-list &body body)
  (with-unique-names (fn)
    `(progn
       (defun ,fn ,lambda-list
	 ,@body)
       (defun ,name (&rest args)
	 (execute-transaction #',fn args)))))

(defmethod get-value (key (database main-database))
  (when (odb-get database key)
    (whereas ((object (cached-object key (datum->object))))
      (values (reify object) t))))

(defmethod get-value (key (database database))
  (when (odb-get database key)
    (values (reify (datum->object)) t)))

(defmethod get-value (key (btree btree))
  (let ((cons (assoc key (new-kv-pairs btree) :test #'equal-for-lookup)))
    (if cons
        (values (cdr cons) t)
        (get-value (cons (id btree) key) *btrees*))))

(defmethod get-value (key (list list))
  (whereas ((cons (assoc key list :test #'equal-for-lookup)))
    (values (cdr cons) t)))

(defmethod get-value (key (oblist oblist))
  (get-value key (new-kv-pairs oblist)))

(defmethod get-value (key (w collection-wrapper))
  (get-value key (collection w)))

(defmethod (setf get-value) (value key (btree btree))
  (prog1 (touch btree)
    (let ((cons (assoc key (new-kv-pairs btree) :test #'equal-for-lookup)))
      (if cons
	  (setf (cdr cons) value)
	  (push (cons key value) (new-kv-pairs btree))))
    (when (member key (removed-keys btree) :test #'equal-for-lookup)
      (setf (removed-keys btree) (delete key (removed-keys btree) :test #'equal-for-lookup)))))

(defmethod (setf get-value) (value key (w collection-wrapper))
  (setf (get-value key w) value))

(defmethod map-with-new-kv ((btree btree) k v)
  (prog1 btree
    (setf (get-value k btree) v)))

(defmethod map-with-new-kv ((oblist oblist) k v)
  (let ((cons (assoc k (new-kv-pairs oblist) :test #'equal-for-lookup)))
    (if cons
        (setf (cdr cons) v)
        (push (cons k v) (new-kv-pairs oblist))))
  (if (<= (length (new-kv-pairs oblist)) +inline-count+)
      oblist
      (let ((btree (make-instance 'btree)))
        (setf (new-kv-pairs btree) (new-kv-pairs oblist))
        btree)))

(defmethod map-with-new-kv ((list list) k v)
  (let ((map (make-instance (if (>= (length list) +inline-count+) 'btree 'oblist))))
    (setf (new-kv-pairs map) (copy-list list))
    (map-with-new-kv map k v)))

(defmethod map-with-new-kv ((w collection-wrapper) k v)
  (prog1 w
    (setf (collection w) (map-with-new-kv (collection w) k v))))

(defmethod map-without-kv ((btree btree) k)
  (prog1 (touch btree)
    (whereas ((cons (assoc k (new-kv-pairs btree) :test #'equal-for-lookup)))
      (setf (new-kv-pairs btree) (delete cons (new-kv-pairs btree))))
    (pushnew k (removed-keys btree) :test #'equal-for-lookup)))

(defmethod map-without-kv ((oblist oblist) k)
  (prog1 oblist
    (whereas ((cons (assoc k (new-kv-pairs oblist) :test #'equal-for-lookup)))
      (setf (new-kv-pairs oblist) (delete cons (new-kv-pairs oblist))))))

(defmethod map-without-kv ((list list) k)
  (remove k list :test #'equal-for-lookup :key #'car))

(defmethod map-without-kv ((w collection-wrappr) k)
  (prog1 w
    (setf (collection w) (map-without-kv (collection w) k))))

(defun unique-key (key unique-value)
  (or (loop for kv in *keys*
	    when (and (equal-for-lookup (car kv) key) (eq (cdr kv) unique-value))
	    return cons)
      (let ((kv (cons key unique-value)))
	(prog1 kv
	  (push kv *keys*)))))

(defun .map-with-new-kv (map k v &key allow-dup-p)
  (map-with-new-kv map (if allow-dup-p (unique-key k v) k) v))

(defun .map-without-kv (map k v &key allow-dup-p)
  (map-without-kv map (if allow-dup-p (unique-key k v) k)))

(define-modify-macro add-kv (&rest args) .map-with-new-kv)
(define-modify-macro remove-kv (&rest args) .map-without-kv)

(defmethod collection-with-new-object ((btree btree) object)
  (prog1 (touch btree)
    (pushnew object (new-objects btree))
    (when (and (id object) (member (id object) (removed-keys btree)))
      (setf (removed-keys btree) (delete (id object) (removed-keys btree))))))

(defmethod collection-with-new-object ((oblist oblist) object)
  (pushnew object (new-objects oblist))
  (if (<= (length (new-objects oblist)) +inline-count+)
      oblist
      (let ((btree (make-instance 'btree)))
        (setf (new-objects btree) (new-objects oblist))
        btree)))

(defmethod collection-with-new-object ((list list) object)
  (let ((collection (make-instance (if (>= (length list) +inline-count+) 'btree 'oblist))))
    (setf (new-objects collection) (copy-list list))
    (pushnew object (new-objects collection))
    collection))

(defmethod collection-with-new-object ((w collection-wrapper) object)
  (prog1 w
    (setf (collection w) (collection-with-new-object (collection w) object))))

(defmethod collection-without-object ((btree btree) object)
  (prog1 (touch btree)
    (when (find object (new-objects btree))
      (setf (new-objects btree) (delete object (new-objects btree))))
    (when (id object)
      (pushnew (id object) (removed-keys btree)))))

(defmethod collection-without-object ((oblist oblist) object)
  (prog1 oblist
    (setf (new-objects oblist) (delete object (new-objects oblist)))))

(defmethod collection-without-object ((list list) object)
  (remove object list))

(defmethod collection-without-object ((w collection-wrapper) object)
  (prog1 w
    (setf (collection w) (collection-without-object (collection w) object))))

(define-modify-macro add-to (object) collection-with-new-object)
(define-modify-macro remove-from (object) collection-without-object)

(defmethod containsp ((btree btree) object)
  (get-value (id object) btree))

(defmethod containsp ((oblist oblist) object)
  (find object (new-objects oblist)))

(defmethod containsp ((list list) object)
  (find object list))

(defmethod containsp ((w collection-wrapper) object)
  (containsp (collection w) object))

(defmethod make-cursor ((database database))
  (make-instance 'database-cursor :handle (db-cursor (handle database))))

(defmethod make-cursor ((btree btree))
  (make-instance 'btree-cursor :handle (db-cursor (handle *btrees*)) :id (id btree)))

(defmethod cursor-move ((cursor database-cursor) flags &optional (key cursor))
  (when (odb-cursor-move cursor flags key)
    (let ((id (datum->object *db-key*)))
      (values t id (reify (cached-object id (datum->object)))))))

(defmethod cursor-move ((cursor btree-cursor) flags &optional (key cursor))
  (when (odb-cursor-move cursor flags (if (eq key cursor) cursor (cons (id cursor) key)))
    (values t (datum->object *db-key*) (datum->object))))

(defmethod cursor-current ((cursor cursor))
  (cursor-move cursor DB_CURRENT))

(defmethod cursor-prev ((cursor database-cursor))
  (cursor-move cursor DB_PREV))

(defmethod cursor-next ((cursor database-cursor))
  (cursor-move cursor DB_NEXT))

(defmethod cursor-first ((cursor database-cursor))
  (cursor-move cursor DB_FIRST))

(defmethod cursor-last ((cursor database-cursor))
  (cursor-move cursor DB_LAST))

(defmethod cursor-set ((cursor database-cursor) key)
  (cursor-move cursor DB_SET key))

(defmethod cursor-set-range ((cursor database-cursor) key)
  (cursor-move cursor DB_SET_RANGE key))

(defmethod cursor-prev ((cursor btree-cursor))
  (if (cursor-initialized-p cursor)
      (multiple-value-bind (present-p key value) (cursor-move cursor DB_PREV)
        (if (and present-p (= (car key) (id cursor)))
            (values t (cdr key) value)
            (setf (cursor-initialized-p cursor) nil)))
      (cursor-last cursor)))

(defmethod cursor-next ((cursor btree-cursor))
  (if (cursor-initialized-p cursor)
      (multiple-value-bind (present-p key value) (cursor-move cursor DB_NEXT)
        (if (and present-p (= (car key) (id cursor)))
            (values t (cdr key) value)
            (setf (cursor-initialized-p cursor) nil)))
      (cursor-first cursor)))

(defmethod cursor-first ((cursor btree-cursor))
  (multiple-value-bind (present-p key value) (cursor-move cursor DB_SET_RANGE nil)
    (if (and present-p (= (car key) (id cursor)))
        (progn
          (setf (cursor-initialized-p cursor) t)
          (values t (cdr key) value))
        (setf (cursor-initialized-p cursor) nil))))

(defmethod cursor-last ((cursor btree-cursor))
  (if (odb-cursor-move cursor DB_SET_RANGE (cons (1+ (id cursor)) nil))
      (progn
        (setf (cursor-initialized-p cursor) t)
        (cursor-prev cursor))
      (multiple-value-bind (present-p key value) (cursor-move cursor DB_LAST)
        (if (and present-p (= (car key) (id cursor)))
            (progn
              (setf (cursor-initialized-p cursor) t)
              (values t (cdr key) value))
            (setf (cursor-initialized-p cursor) nil)))))

(defmethod cursor-set ((cursor btree-cursor) key)
  (multiple-value-bind (present-p found-key value) (cursor-move cursor DB_SET key)
    (if present-p
        (progn
          (setf (cursor-initialized-p cursor) t)
          (values t (cdr found-key) value))
        (setf (cursor-initialized-p cursor) nil))))

(defmethod cursor-set-range ((cursor btree-cursor) key)
  (multiple-value-bind (present-p found-key value) (cursor-move cursor DB_SET_RANGE key)
    (if (and present-p (= (car found-key) (id cursor)))
        (progn
          (setf (cursor-initialized-p cursor) t)
          (values t (cdr found-key) value))
        (setf (cursor-initialized-p cursor) nil))))

(defmacro with-cursor ((cursor btree) &body body)
  `(let ((,cursor (make-cursor ,btree)))
     (unwind-protect
       (progn ,@body)
       (db-cursor-close (handle ,cursor)))))

(defmethod initialize-instance :after ((node node) &key &allow-other-keys)
  (when *mark* (touch node)))

(defmethod initialize-instance :after ((btree btree) &key &allow-other-keys)
  (when *mark* (touch btree)))

(defmethod reify ((object t))
  object)

(defmethod reify ((cons cons))
  (if (sometree #'(lambda (x) (typep x 'proxy)) object)
      (let ((car (reify (car object)))
	    (cdr (reify (cdr object))))
	(if car
	    (cons car cdr)
	    cdr))
      cons))

(defmethod reify ((object proxy))
  (when (and (odb-get *database* (id object))
	     (>= (length *db-value*) 5))
    (with-input-from-string (stream (copy-seq *db-value*) :start (1+ (position #\( *db-value*)))
      (let ((*package* (find-package :kira))
	    (*mark* nil)
	    (*make-proxy* t))
	(whereas ((class-name (read stream nil nil))
		  (initargs (read-delimited-list #\) stream)))
	  (change-class object class-name)
	  (apply #'initialize-instance object initargs)
	  object)))))

(defmethod slot-value-using-class :around (class (node node) slot)
  (whereas ((value (call-next-method)))
    (if *reify*
        (reify value)
        value)))

(defun touch (object)
  (prog1 object
    (when (and (slot-boundp object 'dirtyp) (not (dirtyp object)))
      (let ((*mark* nil))
	(push object (dirty-objects *transaction*))
	(setf (dirtyp object) t)))))

(defmethod (setf slot-value-using-class) :after (new-value class (node node) slot)
  (declare (ignore new-value class slot))
  (when *mark* (touch node)))

(defun read-object (stream char arg)
  (declare (ignore char arg))
  (let ((*package* (find-package :kira))
        (*make-proxy* t)
        (*mark* nil))
    (apply #'make-instance (read stream))))

(defmethod print-object ((oblist oblist) stream)
  (prin1
   (if (new-kv-pairs oblist)
       (sort (new-kv-pairs oblist) #'less-than-for-lookup :key #'car)
       (sort (new-objects oblist) #'< :key #'id))
   stream))

(defmethod print-object ((w collection-wrapper) stream)
  (prin1 (collection w) stream))

(defmethod print-object ((object standard-object) stream)
  (let ((class (class-of object))
        (*package* (find-package :kira)))
    (if (and *print-id*
             (slot-exists-p object 'id)
             (slot-boundp object 'id)
             (slot-value object 'id))
        (progn
          (unless (eq *print-id* :bare)
            (write-string "#i" stream))
          (princ (slot-value object 'id) stream))
        (progn
          (format stream "#S(~S" (class-name class))
          (dolist (slot (class-slots class))
            (let ((name (slot-definition-name slot))
                  (initargs (slot-definition-initargs slot))
                  (*print-id* t)
                  (*reify* nil))
              (when (and initargs (slot-boundp object name))
                (let ((value (slot-value object name))
                      (initfunction (slot-definition-initfunction slot)))
                  (unless (and initfunction (equal value (funcall initfunction)))
                    (format stream " ~S ~S" (first initargs) value))))))
          (write-char #\) stream)))))

(defun read-oid (stream char arg)
  (declare (ignore char arg))
  (let ((id (read stream)))
    (if *make-proxy*
        (cached-object id (make-instance 'proxy :id id))
        (oid->object id))))

(set-dispatch-macro-character #\# #\s 'read-object)
(set-dispatch-macro-character #\# #\S 'read-object)
(set-dispatch-macro-character #\# #\i 'read-oid)
(set-dispatch-macro-character #\# #\I 'read-oid)

(defun oid->object (oid)
  (nth-value 0 (get-value oid *database*)))

(defmethod compare-objects ((a database-object) (b database-object))
  (compare (id a) (id b)))

(defmethod compare-objects ((a integer) (b database-object))
  (compare a (id b)))

(defmethod compare-objects ((a database-object) (b integer))
  (compare (id a) b))