Skip to content

Instantly share code, notes, and snippets.

@killerstorm
Created May 29, 2012 09:39
Show Gist options
  • Save killerstorm/2823562 to your computer and use it in GitHub Desktop.
Save killerstorm/2823562 to your computer and use it in GitHub Desktop.
generic files
(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))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment