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