src/basics/compound.lsp

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