(defpackage :cellophane
(:use :cl :fw.lu :alexandria :serapeum))
(in-package :cellophane)
(defgeneric key-equal (a b key)
(:documentation "Return true if A and B are key-equal under KEY.
KEY has the highest precedence of the arguments but the default
methods specializing on KEY should be sufficient for most cases.
If you specialize on KEY, make sure that KEY is nil if you call
KEY-EQUAL recursively.")
(:argument-precedence-order key a b)
(:method (a b (key symbol))
(if key
(key-equal a b (symbol-function key))
(call-next-method)))
(:method ((a sequence) (b sequence) (key symbol))
(if key
(key-equal a b (symbol-function key))
(call-next-method)))
(:method (a b (key function))
(key-equal (funcall key a)
(funcall key b)
nil))
(:method ((a sequence) (b sequence) (key function))
(key-equal (map 'list key a)
(map 'list key b)
nil))
(:method (a b key)
(declare (ignore key))
(eql a b))
(:method ((a string) (b string) key)
(equal a b))
(:method ((a sequence) (b sequence) key)
(if (= (length a)
(length b))
(reduce (lambda (accum next)
(and accum
(key-equal (car next)
(cdr next)
nil)))
(map 'list #'cons a b)
:initial-value t)
nil)))
(defun == (a b &optional key)
(key-equal a b key))
(defclass axis ()
((%index-map :initform (make-hash-table :test 'equal)
:reader index-map)
(%values :initarg :values :reader axis-values)))
(defclass coordinate-system ()
((%axes :initarg :axes :reader axes)
(%data :initarg :data :reader data)))
(defmethod initialize-instance :after ((object axis) &key values)
(let ((values (coerce values 'vector)))
(setf (slot-value object '%values) values)
(loop
for val across values
for idx from 0
do (setf (gethash val (index-map object)) idx))))
(defgeneric index-for (axis value)
(:documentation "Given an axis and a value, get the baseindex of this value "))
(defmethod index-for ((axis axis) value)
(gethash value (index-map axis)))
(defmethod index-for :before ((axis sequence) (value sequence))
(unless (= (length axis)
(length value))
(error "number of indices must match number of axes")))
(defmethod index-for ((axes sequence) (value sequence))
(map-into (make-sequence (type-of value)
(length value))
#'index-for
axes
value))
(defmethod index-for ((coordinate-system coordinate-system) value)
(index-for (axes coordinate-system) value))
(defun get-cell (coordinate-system index-vals)
(unless (= (length index-vals)
(length (axes coordinate-system)))
(error "must pass as many indices and axes"))
(let ((indices (index-for coordinate-system
(coerce index-vals 'list))))
(format t "~%Indices: ~s~%~4t~s~%" index-vals indices)
(apply #'aref (data coordinate-system)
indices)))
(defun flatmap (type op &rest seqs)
(apply #'concatenate type
(apply #'map 'list op seqs)))
(defun combine-axes (&rest axes)
(when axes
(map 'list (op (list _ (apply #'combine-axes (cdr axes))))
(axis-values (car axes)))))
(defun layout-tree-horizontal (combined)
(values-list (reduce (destructuring-lambda ((accum-vals accum-width) (next-val next-width))
(list (append accum-vals
(list next-val))
(+ accum-width next-width)))
(mapcar (destructuring-lambda ((node child))
(let ((node (princ-to-string node)))
(multiple-value-bind (val width) (layout-tree-horizontal child)
(let* ((width (max (1+ (length node))
width))
(result (format nil "~v@<~a~>" width node)))
(list (list* result val)
width)))))
combined)
:initial-value (list nil 0))))
(defun print-tree-horizontal (layout)
(let ((cur-level (mapcar #'car layout))
(next-levels (apply 'append (mapcar #'cdr layout))))
(princ (string-join cur-level))
(terpri)
(when (some #'identity next-levels)
(print-tree-horizontal next-levels))))
(defun layout-axis (&rest axes)
(let ((combined (apply 'combine-axes axes)))
(print-tree-horizontal (layout-tree-horizontal combined))))
(defparameter *year-axis*
(make-instance 'axis
:values #(2009 2010 2011 2012)))
(defparameter *quarter-axis*
(make-instance 'axis
:values #(1st 2nd 3rd 4th)))
(defparameter *item-type-axis*
(make-instance 'axis
:values #(electronics gas clothing food)))
(defparameter *customer-axis*
(make-instance 'axis
:values #(CustomerA CustomerB CustomerC CustomerD)))
(defparameter *tmp-dataset*
#4a
(((( 6 17 0 14) (18 6 15 7) (14 1 17 6) ( 4 16 8 17))
(( 9 6 6 18) (16 3 17 14) (17 13 12 18) (12 6 15 6))
((13 8 8 19) (19 6 5 10) ( 7 15 17 13) (15 13 1 3))
((12 13 7 10) (18 4 16 14) ( 6 10 7 6) ( 2 5 4 13)))
(((17 7 5 19) ( 6 11 4 6) ( 5 4 7 11) ( 2 9 6 15))
((16 9 13 13) (18 2 5 16) (12 3 6 14) ( 3 8 9 0))
((12 9 0 0) (18 8 19 4) (16 16 16 9) (13 18 0 19))
((11 13 17 0) ( 2 2 17 2) ( 5 18 7 5) ( 2 0 15 19)))
((( 1 15 19 3) (10 12 0 5) ( 6 13 2 3) (12 7 15 1))
((17 5 8 8) ( 4 0 16 18) (18 19 3 17) (10 14 6 2))
((14 7 12 8) ( 2 0 16 12) (18 15 1 9) (14 7 14 10))
((18 18 18 6) ( 3 19 9 3) ( 7 7 14 16) ( 2 5 8 4)))
((( 8 19 7 11) ( 6 14 15 17) (14 13 16 7) ( 1 4 6 9))
(( 5 19 1 17) (10 12 6 1) ( 8 4 16 16) (12 7 12 6))
((14 14 0 2) (11 18 14 15) ( 6 7 9 19) (11 14 14 12))
(( 8 13 2 14) ( 8 6 0 4) ( 9 4 5 2) ( 6 17 2 9)))))
(defparameter *coordinate-system*
(make-instance 'coordinate-system
:axes (list *year-axis* *quarter-axis* *item-type-axis* *customer-axis*)
:data (copy-array *tmp-dataset*)))
(def)