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