Initial commit

cl-table-store.asd

@@ -0,0 +1,19 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cl-table-store.asd -- Serialize cl-table with cl-store
+;;;
+;;; Copyright (C) 2011, Roman Klochkov <kalimehtar@mail.ru>
+;;;
+
+(defpackage #:cl-table-system
+  (:use #:cl #:asdf))
+(in-package #:cl-table-system)
+
+(defsystem cl-table-store
+  :description "CL-TABLE serialized with CL-STORE"
+  :author "Roman Klochkov <kalimehtar@mail.ru>"
+  :version "0.9"
+  :license "BSD"
+  :depends-on (cl-table cl-store)
+  :components
+  ((:file store)))

cl-table.asd

@@ -0,0 +1,22 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cl-table.asd -- Hierarchical tables in Lisp
+;;;
+;;; Copyright (C) 2011, Roman Klochkov <kalimehtar@mail.ru>
+;;;
+
+(defpackage #:cl-table-system
+  (:use #:cl #:asdf))
+(in-package #:cl-table-system)
+
+(defsystem cl-table
+  :description "Hierarchical tables in Lisp"
+  :author "Roman Klochkov <kalimehtar@mail.ru>"
+  :version "0.9"
+  :license "BSD"
+  :depends-on (iterate)
+  :serial t
+  :components
+  ((:file package)
+   (:file table)
+   (:file iterator)))

cl-table.lisp

@@ -0,0 +1,122 @@
+(in-package :cl-table)
+
+(defclass table ()
+  ((columns :accessor columns :type list)
+   (rows :accessor rows :type list)
+   (indexes :accessor indexes :type list)))
+
+(defgeneric generic-lessp (x y)
+  (:documentation "Order by numbers or strings")
+  (:method ((x string) (y string))
+    (string-lessp x y))
+  (:method ((x string) y)
+    (generic-lessp x (write-to-string y)))
+  (:method (x (y string))
+    (generic-lessp (write-to-string x) y))
+  (:method ((x number) (y number))
+    (< x y)))
+
+(defun compare-rows (cols pred row1 row2)
+  (when cols
+    (labels ((%compare (%cols)
+               (let ((f1 (field row1 (car %cols)))
+                     (f2 (field row2 (car %cols))))
+                 (if (equal f1 f2) (%compare (cdr %cols))
+                     (funcall pred f1 f2)))))
+      (%compare cols))))
+
+(defun equal-rows (cols row1 row2)
+  (if cols
+      (let ((f1 (field row1 (car cols)))
+            (f2 (field row2 (car cols))))
+        (when (equal f1 f2) (equal-rows (cdr cols) row1 row2)))
+      t))
+
+(eval-when (:compile-toplevel :execute)
+  (defun enable-sharpL-reader ()
+    (set-dispatch-macro-character #\# #\L #'iterate::sharpL-reader))
+  (setf *readtable* (copy-readtable *readtable*))
+  (enable-sharpL-reader))
+
+
+(defun sort! (table columns)
+  (setf (rows table)
+        (stable-sort (rows table)
+                     #L(compare-rows columns #'generic-lessp 
+                                     (cons table !1) (cons table !2)))))
+
+;; (defun add-columns (sum-columns dst-row src-row)
+;;   (mapc (lambda (column)
+;;           (setf (field dst-row column)
+;;                 (+ (field dst-row column)
+;;                    (field src-row column))))
+;;         sum-columns))
+
+(defun sum-columns! (sum-columns dst-row src-row)
+  "For each column in list SUM-COLUMNS put sum of fields
+from dst and src rows to dst-row" 
+  (assert (eq (car src-row) (car dst-row))) ; the same table for rows
+  (let ((cols (columns (car src-row))))
+    (mapc (lambda (column)
+            (iter (for name in cols)
+                  (for value in (cdr src-row))
+                  (for place on (cdr dst-row))
+                  (when (eq name column) 
+                    (setf (car place) (+ (car place) value)))))
+        sum-columns)))
+
+(defun drop-columns! (table columns)
+  (let ((old-columns (columns table)))
+    (labels ((get-diff (row)
+               (iter
+                 (for col in old-columns)
+                 (for field in row)
+                 (unless (find col columns)
+                   (collect field)))))            
+      (iter
+        (for row on (rows table))
+        (setf (car row) (get-diff (car row))))
+      (setf (columns table) (get-diff (columns table))))))
+
+
+(defun wrap! (table group-columns sum-columns)
+  (assert (null (intersection group-columns sum-columns)))
+  (drop-columns! table 
+                 (set-difference (columns table) 
+                                 (union group-columns sum-columns)))
+  (sort table group-columns)
+  (let (res)
+    (map-table (lambda (str)
+                 (if (equal-rows group-columns (car res) str)
+                     (sum-columns! sum-columns (car res) str)
+                     (push str res))) table)
+    (setf (rows table) (nreverse res))))
+
+
+(defun field (str key)
+  "Returns field of row STR with name symbol KEY
+Assume (car str) = table & (cdr str) = current row"
+  (iter (for name in (columns (car str)))
+        (for value in (cdr str))
+        (when (eq name key) (return value))))
+
+(defsetf field (str key) (new-value)
+  `(iter (for name in (columns (car ,str)))
+         (for value on (cdr ,str))
+         (when (eq name ,key) (setf (car value) ,new-value))))
+
+(defun map-table (func table)
+  (labels ((in-map (rest)
+             (when rest 
+               (funcall func (cons table (car rest)))
+               (in-map (cdr rest)))))
+    (in-map (rows table))))
+
+(defmacro-clause (FOR var IN-TABLE table)
+    "Rows of a table: row = (table field1 field2 ...)"
+    (let ((tab (gensym))
+          (row (gensym)))
+      `(progn
+         (with ,tab = ,table)
+         (for ,row in ,(rows tab))
+         (for ,var = (cons ,tab ,row)))))

iterator.lisp

@@ -0,0 +1,55 @@
+(in-package :cl-table)
+
+(defstruct (iter-row (:include row))
+  "Iterator element"
+  (id 0 :type fixnum)
+  (children-vector #() :type (vector iter-row)))
+
+;; We need vector of top rows and vector of all rows (to have integer -> row)
+;; And we have to store it with the table or else we have independent vars
+;;   for a table
+
+(defstruct iter-table
+  (all #() :type (vector iter-row))
+  (top #() :type (vector iter-row)))
+
+
+(defun make-iterator (table)
+  "Returns array of iter-row"
+  (let (res visited (res-len -1))
+    (declare (special visited))
+    (labels ((to-vector (l)
+               (coerce (nreverse l) 'vector))
+             (visit-row (row)
+               (declare (special visited))
+               (let* ((children
+                       (let (visited)
+                         (declare (special visited))
+                         (map-table-row #'visit-row row)
+                         (to-vector visited)))
+                      (new-row (make-iter-row 
+                                :parent (row-parent row)
+                                :table (row-table row)
+                                :children-vector children
+                                :children (row-children row)
+                                :id (incf res-len)
+                                :num (row-num row)
+                                :data (row-data row))))
+                 (push new-row res)
+                 (push new-row visited))))
+    (map-table #'visit-row table)
+    (make-iter-table :all (to-vector res) :top (to-vector visited)))))
+
+(defun aref* (array index)
+  (when (< -1 index (array-dimension array 0))
+    (aref array index)))
+
+(defmethod path->row ((iter-table iter-table) path)
+  (when path
+    (path->row (aref* (iter-table-top iter-table) (car path)) (cdr path))))
+
+(defmethod path->row ((iter-row iter-row) path)
+  (if path
+    (path->row (aref* (iter-row-children-vector iter-row) (car path))
+               (cdr path))
+    iter-row))

package.lisp

@@ -0,0 +1,11 @@
+(defpackage #:cl-table
+  (:use #:cl #:iterate)
+  (:export
+   #:table
+   #:columns
+   #:wrap
+   #:field
+   #:drop-columns!
+   #:add
+   #:path->row
+   #:make-iterator))

store.lisp

@@ -0,0 +1,12 @@
+(in-package :cl-table)
+
+(defparameter +db-table+ (cl-store:register-code 52 'table))
+
+
+(cl-store:defstore-cl-store (obj table stream)
+  (progn
+    (cl-store:output-type-code +db-table+ stream)
+    (cl-store:store-object (columns table) stream)
+    (labels ((row-list (row)
+               (list (
+    (cl-store:store-object (mapcar #'row->list (rows table)) stream))))