sequence.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 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
   7 ;;;; unrestricted use.  (though Luke never had this file).
   8
   9 ;;;;
  10 ;;;; Package Setup
  11 ;;;;
  12
  13 (in-package :cl-user)
  14
  15 (defpackage :lisp-stat-sequence
  16   (:use :common-lisp
  17         :lisp-stat-types)
  18   (:export check-sequence
  19            get-next-element make-next-element set-next-element
  20            sequencep iseq
  21
  22            ;; maybe?
  23            ordered-nneg-seq
  24            select
  25
  26            which
  27            ;; vector differences
  28            difference rseq))
  29
  30 (in-package :lisp-stat-sequence)
  31
  32 ;;; Sequences are part of ANSI CL, being a supertype of vector and
  33 ;;; list (ordered set of things).
  34 ;;;
  35 ;;; Need to use the interenal structure when possible -- silly to be
  36 ;;; redundant!  However, this means we need to understand what
  37 ;;; sequences were intending to do, which I'm not clear on yet.
  38
  39 ;;; The original ordering, object-wise, was to have compound
  40 ;;; functionality passed into sequences, into other data sources.
  41 ;;; However, at this point, we will see about inverting this and
  42 ;;; having basic data types pushed through compound, to simplify
  43 ;;; packaging.
  44
  45 ;;;                      Type Checking Functions
  46
  47 (defun check-sequence (a)
  48   ;; FIXME:AJR: does this handle consp as well?  (Luke had an "or"
  49   ;; with consp).
  50   (if (not (typep a 'sequence))
  51       (error "not a sequence - ~s" a)))
  52
  53 ;;;                       Sequence Element Access
  54
  55
  56 ;;; (elt x i) -- NOT.  This is more like "pop".
  57 (defun get-next-element (x i)
  58   "Get element i from seq x.  FIXME: not really??"
  59   (let ((myseq (first x)))
  60     (if (consp myseq)
  61         (let ((elem (first myseq)))
  62           (setf (first x) (rest myseq))
  63           elem)
  64       (aref myseq i))))
  65
  66 ;;; (setf (elt x i) v)
  67 (defun set-next-element (x i v)
  68   (let ((seq (first x)))
  69     (cond ((consp seq)
  70            (setf (first seq) v)
  71            (setf (first x) (rest seq)))
  72           (t (setf (aref seq i) v)))))
  73
  74 (defun make-next-element (x) (list x))
  75
  76
  77 ;;;                         Sequence Functions
  78
  79
  80 ;; to prevent breakage.
  81 (defmacro sequencep (x)
  82   (typep x 'sequence))
  83
  84 (defun iseq (a &optional b)
  85 "Args: (n &optional m)
  86 Generate a sequence of consecutive integers from a to b.
  87 With one argumant returns a list of consecutive integers from 0 to N - 1.
  88 With two returns a list of consecutive integers from N to M.
  89 Examples: (iseq 4) returns (0 1 2 3)
  90           (iseq 3 7)  returns (3 4 5 6 7)
  91           (iseq 3 -3) returns (3 2 1 0 -1 -2 -3)"
  92   (if b
  93       (let ((n (+ 1 (abs (- b a))))
  94             (x nil))
  95         (dotimes (i n x)
  96                  (setq x (cons (if (< a b) (- b i) (+ b i)) x))))
  97       (cond
  98        ((= 0 a) nil)
  99        ((< a 0) (iseq (+ a 1) 0))
 100        ((< 0 a) (iseq 0 (- a 1))))))
 101
 102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 103 ;;;;
 104 ;;;;               Subset Selection and Mutation Functions
 105 ;;;;
 106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 107
 108 ;;;; is x an ordered sequence of nonnegative positive integers?
 109 (defun ordered-nneg-seq(x)
 110   ;; FIXME -- sbcl warning about unreachable code, might be a logic error here.
 111   (if (sequencep x)
 112       (let ((n (length x))
 113             (cx (make-next-element x))
 114             (m 0))
 115         (dotimes (i n t)
 116           (let ((elem (check-nonneg-fixnum (get-next-element cx i))))
 117             (if (> m elem) (return nil) (setf m elem)))))))
 118
 119 ;;;; select or set the subsequence corresponding to the specified indices
 120 (defun sequence-select(x indices &optional (values nil set-values))
 121   ;; FIXME -- sbcl warning about unreachable code, might be a logic error here.
 122   (let ((rlen 0)
 123         (dlen 0)
 124         (vlen 0)
 125         (data nil)
 126         (result nil))
 127     (declare (fixnum rlen dlen vlen))
 128
 129     ;; Check the input data
 130     (check-sequence x)
 131     (check-sequence indices)
 132     (if set-values (check-sequence values))
 133
 134     ;; Find the data sizes
 135     (setf data (if (ordered-nneg-seq indices) x (coerce x 'vector)))
 136     (setf dlen (length data))
 137     (setf rlen (length indices))
 138     (when set-values
 139       (setf vlen (length values))
 140       (if (/= vlen rlen) (error "value and index sequences do not match")))
 141
 142     ;; set up the result/value sequence
 143     (setf result
 144           (if set-values
 145               values
 146               (make-sequence (if (listp x) 'list 'vector) rlen)))
 147
 148     ;; get or set the sequence elements
 149     (if set-values
 150       (do ((nextx x)
 151            (cr (make-next-element result))
 152            (ci (make-next-element indices))
 153            (i 0 (+ i 1))
 154            (j 0)
 155            (index 0))
 156           ((>= i rlen))
 157         (declare (fixnum i j index))
 158         (setf index (get-next-element ci i))
 159         (if (<= dlen index) (error "index out of range - ~a" index))
 160         (let ((elem (get-next-element cr i)))
 161           (cond
 162            ((listp x)
 163             (when (> j index)
 164               (setf j 0)
 165               (setf nextx x))
 166             (do ()
 167                 ((not (and (< j index) (consp nextx))))
 168               (incf j 1)
 169               (setf nextx (rest nextx)))
 170             (setf (first nextx) elem))
 171            (t (setf (aref x index) elem)))))
 172       (do ((nextx data)
 173            (cr (make-next-element result))
 174            (ci (make-next-element indices))
 175            (i 0 (+ i 1))
 176            (j 0)
 177            (index 0)
 178            (elem nil))
 179           ((>= i rlen))
 180         (declare (fixnum i j index))
 181         (setf index (get-next-element ci i))
 182         (if (<= dlen index) (error "index out of range - ~a" index))
 183         (cond
 184          ((listp data) ;; indices must be ordered
 185           (do ()
 186               ((not (and (< j index) (consp nextx))))
 187             (incf j 1)
 188             (setf nextx (rest nextx)))
 189           (setf elem (first nextx)))
 190          (t (setf elem (aref data index))))
 191         (set-next-element cr i elem)))
 192
 193     result))
 194
 195 ;;;
 196 ;;; SELECT function
 197 ;;;
 198
 199 (defun select (x &rest args)
 200 "Args: (a &rest indices)
 201 A can be a list or an array. If A is a list and INDICES is a single number
 202 then the appropriate element of A is returned. If  is a list and INDICES is
 203 a list of numbers then the sublist of the corresponding elements is returned.
 204 If A in an array then the number of INDICES must match the ARRAY-RANK of A.
 205 If each index is a number then the appropriate array element is returned.
 206 Otherwise the INDICES must all be lists of numbers and the corresponding
 207 submatrix of A is returned. SELECT can be used in setf."
 208   (cond
 209    ((every #'fixnump args)
 210     (if (listp x) (nth (first args) x) (apply #'aref x args)))
 211    ((sequencep x) (sequence-select x (first args)))
 212    (t (subarray-select x args))))
 213
 214
 215 ;; Built in SET-SELECT (SETF method for SELECT)
 216 (defun set-select (x &rest args)
 217   (let ((indices (butlast args))
 218         (values (first (last args))))
 219     (cond
 220      ((sequencep x)
 221       (if (not (consp indices)) (error "bad indices - ~a" indices))
 222       (let* ((indices (first indices))
 223              (i-list (if (fixnump indices) (list indices) indices))
 224              (v-list (if (fixnump indices) (list values) values)))
 225         (sequence-select x i-list v-list)))
 226      ((arrayp x)
 227       (subarray-select x indices values))
 228      (t (error "bad argument type - ~a" x)))
 229     values))
 230
 231 (defsetf select set-select)
 232
 233 ;;;;
 234 ;;;; Basic Sequence Operations
 235 ;;;;
 236
 237 (defun difference (x)
 238 "Args: (x)
 239 Returns differences for a sequence X."
 240   (let ((n (length x)))
 241     (- (select x (iseq 1 (1- n))) (select x (iseq 0 (- n 2))))))
 242
 243 (defun rseq (a b num)
 244 "Args: (a b num)
 245 Returns a list of NUM equally spaced points starting at A and ending at B."
 246   (+ a (* (values-list (iseq 0 (1- num))) (/ (float (- b a)) (1- num)))))
 247
 248
 249 ;;;;
 250 ;;;; WHICH function
 251 ;;;;
 252
 253 (defun which (x)
 254 "Args: (x)
 255 Returns a list of the indices where elements of sequence X are not NIL."
 256   (let ((x (list (compound-data-seq x)))
 257         (result nil)
 258         (tail nil))
 259     (flet ((add-result (x)
 260              (if result (setf (rest tail) (list x)) (setf result (list x)))
 261              (setf tail (if tail (rest tail) result)))
 262            (get-next-element (seq-list i)
 263              (cond ((consp (first seq-list))
 264                     (let ((elem (first (first seq-list))))
 265                       (setf (first seq-list) (rest (first seq-list)))
 266                       elem))
 267                    (t (aref (first seq-list) i)))))
 268           (let ((n (length (first x))))
 269             (dotimes (i n result)
 270                      (if (get-next-element x i) (add-result i)))))))