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
  12
  13 (in-package :lisp-stat-compound-data)
  14
  15 ;;; Sequences are part of ANSI CL, being a supertype of vector and
  16 ;;; list (ordered set of things).
  17 ;;;
  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.
  22
  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.
  30
  31
  32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33 ;;;
  34 ;;;                    Internal Support Functions
  35 ;;;
  36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37
  38 (defun cmpndp (x)
  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))
  43          nil)
  44          ((or (consp x) (and (arrayp x) (< 0 (array-total-size x))))
  45           t)
  46          (t (compound-object-p x))))
  47
  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))))
  51
  52 (defun any-compound-elements (seq)
  53   "Checks for a compound element."
  54   (cond ((consp seq) (dolist (x seq) (if (cmpndp x) (return x))))
  55         ((vectorp seq)
  56          (let ((n (length seq)))
  57            (declare (fixnum n))
  58            (dotimes (i n)
  59              (declare (fixnum i))
  60              (let ((x (aref seq i)))
  61                (if (cmpndp x) (return x))))))
  62         (t (error "argument must be a list or vector"))))
  63
  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))
  67   (cond
  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))))
  71
  72 (defmacro sequence-type (x) `(if (consp ,x) 'list 'vector))
  73
  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"))
  82     (cond
  83       ((consp shape)
  84        (if (consp sequence) sequence (coerce sequence 'list)))
  85       ((vectorp shape)
  86        (if (vectorp sequence) sequence (coerce sequence 'vector)))
  87       ((arrayp shape)
  88        (make-array (array-dimensions shape)
  89                    :displaced-to (coerce sequence 'vector)))
  90       (t (send shape :make-data sequence)))))
  91
  92 (defun make-circle (x)
  93   "Make a circular list of one element."
  94   (declare (inline cons rplacd))
  95   (let ((x (cons x nil)))
  96     (rplacd x x)
  97     x))
  98
  99 (defun check-compound (x)
 100   "Signals an error if X is not compound."
 101   (if (not (cmpndp x))
 102       (error "not a compound data item - ~a" x)))
 103
 104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 105 ;;;
 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.
 113 ;;;
 114 ;;; This implementation uses FASTMAP, a version of MAP that is assumed
 115 ;;; to
 116 ;;;
 117 ;;;     a) work reasonable fast on any combination of lists and vectors
 118 ;;;        as its arguments
 119 ;;;
 120 ;;;     b) not hang if at least one of its arguments is not a circular
 121 ;;;        list.
 122 ;;;
 123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 124
 125 (defun fixup-map-elements-arglist (args)
 126   (do* ((args args (rest args))
 127         (x (car args) (car args)))
 128        ((null args))
 129     (declare (inline car))
 130     (setf (car args) (if (cmpndp x)
 131                          (compound-data-sequence x)
 132                          (make-circle x)))))
 133
 134 (defun map-elements (fcn &rest args)
 135   "Args: (fcn &rest args)
 136
 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
 141 data values."
 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)))))))
 149
 150 (defun recursive-map-elements (base-fcn fcn &rest args)
 151   "Args: (base-fcn fcn &rest args)
 152
 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
 156 none."
 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)))))))
 165
 166
 167 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 168 ;;;;
 169 ;;;;             Public Predicate and Accessor Functions
 170 ;;;;
 171 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 172
 173 (defun compound-data-p (x)
 174   "Args: (x)
 175 Returns T if X is a compound data item, NIL otherwise."
 176   (cmpndp x))
 177
 178 (defun compound-data-seq (x)
 179   "Args (x)
 180 Returns data sequence in X."
 181   (check-compound x)
 182   (compound-data-sequence x))
 183
 184 (defun compound-data-length (x)
 185   "Args (x)
 186 Returns length of data sequence in X."
 187   (check-compound x)
 188   (length (compound-data-sequence x)))
 189
 190 (defun compound-data-shape (x)
 191   "Needed but undefined??"
 192   x)
 193
 194
 195 (defun element-list (x)
 196   (cond
 197    ((compound-data-p x)
 198     (let ((x (concatenate 'list (compound-data-seq x)))) ; copies sequence
 199       (cond
 200        ((any-compound-elements x)
 201         (do ((next x (rest next)))
 202             ((not (consp 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)))))
 210        (t x))))
 211    (t (list x))))
 212
 213 (defun element-seq (x)
 214 "Args: (x)
 215 Returns sequence of the elements of compound item X."
 216   (check-compound x)
 217   (let ((seq (compound-data-seq x)))
 218     (if (any-compound-elements seq) (element-list seq) seq)))
 219
 220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 221 ;;;;
 222 ;;;;                     Compound Data Objects
 223 ;;;;
 224 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 225
 226 (defvar *compound-data-proto*)
 227 (defproto *compound-data-proto*)
 228
 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))
 238
 239 (defun compound-object-p (x) (kind-of-p x *compound-data-proto*))
 240
 241
 242
 243 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 244 ;;;;
 245 ;;;;                         Sorting Functions
 246 ;;;;
 247 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 248
 249 (defun sort-data (x)
 250 "Args: (sequence)
 251
 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)))
 255
 256 (defun order (x)
 257 "Args (x)
 258
 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))
 263          (i -1))
 264     (flet ((entry (x) (setf i (+ i 1)) (list x i))
 265            (less (a b)
 266                  (let ((x (first a))
 267                        (y (first b)))
 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)))))
 271
 272 ;; this isn't destructive -- do we document destructive only, or any
 273 ;; variant?
 274 (defun rank (x)
 275 "Args (x)
 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))))
 279     (make-compound-data
 280      ;; compound-data-shape is undefined?
 281      (compound-data-shape x) ranked-seq)))
 282
 283
 284
 285 ;;;
 286 ;;; REPEAT function
 287 ;;;
 288
 289 (defun repeat (a b)
 290 "Args: (vals times)
 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))
 302                               'list))
 303                 (result (first reps))
 304                 (tail (last (first reps))))
 305            (dolist (next (rest reps) result)
 306                    (when next
 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)
 311                          (list a)))
 312                   (result nil))
 313              (dotimes (i b result)
 314                       (let ((next (copy-list a)))
 315                         (if result (setf (rest (last next)) result))
 316                         (setf result next)))))))
 317 ;;;
 318 ;;; WHICH function
 319 ;;;
 320
 321 (defun which (x)
 322 "Args: (x)
 323 Returns a list of the indices where elements of sequence X are not NIL."
 324   (let ((x (list (compound-data-seq x)))
 325         (result nil)
 326         (tail nil))
 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)))
 334                       elem))
 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)))))))
 339
 340 ;;;                      Type Checking Functions
 341
 342 (defun check-sequence (a)
 343   ;; FIXME:AJR: does this handle consp as well?  (Luke had an "or"
 344   ;; with consp).
 345   (if (not (or (typep a 'sequence)
 346                (consp a)))
 347       (error "not a sequence or cons - ~s" a)))
 348
 349
 350
 351 ;;;                       Sequence Element Access
 352
 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)))
 357     (if (consp myseq)
 358         (let ((elem (first myseq)))
 359           (setf (first x) (rest myseq))
 360           elem)
 361       (aref myseq i))))
 362
 363 ;;; (setf (elt x i) v)
 364 (defun set-next-element (x i v)
 365   (let ((seq (first x)))
 366     (cond ((consp seq)
 367            (setf (first seq) v)
 368            (setf (first x) (rest seq)))
 369           (t (setf (aref seq i) v)))))
 370
 371 (defun make-next-element (x) (list x))
 372
 373
 374 ;;;                         Sequence Functions
 375
 376
 377 ;; to prevent breakage.
 378 (defmacro sequencep (x)
 379   (typep x 'sequence))
 380
 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)"
 389   (if b
 390       (let ((n (+ 1 (abs (- b a))))
 391             (x nil))
 392         (dotimes (i n x)
 393                  (setq x (cons (if (< a b) (- b i) (+ b i)) x))))
 394       (cond
 395        ((= 0 a) nil)
 396        ((< a 0) (iseq (+ a 1) 0))
 397        ((< 0 a) (iseq 0 (- a 1))))))
 398
 399 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 400 ;;;;
 401 ;;;;               Subset Selection and Mutation Functions
 402 ;;;;
 403 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 404
 405
 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))
 411         (face 1)
 412         (oldface 1)
 413         (oldindex 0))
 414     (declare (fixnum rank face oldface))
 415
 416     (dotimes (i rank)
 417       (declare (fixnum i))
 418       (setf face (* face (aref dim i)))
 419       (setf oldface (* oldface (aref olddim i))))
 420
 421     (dotimes (i rank)
 422       (declare (fixnum i))
 423       (setf face (/ face (aref dim i)))
 424       (setf oldface (/ oldface (aref olddim i)))
 425       (incf oldindex
 426             (* oldface (aref (aref indices i) (floor (/ index face))))) ;;*** is this floor really needed???
 427       (setf index (rem index face)))
 428     oldindex))
 429
 430 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 431 ;;;;
 432 ;;;;               Subset Selection and Mutation Functions
 433 ;;;;
 434 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 435
 436 (defun subarray-select (a indexlist &optional (values nil set_values))
 437   "extract or set subarray for the indices from a displaced array a.
 438
 439 a :  array
 440 indexlist:  ??
 441 values :
 442 nil :
 443 set_values :
 444
 445 and it's poorly documented."
 446   (let ((indices nil)
 447         (index)
 448         (dim)
 449         (vdim)
 450         (data)
 451         (result_data)
 452         (olddim)
 453         (result)
 454         (rank 0)
 455         (n 0)
 456         (k 0))
 457     (declare (fixnum rank n))
 458
 459     (if (or (sequencep a)
 460             (not (arrayp 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)
 465             (array-rank a))
 466         (error "wrong number of indices"))
 467
 468     (setf indices (coerce indexlist 'vector))
 469     (setf olddim (coerce (array-dimensions a) 'vector))
 470
 471     ;; compute the result dimension vector and fix up the indices
 472     (setf rank (array-rank a))
 473     (setf dim (make-array rank))
 474     (dotimes (i rank)
 475       (declare (fixnum i))
 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))
 480       (dotimes (j k)
 481         (declare (fixnum j))
 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)))
 486
 487     ;; set up the result or check the values
 488     (let ((dim-list (coerce dim 'list)))
 489       (cond
 490        (set_values
 491         (cond
 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))
 496           (dotimes (i rank)
 497             (declare (fixnum i))
 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)))))
 503
 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))
 508     (dotimes (i n)
 509       (declare (fixnum i))
 510       (setf k (old-rowmajor-index i indices dim olddim))
 511       (if (or (> 0 k) (>= k (length data))) (error "index out of range"))
 512       (if set_values
 513         (setf (aref data k) (aref result_data i))
 514         (setf (aref result_data i) (aref data k))))
 515
 516     result))
 517
 518
 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)
 523       (let ((n (length x))
 524             (cx (make-next-element x))
 525             (m 0))
 526         (dotimes (i n t)
 527           (let ((elem (check-nonneg-fixnum (get-next-element cx i))))
 528             (if (> m elem) (return nil) (setf m elem)))))))
 529
 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.
 533   (let ((rlen 0)
 534         (dlen 0)
 535         (vlen 0)
 536         (data nil)
 537         (result nil))
 538     (declare (fixnum rlen dlen vlen))
 539
 540     ;; Check the input data
 541     (check-sequence x)
 542     (check-sequence indices)
 543     (if set-values (check-sequence values))
 544
 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))
 549     (when set-values
 550       (setf vlen (length values))
 551       (if (/= vlen rlen) (error "value and index sequences do not match")))
 552
 553     ;; set up the result/value sequence
 554     (setf result
 555           (if set-values
 556               values
 557               (make-sequence (if (listp x) 'list 'vector) rlen)))
 558
 559     ;; get or set the sequence elements
 560     (if set-values
 561       (do ((nextx x)
 562            (cr (make-next-element result))
 563            (ci (make-next-element indices))
 564            (i 0 (+ i 1))
 565            (j 0)
 566            (index 0))
 567           ((>= i rlen))
 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)))
 572           (cond
 573            ((listp x)
 574             (when (> j index)
 575               (setf j 0)
 576               (setf nextx x))
 577             (do ()
 578                 ((not (and (< j index) (consp nextx))))
 579               (incf j 1)
 580               (setf nextx (rest nextx)))
 581             (setf (first nextx) elem))
 582            (t (setf (aref x index) elem)))))
 583       (do ((nextx data)
 584            (cr (make-next-element result))
 585            (ci (make-next-element indices))
 586            (i 0 (+ i 1))
 587            (j 0)
 588            (index 0)
 589            (elem nil))
 590           ((>= i rlen))
 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))
 594         (cond
 595          ((listp data) ;; indices must be ordered
 596           (do ()
 597               ((not (and (< j index) (consp nextx))))
 598             (incf j 1)
 599             (setf nextx (rest nextx)))
 600           (setf elem (first nextx)))
 601          (t (setf elem (aref data index))))
 602         (set-next-element cr i elem)))
 603
 604     result))
 605
 606 ;;;
 607 ;;; SELECT function
 608 ;;;
 609
 610 #|
 611 (defgeneric select (x &rest args)
 612   "Selection of data, Args: (a &rest indices)
 613
 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.")
 622
 623 (defmethod select ((x list) &rest args))
 624 (defmethod select ((x array) &rest args))
 625
 626
 627 |#
 628
 629 (defun select (x &rest args)
 630 "Args: (a &rest indices)
 631
 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."
 640   (cond
 641    ((every #'fixnump args) (if (typep x 'list)
 642                                (nth (first args) x)
 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."))))
 647
 648
 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))))
 653     (cond
 654      ((typep x 'sequence)
 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)))
 660      ((arrayp x)
 661       (subarray-select x (flatten-list indices) values))
 662      (t (error "bad argument type - ~a" x)))
 663     values))
 664
 665 (defsetf select set-select)
 666
 667 ;;;;
 668 ;;;; Basic Sequence Operations
 669 ;;;;
 670
 671 (defun difference (x)
 672 "Args: (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))))))
 676
 677 (defun rseq (a b num)
 678 "Args: (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)))))
 681
 682
 683
 684 (defun split-list (x n)
 685 "Args: (list cols)
 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))"
 688   (check-one-fixnum n)
 689   (if (/= (rem (length x) n) 0) (error "length not divisible by ~a" n))
 690   (flet ((next-split ()
 691            (let ((result nil)
 692                  (end nil))
 693              (dotimes (i n result)
 694                (declare (fixnum i))
 695                (let ((c-elem (list (first x))))
 696                  (cond ((null result)
 697                         (setf result c-elem)
 698                         (setf end result))
 699                        (t
 700                         (setf (rest end) c-elem)
 701                         (setf end (rest end)))))
 702                (setf x (rest x))))))
 703     (let ((result nil)
 704           (end nil)
 705           (k (/ (length x) n)))
 706       (declare (fixnum k))
 707       (dotimes (i k result)
 708         (declare (fixnum i))
 709         (let ((c-sub (list (next-split))))
 710           (cond ((null result)
 711                  (setf result c-sub)
 712                  (setf end result))
 713                 (t
 714                  (setf (rest end) c-sub)
 715                  (setf end (rest end)))))))))
 716
 717
 718 ;;; List flattening
 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?
 725          nil)
 726         ((listp lst)
 727          (append (flatten-list (car lst)) (flatten-list (cdr lst))))
 728         (t
 729          (list lst))))
 730
 731 ;; (flatten-list (list 1 (list 1 2) (list 4 5 6 )))
 732 ;; (flatten-list '(1 (1 2) 3 (4 5 6)))