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