Update local CFFI to darcs from 1.6.08
[CommonLispStat.git] / compound.lsp
blobeefe86d073a3857b3ac58e894be6668cf77f3683
1 ;;; -*- mode: lisp -*-
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
7 ;;;
8 ;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
9 ;;; unrestricted use.
10 ;;;
12 ;;;
13 ;;; Package Setup
14 ;;;
16 (in-package :cl-user)
18 (defpackage :lisp-stat-compound-data
19 (:use :common-lisp
20 :lisp-stat-object-system
21 :lisp-stat-types)
22 (:shadowing-import-from :lisp-stat-object-system
23 slot-value
24 call-next-method call-method)
25 (:export compound-data-p *compound-data-proto*
26 compound-object-p
27 compound-data-seq compound-data-length
28 element-list element-seq
29 sort-data order rank
30 recursive-map-elements map-elements repeat
31 check-sequence
32 get-next-element make-next-element set-next-element
33 sequencep iseq ordered-nneg-seq
34 select split-list which
35 difference rseq
36 flatten-list ))
38 (in-package :lisp-stat-compound-data)
40 ;;; Sequences are part of ANSI CL, being a supertype of vector and
41 ;;; list (ordered set of things).
42 ;;;
43 ;;; Need to use the interenal structure when possible -- silly to be
44 ;;; redundant! However, this means we need to understand what
45 ;;; sequences were intending to do, which I'm not clear on yet.
47 ;;; The original ordering, object-wise, was to have compound
48 ;;; functionality passed into sequences, into other data sources.
49 ;;; However, at this point, we will see about inverting this and
50 ;;; having basic data types pushed through compound, to simplify
51 ;;; packaging. In this vein, we have created a compound package to
52 ;;; contain the compound data and sequence structures. Probably need
53 ;;; to clean this up even more.
56 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
57 ;;;
58 ;;; Internal Support Functions
59 ;;;
60 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
62 (defun cmpndp (x)
63 "Predicate to determine if argument is compound. Most common
64 non-compound types are checked first."
65 (declare (inline numberp symbolp stringp consp arrayp array-total-size))
66 (cond ((or (numberp x) (symbolp x) (stringp x)) nil)
67 ((or (consp x) (and (arrayp x) (< 0 (array-total-size x)))) t)
68 (t (compound-object-p x))))
70 (defun find-compound-data (list)
71 "Returns first compound data item in LIST or NIL if there is none."
72 (dolist (x list) (if (cmpndp x) (return x))))
74 (defun any-compound-elements (seq)
75 "Checks for a compound element."
76 (cond ((consp seq) (dolist (x seq) (if (cmpndp x) (return x))))
77 ((vectorp seq)
78 (let ((n (length seq)))
79 (declare (fixnum n))
80 (dotimes (i n)
81 (declare (fixnum i))
82 (let ((x (aref seq i)))
83 (if (cmpndp x) (return x))))))
84 (t (error "argument must be a list or vector"))))
86 (defun compound-data-sequence (x)
87 "Returns sequence of data values for X."
88 (declare (inline consp vectorp arrayp make-array array-total-size))
89 (cond
90 ((or (consp x) (vectorp x)) x)
91 ((arrayp x) (make-array (array-total-size x) :displaced-to x))
92 (t (send x :data-seq))))
94 (defmacro sequence-type (x) `(if (consp ,x) 'list 'vector))
96 (defun make-compound-data (shape sequence)
97 "Construct a compound data item to match the shape of the first
98 argument."
99 (let ((n (length (compound-data-sequence shape))))
100 (if (/= n (length sequence)) (error "compound data not the same shape"))
101 (cond
102 ((consp shape) (if (consp sequence) sequence (coerce sequence 'list)))
103 ((vectorp shape)
104 (if (vectorp sequence) sequence (coerce sequence 'vector)))
105 ((arrayp shape)
106 (make-array (array-dimensions shape)
107 :displaced-to (coerce sequence 'vector)))
108 (t (send shape :make-data sequence)))))
110 (defun make-circle (x)
111 "Make a circular list of one element."
112 (declare (inline cons rplacd))
113 (let ((x (cons x nil)))
114 (rplacd x x)
117 (defun check-compound (x)
118 "Signals an error if X is not compound."
119 (if (not (cmpndp x)) (error "not a compound data item - ~a" x)))
121 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
123 ;;; MAP-ELEMENTS function
124 ;;; Applies a function to arguments. If all arguments are simple (i. e.
125 ;;; not compound) then MAP-ELEMENTS acts like funcall. Otherwise all
126 ;;; compound arguments must be of the same shape and simple arguments
127 ;;; are treated as if they were compound arguments of the appropriate
128 ;;; shape. This is implemented by replacin all simple arguments by
129 ;;; circular lists of one element.
131 ;;; This implementation uses FASTMAP, a version of MAP that is assumed
132 ;;; to
134 ;;; a) work reasonable fast on any combination of lists and vectors
135 ;;; as its arguments
137 ;;; b) not hang if at least one of its arguments is not a circular
138 ;;; list.
140 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
142 (defun fixup-map-elements-arglist (args)
143 (do* ((args args (rest args))
144 (x (car args) (car args)))
145 ((null args))
146 (declare (inline car))
147 (setf (car args)
148 (if (cmpndp x) (compound-data-sequence x) (make-circle x)))))
150 (defun map-elements (fcn &rest args)
151 "Args: (fcn &rest args)
152 Applies FCN elementwise. If no arguments are compound MAP-ELEMENTS
153 acts like FUNCALL. Compound arguments must all be the same shape. Non
154 compound arguments, in the presence of compound ones, are treated as
155 if they were of the same shape as the compound items with constant data
156 values."
157 (let ((first-compound (find-compound-data args)))
158 (cond ((null first-compound) (apply fcn args))
159 (t (fixup-map-elements-arglist args)
160 (let* ((seq (compound-data-sequence first-compound))
161 (type (sequence-type seq)))
162 (make-compound-data first-compound
163 (apply #'map type fcn args)))))))
165 (defun recursive-map-elements (base-fcn fcn &rest args)
166 "Args: (base-fcn fcn &rest args)
167 The same idea as MAP-ELEMENTS, except arguments are in a list and the
168 base and recursive cases can use different functions. Modified to check
169 for second level of compounding and use base-fcn if there is none."
170 (let ((first-compound (find-compound-data args)))
171 (cond ((null first-compound) (apply base-fcn args))
172 (t (fixup-map-elements-arglist args)
173 (let* ((seq (compound-data-sequence first-compound))
174 (type (sequence-type seq))
175 (f (if (any-compound-elements seq) fcn base-fcn)))
176 (make-compound-data first-compound
177 (apply #'map type f args)))))))
180 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
181 ;;;;
182 ;;;; Public Predicate and Accessor Functions
183 ;;;;
184 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
186 (defun compound-data-p (x)
187 "Args: (x)
188 Returns T if X is a compound data item, NIL otherwise."
189 (cmpndp x))
191 (defun compound-data-seq (x)
192 "Args (x)
193 Returns data sequence in X."
194 (check-compound x)
195 (compound-data-sequence x))
197 (defun compound-data-length (x)
198 "Args (x)
199 Returns length of data sequence in X."
200 (check-compound x)
201 (length (compound-data-sequence x)))
203 (defun compound-data-shape (x)
204 "Needed but undefined??"
208 (defun element-list (x)
209 (cond
210 ((compound-data-p x)
211 (let ((x (concatenate 'list (compound-data-seq x)))) ; copies sequence
212 (cond
213 ((any-compound-elements x)
214 (do ((next x (rest next)))
215 ((not (consp next)))
216 (setf (first next) (element-list (first next))))
217 (do ((result (first x))
218 (last (last (first x)))
219 (next (rest x) (rest next)))
220 ((not (consp next)) result)
221 (setf (rest last) (first next))
222 (setf last (last (first next)))))
223 (t x))))
224 (t (list x))))
226 (defun element-seq (x)
227 "Args: (x)
228 Returns sequence of the elements of compound item X."
229 (check-compound x)
230 (let ((seq (compound-data-seq x)))
231 (if (any-compound-elements seq) (element-list seq) seq)))
233 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
234 ;;;;
235 ;;;; Compound Data Objects
236 ;;;;
237 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
239 (defvar *compound-data-proto*)
240 (defproto *compound-data-proto*)
242 ;;; FIXME: These need to be defined!!
243 (defmeth *compound-data-proto* :data-length (&rest args)
244 (send self :nop args))
245 (defmeth *compound-data-proto* :data-seq (&rest args)
246 (send self :nop args))
247 (defmeth *compound-data-proto* :make-data (&rest args)
248 (send self :nop args))
249 (defmeth *compound-data-proto* :select-data (&rest args)
250 (send self :nop args))
252 (defun compound-object-p (x) (kind-of-p x *compound-data-proto*))
256 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
257 ;;;;
258 ;;;; Sorting Functions
259 ;;;;
260 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
262 (defun sort-data (x)
263 "Args: (sequence)
265 Returns a sequence with the numbers or strings in the sequence X in order."
266 (flet ((less (x y) (if (numberp x) (< x y) (string-lessp x y))))
267 (stable-sort (copy-seq (compound-data-seq x)) #'less)))
269 (defun order (x)
270 "Args (x)
272 Returns a sequence of the indices of elements in the sequence of numbers
273 or strings X in order."
274 (let* ((seq (compound-data-seq x))
275 (type (if (consp seq) 'list 'vector))
276 (i -1))
277 (flet ((entry (x) (setf i (+ i 1)) (list x i))
278 (less (a b)
279 (let ((x (first a))
280 (y (first b)))
281 (if (numberp x) (< x y) (string-lessp x y)))))
282 (let ((sorted-seq (stable-sort (map type #'entry seq) #'less)))
283 (map type #'second sorted-seq)))))
285 ;; this isn't destructive -- do we document destructive only, or any
286 ;; variant?
287 (defun rank (x)
288 "Args (x)
289 Returns a sequence with the elements of the list or array of numbers or
290 strings X replaced by their ranks."
291 (let ((ranked-seq (order (order x))))
292 (make-compound-data
293 ;; compound-data-shape is undefined?
294 (compound-data-shape x) ranked-seq)))
299 ;;; REPEAT function
302 (defun repeat (a b)
303 "Args: (vals times)
304 Repeats VALS. If TIMES is a number and VALS is a non-null, non-array atom,
305 a list of length TIMES with all elements eq to VALS is returned. If VALS
306 is a list and TIMES is a number then VALS is appended TIMES times. If
307 TIMES is a list of numbers then VALS must be a list of equal length and
308 the simpler version of repeat is mapped down the two lists.
309 Examples: (repeat 2 5) returns (2 2 2 2 2)
310 (repeat '(1 2) 3) returns (1 2 1 2 1 2)
311 (repeat '(4 5 6) '(1 2 3)) returns (4 5 5 6 6 6)
312 (repeat '((4) (5 6)) '(2 3)) returns (4 4 5 6 5 6 5 6)"
313 (cond ((compound-data-p b)
314 (let* ((reps (coerce (compound-data-seq (map-elements #'repeat a b))
315 'list))
316 (result (first reps))
317 (tail (last (first reps))))
318 (dolist (next (rest reps) result)
319 (when next
320 (setf (rest tail) next)
321 (setf tail (last next))))))
322 (t (let* ((a (if (compound-data-p a)
323 (coerce (compound-data-seq a) 'list)
324 (list a)))
325 (result nil))
326 (dotimes (i b result)
327 (let ((next (copy-list a)))
328 (if result (setf (rest (last next)) result))
329 (setf result next)))))))
331 ;;; WHICH function
334 (defun which (x)
335 "Args: (x)
336 Returns a list of the indices where elements of sequence X are not NIL."
337 (let ((x (list (compound-data-seq x)))
338 (result nil)
339 (tail nil))
340 (flet ((add-result (x)
341 (if result (setf (rest tail) (list x)) (setf result (list x)))
342 (setf tail (if tail (rest tail) result)))
343 (get-next-element (seq-list i)
344 (cond ((consp (first seq-list))
345 (let ((elem (first (first seq-list))))
346 (setf (first seq-list) (rest (first seq-list)))
347 elem))
348 (t (aref (first seq-list) i)))))
349 (let ((n (length (first x))))
350 (dotimes (i n result)
351 (if (get-next-element x i) (add-result i)))))))
353 ;;; Type Checking Functions
355 (defun check-sequence (a)
356 ;; FIXME:AJR: does this handle consp as well? (Luke had an "or"
357 ;; with consp).
358 (if (not (or (typep a 'sequence)
359 (consp a)))
360 (error "not a sequence or cons - ~s" a)))
364 ;;; Sequence Element Access
366 ;;; (elt x i) -- NOT. This is more like "pop".
367 (defun get-next-element (x i)
368 "Get element i from seq x. FIXME: not really??"
369 (let ((myseq (first x)))
370 (if (consp myseq)
371 (let ((elem (first myseq)))
372 (setf (first x) (rest myseq))
373 elem)
374 (aref myseq i))))
376 ;;; (setf (elt x i) v)
377 (defun set-next-element (x i v)
378 (let ((seq (first x)))
379 (cond ((consp seq)
380 (setf (first seq) v)
381 (setf (first x) (rest seq)))
382 (t (setf (aref seq i) v)))))
384 (defun make-next-element (x) (list x))
387 ;;; Sequence Functions
390 ;; to prevent breakage.
391 (defmacro sequencep (x)
392 (typep x 'sequence))
394 (defun iseq (a &optional b)
395 "Args: (n &optional m)
396 Generate a sequence of consecutive integers from a to b.
397 With one argumant returns a list of consecutive integers from 0 to N - 1.
398 With two returns a list of consecutive integers from N to M.
399 Examples: (iseq 4) returns (0 1 2 3)
400 (iseq 3 7) returns (3 4 5 6 7)
401 (iseq 3 -3) returns (3 2 1 0 -1 -2 -3)"
402 (if b
403 (let ((n (+ 1 (abs (- b a))))
404 (x nil))
405 (dotimes (i n x)
406 (setq x (cons (if (< a b) (- b i) (+ b i)) x))))
407 (cond
408 ((= 0 a) nil)
409 ((< a 0) (iseq (+ a 1) 0))
410 ((< 0 a) (iseq 0 (- a 1))))))
412 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
413 ;;;;
414 ;;;; Subset Selection and Mutation Functions
415 ;;;;
416 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
419 (defun old-rowmajor-index (index indices dim olddim)
420 "translate row major index in resulting subarray to row major index
421 in the original array."
422 (declare (fixnum index))
423 (let ((rank (length dim))
424 (face 1)
425 (oldface 1)
426 (oldindex 0))
427 (declare (fixnum rank face oldface))
429 (dotimes (i rank)
430 (declare (fixnum i))
431 (setf face (* face (aref dim i)))
432 (setf oldface (* oldface (aref olddim i))))
434 (dotimes (i rank)
435 (declare (fixnum i))
436 (setf face (/ face (aref dim i)))
437 (setf oldface (/ oldface (aref olddim i)))
438 (incf oldindex
439 (* oldface (aref (aref indices i) (floor (/ index face))))) ;;*** is this floor really needed???
440 (setf index (rem index face)))
441 oldindex))
443 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
444 ;;;;
445 ;;;; Subset Selection and Mutation Functions
446 ;;;;
447 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
449 (defun subarray-select (a indexlist &optional (values nil set_values))
450 "extract or set subarray for the indices from a displaced array a.
452 a : array
453 indexlist: ??
454 values :
455 nil :
456 set_values :
458 and it's poorly documented."
459 (let ((indices nil)
460 (index)
461 (dim)
462 (vdim)
463 (data)
464 (result_data)
465 (olddim)
466 (result)
467 (rank 0)
468 (n 0)
469 (k 0))
470 (declare (fixnum rank n))
472 (if (or (sequencep a)
473 (not (arrayp a)))
474 (error "not an array - ~a" a))
475 (if (not (listp indexlist))
476 (error "bad index list - ~a" indexlist)) ;; ?indices?
477 (if (/= (length indexlist)
478 (array-rank a))
479 (error "wrong number of indices"))
481 (setf indices (coerce indexlist 'vector))
482 (setf olddim (coerce (array-dimensions a) 'vector))
484 ;; compute the result dimension vector and fix up the indices
485 (setf rank (array-rank a))
486 (setf dim (make-array rank))
487 (dotimes (i rank)
488 (declare (fixnum i))
489 (setf index (aref indices i))
490 (setf n (aref olddim i))
491 (setf index (if (fixnump index) (vector index) (coerce index 'vector)))
492 (setf k (length index))
493 (dotimes (j k)
494 (declare (fixnum j))
495 (if (<= n (check-nonneg-fixnum (aref index j)))
496 (error "index out of bounds - ~a" (aref index j)))
497 (setf (aref indices i) index))
498 (setf (aref dim i) (length index)))
500 ;; set up the result or check the values
501 (let ((dim-list (coerce dim 'list)))
502 (cond
503 (set_values
504 (cond
505 ((compound-data-p values)
506 (if (or (not (arrayp values)) (/= rank (array-rank values)))
507 (error "bad values array - ~a" values))
508 (setf vdim (coerce (array-dimensions values) 'vector))
509 (dotimes (i rank)
510 (declare (fixnum i))
511 (if (/= (aref vdim i) (aref dim i))
512 (error "bad value array dimensions - ~a" values)))
513 (setf result values))
514 (t (setf result (make-array dim-list :initial-element values)))))
515 (t (setf result (make-array dim-list)))))
517 ;; compute the result or set the values
518 (setf data (compound-data-seq a))
519 (setf result_data (compound-data-seq result))
520 (setf n (length result_data))
521 (dotimes (i n)
522 (declare (fixnum i))
523 (setf k (old-rowmajor-index i indices dim olddim))
524 (if (or (> 0 k) (>= k (length data))) (error "index out of range"))
525 (if set_values
526 (setf (aref data k) (aref result_data i))
527 (setf (aref result_data i) (aref data k))))
529 result))
532 ;;;; is x an ordered sequence of nonnegative positive integers?
533 (defun ordered-nneg-seq(x)
534 ;; FIXME -- sbcl warning about unreachable code, might be a logic error here.
535 (if (typep x 'sequence)
536 (let ((n (length x))
537 (cx (make-next-element x))
538 (m 0))
539 (dotimes (i n t)
540 (let ((elem (check-nonneg-fixnum (get-next-element cx i))))
541 (if (> m elem) (return nil) (setf m elem)))))))
543 ;;;; select or set the subsequence corresponding to the specified indices
544 (defun sequence-select(x indices &optional (values nil set-values))
545 ;; FIXME -- sbcl warning about unreachable code, might be a logic error here.
546 (let ((rlen 0)
547 (dlen 0)
548 (vlen 0)
549 (data nil)
550 (result nil))
551 (declare (fixnum rlen dlen vlen))
553 ;; Check the input data
554 (check-sequence x)
555 (check-sequence indices)
556 (if set-values (check-sequence values))
558 ;; Find the data sizes
559 (setf data (if (ordered-nneg-seq indices) x (coerce x 'vector)))
560 (setf dlen (length data))
561 (setf rlen (length indices))
562 (when set-values
563 (setf vlen (length values))
564 (if (/= vlen rlen) (error "value and index sequences do not match")))
566 ;; set up the result/value sequence
567 (setf result
568 (if set-values
569 values
570 (make-sequence (if (listp x) 'list 'vector) rlen)))
572 ;; get or set the sequence elements
573 (if set-values
574 (do ((nextx x)
575 (cr (make-next-element result))
576 (ci (make-next-element indices))
577 (i 0 (+ i 1))
578 (j 0)
579 (index 0))
580 ((>= i rlen))
581 (declare (fixnum i j index))
582 (setf index (get-next-element ci i))
583 (if (<= dlen index) (error "index out of range - ~a" index))
584 (let ((elem (get-next-element cr i)))
585 (cond
586 ((listp x)
587 (when (> j index)
588 (setf j 0)
589 (setf nextx x))
590 (do ()
591 ((not (and (< j index) (consp nextx))))
592 (incf j 1)
593 (setf nextx (rest nextx)))
594 (setf (first nextx) elem))
595 (t (setf (aref x index) elem)))))
596 (do ((nextx data)
597 (cr (make-next-element result))
598 (ci (make-next-element indices))
599 (i 0 (+ i 1))
600 (j 0)
601 (index 0)
602 (elem nil))
603 ((>= i rlen))
604 (declare (fixnum i j index))
605 (setf index (get-next-element ci i))
606 (if (<= dlen index) (error "index out of range - ~a" index))
607 (cond
608 ((listp data) ;; indices must be ordered
609 (do ()
610 ((not (and (< j index) (consp nextx))))
611 (incf j 1)
612 (setf nextx (rest nextx)))
613 (setf elem (first nextx)))
614 (t (setf elem (aref data index))))
615 (set-next-element cr i elem)))
617 result))
620 ;;; SELECT function
624 (defgeneric select (x &rest args)
625 "Selection of data, Args: (a &rest indices)
627 A can be a list or an array. If A is a list and INDICES is a single
628 number then the appropriate element of A is returned. If is a list and
629 INDICES is a list of numbers then the sublist of the corresponding
630 elements is returned. If A in an array then the number of INDICES
631 must match the ARRAY-RANK of A. If each index is a number then the
632 appropriate array element is returned. Otherwise the INDICES must all
633 be lists of numbers and the corresponding submatrix of A is
634 returned. SELECT can be used in setf.")
636 (defmethod select ((x list) &rest args))
637 (defmethod select ((x array) &rest args))
642 (defun select (x &rest args)
643 "Args: (a &rest indices)
645 A can be a list or an array. If A is a list and INDICES is a single
646 number then the appropriate element of A is returned. If is a list and
647 INDICES is a list of numbers then the sublist of the corresponding
648 elements is returned. If A in an array then the number of INDICES
649 must match the ARRAY-RANK of A. If each index is a number then the
650 appropriate array element is returned. Otherwise the INDICES must all
651 be lists of numbers and the corresponding submatrix of A is
652 returned. SELECT can be used in setf."
653 (cond
654 ((every #'fixnump args) (if (typep x 'list)
655 (nth (first args) x)
656 (apply #'aref x args)))
657 ((typep x 'sequence) (sequence-select x (first args)))
658 ((typep x 'array) (subarray-select x args))
659 (t (error "compound.lsp:select: Not a valid type."))))
662 ;; Built in SET-SELECT (SETF method for SELECT)
663 (defun set-select (x &rest args)
664 (let ((indices (butlast args))
665 (values (first (last args))))
666 (cond
667 ((typep x 'sequence)
668 (if (not (consp indices)) (error "bad indices - ~a" indices))
669 (let* ((indices (first indices))
670 (i-list (if (fixnump indices) (list indices) indices))
671 (v-list (if (fixnump indices) (list values) values)))
672 (sequence-select x i-list v-list)))
673 ((arrayp x)
674 (subarray-select x (flatten-list indices) values))
675 (t (error "bad argument type - ~a" x)))
676 values))
678 (defsetf select set-select)
680 ;;;;
681 ;;;; Basic Sequence Operations
682 ;;;;
684 (defun difference (x)
685 "Args: (x)
686 Returns differences for a sequence X."
687 (let ((n (length x)))
688 (- (select x (iseq 1 (1- n))) (select x (iseq 0 (- n 2))))))
690 (defun rseq (a b num)
691 "Args: (a b num)
692 Returns a list of NUM equally spaced points starting at A and ending at B."
693 (+ a (* (values-list (iseq 0 (1- num))) (/ (float (- b a)) (1- num)))))
697 (defun split-list (x n)
698 "Args: (list cols)
699 Returns a list of COLS lists of equal length of the elements of LIST.
700 Example: (split-list '(1 2 3 4 5 6) 2) returns ((1 2 3) (4 5 6))"
701 (check-one-fixnum n)
702 (if (/= (rem (length x) n) 0) (error "length not divisible by ~a" n))
703 (flet ((next-split ()
704 (let ((result nil)
705 (end nil))
706 (dotimes (i n result)
707 (declare (fixnum i))
708 (let ((c-elem (list (first x))))
709 (cond ((null result)
710 (setf result c-elem)
711 (setf end result))
713 (setf (rest end) c-elem)
714 (setf end (rest end)))))
715 (setf x (rest x))))))
716 (let ((result nil)
717 (end nil)
718 (k (/ (length x) n)))
719 (declare (fixnum k))
720 (dotimes (i k result)
721 (declare (fixnum i))
722 (let ((c-sub (list (next-split))))
723 (cond ((null result)
724 (setf result c-sub)
725 (setf end result))
727 (setf (rest end) c-sub)
728 (setf end (rest end)))))))))
731 ;;; List flattening
732 ;;; need to figure out how to make
733 ;;; '((1 2 3) (4 5) 6 7 (8)) into '(1 2 3 4 5 6 7 8)
734 (defun flatten-list (lst)
735 "Flattens a list of lists into a single list. Only useful when
736 we've mucked up data. Sign of usage means poor coding!"
737 (cond ((null lst) ;; endp?
738 nil)
739 ((listp lst)
740 (append (flatten-list (car lst)) (flatten-list (cdr lst))))
742 (list lst))))
744 ;; (flatten-list (list 1 (list 1 2) (list 4 5 6 )))
745 ;; (flatten-list '(1 (1 2) 3 (4 5 6)))