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