git.fiddlerwoaroof.com
Browse code

(init)

Ed Langley authored on 21/02/2020 03:23:35
Showing 4 changed files
.gitignore
History View file @ 250db60
1 1 
new file mode 100644
... ... 
@@ -0,0 +1 @@
1 
+*~
cellophane.asd
History View file @ 250db60
0 2 
new file mode 100644
cellophane.lisp
History View file @ 250db60
1 3 
new file mode 100644
... ... 
@@ -0,0 +1,182 @@
1 
+(defpackage :cellophane
2 
+  (:use :cl :fw.lu :alexandria :serapeum))
3 
+(in-package :cellophane)
4 
+
5 
+(defgeneric key-equal (a b key)
6 
+  (:documentation "Return true if A and B are key-equal under KEY.
7 
+
8 
+KEY has the highest precedence of the arguments but the default
9 
+methods specializing on KEY should be sufficient for most cases.
10 
+If you specialize on KEY, make sure that KEY is nil if you call
11 
+KEY-EQUAL recursively.")
12 
+  (:argument-precedence-order key a b)
13 
+  (:method (a b (key symbol))
14 
+    (if key
15 
+        (key-equal a b (symbol-function key))
16 
+        (call-next-method)))
17 
+  (:method ((a sequence) (b sequence) (key symbol))
18 
+    (if key
19 
+        (key-equal a b (symbol-function key))
20 
+        (call-next-method)))
21 
+
22 
+  (:method (a b (key function))
23 
+    (key-equal (funcall key a)
24 
+               (funcall key b)
25 
+               nil))
26 
+  (:method ((a sequence) (b sequence) (key function))
27 
+    (key-equal (map 'list key a)
28 
+               (map 'list key b)
29 
+               nil))
30 
+
31 
+  (:method (a b key)
32 
+    (declare (ignore key))
33 
+    (eql a b))
34 
+
35 
+  (:method ((a string) (b string) key)
36 
+    (equal a b))
37 
+
38 
+  (:method ((a sequence) (b sequence) key)
39 
+    (if (= (length a)
40 
+           (length b))
41 
+        (reduce (lambda (accum next)
42 
+                  (and accum
43 
+                       (key-equal (car next)
44 
+				                          (cdr next)
45 
+				                          nil)))
46 
+		            (map 'list #'cons a b)
47 
+		            :initial-value t)
48 
+	      nil)))
49 
+
50 
+(defun == (a b &optional key)
51 
+  (key-equal a b key))
52 
+
53 
+(defclass axis ()
54 
+  ((%index-map :initform (make-hash-table :test 'equal)
55 
+	       :reader index-map)
56 
+   (%values :initarg :values :reader axis-values)))
57 
+
58 
+(defclass coordinate-system ()
59 
+  ((%axes :initarg :axes :reader axes)
60 
+   (%data :initarg :data :reader data)))
61 
+
62 
+(defmethod initialize-instance :after ((object axis) &key values)
63 
+  (let ((values (coerce values 'vector)))
64 
+    (setf (slot-value object '%values) values)
65 
+    (loop
66 
+       for val across values
67 
+       for idx from 0
68 
+       do (setf (gethash val (index-map object)) idx))))
69 
+
70 
+(defgeneric index-for (axis value)
71 
+  (:documentation "Given an axis and a value, get the baseindex of this value "))
72 
+
73 
+(defmethod index-for ((axis axis) value)
74 
+  (gethash value (index-map axis)))
75 
+
76 
+(defmethod index-for :before ((axis sequence) (value sequence))
77 
+  (unless (= (length axis)
78 
+	     (length value))
79 
+    (error "number of indices must match number of axes")))
80 
+
81 
+(defmethod index-for ((axes sequence) (value sequence))
82 
+  (map-into (make-sequence (type-of value)
83 
+			   (length value))
84 
+	    #'index-for
85 
+	    axes
86 
+	    value))
87 
+
88 
+(defmethod index-for ((coordinate-system coordinate-system) value)
89 
+  (index-for (axes coordinate-system) value))
90 
+
91 
+(defun get-cell (coordinate-system index-vals)
92 
+  (unless (= (length index-vals)
93 
+	     (length (axes coordinate-system)))
94 
+    (error "must pass as many indices and axes"))
95 
+  (let ((indices (index-for coordinate-system
96 
+			    (coerce index-vals 'list))))
97 
+    (format t "~%Indices: ~s~%~4t~s~%" index-vals indices)
98 
+    (apply #'aref (data coordinate-system)
99 
+	   indices)))
100 
+
101 
+(defun flatmap (type op &rest seqs)
102 
+  (apply #'concatenate type
103 
+	 (apply #'map 'list  op seqs)))
104 
+
105 
+(defun combine-axes (&rest axes)
106 
+  (when axes
107 
+    (map 'list (op (list _ (apply #'combine-axes (cdr axes))))
108 
+	 (axis-values (car axes)))))
109 
+
110 
+(defun layout-tree-horizontal (combined)
111 
+  (values-list (reduce (destructuring-lambda ((accum-vals accum-width) (next-val next-width))
112 
+			 (list (append accum-vals
113 
+				       (list next-val))
114 
+			       (+ accum-width next-width)))
115 
+		       (mapcar (destructuring-lambda ((node child))
116 
+				 (let ((node (princ-to-string node)))
117 
+				   (multiple-value-bind (val width) (layout-tree-horizontal child)
118 
+				     (let* ((width (max (1+ (length node))
119 
+							width))
120 
+					    (result (format nil "~v@<~a~>" width node)))
121 
+				       (list (list* result val)
122 
+					     width)))))
123 
+			       combined)
124 
+		       :initial-value (list nil 0))))
125 
+
126 
+(defun print-tree-horizontal (layout)
127 
+  (let ((cur-level (mapcar #'car layout))
128 
+	(next-levels (apply 'append (mapcar #'cdr layout))))
129 
+    (princ (string-join cur-level))
130 
+    (terpri)
131 
+    (when (some #'identity next-levels)
132 
+      (print-tree-horizontal next-levels))))
133 
+
134 
+(defun layout-axis (&rest axes)
135 
+  (let ((combined (apply 'combine-axes axes)))
136 
+    (print-tree-horizontal (layout-tree-horizontal combined))))
137 
+
138 
+
139 
+(defparameter *year-axis*
140 
+  (make-instance 'axis
141 
+		 :values #(2009 2010 2011 2012)))
142 
+
143 
+(defparameter *quarter-axis*
144 
+  (make-instance 'axis
145 
+		 :values #(1st 2nd 3rd 4th)))
146 
+
147 
+(defparameter *item-type-axis*
148 
+  (make-instance 'axis
149 
+		 :values #(electronics gas clothing food)))
150 
+
151 
+(defparameter *customer-axis*
152 
+  (make-instance 'axis
153 
+		 :values #(CustomerA CustomerB CustomerC CustomerD)))
154 
+
155 
+(defparameter *tmp-dataset*
156 
+  #4a
157 
+  (((( 6 17  0 14) (18  6 15  7) (14  1 17  6) ( 4 16  8 17))
158 
+    (( 9  6  6 18) (16  3 17 14) (17 13 12 18) (12  6 15  6))
159 
+    ((13  8  8 19) (19  6  5 10) ( 7 15 17 13) (15 13  1  3))
160 
+    ((12 13  7 10) (18  4 16 14) ( 6 10  7  6) ( 2  5  4 13)))
161 
+
162 
+   (((17  7  5 19) ( 6 11  4  6) ( 5  4  7 11) ( 2  9  6 15))
163 
+    ((16  9 13 13) (18  2  5 16) (12  3  6 14) ( 3  8  9  0))
164 
+    ((12  9  0  0) (18  8 19  4) (16 16 16  9) (13 18  0 19))
165 
+    ((11 13 17  0) ( 2  2 17  2) ( 5 18  7  5) ( 2  0 15 19)))
166 
+
167 
+
168 
+   ((( 1 15 19  3) (10 12  0  5) ( 6 13  2  3) (12  7 15  1))
169 
+    ((17  5  8  8) ( 4  0 16 18) (18 19  3 17) (10 14  6  2))
170 
+    ((14  7 12  8) ( 2  0 16 12) (18 15  1  9) (14  7 14 10))
171 
+    ((18 18 18  6) ( 3 19  9  3) ( 7  7 14 16) ( 2  5  8  4)))
172 
+
173 
+   ((( 8 19  7 11) ( 6 14 15 17) (14 13 16  7) ( 1  4  6  9))
174 
+    (( 5 19  1 17) (10 12  6  1) ( 8  4 16 16) (12  7 12  6))
175 
+    ((14 14  0  2) (11 18 14 15) ( 6  7  9 19) (11 14 14 12))
176 
+    (( 8 13  2 14) ( 8  6  0  4) ( 9  4  5  2) ( 6 17  2  9)))))
177 
+
178 
+(defparameter *coordinate-system*
179 
+  (make-instance 'coordinate-system
180 
+		 :axes (list *year-axis* *quarter-axis* *item-type-axis* *customer-axis*)
181 
+		 :data (copy-array *tmp-dataset*)))
182 
+
cellophane.old.lisp
History View file @ 250db60
0 183 
new file mode 100644
... ... 
@@ -0,0 +1,183 @@
1 
+(defpackage :cellophane
2 
+  (:use :cl :fw.lu :alexandria :serapeum))
3 
+(in-package :cellophane)
4 
+
5 
+(defgeneric key-equal (a b key)
6 
+  (:documentation "Return true if A and B are key-equal under KEY.
7 
+
8 
+KEY has the highest precedence of the arguments but the default
9 
+methods specializing on KEY should be sufficient for most cases.
10 
+If you specialize on KEY, make sure that KEY is nil if you call
11 
+KEY-EQUAL recursively.")
12 
+  (:argument-precedence-order key a b)
13 
+  (:method (a b (key symbol))
14 
+    (if key
15 
+	(key-equal a b (symbol-function key))
16 
+	(call-next-method)))
17 
+  (:method ((a sequence) (b sequence) (key symbol))
18 
+    (if key
19 
+	(key-equal a b (symbol-function key))
20 
+	(call-next-method)))
21 
+
22 
+  (:method (a b (key function))
23 
+    (key-equal (funcall key a)
24 
+	       (funcall key b)
25 
+	       nil))
26 
+  (:method ((a sequence) (b sequence) (key function))
27 
+    (key-equal (map 'list key a)
28 
+	       (map 'list key b)
29 
+	       nil))
30 
+
31 
+  (:method (a b key)
32 
+    (declare (ignore key))
33 
+    (eql a b))
34 
+
35 
+  (:method ((a string) (b string) key)
36 
+    (equal a b))
37 
+
38 
+  (:method ((a sequence) (b sequence) key)
39 
+    (if (= (length a)
40 
+	   (length b))
41 
+	(reduce (lambda (accum next)
42 
+		  (and accum
43 
+		       (key-equal (car next)
44 
+				  (cdr next)
45 
+				  nil)))
46 
+		(map 'list #'cons a b)
47 
+		:initial-value t)
48 
+	nil)))
49 
+
50 
+(defun == (a b &optional key)
51 
+  (key-equal a b key))
52 
+
53 
+(defclass axis ()
54 
+  ((%index-map :initform (make-hash-table :test 'equal)
55 
+	       :reader index-map)
56 
+   (%values :initarg :values :reader axis-values)))
57 
+
58 
+(defclass coordinate-system ()
59 
+  ((%axes :initarg :axes :reader axes)
60 
+   (%data :initarg :data :reader data)))
61 
+
62 
+(defmethod initialize-instance :after ((object axis) &key values)
63 
+  (let ((values (coerce values 'vector)))
64 
+    (setf (slot-value object '%values) values)
65 
+    (loop
66 
+       for val across values
67 
+       for idx from 0
68 
+       do (setf (gethash val (index-map object)) idx))))
69 
+
70 
+(defgeneric index-for (axis value)
71 
+  (:documentation "Given an axis and a value, get the baseindex of this value "))
72 
+
73 
+(defmethod index-for ((axis axis) value)
74 
+  (gethash value (index-map axis)))
75 
+
76 
+(defmethod index-for :before ((axis sequence) (value sequence))
77 
+  (unless (= (length axis)
78 
+	     (length value))
79 
+    (error "number of indices must match number of axes")))
80 
+
81 
+(defmethod index-for ((axes sequence) (value sequence))
82 
+  (map-into (make-sequence (type-of value)
83 
+			   (length value))
84 
+	    #'index-for
85 
+	    axes
86 
+	    value))
87 
+
88 
+(defmethod index-for ((coordinate-system coordinate-system) value)
89 
+  (index-for (axes coordinate-system) value))
90 
+
91 
+(defun get-cell (coordinate-system index-vals)
92 
+  (unless (= (length index-vals)
93 
+	     (length (axes coordinate-system)))
94 
+    (error "must pass as many indices and axes"))
95 
+  (let ((indices (index-for coordinate-system
96 
+			    (coerce index-vals 'list))))
97 
+    (format t "~%Indices: ~s~%~4t~s~%" index-vals indices)
98 
+    (apply #'aref (data coordinate-system)
99 
+	   indices)))
100 
+
101 
+(defun flatmap (type op &rest seqs)
102 
+  (apply #'concatenate type
103 
+	 (apply #'map 'list  op seqs)))
104 
+
105 
+(defun combine-axes (&rest axes)
106 
+  (when axes
107 
+    (map 'list (op (list _ (apply #'combine-axes (cdr axes))))
108 
+	 (axis-values (car axes)))))
109 
+
110 
+(defun layout-tree-horizontal (combined)
111 
+  (values-list (reduce (destructuring-lambda ((accum-vals accum-width) (next-val next-width))
112 
+			 (list (append accum-vals
113 
+				       (list next-val))
114 
+			       (+ accum-width next-width)))
115 
+		       (mapcar (destructuring-lambda ((node child))
116 
+				 (let ((node (princ-to-string node)))
117 
+				   (multiple-value-bind (val width) (layout-tree-horizontal child)
118 
+				     (let* ((width (max (1+ (length node))
119 
+							width))
120 
+					    (result (format nil "~v@<~a~>" width node)))
121 
+				       (list (list* result val)
122 
+					     width)))))
123 
+			       combined)
124 
+		       :initial-value (list nil 0))))
125 
+
126 
+(defun print-tree-horizontal (layout)
127 
+  (let ((cur-level (mapcar #'car layout))
128 
+	(next-levels (apply 'append (mapcar #'cdr layout))))
129 
+    (princ (string-join cur-level))
130 
+    (terpri)
131 
+    (when (some #'identity next-levels)
132 
+      (print-tree-horizontal next-levels))))
133 
+
134 
+(defun layout-axis (&rest axes)
135 
+  (let ((combined (apply 'combine-axes axes)))
136 
+    (print-tree-horizontal (layout-tree-horizontal combined))))
137 
+
138 
+
139 
+(defparameter *year-axis*
140 
+  (make-instance 'axis
141 
+		 :values #(2009 2010 2011 2012)))
142 
+
143 
+(defparameter *quarter-axis*
144 
+  (make-instance 'axis
145 
+		 :values #(1st 2nd 3rd 4th)))
146 
+
147 
+(defparameter *item-type-axis*
148 
+  (make-instance 'axis
149 
+		 :values #(electronics gas clothing food)))
150 
+
151 
+(defparameter *customer-axis*
152 
+  (make-instance 'axis
153 
+		 :values #(CustomerA CustomerB CustomerC CustomerD)))
154 
+
155 
+(defparameter *tmp-dataset*
156 
+  #4a
157 
+  (((( 6 17  0 14) (18  6 15  7) (14  1 17  6) ( 4 16  8 17))
158 
+    (( 9  6  6 18) (16  3 17 14) (17 13 12 18) (12  6 15  6))
159 
+    ((13  8  8 19) (19  6  5 10) ( 7 15 17 13) (15 13  1  3))
160 
+    ((12 13  7 10) (18  4 16 14) ( 6 10  7  6) ( 2  5  4 13)))
161 
+
162 
+   (((17  7  5 19) ( 6 11  4  6) ( 5  4  7 11) ( 2  9  6 15))
163 
+    ((16  9 13 13) (18  2  5 16) (12  3  6 14) ( 3  8  9  0))
164 
+    ((12  9  0  0) (18  8 19  4) (16 16 16  9) (13 18  0 19))
165 
+    ((11 13 17  0) ( 2  2 17  2) ( 5 18  7  5) ( 2  0 15 19)))
166 
+
167 
+
168 
+   ((( 1 15 19  3) (10 12  0  5) ( 6 13  2  3) (12  7 15  1))
169 
+    ((17  5  8  8) ( 4  0 16 18) (18 19  3 17) (10 14  6  2))
170 
+    ((14  7 12  8) ( 2  0 16 12) (18 15  1  9) (14  7 14 10))
171 
+    ((18 18 18  6) ( 3 19  9  3) ( 7  7 14 16) ( 2  5  8  4)))
172 
+
173 
+   ((( 8 19  7 11) ( 6 14 15 17) (14 13 16  7) ( 1  4  6  9))
174 
+    (( 5 19  1 17) (10 12  6  1) ( 8  4 16 16) (12  7 12  6))
175 
+    ((14 14  0  2) (11 18 14 15) ( 6  7  9 19) (11 14 14 12))
176 
+    (( 8 13  2 14) ( 8  6  0  4) ( 9  4  5  2) ( 6 17  2  9)))))
177 
+
178 
+(defparameter *coordinate-system*
179 
+  (make-instance 'coordinate-system
180 
+		 :axes (list *year-axis* *quarter-axis* *item-type-axis* *customer-axis*)
181 
+		 :data (copy-array *tmp-dataset*)))
182 
+
183 
+(def)