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 (defproto *compound-data-proto*)
 239
 240 ;;; FIXME: These need to be defined!!
 241 (defmeth *compound-data-proto* :data-length (&rest args) nil)
 242 (defmeth *compound-data-proto* :data-seq (&rest args) nil)
 243 (defmeth *compound-data-proto* :make-data (&rest args) nil)
 244 (defmeth *compound-data-proto* :select-data (&rest args) nil)
 245
 246 (defun compound-object-p (x) (kind-of-p x *compound-data-proto*))
 247
 248
 249
 250 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 251 ;;;;
 252 ;;;;                         Sorting Functions
 253 ;;;;
 254 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 255
 256 (defun sort-data (x)
 257 "Args: (sequence)
 258 Returns a sequence with the numbers or strings in the sequence X in order."
 259   (flet ((less (x y) (if (numberp x) (< x y) (string-lessp x y))))
 260     (stable-sort (copy-seq (compound-data-seq x)) #'less)))
 261
 262 (defun order (x)
 263 "Args (x)
 264 Returns a sequence of the indices of elements in the sequence of numbers
 265 or strings X in order."
 266   (let* ((seq (compound-data-seq x))
 267          (type (if (consp seq) 'list 'vector))
 268          (i -1))
 269     (flet ((entry (x) (setf i (+ i 1)) (list x i))
 270            (less (a b)
 271                  (let ((x (first a))
 272                        (y (first b)))
 273                    (if (numberp x) (< x y) (string-lessp x y)))))
 274       (let ((sorted-seq (stable-sort (map type #'entry seq) #'less)))
 275         (map type #'second sorted-seq)))))
 276
 277 ;; this isn't destructive -- do we document destructive only, or any
 278 ;; variant?
 279 (defun rank (x)
 280 "Args (x)
 281 Returns a sequence with the elements of the list or array of numbers or
 282 strings X replaced by their ranks."
 283   (let ((ranked-seq (order (order x))))
 284     (make-compound-data
 285      ;; compound-data-shape is undefined?
 286      (compound-data-shape x) ranked-seq)))
 287
 288
 289
 290 ;;;
 291 ;;; REPEAT function
 292 ;;;
 293
 294 (defun repeat (a b)
 295 "Args: (vals times)
 296 Repeats VALS. If TIMES is a number and VALS is a non-null, non-array atom,
 297 a list of length TIMES with all elements eq to VALS is returned. If VALS
 298 is a list and TIMES is a number then VALS is appended TIMES times. If
 299 TIMES is a list of numbers then VALS must be a list of equal length and
 300 the simpler version of repeat is mapped down the two lists.
 301 Examples: (repeat 2 5)                 returns (2 2 2 2 2)
 302           (repeat '(1 2) 3)            returns (1 2 1 2 1 2)
 303           (repeat '(4 5 6) '(1 2 3))   returns (4 5 5 6 6 6)
 304           (repeat '((4) (5 6)) '(2 3)) returns (4 4 5 6 5 6 5 6)"
 305   (cond ((compound-data-p b)
 306          (let* ((reps (coerce (compound-data-seq (map-elements #'repeat a b))
 307                               'list))
 308                 (result (first reps))
 309                 (tail (last (first reps))))
 310            (dolist (next (rest reps) result)
 311                    (when next
 312                          (setf (rest tail) next)
 313                          (setf tail (last next))))))
 314         (t (let* ((a (if (compound-data-p a)
 315                          (coerce (compound-data-seq a) 'list)
 316                          (list a)))
 317                   (result nil))
 318              (dotimes (i b result)
 319                       (let ((next (copy-list a)))
 320                         (if result (setf (rest (last next)) result))
 321                         (setf result next)))))))
 322 ;;;
 323 ;;; WHICH function
 324 ;;;
 325
 326 (defun which (x)
 327 "Args: (x)
 328 Returns a list of the indices where elements of sequence X are not NIL."
 329   (let ((x (list (compound-data-seq x)))
 330         (result nil)
 331         (tail nil))
 332     (flet ((add-result (x)
 333              (if result (setf (rest tail) (list x)) (setf result (list x)))
 334              (setf tail (if tail (rest tail) result)))
 335            (get-next-element (seq-list i)
 336              (cond ((consp (first seq-list))
 337                     (let ((elem (first (first seq-list))))
 338                       (setf (first seq-list) (rest (first seq-list)))
 339                       elem))
 340                    (t (aref (first seq-list) i)))))
 341           (let ((n (length (first x))))
 342             (dotimes (i n result)
 343                      (if (get-next-element x i) (add-result i)))))))
 344
 345 ;;;                      Type Checking Functions
 346
 347 (defun check-sequence (a)
 348   ;; FIXME:AJR: does this handle consp as well?  (Luke had an "or"
 349   ;; with consp).
 350   (if (not (typep a 'sequence))
 351       (error "not a sequence - ~s" a)))
 352
 353 ;;;                       Sequence Element Access
 354
 355
 356 ;;; (elt x i) -- NOT.  This is more like "pop".
 357 (defun get-next-element (x i)
 358   "Get element i from seq x.  FIXME: not really??"
 359   (let ((myseq (first x)))
 360     (if (consp myseq)
 361         (let ((elem (first myseq)))
 362           (setf (first x) (rest myseq))
 363           elem)
 364       (aref myseq i))))
 365
 366 ;;; (setf (elt x i) v)
 367 (defun set-next-element (x i v)
 368   (let ((seq (first x)))
 369     (cond ((consp seq)
 370            (setf (first seq) v)
 371            (setf (first x) (rest seq)))
 372           (t (setf (aref seq i) v)))))
 373
 374 (defun make-next-element (x) (list x))
 375
 376
 377 ;;;                         Sequence Functions
 378
 379
 380 ;; to prevent breakage.
 381 (defmacro sequencep (x)
 382   (typep x 'sequence))
 383
 384 (defun iseq (a &optional b)
 385 "Args: (n &optional m)
 386 Generate a sequence of consecutive integers from a to b.
 387 With one argumant returns a list of consecutive integers from 0 to N - 1.
 388 With two returns a list of consecutive integers from N to M.
 389 Examples: (iseq 4) returns (0 1 2 3)
 390           (iseq 3 7)  returns (3 4 5 6 7)
 391           (iseq 3 -3) returns (3 2 1 0 -1 -2 -3)"
 392   (if b
 393       (let ((n (+ 1 (abs (- b a))))
 394             (x nil))
 395         (dotimes (i n x)
 396                  (setq x (cons (if (< a b) (- b i) (+ b i)) x))))
 397       (cond
 398        ((= 0 a) nil)
 399        ((< a 0) (iseq (+ a 1) 0))
 400        ((< 0 a) (iseq 0 (- a 1))))))
 401
 402 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 403 ;;;;
 404 ;;;;               Subset Selection and Mutation Functions
 405 ;;;;
 406 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 407
 408
 409 (defun old-rowmajor-index (index indices dim olddim)
 410   "translate row major index in resulting subarray to row major index
 411 in the original array."
 412   (declare (fixnum index))
 413   (let ((rank (length dim))
 414         (face 1)
 415         (oldface 1)
 416         (oldindex 0))
 417     (declare (fixnum rank face oldface))
 418
 419     (dotimes (i rank)
 420       (declare (fixnum i))
 421       (setf face (* face (aref dim i)))
 422       (setf oldface (* oldface (aref olddim i))))
 423
 424     (dotimes (i rank)
 425       (declare (fixnum i))
 426       (setf face (/ face (aref dim i)))
 427       (setf oldface (/ oldface (aref olddim i)))
 428       (incf oldindex
 429             (* oldface (aref (aref indices i) (floor (/ index face))))) ;;*** is this floor really needed???
 430       (setf index (rem index face)))
 431     oldindex))
 432
 433 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 434 ;;;;
 435 ;;;;               Subset Selection and Mutation Functions
 436 ;;;;
 437 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 438
 439 (defun subarray-select (a indexlist &optional (values nil set_values))
 440   "extract or set subarray for the indices from a displaced array."
 441   (let ((indices nil)
 442         (index)
 443         (dim)
 444         (vdim)
 445         (data)
 446         (result_data)
 447         (olddim)
 448         (result)
 449         (rank 0)
 450         (n 0)
 451         (k 0))
 452     (declare (fixnum rank n))
 453
 454     (if (or (sequencep a) (not (arrayp a))) (error "not an array - ~a" a))
 455     (if (not (listp indexlist))  (error "bad index list - ~a" indices))
 456     (if (/= (length indexlist)  (array-rank a))
 457         (error "wrong number of indices"))
 458
 459     (setf indices (coerce indexlist 'vector))
 460
 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
 511 ;;;; is x an ordered sequence of nonnegative positive integers?
 512 (defun ordered-nneg-seq(x)
 513   ;; FIXME -- sbcl warning about unreachable code, might be a logic error here.
 514   (if (sequencep x)
 515       (let ((n (length x))
 516             (cx (make-next-element x))
 517             (m 0))
 518         (dotimes (i n t)
 519           (let ((elem (check-nonneg-fixnum (get-next-element cx i))))
 520             (if (> m elem) (return nil) (setf m elem)))))))
 521
 522 ;;;; select or set the subsequence corresponding to the specified indices
 523 (defun sequence-select(x indices &optional (values nil set-values))
 524   ;; FIXME -- sbcl warning about unreachable code, might be a logic error here.
 525   (let ((rlen 0)
 526         (dlen 0)
 527         (vlen 0)
 528         (data nil)
 529         (result nil))
 530     (declare (fixnum rlen dlen vlen))
 531
 532     ;; Check the input data
 533     (check-sequence x)
 534     (check-sequence indices)
 535     (if set-values (check-sequence values))
 536
 537     ;; Find the data sizes
 538     (setf data (if (ordered-nneg-seq indices) x (coerce x 'vector)))
 539     (setf dlen (length data))
 540     (setf rlen (length indices))
 541     (when set-values
 542       (setf vlen (length values))
 543       (if (/= vlen rlen) (error "value and index sequences do not match")))
 544
 545     ;; set up the result/value sequence
 546     (setf result
 547           (if set-values
 548               values
 549               (make-sequence (if (listp x) 'list 'vector) rlen)))
 550
 551     ;; get or set the sequence elements
 552     (if set-values
 553       (do ((nextx x)
 554            (cr (make-next-element result))
 555            (ci (make-next-element indices))
 556            (i 0 (+ i 1))
 557            (j 0)
 558            (index 0))
 559           ((>= i rlen))
 560         (declare (fixnum i j index))
 561         (setf index (get-next-element ci i))
 562         (if (<= dlen index) (error "index out of range - ~a" index))
 563         (let ((elem (get-next-element cr i)))
 564           (cond
 565            ((listp x)
 566             (when (> j index)
 567               (setf j 0)
 568               (setf nextx x))
 569             (do ()
 570                 ((not (and (< j index) (consp nextx))))
 571               (incf j 1)
 572               (setf nextx (rest nextx)))
 573             (setf (first nextx) elem))
 574            (t (setf (aref x index) elem)))))
 575       (do ((nextx data)
 576            (cr (make-next-element result))
 577            (ci (make-next-element indices))
 578            (i 0 (+ i 1))
 579            (j 0)
 580            (index 0)
 581            (elem nil))
 582           ((>= i rlen))
 583         (declare (fixnum i j index))
 584         (setf index (get-next-element ci i))
 585         (if (<= dlen index) (error "index out of range - ~a" index))
 586         (cond
 587          ((listp data) ;; indices must be ordered
 588           (do ()
 589               ((not (and (< j index) (consp nextx))))
 590             (incf j 1)
 591             (setf nextx (rest nextx)))
 592           (setf elem (first nextx)))
 593          (t (setf elem (aref data index))))
 594         (set-next-element cr i elem)))
 595
 596     result))
 597
 598 ;;;
 599 ;;; SELECT function
 600 ;;;
 601
 602 (defun select (x &rest args)
 603 "Args: (a &rest indices)
 604 A can be a list or an array. If A is a list and INDICES is a single number
 605 then the appropriate element of A is returned. If  is a list and INDICES is
 606 a list of numbers then the sublist of the corresponding elements is returned.
 607 If A in an array then the number of INDICES must match the ARRAY-RANK of A.
 608 If each index is a number then the appropriate array element is returned.
 609 Otherwise the INDICES must all be lists of numbers and the corresponding
 610 submatrix of A is returned. SELECT can be used in setf."
 611   (cond
 612    ((every #'fixnump args)
 613     (if (listp x) (nth (first args) x) (apply #'aref x args)))
 614    ((sequencep x) (sequence-select x (first args)))
 615    (t (subarray-select x args))))
 616
 617
 618 ;; Built in SET-SELECT (SETF method for SELECT)
 619 ;; FIXME: This should be done cleaner, check the spec, something like
 620 ;; (defun (setf select) (x &rest args)...)
 621 (defun set-select (x &rest args)
 622   (let ((indices (butlast args))
 623         (values (first (last args))))
 624     (cond
 625      ((typep x 'sequence)
 626       (if (not (consp indices)) (error "bad indices - ~a" indices))
 627       (let* ((indices (first indices))
 628              (i-list (if (fixnump indices) (list indices) indices))
 629              (v-list (if (fixnump indices) (list values) values)))
 630         (sequence-select x i-list v-list)))
 631      ((arrayp x)
 632       (subarray-select x indices values))
 633      (t (error "bad argument type - ~a" x)))
 634     values))
 635
 636 (defsetf select set-select)
 637
 638 ;;;;
 639 ;;;; Basic Sequence Operations
 640 ;;;;
 641
 642 (defun difference (x)
 643 "Args: (x)
 644 Returns differences for a sequence X."
 645   (let ((n (length x)))
 646     (- (select x (iseq 1 (1- n))) (select x (iseq 0 (- n 2))))))
 647
 648 (defun rseq (a b num)
 649 "Args: (a b num)
 650 Returns a list of NUM equally spaced points starting at A and ending at B."
 651   (+ a (* (values-list (iseq 0 (1- num))) (/ (float (- b a)) (1- num)))))
 652
 653
 654
 655 (defun split-list (x n)
 656 "Args: (list cols)
 657 Returns a list of COLS lists of equal length of the elements of LIST.
 658 Example: (split-list '(1 2 3 4 5 6) 2) returns ((1 2 3) (4 5 6))"
 659   (check-one-fixnum n)
 660   (if (/= (rem (length x) n) 0) (error "length not divisible by ~a" n))
 661   (flet ((next-split ()
 662            (let ((result nil)
 663                  (end nil))
 664              (dotimes (i n result)
 665                (declare (fixnum i))
 666                (let ((c-elem (list (first x))))
 667                  (cond ((null result)
 668                         (setf result c-elem)
 669                         (setf end result))
 670                        (t
 671                         (setf (rest end) c-elem)
 672                         (setf end (rest end)))))
 673                (setf x (rest x))))))
 674     (let ((result nil)
 675           (end nil)
 676           (k (/ (length x) n)))
 677       (declare (fixnum k))
 678       (dotimes (i k result)
 679         (declare (fixnum i))
 680         (let ((c-sub (list (next-split))))
 681           (cond ((null result)
 682                  (setf result c-sub)
 683                  (setf end result))
 684                 (t
 685                  (setf (rest end) c-sub)
 686                  (setf end (rest end)))))))))