generic files

gfile.lisp

(defpackage #:gfile (:use #:cl))

(in-package :gfile)

;; I/O API

(defgeneric read-elt (file position))
(defgeneric write-elt (file position elt))
(defgeneric read-elts (file position count)
  (:documentation "Read a sequence of elements."))
(defgeneric write-elts (file position elt-seq)
  (:documentation "Write a sequence of elements to file."))

(defgeneric close-file (file)
  (:method (file))
  (:documentation "Supposed to free and unlock resources when file is no longer needed.
  Default implementation is no-op"))

;; optional API

(defgeneric element-type-of (file))
(defgeneric length-of (file))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass gfile () ())

(defmethod write-elts ((gf gfile) position elts)
  (loop for pos upfrom position
        for i upfrom 0
        do (write-elts gf pos (elt elts i))))

(defmethod read-elts ((gf gfile) position count)
  (loop for pos upfrom position
        repeat count
        collect (read-elt gf pos)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; byte-file is a ``physical'' storage which works directly with bytes.
;; should implement length-of and element-type-of

(defclass abstract-byte-file (gfile)
  ((element-type :reader element-type-of 
                 :initform '(unsigned-byte 8)
                 :initarg :element-type)))

(defclass byte-file (abstract-byte-file)
  ((stream :accessor stream-of)
   (filename :accessor filename-pf :initform :filename)
   (length :accessor length-of)))

(defmethod initialize-instance :after ((bf byte-file) &key filename &allow-other-keys)
  (let ((stream (open filename :direction :io :element-type (element-type-of bf)
                      :if-exists :overwrite
                      :if-does-not-exist :create)))
    (setf (stream-of bf) stream
          (length-of bf) (file-length stream))))

(defmethod read-elt ((bf byte-file) position)
  (when (>= position (length-of bf))
    (error "Reading past the end of file"))
  (file-position (stream-of bf) position)
  (read-byte (stream-of bf)))

(defmethod write-elt ((bf byte-file) position (elt integer))
  (let ((l (length-of bf))
        (s (stream-of bf)))
    (when (< l position) (error "Writing past the end of file."))
    (file-position s position)
    (write-byte elt s)
    (when (= l position) (incf (length-of bf)))
    (values)))

(defmethod write-elts ((bf byte-file) position (elts sequence))
  (let ((l (length-of bf))
        (s (stream-of bf)))
    (when (< l position) (error "Writing past the end of file."))
    (file-position s position)
    (write-sequence elts s)
    (when (> (+ position (length elts)) l)
      (setf (length-of bf) (+ position (length elts))))
    (values)))

(defmethod close-file ((bf byte-file))
  (close (stream-of bf)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass record-file (gfile)
  ((byte-file :accessor byte-file-of :initarg :byte-file
              :documentation "Underlying byte file")
   (record-size :accessor record-size-of :initarg :record-size
                 :documentation "Size of record in bytes of underlying byte-file.")
   (length :accessor length-of))
  (:documentation "File which is composed of records of fixed size mapped into bytes of underlying byte-file."))

(defgeneric  update-length (rf)
  (:method ((rf record-file))
    (setf (length-of rf)
          (/ (length-of (byte-file-of rf)) (record-size-of rf)))))


(defmethod initialize-instance :after ((rf record-file) &key)
  (update-length rf))

(defgeneric serialize (record-file record)
  (:documentation "Represent record as a sequence of bytes."))
(defgeneric deserialize (record-file byte-seq)
  (:documentation "Reconstruct a record from a sequence of bytes"))

(defmethod write-elt ((rf record-file) position r)
  (write-elts (byte-file-of rf)
             (* position (record-size-of rf))
             (serialize rf r))
  (update-length rf))

(defmethod read-elt ((rf record-file) position)
  (deserialize rf (read-elts (byte-file-of rf)
                             (* position (record-size-of rf))
                             (record-size-of rf))))

(defmethod close-file ((rf record-file)) (close-file (byte-file-of rf)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Example of use: persistent binary search tree.
;; (Non-balanced, only bare minimum, proof-of-concept API 

(defstruct (bst-node (:type vector))
  key value
  (left -1)
  (right -1))

(defclass bst-node-file (record-file)
  ()
  (:default-initargs :record-size 4))

(defmethod serialize ((bnf bst-node-file) node) node)
(defmethod deserialize ((bnf bst-node-file) byte-seq)
  (coerce byte-seq 'vector))

(defclass node-bst (bst-node-file) ())

;; BST-level API

(defgeneric root-node-id (bst))
(defgeneric read-node (bst node-id))
(defgeneric write-node (bst node-id node))
(defgeneric insert-node (bts key value))
(defgeneric fine-node-eq (bst key))
(defgeneric fine-node-ge (bst key))

;; implementation

(defgeneric key-to-byte (bst key)
  (:method (bst (key integer))
    key))

(defgeneric byte-to-key (bst byte)
  (:method (bst byte) byte))

(defgeneric value-to-byte (bst value)
  (:method (bst (val integer)) val))
                               
(defgeneric compare-keys (bst l-key-raw r-key)
  (:method (bst (l-key integer) (r-key integer))
    (if (<= l-key r-key)
        (if (= l-key r-key)
            :equal
            :less)
        :greater)))

(defmethod root-node-id ((bst node-bst)) 0)
(defgeneric node-id->position (bst node-id)
  (:method ((bst node-bst) node-id)
    (unless (minusp node-id) node-id)))

(defmethod read-node ((bst node-bst) node-id)
  (let ((pos (node-id->position bst node-id)))
    (when pos (read-elt bst pos))))

(defmethod write-node ((bst node-bst) node-id node)
  (let ((pos (node-id->position bst node-id)))
    (if pos
        (write-elt bst pos node)
        (error "Writing node with wrong id"))))

(defgeneric insert-node% (bst key value via-node-id)
  (:method ((bst node-bst) key value via-node-id)
    (flet ((write-new-node (&key (left -1) (right -1))
             (let ((pos (length-of bst)))
               (write-node bst pos  (make-bst-node :key (key-to-byte bst key) 
                                                   :value (value-to-byte bst value)
                                                   :left left :right right))
                 pos)))
    (if (zerop (length-of bst))
        (write-new-node)
        (let* ((via-node (read-node bst via-node-id))
               (via-key (bst-node-key via-node)))
          (flet ((insert-node-left-or-right (lr-get lr-set)
                   (if (not (node-id->position bst (funcall lr-get via-node)))
                       ;; Found nil => insert here
                       (let* ((new-node-pos (write-new-node))
                              (via-node-copy (copy-bst-node via-node)))
                         (funcall lr-set new-node-pos via-node-copy)
                         (write-node bst via-node-id via-node-copy)
                         new-node-pos)
                       (insert-node% bst key value (funcall lr-get via-node)))))
            (ecase (compare-keys bst via-key key)
              (:equal
               ;; update node in-place
               (write-node bst via-node-id 
                         (make-bst-node :key via-key :value (value-to-byte bst value)
                                        :left (bst-node-left via-node)
                                        :right (bst-node-right via-node))))
              (:greater
               (insert-node-left-or-right (function bst-node-left)
                                          (function (setf bst-node-left))))
              (:less
               (insert-node-left-or-right (function bst-node-right)
                                          (function (setf bst-node-right)))))))))))

(defmethod insert-node ((bst node-bst) key value)
  (insert-node% bst key value (root-node-id bst)))

(defgeneric find-node-eq% (bst key via-node-id)
  (:method ((bst node-bst) key via-node-id)
    (if (not (node-id->position bst via-node-id))
        nil
        (let* ((via-node (read-node bst via-node-id))
               (via-key (bst-node-key via-node)))
          (ecase (compare-keys bst via-key key)
            (:equal (values via-node-id via-node))
            (:greater (find-node-eq% bst key (bst-node-left via-node)))
            (:less (find-node-eq% bst key (bst-node-right via-node))))))))

(defmethod find-node-eq ((bst node-bst) key)
  (find-node-eq% bst key (root-node-id bst)))

(defgeneric find-node-ge% (bst k via-node-id)
  (:method ((bst node-bst) k via-node-id)
    (if (not (node-id->position bst via-node-id))
        nil
        (let* ((via-node (read-node bst via-node-id))
               (via-key (bst-node-key via-node)))
          (ecase (compare-keys bst via-key k)
            (:equal (values via-node-id via-node))
            (:greater 
             (multiple-value-bind (rnid rnode)
                 (find-node-ge% bst k (bst-node-left via-node))
               (if rnid (values rnid rnode)
                   (values via-node-id via-node))))
            (:less 
             (find-node-ge% bst k (bst-node-right via-node))))))))

(defmethod find-node-ge ((bst node-bst) key)
  (find-node-ge% bst key (root-node-id bst)))

(defun maybe-delete-file (pathname)
  (when (probe-file pathname) (delete-file pathname)))

(defun example1 ()
  (maybe-delete-file #p"example1.bst")
  (let (bst)
    (unwind-protect
         (progn 
           (setf bst (make-instance 'node-bst 
                                    :byte-file (make-instance 'byte-file 
                                                              :filename #p"example1.bst" :element-type '(signed-byte 16))))
           (insert-node bst 4 40)
           (insert-node bst 3 30)
           (insert-node bst 6 60)
           (insert-node bst 2 20)
           
           (format t "find(4) = ~a~%" (multiple-value-list (find-node-eq bst 4)))
           (format t "find(5) = ~a~%" (multiple-value-list (find-node-eq bst 5)))
           (format t "find-ge(5) = ~a~%" (multiple-value-list (find-node-ge bst 5))))
      (when bst (close-file bst)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; example 2: trees with variable-lenght entries

(defclass string-store-file (byte-file)
  ()
  (:default-initargs :element-type '(unsigned-byte 32)))

(defgeneric store-string (file string)
  (:method ((ssf string-store-file) string)
    (let* ((len (length string))
           (buf (make-array (list (+ 1 len)) :element-type (element-type-of ssf)))
           (pos (length-of ssf)))
      (setf (aref buf 0) len)
      (loop for i from 1 to len
            for j upfrom 0
            do (setf (aref buf i)
                     (char-code (char string j))))
      (write-elts ssf pos buf)
      pos)))

(defgeneric read-string (file pos)
  (:method ((ssf string-store-file) pos)
    (let* ((len (read-elt ssf pos))
           (str (make-string len)))
      (loop for i from 0 below len
            for j upfrom (+ 1 pos)
            do (setf (elt str i) (code-char (read-elt ssf j))))
      str)))

(defclass s-node-bst (node-bst)
  ((string-store :accessor string-store-of :initarg :string-store)))

(defmethod key-to-byte ((snbst s-node-bst) (s string))
  (store-string (string-store-of snbst) s))

(defmethod byte-to-key ((snbst s-node-bst) b)
  (read-string (string-store-of snbst) b))

(defmethod compare-keys ((bst s-node-bst) l-key-raw (r-key string))
  (let ((l-key (byte-to-key bst l-key-raw)))
    (if (string<= l-key r-key)
        (if (string= l-key r-key)
            :equal
            :less)
        :greater)))

(defun example2 ()
  (maybe-delete-file #p"example2.bst")
  (maybe-delete-file #p"example2.ss")
  (let (bst ss)
    (flet ((print-node (node-id)
             (let ((node (when node-id (read-node bst node-id))))
               (if node
                   (format t "pos = ~a, key = `~a`(~a), value=~a, left=~a, right=~a"
                           node-id
                           (byte-to-key bst (bst-node-key node))
                           (bst-node-key node)
                           (bst-node-value node)
                           (bst-node-left node)
                           (bst-node-right node))
                   (format t "EMPTY")))))
    (unwind-protect
         (progn 
           (setf ss (make-instance 'string-store-file :filename #p"example2.ss"))
           (setf bst (make-instance 's-node-bst 
                                    :byte-file (make-instance 'byte-file 
                                                              :filename #p"example2.bst" :element-type '(signed-byte 16))
                                    :string-store ss))
           (insert-node bst "4" 4)
           (insert-node bst "3" 3)
           (insert-node bst "60" 60)
           (insert-node bst "2" 2)
           (insert-node bst "abc" 0)
           (insert-node bst "a" -1)

           (print "find(`4`)") (print-node (find-node-eq bst "4"))
           (print "find(`5`)") (print-node (find-node-eq bst "5"))
           (print "find-ge(`5`)") (print-node (find-node-ge bst "5"))
           (print "find-ge(`ab`)") (print-node (find-node-ge bst "ab")))
      (when bst (close-file bst))
      (when ss (close-file ss))))))