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