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