2 ;;; Copyright (c) 2005--2007, by A.J. Rossini <blindglobe@gmail.com>
3 ;;; See COPYRIGHT file for any additional restrictions (BSD license).
4 ;;; Since 1991, ANSI was finally finished. Edited for ANSI Common Lisp.
6 ;;; compound -- Compound data and element-wise mapping functions
8 ;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
13 (in-package :lisp-stat-compound-data
)
15 ;;; Sequences are part of ANSI CL, being a supertype of vector and
16 ;;; list (ordered set of things).
18 ;;; The current mandate for CommonLisp Stat is to use the internal
19 ;;; structure when possible -- silly to be redundant! However, this
20 ;;; means we need to understand what sequences as implemented in
21 ;;; XLispStat intended to do, which I'm not clear on yet.
23 ;;; The original ordering, object-wise, was to have compound
24 ;;; functionality be a superclass, specialized into sequences, into
25 ;;; other data sources. However, at this point, we will see about
26 ;;; inverting this and having basic data types pushed through
27 ;;; compound, to simplify packaging. In this vein, we have created a
28 ;;; compound package to contain the compound data and sequence
29 ;;; structures. Probably need to clean this up even more.
32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
34 ;;; Internal Support Functions
36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
39 "Predicate to determine if argument is compound. Most common
40 non-compound types are checked first."
41 (declare (inline numberp symbolp stringp consp arrayp array-total-size
))
42 (cond ((or (numberp x
) (symbolp x
) (stringp x
))
44 ((or (consp x
) (and (arrayp x
) (< 0 (array-total-size x
))))
46 (t (compound-object-p x
))))
48 (defun find-compound-data (list)
49 "Returns first compound data item in LIST, or NIL if there is none."
50 (dolist (x list
) (if (cmpndp x
) (return x
))))
52 (defun any-compound-elements (seq)
53 "Checks for a compound element."
54 (cond ((consp seq
) (dolist (x seq
) (if (cmpndp x
) (return x
))))
56 (let ((n (length seq
)))
60 (let ((x (aref seq i
)))
61 (if (cmpndp x
) (return x
))))))
62 (t (error "argument must be a list or vector"))))
64 (defun compound-data-sequence (x)
65 "Returns sequence of data values for X."
66 (declare (inline consp vectorp arrayp make-array array-total-size
))
68 ((or (consp x
) (vectorp x
)) x
)
69 ((arrayp x
) (make-array (array-total-size x
) :displaced-to x
))
70 (t (send x
:data-seq
))))
72 (defmacro sequence-type
(x) `(if (consp ,x
) 'list
'vector
))
74 (defun make-compound-data (shape sequence
)
75 "Construct a compound data item, matching the shape of the first
76 argument. Shape referrs to the primary approach that we might have
77 that we could use for each element in the sequence. This gets
78 confusing, since compound data might be better done as a p-list rather
79 than as a list of lists."
80 (let ((n (length (compound-data-sequence shape
))))
81 (if (/= n
(length sequence
)) (error "compound data not the same shape"))
84 (if (consp sequence
) sequence
(coerce sequence
'list
)))
86 (if (vectorp sequence
) sequence
(coerce sequence
'vector
)))
88 (make-array (array-dimensions shape
)
89 :displaced-to
(coerce sequence
'vector
)))
90 (t (send shape
:make-data sequence
)))))
92 (defun make-circle (x)
93 "Make a circular list of one element."
94 (declare (inline cons rplacd
))
95 (let ((x (cons x nil
)))
99 (defun check-compound (x)
100 "Signals an error if X is not compound."
102 (error "not a compound data item - ~a" x
)))
104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
106 ;;; MAP-ELEMENTS function
107 ;;; Applies a function to arguments. If all arguments are simple (i. e.
108 ;;; not compound) then MAP-ELEMENTS acts like funcall. Otherwise all
109 ;;; compound arguments must be of the same shape and simple arguments
110 ;;; are treated as if they were compound arguments of the appropriate
111 ;;; shape. This is implemented by replacin all simple arguments by
112 ;;; circular lists of one element.
114 ;;; This implementation uses FASTMAP, a version of MAP that is assumed
117 ;;; a) work reasonable fast on any combination of lists and vectors
120 ;;; b) not hang if at least one of its arguments is not a circular
123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
125 (defun fixup-map-elements-arglist (args)
126 (do* ((args args
(rest args
))
127 (x (car args
) (car args
)))
129 (declare (inline car
))
130 (setf (car args
) (if (cmpndp x
)
131 (compound-data-sequence x
)
134 (defun map-elements (fcn &rest args
)
135 "Args: (fcn &rest args)
137 Applies FCN elementwise. If no arguments are compound MAP-ELEMENTS
138 acts like FUNCALL. Compound arguments must all be the same shape. Non
139 compound arguments, in the presence of compound ones, are treated as
140 if they were of the same shape as the compound items with constant
142 (let ((first-compound (find-compound-data args
)))
143 (cond ((null first-compound
) (apply fcn args
))
144 (t (fixup-map-elements-arglist args
)
145 (let* ((seq (compound-data-sequence first-compound
))
146 (type (sequence-type seq
)))
147 (make-compound-data first-compound
148 (apply #'map type fcn args
)))))))
150 (defun recursive-map-elements (base-fcn fcn
&rest args
)
151 "Args: (base-fcn fcn &rest args)
153 The same idea as MAP-ELEMENTS, except arguments are in a list and the
154 base and recursive cases can use different functions. Modified to
155 check for second level of compounding and use base-fcn if there is
157 (let ((first-compound (find-compound-data args
)))
158 (cond ((null first-compound
) (apply base-fcn args
))
159 (t (fixup-map-elements-arglist args
)
160 (let* ((seq (compound-data-sequence first-compound
))
161 (type (sequence-type seq
))
162 (f (if (any-compound-elements seq
) fcn base-fcn
)))
163 (make-compound-data first-compound
164 (apply #'map type f args
)))))))
167 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
169 ;;;; Public Predicate and Accessor Functions
171 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
173 (defun compound-data-p (x)
175 Returns T if X is a compound data item, NIL otherwise."
178 (defun compound-data-seq (x)
180 Returns data sequence in X."
182 (compound-data-sequence x
))
184 (defun compound-data-length (x)
186 Returns length of data sequence in X."
188 (length (compound-data-sequence x
)))
190 (defun compound-data-shape (x)
191 "Needed but undefined??"
195 (defun element-list (x)
198 (let ((x (concatenate 'list
(compound-data-seq x
)))) ; copies sequence
200 ((any-compound-elements x
)
201 (do ((next x
(rest next
)))
203 (setf (first next
) (element-list (first next
))))
204 (do ((result (first x
))
205 (last (last (first x
)))
206 (next (rest x
) (rest next
)))
207 ((not (consp next
)) result
)
208 (setf (rest last
) (first next
))
209 (setf last
(last (first next
)))))
213 (defun element-seq (x)
215 Returns sequence of the elements of compound item X."
217 (let ((seq (compound-data-seq x
)))
218 (if (any-compound-elements seq
) (element-list seq
) seq
)))
220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
222 ;;;; Compound Data Objects
224 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
226 (defvar *compound-data-proto
*)
227 (defproto *compound-data-proto
*)
229 ;;; FIXME: These need to be defined!!
230 (defmeth *compound-data-proto
* :data-length
(&rest args
)
231 (send self
:nop args
))
232 (defmeth *compound-data-proto
* :data-seq
(&rest args
)
233 (send self
:nop args
))
234 (defmeth *compound-data-proto
* :make-data
(&rest args
)
235 (send self
:nop args
))
236 (defmeth *compound-data-proto
* :select-data
(&rest args
)
237 (send self
:nop args
))
239 (defun compound-object-p (x) (kind-of-p x
*compound-data-proto
*))
243 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
245 ;;;; Sorting Functions
247 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
252 Returns a sequence with the numbers or strings in the sequence X in order."
253 (flet ((less (x y
) (if (numberp x
) (< x y
) (string-lessp x y
))))
254 (stable-sort (copy-seq (compound-data-seq x
)) #'less
)))
259 Returns a sequence of the indices of elements in the sequence of numbers
260 or strings X in order."
261 (let* ((seq (compound-data-seq x
))
262 (type (if (consp seq
) 'list
'vector
))
264 (flet ((entry (x) (setf i
(+ i
1)) (list x i
))
268 (if (numberp x
) (< x y
) (string-lessp x y
)))))
269 (let ((sorted-seq (stable-sort (map type
#'entry seq
) #'less
)))
270 (map type
#'second sorted-seq
)))))
272 ;; this isn't destructive -- do we document destructive only, or any
276 Returns a sequence with the elements of the list or array of numbers or
277 strings X replaced by their ranks."
278 (let ((ranked-seq (order (order x
))))
280 ;; compound-data-shape is undefined?
281 (compound-data-shape x
) ranked-seq
)))
291 Repeats VALS. If TIMES is a number and VALS is a non-null, non-array atom,
292 a list of length TIMES with all elements eq to VALS is returned. If VALS
293 is a list and TIMES is a number then VALS is appended TIMES times. If
294 TIMES is a list of numbers then VALS must be a list of equal length and
295 the simpler version of repeat is mapped down the two lists.
296 Examples: (repeat 2 5) returns (2 2 2 2 2)
297 (repeat '(1 2) 3) returns (1 2 1 2 1 2)
298 (repeat '(4 5 6) '(1 2 3)) returns (4 5 5 6 6 6)
299 (repeat '((4) (5 6)) '(2 3)) returns (4 4 5 6 5 6 5 6)"
300 (cond ((compound-data-p b
)
301 (let* ((reps (coerce (compound-data-seq (map-elements #'repeat a b
))
303 (result (first reps
))
304 (tail (last (first reps
))))
305 (dolist (next (rest reps
) result
)
307 (setf (rest tail
) next
)
308 (setf tail
(last next
))))))
309 (t (let* ((a (if (compound-data-p a
)
310 (coerce (compound-data-seq a
) 'list
)
313 (dotimes (i b result
)
314 (let ((next (copy-list a
)))
315 (if result
(setf (rest (last next
)) result
))
316 (setf result next
)))))))
323 Returns a list of the indices where elements of sequence X are not NIL."
324 (let ((x (list (compound-data-seq x
)))
327 (flet ((add-result (x)
328 (if result
(setf (rest tail
) (list x
)) (setf result
(list x
)))
329 (setf tail
(if tail
(rest tail
) result
)))
330 (get-next-element (seq-list i
)
331 (cond ((consp (first seq-list
))
332 (let ((elem (first (first seq-list
))))
333 (setf (first seq-list
) (rest (first seq-list
)))
335 (t (aref (first seq-list
) i
)))))
336 (let ((n (length (first x
))))
337 (dotimes (i n result
)
338 (if (get-next-element x i
) (add-result i
)))))))
340 ;;; Type Checking Functions
342 (defun check-sequence (a)
343 ;; FIXME:AJR: does this handle consp as well? (Luke had an "or"
345 (if (not (or (typep a
'sequence
)
347 (error "not a sequence or cons - ~s" a
)))
351 ;;; Sequence Element Access
353 ;;; (elt x i) -- NOT. This is more like "pop".
354 (defun get-next-element (x i
)
355 "Get element i from seq x. FIXME: not really??"
356 (let ((myseq (first x
)))
358 (let ((elem (first myseq
)))
359 (setf (first x
) (rest myseq
))
363 ;;; (setf (elt x i) v)
364 (defun set-next-element (x i v
)
365 (let ((seq (first x
)))
368 (setf (first x
) (rest seq
)))
369 (t (setf (aref seq i
) v
)))))
371 (defun make-next-element (x) (list x
))
374 ;;; Sequence Functions
377 ;; to prevent breakage.
378 (defmacro sequencep
(x)
381 (defun iseq (a &optional b
)
382 "Args: (n &optional m)
383 Generate a sequence of consecutive integers from a to b.
384 With one argumant returns a list of consecutive integers from 0 to N - 1.
385 With two returns a list of consecutive integers from N to M.
386 Examples: (iseq 4) returns (0 1 2 3)
387 (iseq 3 7) returns (3 4 5 6 7)
388 (iseq 3 -3) returns (3 2 1 0 -1 -2 -3)"
390 (let ((n (+ 1 (abs (- b a
))))
393 (setq x
(cons (if (< a b
) (- b i
) (+ b i
)) x
))))
396 ((< a
0) (iseq (+ a
1) 0))
397 ((< 0 a
) (iseq 0 (- a
1))))))
399 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
401 ;;;; Subset Selection and Mutation Functions
403 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
406 (defun old-rowmajor-index (index indices dim olddim
)
407 "translate row major index in resulting subarray to row major index
408 in the original array."
409 (declare (fixnum index
))
410 (let ((rank (length dim
))
414 (declare (fixnum rank face oldface
))
418 (setf face
(* face
(aref dim i
)))
419 (setf oldface
(* oldface
(aref olddim i
))))
423 (setf face
(/ face
(aref dim i
)))
424 (setf oldface
(/ oldface
(aref olddim i
)))
426 (* oldface
(aref (aref indices i
) (floor (/ index face
))))) ;;*** is this floor really needed???
427 (setf index
(rem index face
)))
430 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
432 ;;;; Subset Selection and Mutation Functions
434 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
436 (defun subarray-select (a indexlist
&optional
(values nil set_values
))
437 "extract or set subarray for the indices from a displaced array a.
445 and it's poorly documented."
457 (declare (fixnum rank n
))
459 (if (or (sequencep a
)
461 (error "not an array - ~a" a
))
462 (if (not (listp indexlist
))
463 (error "bad index list - ~a" indexlist
)) ;; ?indices?
464 (if (/= (length indexlist
)
466 (error "wrong number of indices"))
468 (setf indices
(coerce indexlist
'vector
))
469 (setf olddim
(coerce (array-dimensions a
) 'vector
))
471 ;; compute the result dimension vector and fix up the indices
472 (setf rank
(array-rank a
))
473 (setf dim
(make-array rank
))
476 (setf index
(aref indices i
))
477 (setf n
(aref olddim i
))
478 (setf index
(if (fixnump index
) (vector index
) (coerce index
'vector
)))
479 (setf k
(length index
))
482 (if (<= n
(check-nonneg-fixnum (aref index j
)))
483 (error "index out of bounds - ~a" (aref index j
)))
484 (setf (aref indices i
) index
))
485 (setf (aref dim i
) (length index
)))
487 ;; set up the result or check the values
488 (let ((dim-list (coerce dim
'list
)))
492 ((compound-data-p values
)
493 (if (or (not (arrayp values
)) (/= rank
(array-rank values
)))
494 (error "bad values array - ~a" values
))
495 (setf vdim
(coerce (array-dimensions values
) 'vector
))
498 (if (/= (aref vdim i
) (aref dim i
))
499 (error "bad value array dimensions - ~a" values
)))
500 (setf result values
))
501 (t (setf result
(make-array dim-list
:initial-element values
)))))
502 (t (setf result
(make-array dim-list
)))))
504 ;; compute the result or set the values
505 (setf data
(compound-data-seq a
))
506 (setf result_data
(compound-data-seq result
))
507 (setf n
(length result_data
))
510 (setf k
(old-rowmajor-index i indices dim olddim
))
511 (if (or (> 0 k
) (>= k
(length data
))) (error "index out of range"))
513 (setf (aref data k
) (aref result_data i
))
514 (setf (aref result_data i
) (aref data k
))))
519 ;;;; is x an ordered sequence of nonnegative positive integers?
520 (defun ordered-nneg-seq(x)
521 ;; FIXME -- sbcl warning about unreachable code, might be a logic error here.
522 (if (typep x
'sequence
)
524 (cx (make-next-element x
))
527 (let ((elem (check-nonneg-fixnum (get-next-element cx i
))))
528 (if (> m elem
) (return nil
) (setf m elem
)))))))
530 ;;;; select or set the subsequence corresponding to the specified indices
531 (defun sequence-select(x indices
&optional
(values nil set-values
))
532 ;; FIXME -- sbcl warning about unreachable code, might be a logic error here.
538 (declare (fixnum rlen dlen vlen
))
540 ;; Check the input data
542 (check-sequence indices
)
543 (if set-values
(check-sequence values
))
545 ;; Find the data sizes
546 (setf data
(if (ordered-nneg-seq indices
) x
(coerce x
'vector
)))
547 (setf dlen
(length data
))
548 (setf rlen
(length indices
))
550 (setf vlen
(length values
))
551 (if (/= vlen rlen
) (error "value and index sequences do not match")))
553 ;; set up the result/value sequence
557 (make-sequence (if (listp x
) 'list
'vector
) rlen
)))
559 ;; get or set the sequence elements
562 (cr (make-next-element result
))
563 (ci (make-next-element indices
))
568 (declare (fixnum i j index
))
569 (setf index
(get-next-element ci i
))
570 (if (<= dlen index
) (error "index out of range - ~a" index
))
571 (let ((elem (get-next-element cr i
)))
578 ((not (and (< j index
) (consp nextx
))))
580 (setf nextx
(rest nextx
)))
581 (setf (first nextx
) elem
))
582 (t (setf (aref x index
) elem
)))))
584 (cr (make-next-element result
))
585 (ci (make-next-element indices
))
591 (declare (fixnum i j index
))
592 (setf index
(get-next-element ci i
))
593 (if (<= dlen index
) (error "index out of range - ~a" index
))
595 ((listp data
) ;; indices must be ordered
597 ((not (and (< j index
) (consp nextx
))))
599 (setf nextx
(rest nextx
)))
600 (setf elem
(first nextx
)))
601 (t (setf elem
(aref data index
))))
602 (set-next-element cr i elem
)))
611 (defgeneric select
(x &rest args
)
612 "Selection of data, Args: (a &rest indices)
614 A can be a list or an array. If A is a list and INDICES is a single
615 number then the appropriate element of A is returned. If is a list and
616 INDICES is a list of numbers then the sublist of the corresponding
617 elements is returned. If A in an array then the number of INDICES
618 must match the ARRAY-RANK of A. If each index is a number then the
619 appropriate array element is returned. Otherwise the INDICES must all
620 be lists of numbers and the corresponding submatrix of A is
621 returned. SELECT can be used in setf.")
623 (defmethod select ((x list
) &rest args
))
624 (defmethod select ((x array
) &rest args
))
629 (defun select (x &rest args
)
630 "Args: (a &rest indices)
632 A can be a list or an array. If A is a list and INDICES is a single
633 number then the appropriate element of A is returned. If is a list and
634 INDICES is a list of numbers then the sublist of the corresponding
635 elements is returned. If A in an array then the number of INDICES
636 must match the ARRAY-RANK of A. If each index is a number then the
637 appropriate array element is returned. Otherwise the INDICES must all
638 be lists of numbers and the corresponding submatrix of A is
639 returned. SELECT can be used in setf."
641 ((every #'fixnump args
) (if (typep x
'list
)
643 (apply #'aref x args
)))
644 ((typep x
'sequence
) (sequence-select x
(first args
)))
645 ((typep x
'array
) (subarray-select x args
))
646 (t (error "compound.lsp:select: Not a valid type."))))
649 ;; Built in SET-SELECT (SETF method for SELECT)
650 (defun set-select (x &rest args
)
651 (let ((indices (butlast args
))
652 (values (first (last args
))))
655 (if (not (consp indices
)) (error "bad indices - ~a" indices
))
656 (let* ((indices (first indices
))
657 (i-list (if (fixnump indices
) (list indices
) indices
))
658 (v-list (if (fixnump indices
) (list values
) values
)))
659 (sequence-select x i-list v-list
)))
661 (subarray-select x
(flatten-list indices
) values
))
662 (t (error "bad argument type - ~a" x
)))
665 (defsetf select set-select
)
668 ;;;; Basic Sequence Operations
671 (defun difference (x)
673 Returns differences for a sequence X."
674 (let ((n (length x
)))
675 (- (select x
(iseq 1 (1- n
))) (select x
(iseq 0 (- n
2))))))
677 (defun rseq (a b num
)
679 Returns a list of NUM equally spaced points starting at A and ending at B."
680 (+ a
(* (values-list (iseq 0 (1- num
))) (/ (float (- b a
)) (1- num
)))))
684 (defun split-list (x n
)
686 Returns a list of COLS lists of equal length of the elements of LIST.
687 Example: (split-list '(1 2 3 4 5 6) 2) returns ((1 2 3) (4 5 6))"
689 (if (/= (rem (length x
) n
) 0) (error "length not divisible by ~a" n
))
690 (flet ((next-split ()
693 (dotimes (i n result
)
695 (let ((c-elem (list (first x
))))
700 (setf (rest end
) c-elem
)
701 (setf end
(rest end
)))))
702 (setf x
(rest x
))))))
705 (k (/ (length x
) n
)))
707 (dotimes (i k result
)
709 (let ((c-sub (list (next-split))))
714 (setf (rest end
) c-sub
)
715 (setf end
(rest end
)))))))))
719 ;;; need to figure out how to make
720 ;;; '((1 2 3) (4 5) 6 7 (8)) into '(1 2 3 4 5 6 7 8)
721 (defun flatten-list (lst)
722 "Flattens a list of lists into a single list. Only useful when
723 we've mucked up data. Sign of usage means poor coding!"
724 (cond ((null lst
) ;; endp?
727 (append (flatten-list (car lst
)) (flatten-list (cdr lst
))))
731 ;; (flatten-list (list 1 (list 1 2) (list 4 5 6 )))
732 ;; (flatten-list '(1 (1 2) 3 (4 5 6)))