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