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