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