/[cl-table]/table.lisp
ViewVC logotype

Contents of /table.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (hide annotations)
Thu Feb 9 15:45:13 2012 UTC (2 years, 2 months ago) by rklochkov
File size: 10044 byte(s)
Initial release
1 rklochkov 1 (in-package :cl-table)
2    
3     (defstruct row
4     "Struct for representing row in table"
5     (parent nil :type (or null row))
6     (ref nil :type list)
7     (children nil :type list)
8     (table nil :type table)
9     (num 0 :type fixnum)
10     (data nil :type list))
11    
12     (defstruct column
13     (name nil :type (and symbol (not null)))
14     (type t :type (or symbol list)))
15    
16     (defclass table ()
17     ((columns :accessor columns :type list)
18     (rows :accessor rows :type list :initform nil
19     :documentation
20     "List of lists = data in (car row), list of children rows in (cdr row)
21     Assert (length (car row)) == (length columns)")
22     (indexes :accessor indexes :type list :initform nil)))
23    
24     (defmethod shared-initialize :after ((table table) slot-names
25     &key columns)
26     (when (notevery #'column-p columns)
27     (setf (columns table)
28     (mapcar (lambda (x) (etypecase x
29     (symbol (make-column :name x))
30     (list (make-column :name (car x)
31     :type (second x)))
32     (column x)))
33     columns))))
34    
35    
36     (defgeneric generic-lessp (x y)
37     (:documentation "Order by numbers or strings")
38     (:method ((x string) (y string))
39     (string-lessp x y))
40     (:method ((x string) y)
41     (generic-lessp x (write-to-string y)))
42     (:method (x (y string))
43     (generic-lessp (write-to-string x) y))
44     (:method ((x number) (y number))
45     (< x y)))
46    
47     (defun compare-rows (cols pred row1 row2)
48     (when cols
49     (labels ((%compare (%cols)
50     (let ((f1 (field row1 (car %cols)))
51     (f2 (field row2 (car %cols))))
52     (if (equal f1 f2) (%compare (cdr %cols))
53     (funcall pred f1 f2)))))
54     (%compare cols))))
55    
56     (defun equal-rows (cols row1 row2)
57     (if cols
58     (let ((f1 (field row1 (car cols)))
59     (f2 (field row2 (car cols))))
60     (when (equal f1 f2) (equal-rows (cdr cols) row1 row2)))
61     t))
62    
63     (eval-when (:compile-toplevel :execute)
64    
65     (defun list-of-forms? (x)
66     (and (consp x) (consp (car x))
67     (not (eq (caar x) 'lambda))))
68    
69     (defun sharpL-reader (stream subchar n-args)
70     (declare (ignore subchar))
71     (let* ((form (read stream t nil t))
72     (bang-vars (sort (bang-vars form) #'< :key #'bang-var-num))
73     (bang-var-nums (mapcar #'bang-var-num bang-vars))
74     (max-bv-num (if bang-vars
75     (reduce #'max bang-var-nums :initial-value 0)
76     0)))
77     (cond
78     ((null n-args)
79     (setq n-args max-bv-num))
80     ((< n-args max-bv-num)
81     (error "#L: digit-string ~d specifies too few arguments" n-args)))
82     (let* ((bvars (let ((temp nil))
83     (dotimes (i n-args (nreverse temp))
84     (push (make-bang-var (1+ i)) temp))))
85     (args (mapcar #'(lambda (x) (declare (ignore x)) (gensym))
86     bvars))
87     (ignores (set-difference bvars bang-vars))
88     (decl (if ignores `(declare (ignore .,ignores)) nil))
89     (body (if (list-of-forms? form)
90     (if decl (cons decl form) form)
91     (if decl (list decl form) (list form))))
92     (subbed-body (sublis (pairlis bvars args) body)))
93     `#'(lambda ,args ,.subbed-body))))
94    
95     (defun make-bang-var (n)
96     (intern (format nil "!~d" n)))
97    
98     (defun bang-vars (form)
99     (delete-duplicates (bang-vars-1 form '()) :test #'eq))
100    
101     (defun bang-vars-1 (form vars)
102     (cond
103     ((consp form)
104     (bang-vars-1 (cdr form)
105     (bang-vars-1 (car form) vars)))
106     ((and (symbolp form) (bang-var? form)) (cons form vars))
107     (t vars)))
108    
109     (defun bang-var? (sym)
110     (char= (char (symbol-name sym) 0) #\!))
111    
112     (defun bang-var-num (sym)
113     (let ((num (read-from-string (subseq (symbol-name sym) 1))))
114     (if (not (and (integerp num) (> num 0)))
115     (error "#L: ~a is not a valid variable specifier" sym)
116     num)))
117    
118     (defun enable-sharpL-reader ()
119     (set-dispatch-macro-character #\# #\L #'sharpL-reader))
120    
121     ;; According to CLHS, *readtable* must be rebound when compiling
122     ;; so we are free to reassign it to a copy and modify that copy.
123     (setf *readtable* (copy-readtable *readtable*))
124     (enable-sharpL-reader)
125    
126     ) ; end eval-when
127    
128    
129     (defun sort! (table columns)
130     (setf (rows table)
131     (stable-sort (rows table)
132     #L(compare-rows columns #'generic-lessp
133     (make-row :table table :data !1)
134     (make-row :table table :data !2)))))
135    
136     ;; (defun add-columns (sum-columns dst-row src-row)
137     ;; (mapc (lambda (column)
138     ;; (setf (field dst-row column)
139     ;; (+ (field dst-row column)
140     ;; (field src-row column))))
141     ;; sum-columns))
142    
143     (defun sum-columns! (sum-columns dst-row src-row)
144     "For each column in list SUM-COLUMNS put sum of fields
145     from dst and src rows to dst-row"
146     (assert (eq (car src-row) (car dst-row))) ; the same table for rows
147     (let ((cols (columns (car src-row))))
148     (mapc (lambda (column)
149     (iter (for name in cols)
150     (for value in (cdr src-row))
151     (for place on (cdr dst-row))
152     (when (eq name column)
153     (setf (car place) (+ (car place) value)))))
154     sum-columns)))
155    
156     (defun drop-columns! (table columns)
157     (let ((old-columns (columns table)))
158     (labels ((get-diff (row)
159     (iter
160     (for col in old-columns)
161     (for field in row)
162     (unless (find col columns)
163     (collect field)))))
164     (iter
165     (for row on (rows table))
166     (setf (car row) (get-diff (car row))))
167     (setf (columns table) (get-diff (columns table))))))
168    
169    
170     (defun wrap! (table group-columns sum-columns)
171     (assert (null (intersection group-columns sum-columns)))
172     (drop-columns! table
173     (set-difference (columns table)
174     (union group-columns sum-columns)))
175     (sort! table group-columns)
176     (let (res)
177     (map-table (lambda (str)
178     (if (equal-rows group-columns (car res) str)
179     (sum-columns! sum-columns (car res) str)
180     (push str res))) table)
181     (setf (rows table) (nreverse res))))
182    
183    
184     (defun field (str key)
185     "Returns field of row STR with name symbol KEY"
186     (iter (for column in (columns (row-table str)))
187     (for value in (row-data str))
188     (when (eq (column-name column) key) (return value))))
189    
190     (defsetf field (str key) (new-value)
191     (let ((column (gensym))
192     (value (gensym)))
193     `(iter (for ,column in (columns (row-table ,str)))
194     (for ,value on (row-data ,str))
195     (when (eq (column-name ,column) ,key)
196     (assert (typep ,new-value (column-type ,column)) (,new-value)
197     'type-error
198     :datum ,new-value
199     :expected-type (column-type ,column))
200     (return (setf (car ,value) ,new-value))))))
201    
202     (defun map-table (func table)
203     (labels ((in-map (rows num)
204     (when rows
205     (funcall func (make-row :table table
206     :num num
207     :data (caar rows)
208     :children (cdar rows)))
209     (in-map (cdr rows) (+ 1 num)))))
210     (in-map (rows table) 0)))
211    
212     (defun map-table-row (func row)
213     (labels ((in-table-row (rows num)
214     (when rows
215     (funcall func (make-row :table (row-table row)
216     :num num
217     :parent row
218     :data (caar rows)
219     :children (cdar rows)))
220     (in-table-row (cdr rows) (+ 1 num)))))
221     (in-table-row (row-children row) 0)))
222    
223     (defmacro-clause (FOR var IN-TABLE table)
224     "Rows of a table: row = (table field1 field2 ...)"
225     (let ((tab (gensym))
226     (row (gensym))
227     (num (gensym)))
228     `(progn
229     (with ,tab = ,table)
230     (for ,row in ,(rows tab))
231     (for ,num from 0)
232     (for ,var = (make-row :table ,tab :num ,num
233     :data (car ,row)
234     :children (cdr ,row))))))
235    
236     (defmacro-clause (FOR var IN-TABLE-ROW table)
237     "Rows of a table: row = (table field1 field2 ...)"
238     (let ((tab (gensym))
239     (row (gensym))
240     (parent (gensym))
241     (num (gensym)))
242     `(progn
243     (with ,parent = ,table)
244     (with ,tab = ,(row-table table))
245     (for ,row in (row-children ,tab))
246     (for ,num from 0)
247     (for ,var = (make-row :table ,tab :num ,num
248     :data (car ,row)
249     :children (cdr ,row)
250     :parent ,table)))))
251    
252    
253     (defgeneric add (to-place))
254    
255     (defmacro append-item (item list)
256     `(setf ,list (append ,list (list ,item))))
257    
258     (defmethod add ((table table))
259     (let (res)
260     (push nil res)
261     (dotimes (i (length (columns table)))
262     (push nil (car res)))
263     (prog1
264     (make-row :data (car res) :table table
265     :num (length (rows table)) :ref res)
266     (append-item res (rows table)))))
267    
268     (defmethod add ((row row))
269     (let (res)
270     (push nil res)
271     (dotimes (i (length (columns (row-table row))))
272     (push nil (car res)))
273     (prog1
274     (make-row :data (car res) :table (row-table row) :ref res
275     :num (length (row-children row)) :parent row)
276     (append-item res (cdr (row-ref row))))))
277    
278     (defgeneric path->row (table path))
279    
280     (defmethod path->row :around (table (path fixnum))
281     (call-next-method table (list path)))
282    
283     (defmethod path->row ((table table) path)
284     (when path
285     (let* ((parent (path->row table (butlast path)))
286     (num (car (last path)))
287     (row (nth num (if parent
288     (row-children parent)
289     (rows table)))))
290     (make-row :table table
291     :num num
292     :parent parent
293     :data (car row)
294     :children (cdr row)))))
295    

  ViewVC Help
Powered by ViewVC 1.1.5