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