gamao/src/pvector.lisp

;;;; pvector.lisp

(in-package #:gamao-impl)

;;; PERSISTENT VECTORS

#|
A simple diff-based persistent vector implementation.  API:
Type pvector
make-pvector &rest arguments => value: accepts arguments as make-array, but must be one-dimensional
pvector-ref pvector index => value
pvector-update pvector index value => new-pvector
pvector-reroot pvector => pvector
|#

(defstruct (pvector (:constructor %make-pvector)
                    (:conc-name %pvector-))
  index value next)

(defun make-pvector (&rest arguments)
  (%make-pvector :index nil :value nil :next (apply #'make-array arguments)))

(defun pvector-ref (pvector index)
  (loop for v = pvector then (%pvector-next v)
        for vidx = (%pvector-index v)
        when (null vidx) do (return (aref (%pvector-next v) index))
        when (= vidx index) do (return (%pvector-value v))))

(defun pvector-update (pvector index value)
  (%make-pvector :index index :value value :next pvector))

(defun pvector-reroot (pvector)
  (let ((lineage '() ))
    (do ((v pvector (%pvector-next v)))
        ((null (%pvector-index v)))
        (push v lineage))
    (dolist (pvector lineage)
      (let ((next (%pvector-next pvector))
            (index (%pvector-index pvector)))
        (pvector-reroot next)
        (let ((vector (%pvector-next next)))
          (setf (%pvector-next pvector) vector
                (%pvector-next next) pvector
                (%pvector-index next) (%pvector-index pvector)
                (%pvector-value next) (aref vector index)
                (aref vector index) (%pvector-value pvector)
                (%pvector-index pvector) nil
                (%pvector-value pvector) nil)))))
  pvector)