From rklochkov at common-lisp.net Thu Feb 9 15:45:14 2012 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Thu, 09 Feb 2012 07:45:14 -0800 Subject: [cl-table-cvs] r1 - Message-ID: 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 +;;; + +(defpackage #:cl-table-system + (:use #:cl #:asdf)) +(in-package #:cl-table-system) + +(defsystem cl-table + :description "Hierarchical tables in Lisp" + :author "Roman Klochkov " + :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 From rklochkov at common-lisp.net Thu Feb 9 16:05:54 2012 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Thu, 09 Feb 2012 08:05:54 -0800 Subject: [cl-table-cvs] r2 - Message-ID: Author: rklochkov Date: Thu Feb 9 08:05:54 2012 New Revision: 2 Log: Cleanup Deleted: svn-commit.tmp