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