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

Contents of /cl-table.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1 - (show annotations)
Thu Feb 9 15:45:13 2012 UTC (2 years, 2 months ago) by rklochkov
File size: 4127 byte(s)
Initial release
1 (in-package :cl-table)
2
3 (defclass table ()
4 ((columns :accessor columns :type list)
5 (rows :accessor rows :type list)
6 (indexes :accessor indexes :type list)))
7
8 (defgeneric generic-lessp (x y)
9 (:documentation "Order by numbers or strings")
10 (:method ((x string) (y string))
11 (string-lessp x y))
12 (:method ((x string) y)
13 (generic-lessp x (write-to-string y)))
14 (:method (x (y string))
15 (generic-lessp (write-to-string x) y))
16 (:method ((x number) (y number))
17 (< x y)))
18
19 (defun compare-rows (cols pred row1 row2)
20 (when cols
21 (labels ((%compare (%cols)
22 (let ((f1 (field row1 (car %cols)))
23 (f2 (field row2 (car %cols))))
24 (if (equal f1 f2) (%compare (cdr %cols))
25 (funcall pred f1 f2)))))
26 (%compare cols))))
27
28 (defun equal-rows (cols row1 row2)
29 (if cols
30 (let ((f1 (field row1 (car cols)))
31 (f2 (field row2 (car cols))))
32 (when (equal f1 f2) (equal-rows (cdr cols) row1 row2)))
33 t))
34
35 (eval-when (:compile-toplevel :execute)
36 (defun enable-sharpL-reader ()
37 (set-dispatch-macro-character #\# #\L #'iterate::sharpL-reader))
38 (setf *readtable* (copy-readtable *readtable*))
39 (enable-sharpL-reader))
40
41
42 (defun sort! (table columns)
43 (setf (rows table)
44 (stable-sort (rows table)
45 #L(compare-rows columns #'generic-lessp
46 (cons table !1) (cons table !2)))))
47
48 ;; (defun add-columns (sum-columns dst-row src-row)
49 ;; (mapc (lambda (column)
50 ;; (setf (field dst-row column)
51 ;; (+ (field dst-row column)
52 ;; (field src-row column))))
53 ;; sum-columns))
54
55 (defun sum-columns! (sum-columns dst-row src-row)
56 "For each column in list SUM-COLUMNS put sum of fields
57 from dst and src rows to dst-row"
58 (assert (eq (car src-row) (car dst-row))) ; the same table for rows
59 (let ((cols (columns (car src-row))))
60 (mapc (lambda (column)
61 (iter (for name in cols)
62 (for value in (cdr src-row))
63 (for place on (cdr dst-row))
64 (when (eq name column)
65 (setf (car place) (+ (car place) value)))))
66 sum-columns)))
67
68 (defun drop-columns! (table columns)
69 (let ((old-columns (columns table)))
70 (labels ((get-diff (row)
71 (iter
72 (for col in old-columns)
73 (for field in row)
74 (unless (find col columns)
75 (collect field)))))
76 (iter
77 (for row on (rows table))
78 (setf (car row) (get-diff (car row))))
79 (setf (columns table) (get-diff (columns table))))))
80
81
82 (defun wrap! (table group-columns sum-columns)
83 (assert (null (intersection group-columns sum-columns)))
84 (drop-columns! table
85 (set-difference (columns table)
86 (union group-columns sum-columns)))
87 (sort table group-columns)
88 (let (res)
89 (map-table (lambda (str)
90 (if (equal-rows group-columns (car res) str)
91 (sum-columns! sum-columns (car res) str)
92 (push str res))) table)
93 (setf (rows table) (nreverse res))))
94
95
96 (defun field (str key)
97 "Returns field of row STR with name symbol KEY
98 Assume (car str) = table & (cdr str) = current row"
99 (iter (for name in (columns (car str)))
100 (for value in (cdr str))
101 (when (eq name key) (return value))))
102
103 (defsetf field (str key) (new-value)
104 `(iter (for name in (columns (car ,str)))
105 (for value on (cdr ,str))
106 (when (eq name ,key) (setf (car value) ,new-value))))
107
108 (defun map-table (func table)
109 (labels ((in-map (rest)
110 (when rest
111 (funcall func (cons table (car rest)))
112 (in-map (cdr rest)))))
113 (in-map (rows table))))
114
115 (defmacro-clause (FOR var IN-TABLE table)
116 "Rows of a table: row = (table field1 field2 ...)"
117 (let ((tab (gensym))
118 (row (gensym)))
119 `(progn
120 (with ,tab = ,table)
121 (for ,row in ,(rows tab))
122 (for ,var = (cons ,tab ,row)))))

  ViewVC Help
Powered by ViewVC 1.1.5