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

Contents of /table.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3 - (show annotations)
Wed Mar 20 17:22:22 2013 UTC (12 months, 4 weeks ago) by rklochkov
File size: 7956 byte(s)
Minor fixes
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
64 (defun sort! (table columns)
65 (setf (rows table)
66 (stable-sort (rows table)
67 (lambda (x y)
68 (compare-rows columns #'generic-lessp
69 (make-row :table table :data x)
70 (make-row :table table :data y))))))
71
72 ;; (defun add-columns (sum-columns dst-row src-row)
73 ;; (mapc (lambda (column)
74 ;; (setf (field dst-row column)
75 ;; (+ (field dst-row column)
76 ;; (field src-row column))))
77 ;; sum-columns))
78
79 (defun sum-columns! (sum-columns dst-row src-row)
80 "For each column in list SUM-COLUMNS put sum of fields
81 from dst and src rows to dst-row"
82 (assert (eq (car src-row) (car dst-row))) ; the same table for rows
83 (let ((cols (columns (car src-row))))
84 (mapc (lambda (column)
85 (iter (for name in cols)
86 (for value in (cdr src-row))
87 (for place on (cdr dst-row))
88 (when (eq name column)
89 (setf (car place) (+ (car place) value)))))
90 sum-columns)))
91
92 (defun drop-columns! (table columns)
93 (let ((old-columns (columns table)))
94 (labels ((get-diff (row)
95 (iter
96 (for col in old-columns)
97 (for field in row)
98 (unless (find col columns)
99 (collect field)))))
100 (iter
101 (for row on (rows table))
102 (setf (car row) (get-diff (car row))))
103 (setf (columns table) (get-diff (columns table))))))
104
105
106 (defun wrap! (table group-columns sum-columns)
107 (assert (null (intersection group-columns sum-columns)))
108 (drop-columns! table
109 (set-difference (columns table)
110 (union group-columns sum-columns)))
111 (sort! table group-columns)
112 (let (res)
113 (map-table (lambda (str)
114 (if (equal-rows group-columns (car res) str)
115 (sum-columns! sum-columns (car res) str)
116 (push str res))) table)
117 (setf (rows table) (nreverse res))))
118
119
120 (defun field (str key)
121 "Returns field of row STR with name symbol KEY"
122 (iter (for column in (columns (row-table str)))
123 (for value in (row-data str))
124 (when (eq (column-name column) key) (return value))))
125
126 (defsetf field (str key) (new-value)
127 (let ((column (gensym))
128 (value (gensym)))
129 `(iter (for ,column in (columns (row-table ,str)))
130 (for ,value on (row-data ,str))
131 (when (eq (column-name ,column) ,key)
132 (assert (typep ,new-value (column-type ,column)) (,new-value)
133 'type-error
134 :datum ,new-value
135 :expected-type (column-type ,column))
136 (return (setf (car ,value) ,new-value))))))
137
138 (defun map-table (func table)
139 (labels ((in-map (rows num)
140 (when rows
141 (funcall func (make-row :table table
142 :num num
143 :data (caar rows)
144 :children (cdar rows)))
145 (in-map (cdr rows) (+ 1 num)))))
146 (in-map (rows table) 0)))
147
148 (defun map-table-row (func row)
149 (labels ((in-table-row (rows num)
150 (when rows
151 (funcall func (make-row :table (row-table row)
152 :num num
153 :parent row
154 :data (caar rows)
155 :children (cdar rows)))
156 (in-table-row (cdr rows) (+ 1 num)))))
157 (in-table-row (row-children row) 0)))
158
159 (defmacro-clause (FOR var IN-TABLE table)
160 "Rows of a table: row = (table field1 field2 ...)"
161 (let ((tab (gensym))
162 (row (gensym))
163 (num (gensym)))
164 `(progn
165 (with ,tab = ,table)
166 (for ,row in ,(rows tab))
167 (for ,num from 0)
168 (for ,var = (make-row :table ,tab :num ,num
169 :data (car ,row)
170 :children (cdr ,row))))))
171
172 (defmacro-clause (FOR var IN-TABLE-ROW table)
173 "Rows of a table: row = (table field1 field2 ...)"
174 (let ((tab (gensym))
175 (row (gensym))
176 (parent (gensym))
177 (num (gensym)))
178 `(progn
179 (with ,parent = ,table)
180 (with ,tab = ,(row-table table))
181 (for ,row in (row-children ,tab))
182 (for ,num from 0)
183 (for ,var = (make-row :table ,tab :num ,num
184 :data (car ,row)
185 :children (cdr ,row)
186 :parent ,table)))))
187
188
189 (defgeneric add (to-place))
190
191 (defmacro append-item (item list)
192 `(setf ,list (append ,list (list ,item))))
193
194 (defmethod add ((table table))
195 (let (res)
196 (push nil res)
197 (dotimes (i (length (columns table)))
198 (push nil (car res)))
199 (prog1
200 (make-row :data (car res) :table table
201 :num (length (rows table)) :ref res)
202 (append-item res (rows table)))))
203
204 (defmethod add ((row row))
205 (let (res)
206 (push nil res)
207 (dotimes (i (length (columns (row-table row))))
208 (push nil (car res)))
209 (prog1
210 (make-row :data (car res) :table (row-table row) :ref res
211 :num (length (row-children row)) :parent row)
212 (append-item res (cdr (row-ref row))))))
213
214 (defgeneric path->row (table path))
215
216 (defmethod path->row :around (table (path fixnum))
217 (call-next-method table (list path)))
218
219 (defmethod path->row ((table table) path)
220 (when path
221 (let* ((parent (path->row table (butlast path)))
222 (num (car (last path)))
223 (row (nth num (if parent
224 (row-children parent)
225 (rows table)))))
226 (make-row :table table
227 :num num
228 :parent parent
229 :data (car row)
230 :children (cdr row)))))
231

  ViewVC Help
Powered by ViewVC 1.1.5