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