[cl-table-cvs] r1 -
rklochkov at common-lisp.net
rklochkov at common-lisp.net
Thu Feb 9 15:45:14 UTC 2012
Author: rklochkov
Date: Thu Feb 9 07:45:13 2012
New Revision: 1
Log:
Initial release
Added:
cl-table.asd
cl-table.lisp
iterator.lisp
package.lisp
svn-commit.tmp
table.lisp
test.lisp
Added: cl-table.asd
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ cl-table.asd Thu Feb 9 07:45:13 2012 (r1)
@@ -0,0 +1,22 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+;;;
+;;; cl-table.asd -- Hierarchical tables in Lisp
+;;;
+;;; Copyright (C) 2011, Roman Klochkov <kalimehtar at 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 at mail.ru>"
+ :version "0.9"
+ :license "BSD"
+ :depends-on (iterate)
+ :serial t
+ :components
+ ((:file package)
+ (:file table)
+ (:file iterator)))
Added: cl-table.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ cl-table.lisp Thu Feb 9 07:45:13 2012 (r1)
@@ -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)))))
\ No newline at end of file
Added: iterator.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ iterator.lisp Thu Feb 9 07:45:13 2012 (r1)
@@ -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))
Added: package.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ package.lisp Thu Feb 9 07:45:13 2012 (r1)
@@ -0,0 +1,11 @@
+(defpackage #:cl-table
+ (:use #:cl #:iterate)
+ (:export
+ #:table
+ #:columns
+ #:wrap
+ #:field
+ #:drop-columns!
+ #:add
+ #:path->row
+ #:make-iterator))
\ No newline at end of file
Added: svn-commit.tmp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ svn-commit.tmp Thu Feb 9 07:45:13 2012 (r1)
@@ -0,0 +1,4 @@
+Initial release of cl-table
+--This line, and those below, will be ignored--
+
+A .
Added: table.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ table.lisp Thu Feb 9 07:45:13 2012 (r1)
@@ -0,0 +1,295 @@
+(in-package :cl-table)
+
+(defstruct row
+ "Struct for representing row in table"
+ (parent nil :type (or null row))
+ (ref nil :type list)
+ (children nil :type list)
+ (table nil :type table)
+ (num 0 :type fixnum)
+ (data nil :type list))
+
+(defstruct column
+ (name nil :type (and symbol (not null)))
+ (type t :type (or symbol list)))
+
+(defclass table ()
+ ((columns :accessor columns :type list)
+ (rows :accessor rows :type list :initform nil
+ :documentation
+ "List of lists = data in (car row), list of children rows in (cdr row)
+Assert (length (car row)) == (length columns)")
+ (indexes :accessor indexes :type list :initform nil)))
+
+(defmethod shared-initialize :after ((table table) slot-names
+ &key columns)
+ (when (notevery #'column-p columns)
+ (setf (columns table)
+ (mapcar (lambda (x) (etypecase x
+ (symbol (make-column :name x))
+ (list (make-column :name (car x)
+ :type (second x)))
+ (column x)))
+ columns))))
+
+
+(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 list-of-forms? (x)
+ (and (consp x) (consp (car x))
+ (not (eq (caar x) 'lambda))))
+
+ (defun sharpL-reader (stream subchar n-args)
+ (declare (ignore subchar))
+ (let* ((form (read stream t nil t))
+ (bang-vars (sort (bang-vars form) #'< :key #'bang-var-num))
+ (bang-var-nums (mapcar #'bang-var-num bang-vars))
+ (max-bv-num (if bang-vars
+ (reduce #'max bang-var-nums :initial-value 0)
+ 0)))
+ (cond
+ ((null n-args)
+ (setq n-args max-bv-num))
+ ((< n-args max-bv-num)
+ (error "#L: digit-string ~d specifies too few arguments" n-args)))
+ (let* ((bvars (let ((temp nil))
+ (dotimes (i n-args (nreverse temp))
+ (push (make-bang-var (1+ i)) temp))))
+ (args (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
+ bvars))
+ (ignores (set-difference bvars bang-vars))
+ (decl (if ignores `(declare (ignore .,ignores)) nil))
+ (body (if (list-of-forms? form)
+ (if decl (cons decl form) form)
+ (if decl (list decl form) (list form))))
+ (subbed-body (sublis (pairlis bvars args) body)))
+ `#'(lambda ,args ,.subbed-body))))
+
+ (defun make-bang-var (n)
+ (intern (format nil "!~d" n)))
+
+ (defun bang-vars (form)
+ (delete-duplicates (bang-vars-1 form '()) :test #'eq))
+
+ (defun bang-vars-1 (form vars)
+ (cond
+ ((consp form)
+ (bang-vars-1 (cdr form)
+ (bang-vars-1 (car form) vars)))
+ ((and (symbolp form) (bang-var? form)) (cons form vars))
+ (t vars)))
+
+ (defun bang-var? (sym)
+ (char= (char (symbol-name sym) 0) #\!))
+
+ (defun bang-var-num (sym)
+ (let ((num (read-from-string (subseq (symbol-name sym) 1))))
+ (if (not (and (integerp num) (> num 0)))
+ (error "#L: ~a is not a valid variable specifier" sym)
+ num)))
+
+ (defun enable-sharpL-reader ()
+ (set-dispatch-macro-character #\# #\L #'sharpL-reader))
+
+ ;; According to CLHS, *readtable* must be rebound when compiling
+ ;; so we are free to reassign it to a copy and modify that copy.
+ (setf *readtable* (copy-readtable *readtable*))
+ (enable-sharpL-reader)
+
+ ) ; end eval-when
+
+
+(defun sort! (table columns)
+ (setf (rows table)
+ (stable-sort (rows table)
+ #L(compare-rows columns #'generic-lessp
+ (make-row :table table :data !1)
+ (make-row :table table :data !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"
+ (iter (for column in (columns (row-table str)))
+ (for value in (row-data str))
+ (when (eq (column-name column) key) (return value))))
+
+(defsetf field (str key) (new-value)
+ (let ((column (gensym))
+ (value (gensym)))
+ `(iter (for ,column in (columns (row-table ,str)))
+ (for ,value on (row-data ,str))
+ (when (eq (column-name ,column) ,key)
+ (assert (typep ,new-value (column-type ,column)) (,new-value)
+ 'type-error
+ :datum ,new-value
+ :expected-type (column-type ,column))
+ (return (setf (car ,value) ,new-value))))))
+
+(defun map-table (func table)
+ (labels ((in-map (rows num)
+ (when rows
+ (funcall func (make-row :table table
+ :num num
+ :data (caar rows)
+ :children (cdar rows)))
+ (in-map (cdr rows) (+ 1 num)))))
+ (in-map (rows table) 0)))
+
+(defun map-table-row (func row)
+ (labels ((in-table-row (rows num)
+ (when rows
+ (funcall func (make-row :table (row-table row)
+ :num num
+ :parent row
+ :data (caar rows)
+ :children (cdar rows)))
+ (in-table-row (cdr rows) (+ 1 num)))))
+ (in-table-row (row-children row) 0)))
+
+(defmacro-clause (FOR var IN-TABLE table)
+ "Rows of a table: row = (table field1 field2 ...)"
+ (let ((tab (gensym))
+ (row (gensym))
+ (num (gensym)))
+ `(progn
+ (with ,tab = ,table)
+ (for ,row in ,(rows tab))
+ (for ,num from 0)
+ (for ,var = (make-row :table ,tab :num ,num
+ :data (car ,row)
+ :children (cdr ,row))))))
+
+(defmacro-clause (FOR var IN-TABLE-ROW table)
+ "Rows of a table: row = (table field1 field2 ...)"
+ (let ((tab (gensym))
+ (row (gensym))
+ (parent (gensym))
+ (num (gensym)))
+ `(progn
+ (with ,parent = ,table)
+ (with ,tab = ,(row-table table))
+ (for ,row in (row-children ,tab))
+ (for ,num from 0)
+ (for ,var = (make-row :table ,tab :num ,num
+ :data (car ,row)
+ :children (cdr ,row)
+ :parent ,table)))))
+
+
+(defgeneric add (to-place))
+
+(defmacro append-item (item list)
+ `(setf ,list (append ,list (list ,item))))
+
+(defmethod add ((table table))
+ (let (res)
+ (push nil res)
+ (dotimes (i (length (columns table)))
+ (push nil (car res)))
+ (prog1
+ (make-row :data (car res) :table table
+ :num (length (rows table)) :ref res)
+ (append-item res (rows table)))))
+
+(defmethod add ((row row))
+ (let (res)
+ (push nil res)
+ (dotimes (i (length (columns (row-table row))))
+ (push nil (car res)))
+ (prog1
+ (make-row :data (car res) :table (row-table row) :ref res
+ :num (length (row-children row)) :parent row)
+ (append-item res (cdr (row-ref row))))))
+
+(defgeneric path->row (table path))
+
+(defmethod path->row :around (table (path fixnum))
+ (call-next-method table (list path)))
+
+(defmethod path->row ((table table) path)
+ (when path
+ (let* ((parent (path->row table (butlast path)))
+ (num (car (last path)))
+ (row (nth num (if parent
+ (row-children parent)
+ (rows table)))))
+ (make-row :table table
+ :num num
+ :parent parent
+ :data (car row)
+ :children (cdr row)))))
+
\ No newline at end of file
Added: test.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ test.lisp Thu Feb 9 07:45:13 2012 (r1)
@@ -0,0 +1,46 @@
+(defpackage #:cl-table-test
+ (:use #:cl #:cl-table))
+
+(in-package #:cl-table-test)
+
+(defun test ()
+ (let ((tab (make-instance 'table :columns '(a b))))
+ (let ((str (add tab)))
+ (setf (field str 'a) "str1a"
+ (field str 'b) "str1b"))
+ (let ((str (add tab)))
+ (setf (field str 'a) "str2a"
+ (field str 'b) "str2b")
+ (let ((str2 (add str)))
+ (setf (field str2 'a) "str21a"
+ (field str2 'b) "str21b")))
+ (list (field (path->row tab '(0)) 'b)
+ (field (path->row tab 1) 'a)
+ (field (path->row tab '(1 0)) 'b))
+ (path->row tab '(1 0))))
+
+
+
+(let ((tab (make-instance 'table :columns '(a b))))
+ (let ((str (add tab)))
+ (setf (field str 'a) "str1a"
+ (field str 'b) "str1b"))
+ (let ((str (add tab)))
+ (setf (field str 'a) "str2a"
+ (field str 'b) "str2b")
+ (let ((str2 (add str)))
+ (setf (field str2 'a) "str21a"
+ (field str2 'b) "str21b")))
+
+ (assert (equalp '("str1b" "str2a" "str21b")
+ (list (field (path->row tab '(0)) 'b)
+ (field (path->row tab 1) 'a)
+ (field (path->row tab '(1 0)) 'b))))
+ (let ((tab2 (make-iterator tab)))
+ (assert (equalp '("str1b" "str2a" "str21b")
+ (list (field (path->row tab2 '(0)) 'b)
+ (field (path->row tab2 1) 'a)
+ (field (path->row tab2 '(1 0)) 'b))))))
+
+
+
\ No newline at end of file
More information about the cl-table-cvs
mailing list