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