(in-package :graph-db)

(alexandria:define-constant +node-header-size+ 15)

(defgeneric node-p (thing)
  (:method ((thing node)) t)
  (:method (thing) nil))

(defmethod print-object ((node node) stream)
  (format stream "#<~A ~S REV ~S>"
          (type-of node) (string-id (id node))
          (revision node)))

(defmethod flags-as-int ((n node))
  (let ((flags 0))
    (when (slot-value n 'deleted-p)
      (setq flags (dpb 1 (byte 1 0) flags)))
    (when (slot-value n 'written-p)
      (setq flags (dpb 1 (byte 1 1) flags)))
    (when (slot-value n 'heap-written-p)
      (setq flags (dpb 1 (byte 1 2) flags)))
    (when (slot-value n 'type-idx-written-p)
      (setq flags (dpb 1 (byte 1 3) flags)))
    (when (slot-value n 'views-written-p)
      (setq flags (dpb 1 (byte 1 4) flags)))
    (when (slot-value n 've-written-p)
      (setq flags (dpb 1 (byte 1 5) flags)))
    (when (slot-value n 'vev-written-p)
      (setq flags (dpb 1 (byte 1 6) flags)))
    flags))

(defmethod save-node-flags ((table lhash) (node node))
  (lhash-custom-update table
                       (lambda (mf offset)
                         (let ((flags (flags-as-int node)))
                           (set-byte mf offset flags)))
                       (id node)))

(defun serialize-node-head (mf n offset)
  ;; flags: deleted-p, written-p
  (let ((flags (flags-as-int n)))
    (set-byte mf offset flags))
  ;; type-id
  (dotimes (i 2)
    (set-byte mf (incf offset) (ldb (byte 8 (* i 8)) (type-id n))))
  ;; revision
  (dotimes (i 4)
    (set-byte mf (incf offset) (ldb (byte 8 (* i 8)) (revision n))))
  ;; data-pointer
  (dotimes (i 8)
    (set-byte mf (incf offset) (ldb (byte 8 (* i 8)) (data-pointer n))))
  offset)

(defun deserialize-node-head (mf offset)
  (let ((flags (get-byte mf offset)))
    (values
     (ldb-test (byte 1 0) flags) ;; deleted-p
     (ldb-test (byte 1 1) flags) ;; written-p
     (ldb-test (byte 1 2) flags) ;; heap-written-p
     (ldb-test (byte 1 3) flags) ;; type-idx-written-p
     (ldb-test (byte 1 4) flags) ;; views-written-p
     (ldb-test (byte 1 5) flags) ;; ve-written-p
     (ldb-test (byte 1 6) flags) ;; vev-written-p
     (let ((int 0)) ;; type-id
       (declare (type (integer 0 65535) int))
       (dotimes (i 2)
         (setq int (dpb (get-byte mf (incf offset))
                        (byte 8 (* i 8)) int)))
       int)
     (let ((int 0)) ;; revision
       (declare (type (integer 0 4294967295) int))
       (dotimes (i 4)
         (setq int (dpb (get-byte mf (incf offset))
                        (byte 8 (* i 8)) int)))
       int)
     (let ((int 0)) ;; data-pointer
       #+sbcl (declare (type sb-ext:word int))
       (dotimes (i 8)
         (setq int (dpb (get-byte mf (incf offset))
                        (byte 8 (* i 8)) int)))
       int)
     offset)))

(defun finalize-node (node table graph)
  (setf (written-p node) t)
  (save-node-flags table node)
  (setf (gethash (id node) (cache graph)) node))

;;; FIXME: reenable when deallocation bug is fixed
;;; (declaim (inline maybe-init-node-data))
(defun maybe-init-node-data (node &key (graph *graph*))
  (when (> (data-pointer node) 0)
    (when (or (eq (bytes node) :init) (null (bytes node)))
      (let ((bytes (read-bytes (make-mpointer
                                :mmap (memory-mmap (heap graph))
                                :loc (data-pointer node)))))
        (when bytes
          (setf (data node)
                (deserialize bytes)
                (bytes node)
                bytes)))))
  node)

(defmethod lookup-node ((table lhash) (key array) (graph graph))
  (or (and *cache-enabled*
           (let ((node (gethash key (cache graph))))
             (when node
               (record-graph-read)
               node)))
      (let ((node (lhash-get table key)))
        (when (node-p node)
          (setf (id node) key)
          ;; we should wait to do this until we need the data.
          ;;(maybe-init-node-data node :graph graph)
          (when *cache-enabled*
            (setf (gethash key (cache graph)) node))
          (record-graph-read)
          node))))

(defun save-node (node table &key (graph *graph*))
  ;; you must copy the node before writing to its slots,
  ;; in case others are reading it!
  ;;(log:info "SAVING ~A" (string-id node))
  (let ((old-node nil))
    (when (plusp (data-pointer node))
      (if (data node)
          (setf (bytes node) (serialize (data node)))
          (maybe-init-node-data node :graph graph))
      (let ((addr (allocate (heap graph) (length (bytes node)))))
        (dotimes (i (length (bytes node)))
          (set-byte (heap graph)
                    (+ i addr) (aref (bytes node) i)))
        (setf (data-pointer node) addr)))
    (with-locked-hash-key (table (id node))
      ;; Assure that the old node is available in cache for readers
      (setq old-node (%lhash-get table (id node)))
      (setf (id old-node) (id node))
      ;;(log:info "~A OLD ADDRESS IS ~A" (string-id node) (data-pointer old-node))
( log : info " ~A NEW ADDRESS IS ~A " ( string - id node ) ( data - pointer node ) )
      (maybe-init-node-data old-node :graph graph)
      (setf (gethash (id old-node) (cache graph)) old-node)
      ;;(log:info "OLD REV OF ~A CACHED" (string-id old-node))
      ;; Make sure we are modifying the latest revision or bail
      (unless (= (revision node) (revision old-node))
        ;; Undo data slot saving
        (log:error "REVISION ERROR ~A: ~A /= ~A"
                   (string-id node) (revision node) (revision old-node))
        (when (/= 0 (data-pointer node))
          (free (heap graph) (data-pointer node)))
        (error 'stale-revision-error
               :current-revision (revision old-node)
               :instance (string-id node)))
      ;; Save our changes
  Do n't overflow the revision ( 32 bit int )
      (if (>= (revision node) 4294967295)
          (setf (revision node) 0)
          (incf (revision node)))
      ;;(log:info "UPDATING LHASH FOR ~A" (string-id node))
      (%lhash-update table (id node) node)
      ;;(log:info "RECORDING WRITE FOR ~A" (string-id node))
      (record-graph-write)
      ;;(log:info "CACHING NEW REV OF ~A" (string-id node))
      (setf (gethash (id node) (cache graph)) node))
    (when (/= 0 (data-pointer old-node))
      (let ((pointer (data-pointer old-node))
            ;;(old-id (string-id old-node))
            (heap (heap graph)))
( log : info " ~A FREEING ~A IN ~A " old - id pointer heap )
        (free heap pointer)
        ;; Remove from heap upon gc
        ;;(sb-ext:finalize old-node
        ;;                 (lambda ()
        ;;                   (let ((*package* (find-package :graph-db)))
        ;;                     (log:debug "~A FREEING ~A IN ~A" old-id pointer heap)
        ;;                     (free heap pointer))))
        ))
    ;;(log:info "SAVED ~A" (string-id node))
    (values node old-node)))

(defmethod string-id ((id array))
  (with-output-to-string (out)
    (map nil
         (lambda (byte)
           (format out "~(~2,'0X~)" byte))
         id)))

(defmethod string-id ((node node))
  (with-output-to-string (out)
    (map nil
         (lambda (byte)
           (format out "~(~2,'0X~)" byte))
         (id node))))

(defun node-to-alist (node &key slots)
  (maybe-init-node-data node)
  (remove-if (lambda (pair)
               (member (car pair) slots))
             (append (list (cons :id (string-id node)))
                     (copy-alist (data node)))))

(defun node-slot-value (node key &key (graph *graph*))
  ;;(log:info "GETTING ~A FOR ~A" key (string-id node))
  (maybe-init-node-data node :graph graph)
  (when (consp (data node))
    (cdr (assoc (if (keywordp key)
                    key
                    (intern (symbol-name key) :keyword))
                (data node)))))

(defsetf node-slot-value (node key) (value)
  (with-gensyms (pair keyword)
    `(if (typep ,value 'graph-db::node)
         (error "Cannot set ~A slots to objects with parent type NODE" (type-of ,node))
         (let ((,keyword (if (keywordp ,key)
                             ,key
                             (intern (symbol-name ,key) :keyword))))
           (maybe-init-node-data ,node)
           (cond ((null (data ,node))
                  (push (cons ,keyword ,value) (data ,node)))
                 ((consp (data ,node))
                  (let ((,pair (assoc ,keyword (data ,node))))
                    (if ,pair
                        (setf (cdr ,pair) ,value)
                        (push (cons ,keyword ,value) (data ,node)))))
                 (t
                  (error "Cannot set slot value when data slot is of type ~A"
                         (type-of (data ,node)))))))))

(defmethod slot-value-using-class :around ((class node-class) instance slot)
  "Around method that is alternate-version aware and will show values for the current,
   working private version of instance."
  (log:trace "slot-value-using-class~%  '~A'~%  '~A'" class (slot-definition-name slot))
  (let* (#+lispworks(slot (closer-mop::find-slot slot class))
         (slot-name (slot-definition-name slot))
         (slot-keyword-name (intern (symbol-name slot-name) :keyword)))
    (cond ((member slot-name (persistent-slot-names class))
           ;; FIXME: Check for txn and give current revision's value
           (node-slot-value instance slot-keyword-name))
          ((member slot-name (ephemeral-slot-names class))
           ;; FIXME: Check for txn and give current revision's value
           (call-next-method))
          ((member slot-name (meta-slot-names class))
           (call-next-method))
          (t
           (call-next-method)))))

(defmethod (setf slot-value-using-class) :around
    (new-value (class node-class) instance slot)
  "Is alternate-version aware and will update values for the current, working private
   version of instance."
( log : debug " setf slot - value - using - class~%   ' ~A'~%   ' ~A'~%   ' ~A ' " new - value class
  ;;(sb-pcl:slot-definition-name slot))
  (let* (#+lispworks(slot (closer-mop::find-slot slot class))
         (slot-name (slot-definition-name slot))
         (slot-keyword-name (intern (symbol-name slot-name) :keyword)))
    (cond ((member slot-name (persistent-slot-names class))
           ;; FIXME: Check for txn and handle
           (setf (node-slot-value instance slot-keyword-name) new-value))
          ((member slot-name (ephemeral-slot-names class))
           ;; FIXME: Check for txn and handle
           (call-next-method))
          ((member slot-name (meta-slot-names class))
           (call-next-method))
          (t
           (call-next-method)))))

(defgeneric node-equal (x y)
  (:method ((x node) (y node))
    (equalp (id x) (id y)))
  (:method (x y)
    nil))

(defmethod %hash ((key #.(class-of (make-array 16 :element-type '(unsigned-byte 8)))))
  (declare (optimize (speed 3) (safety 0)))
  (let ((int (aref key 0)))
    (loop
       for subscript from 1 to 15
       for shift from 8 by 8
       do
         (incf int (ash (logand (aref key subscript) #xFF) shift)))
    int))

(defun sxhash-node (node) (sxhash (%hash (id node))))
#+sbcl (sb-ext:define-hash-table-test node-equal sxhash-node)
(defun make-node-table (&key weakness synchronized)
  #+ccl
  (make-hash-table :test 'node-equal
                   :hash-function 'sxhash-node
                   :weakness weakness
                   :shared synchronized)
  #+lispworks
  (make-hash-table :test 'node-equal
                   :hash-function 'sxhash-node
                   :weak-kind weakness
                   :single-thread (not synchronized))
  #+sbcl
  (make-hash-table :test 'node-equal
                   :weakness weakness
                   :synchronized synchronized))

(defun id-equal (x y) (equalp x y))
(defun sxhash-id-array (id) (sxhash (%hash id)))
#+sbcl (sb-ext:define-hash-table-test id-equal sxhash-id-array)
(defun make-id-table (&key weakness synchronized)
  #+lispworks
  (make-hash-table :test 'id-equal
                   :hash-function 'sxhash-id-array
                   :weak-kind weakness
                   :single-thread (not synchronized))

  #+ccl
  (make-hash-table :test 'id-equal
                   :hash-function 'sxhash-id-array
                   :weak weakness
                   :shared synchronized)
  #+sbcl
  (make-hash-table :test 'id-equal
                   :weakness weakness
                   :synchronized synchronized))

 flags: deleted-p, written-p
 type-id
 revision
 data-pointer
 deleted-p
 written-p
 heap-written-p
 type-idx-written-p
 views-written-p
 ve-written-p
 vev-written-p
 type-id
 revision
 data-pointer
 FIXME: reenable when deallocation bug is fixed
 (declaim (inline maybe-init-node-data))
 we should wait to do this until we need the data.
(maybe-init-node-data node :graph graph)
 you must copy the node before writing to its slots,
 in case others are reading it!
(log:info "SAVING ~A" (string-id node))
 Assure that the old node is available in cache for readers
(log:info "~A OLD ADDRESS IS ~A" (string-id node) (data-pointer old-node))
(log:info "OLD REV OF ~A CACHED" (string-id old-node))
 Make sure we are modifying the latest revision or bail
 Undo data slot saving
 Save our changes
(log:info "UPDATING LHASH FOR ~A" (string-id node))
(log:info "RECORDING WRITE FOR ~A" (string-id node))
(log:info "CACHING NEW REV OF ~A" (string-id node))
(old-id (string-id old-node))
 Remove from heap upon gc
(sb-ext:finalize old-node
                 (lambda ()
                   (let ((*package* (find-package :graph-db)))
                     (log:debug "~A FREEING ~A IN ~A" old-id pointer heap)
                     (free heap pointer))))
(log:info "SAVED ~A" (string-id node))
(log:info "GETTING ~A FOR ~A" key (string-id node))
 FIXME: Check for txn and give current revision's value
 FIXME: Check for txn and give current revision's value
(sb-pcl:slot-definition-name slot))
 FIXME: Check for txn and handle
 FIXME: Check for txn and handle
(in-package :graph-db)

(alexandria:define-constant +node-header-size+ 15)

(defgeneric node-p (thing)
  (:method ((thing node)) t)
  (:method (thing) nil))

(defmethod print-object ((node node) stream)
  (format stream "#<~A ~S REV ~S>"
          (type-of node) (string-id (id node))
          (revision node)))

(defmethod flags-as-int ((n node))
  (let ((flags 0))
    (when (slot-value n 'deleted-p)
      (setq flags (dpb 1 (byte 1 0) flags)))
    (when (slot-value n 'written-p)
      (setq flags (dpb 1 (byte 1 1) flags)))
    (when (slot-value n 'heap-written-p)
      (setq flags (dpb 1 (byte 1 2) flags)))
    (when (slot-value n 'type-idx-written-p)
      (setq flags (dpb 1 (byte 1 3) flags)))
    (when (slot-value n 'views-written-p)
      (setq flags (dpb 1 (byte 1 4) flags)))
    (when (slot-value n 've-written-p)
      (setq flags (dpb 1 (byte 1 5) flags)))
    (when (slot-value n 'vev-written-p)
      (setq flags (dpb 1 (byte 1 6) flags)))
    flags))

(defmethod save-node-flags ((table lhash) (node node))
  (lhash-custom-update table
                       (lambda (mf offset)
                         (let ((flags (flags-as-int node)))
                           (set-byte mf offset flags)))
                       (id node)))

(defun serialize-node-head (mf n offset)
  (let ((flags (flags-as-int n)))
    (set-byte mf offset flags))
  (dotimes (i 2)
    (set-byte mf (incf offset) (ldb (byte 8 (* i 8)) (type-id n))))
  (dotimes (i 4)
    (set-byte mf (incf offset) (ldb (byte 8 (* i 8)) (revision n))))
  (dotimes (i 8)
    (set-byte mf (incf offset) (ldb (byte 8 (* i 8)) (data-pointer n))))
  offset)

(defun deserialize-node-head (mf offset)
  (let ((flags (get-byte mf offset)))
    (values
       (declare (type (integer 0 65535) int))
       (dotimes (i 2)
         (setq int (dpb (get-byte mf (incf offset))
                        (byte 8 (* i 8)) int)))
       int)
       (declare (type (integer 0 4294967295) int))
       (dotimes (i 4)
         (setq int (dpb (get-byte mf (incf offset))
                        (byte 8 (* i 8)) int)))
       int)
       #+sbcl (declare (type sb-ext:word int))
       (dotimes (i 8)
         (setq int (dpb (get-byte mf (incf offset))
                        (byte 8 (* i 8)) int)))
       int)
     offset)))

(defun finalize-node (node table graph)
  (setf (written-p node) t)
  (save-node-flags table node)
  (setf (gethash (id node) (cache graph)) node))

(defun maybe-init-node-data (node &key (graph *graph*))
  (when (> (data-pointer node) 0)
    (when (or (eq (bytes node) :init) (null (bytes node)))
      (let ((bytes (read-bytes (make-mpointer
                                :mmap (memory-mmap (heap graph))
                                :loc (data-pointer node)))))
        (when bytes
          (setf (data node)
                (deserialize bytes)
                (bytes node)
                bytes)))))
  node)

(defmethod lookup-node ((table lhash) (key array) (graph graph))
  (or (and *cache-enabled*
           (let ((node (gethash key (cache graph))))
             (when node
               (record-graph-read)
               node)))
      (let ((node (lhash-get table key)))
        (when (node-p node)
          (setf (id node) key)
          (when *cache-enabled*
            (setf (gethash key (cache graph)) node))
          (record-graph-read)
          node))))

(defun save-node (node table &key (graph *graph*))
  (let ((old-node nil))
    (when (plusp (data-pointer node))
      (if (data node)
          (setf (bytes node) (serialize (data node)))
          (maybe-init-node-data node :graph graph))
      (let ((addr (allocate (heap graph) (length (bytes node)))))
        (dotimes (i (length (bytes node)))
          (set-byte (heap graph)
                    (+ i addr) (aref (bytes node) i)))
        (setf (data-pointer node) addr)))
    (with-locked-hash-key (table (id node))
      (setq old-node (%lhash-get table (id node)))
      (setf (id old-node) (id node))
( log : info " ~A NEW ADDRESS IS ~A " ( string - id node ) ( data - pointer node ) )
      (maybe-init-node-data old-node :graph graph)
      (setf (gethash (id old-node) (cache graph)) old-node)
      (unless (= (revision node) (revision old-node))
        (log:error "REVISION ERROR ~A: ~A /= ~A"
                   (string-id node) (revision node) (revision old-node))
        (when (/= 0 (data-pointer node))
          (free (heap graph) (data-pointer node)))
        (error 'stale-revision-error
               :current-revision (revision old-node)
               :instance (string-id node)))
  Do n't overflow the revision ( 32 bit int )
      (if (>= (revision node) 4294967295)
          (setf (revision node) 0)
          (incf (revision node)))
      (%lhash-update table (id node) node)
      (record-graph-write)
      (setf (gethash (id node) (cache graph)) node))
    (when (/= 0 (data-pointer old-node))
      (let ((pointer (data-pointer old-node))
            (heap (heap graph)))
( log : info " ~A FREEING ~A IN ~A " old - id pointer heap )
        (free heap pointer)
        ))
    (values node old-node)))

(defmethod string-id ((id array))
  (with-output-to-string (out)
    (map nil
         (lambda (byte)
           (format out "~(~2,'0X~)" byte))
         id)))

(defmethod string-id ((node node))
  (with-output-to-string (out)
    (map nil
         (lambda (byte)
           (format out "~(~2,'0X~)" byte))
         (id node))))

(defun node-to-alist (node &key slots)
  (maybe-init-node-data node)
  (remove-if (lambda (pair)
               (member (car pair) slots))
             (append (list (cons :id (string-id node)))
                     (copy-alist (data node)))))

(defun node-slot-value (node key &key (graph *graph*))
  (maybe-init-node-data node :graph graph)
  (when (consp (data node))
    (cdr (assoc (if (keywordp key)
                    key
                    (intern (symbol-name key) :keyword))
                (data node)))))

(defsetf node-slot-value (node key) (value)
  (with-gensyms (pair keyword)
    `(if (typep ,value 'graph-db::node)
         (error "Cannot set ~A slots to objects with parent type NODE" (type-of ,node))
         (let ((,keyword (if (keywordp ,key)
                             ,key
                             (intern (symbol-name ,key) :keyword))))
           (maybe-init-node-data ,node)
           (cond ((null (data ,node))
                  (push (cons ,keyword ,value) (data ,node)))
                 ((consp (data ,node))
                  (let ((,pair (assoc ,keyword (data ,node))))
                    (if ,pair
                        (setf (cdr ,pair) ,value)
                        (push (cons ,keyword ,value) (data ,node)))))
                 (t
                  (error "Cannot set slot value when data slot is of type ~A"
                         (type-of (data ,node)))))))))

(defmethod slot-value-using-class :around ((class node-class) instance slot)
  "Around method that is alternate-version aware and will show values for the current,
   working private version of instance."
  (log:trace "slot-value-using-class~%  '~A'~%  '~A'" class (slot-definition-name slot))
  (let* (#+lispworks(slot (closer-mop::find-slot slot class))
         (slot-name (slot-definition-name slot))
         (slot-keyword-name (intern (symbol-name slot-name) :keyword)))
    (cond ((member slot-name (persistent-slot-names class))
           (node-slot-value instance slot-keyword-name))
          ((member slot-name (ephemeral-slot-names class))
           (call-next-method))
          ((member slot-name (meta-slot-names class))
           (call-next-method))
          (t
           (call-next-method)))))

(defmethod (setf slot-value-using-class) :around
    (new-value (class node-class) instance slot)
  "Is alternate-version aware and will update values for the current, working private
   version of instance."
( log : debug " setf slot - value - using - class~%   ' ~A'~%   ' ~A'~%   ' ~A ' " new - value class
  (let* (#+lispworks(slot (closer-mop::find-slot slot class))
         (slot-name (slot-definition-name slot))
         (slot-keyword-name (intern (symbol-name slot-name) :keyword)))
    (cond ((member slot-name (persistent-slot-names class))
           (setf (node-slot-value instance slot-keyword-name) new-value))
          ((member slot-name (ephemeral-slot-names class))
           (call-next-method))
          ((member slot-name (meta-slot-names class))
           (call-next-method))
          (t
           (call-next-method)))))

(defgeneric node-equal (x y)
  (:method ((x node) (y node))
    (equalp (id x) (id y)))
  (:method (x y)
    nil))

(defmethod %hash ((key #.(class-of (make-array 16 :element-type '(unsigned-byte 8)))))
  (declare (optimize (speed 3) (safety 0)))
  (let ((int (aref key 0)))
    (loop
       for subscript from 1 to 15
       for shift from 8 by 8
       do
         (incf int (ash (logand (aref key subscript) #xFF) shift)))
    int))

(defun sxhash-node (node) (sxhash (%hash (id node))))
#+sbcl (sb-ext:define-hash-table-test node-equal sxhash-node)
(defun make-node-table (&key weakness synchronized)
  #+ccl
  (make-hash-table :test 'node-equal
                   :hash-function 'sxhash-node
                   :weakness weakness
                   :shared synchronized)
  #+lispworks
  (make-hash-table :test 'node-equal
                   :hash-function 'sxhash-node
                   :weak-kind weakness
                   :single-thread (not synchronized))
  #+sbcl
  (make-hash-table :test 'node-equal
                   :weakness weakness
                   :synchronized synchronized))

(defun id-equal (x y) (equalp x y))
(defun sxhash-id-array (id) (sxhash (%hash id)))
#+sbcl (sb-ext:define-hash-table-test id-equal sxhash-id-array)
(defun make-id-table (&key weakness synchronized)
  #+lispworks
  (make-hash-table :test 'id-equal
                   :hash-function 'sxhash-id-array
                   :weak-kind weakness
                   :single-thread (not synchronized))

  #+ccl
  (make-hash-table :test 'id-equal
                   :hash-function 'sxhash-id-array
                   :weak weakness
                   :shared synchronized)
  #+sbcl
  (make-hash-table :test 'id-equal
                   :weakness weakness
                   :synchronized synchronized))
