compound.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 ;;; compound -- Compound data and element-wise mapping functions
   7 ;;;
   8 ;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
   9 ;;; unrestricted use.
  10 ;;;
  11
  12 ;;;
  13 ;;; Package Setup
  14 ;;;
  15
  16 (in-package :cl-user)
  17
  18 (defpackage :lisp-stat-compound-data
  19   (:use :common-lisp
  20         :lisp-stat-object-system
  21         :lisp-stat-sequence)
  22   (:import-from :lisp-stat-fastmap fastmap)
  23   (:shadowing-import-from :lisp-stat-object-system
  24                           slot-value
  25                           call-next-method call-method)
  26   (:export compound-data-p compound-data-proto
  27            compound-object-p
  28            compound-data-seq compound-data-length
  29
  30            element-list element-seq
  31
  32            sort-data order rank
  33
  34            ;; export sequence-related functionality
  35
  36            ;; export matrix-related functionality (not sure??)
  37            ))
  38
  39 (in-package :lisp-stat-compound-data)
  40
  41 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  42 ;;;
  43 ;;;                    Internal Support Functions
  44 ;;;
  45 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  46
  47 (defun cmpndp (x)
  48   "Predicate to determine if argument is compound. Most common
  49 non-compound types are checked first."
  50   (declare (inline numberp symbolp stringp consp arrayp array-total-size))
  51   (cond ((or (numberp x) (symbolp x) (stringp x)) nil)
  52          ((or (consp x) (and (arrayp x) (< 0 (array-total-size x)))) t)
  53          (t (compound-object-p x))))
  54
  55 (defun find-compound-data (list)
  56   "Returns first compound data item in LIST or NIL if there is none."
  57   (dolist (x list) (if (cmpndp x) (return x))))
  58
  59 (defun any-compound-elements (seq)
  60   "Checks for a compound element."
  61   (cond ((consp seq) (dolist (x seq) (if (cmpndp x) (return x))))
  62         ((vectorp seq)
  63          (let ((n (length seq)))
  64            (declare (fixnum n))
  65            (dotimes (i n)
  66              (declare (fixnum i))
  67              (let ((x (aref seq i)))
  68                (if (cmpndp x) (return x))))))
  69         (t (error "argument must be a list or vector"))))
  70
  71 (defun compound-data-sequence (x)
  72   "Returns sequence of data values for X."
  73   (declare (inline consp vectorp arrayp make-array array-total-size))
  74   (cond
  75    ((or (consp x) (vectorp x)) x)
  76    ((arrayp x) (make-array (array-total-size x) :displaced-to x))
  77    (t (send x :data-seq))))
  78
  79 (defmacro sequence-type (x) `(if (consp ,x) 'list 'vector))
  80
  81 (defun make-compound-data (shape sequence)
  82 "Construct a compound data item to match the shape of the first
  83 argument."
  84   (let ((n (length (compound-data-sequence shape))))
  85     (if (/= n (length sequence)) (error "compound data not the same shape"))
  86     (cond
  87      ((consp shape) (if (consp sequence) sequence (coerce sequence 'list)))
  88      ((vectorp shape)
  89       (if (vectorp sequence) sequence (coerce sequence 'vector)))
  90      ((arrayp shape)
  91       (make-array (array-dimensions shape)
  92                   :displaced-to (coerce sequence 'vector)))
  93      (t (send shape :make-data sequence)))))
  94
  95 (defun make-circle (x)
  96   "Make a circular list of one element."
  97   (declare (inline cons rplacd))
  98   (let ((x (cons x nil)))
  99     (rplacd x x)
 100     x))
 101
 102 (defun check-compound (x)
 103   "Signals an error if X is not compound."
 104   (if (not (cmpndp x)) (error "not a compound data item - ~a" x)))
 105
 106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 107 ;;;
 108 ;;; MAP-ELEMENTS function
 109 ;;; Applies a function to arguments. If all arguments are simple (i. e.
 110 ;;; not compound) then MAP-ELEMENTS acts like funcall. Otherwise all
 111 ;;; compound arguments must be of the same shape and simple arguments
 112 ;;; are treated as if they were compound arguments of the appropriate
 113 ;;; shape. This is implemented by replacin all simple arguments by
 114 ;;; circular lists of one element.
 115 ;;;
 116 ;;; This implementation uses FASTMAP, a version of MAP that is assumed
 117 ;;; to
 118 ;;;
 119 ;;;     a) work reasonable fast on any combination of lists and vectors
 120 ;;;        as its arguments
 121 ;;;
 122 ;;;     b) not hang if at least one of its arguments is not a circular
 123 ;;;        list.
 124 ;;;
 125 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 126
 127 (defun fixup-map-elements-arglist (args)
 128   (do* ((args args (rest args))
 129         (x (car args) (car args)))
 130        ((null args))
 131     (declare (inline car))
 132     (setf (car args)
 133           (if (cmpndp x) (compound-data-sequence x) (make-circle x)))))
 134
 135 (defun map-elements (fcn &rest args)
 136 "Args: (fcn &rest args)
 137 Applies FCN elementwise. If no arguments are compound MAP-ELEMENTS
 138 acts like FUNCALL. Compound arguments must all be the same shape. Non
 139 compound arguments, in the presence of compound ones, are treated as
 140 if they were of the same shape as the compound items with constant data
 141 values."
 142   (let ((first-compound (find-compound-data args)))
 143     (cond ((null first-compound) (apply fcn args))
 144           (t (fixup-map-elements-arglist args)
 145              (let* ((seq (compound-data-sequence first-compound))
 146                     (type (sequence-type seq)))
 147                (make-compound-data first-compound
 148                                    (apply #'fastmap type fcn args)))))))
 149
 150 (defun recursive-map-elements (base-fcn fcn &rest args)
 151 "Args: (base-fcn fcn &rest args)
 152 The same idea as MAP-ELEMENTS, except arguments are in a list and the
 153 base and recursive cases can use different functions. Modified to check
 154 for second level of compounding and use base-fcn if there is none."
 155   (let ((first-compound (find-compound-data args)))
 156     (cond ((null first-compound) (apply base-fcn args))
 157           (t (fixup-map-elements-arglist args)
 158              (let* ((seq (compound-data-sequence first-compound))
 159                     (type (sequence-type seq))
 160                     (f (if (any-compound-elements seq) fcn base-fcn)))
 161                (make-compound-data first-compound
 162                                    (apply #'fastmap type f args)))))))
 163
 164
 165 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 166 ;;;;
 167 ;;;;             Public Predicate and Accessor Functions
 168 ;;;;
 169 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 170
 171 (defun compound-data-p (x)
 172 "Args: (x)
 173 Returns T if X is a compound data item, NIL otherwise."
 174   (cmpndp x))
 175
 176 (defun compound-data-seq (x)
 177 "Args (x)
 178 Returns data sequence in X."
 179   (check-compound x)
 180   (compound-data-sequence x))
 181
 182 (defun compound-data-length (x)
 183 "Args (x)
 184 Returns length of data sequence in X."
 185   (check-compound x)
 186   (length (compound-data-sequence x)))
 187
 188 (defun element-list (x)
 189   (cond
 190    ((compound-data-p x)
 191     (let ((x (concatenate 'list (compound-data-seq x)))) ; copies sequence
 192       (cond
 193        ((any-compound-elements x)
 194         (do ((next x (rest next)))
 195             ((not (consp next)))
 196           (setf (first next) (element-list (first next))))
 197         (do ((result (first x))
 198              (last (last (first x)))
 199              (next (rest x) (rest next)))
 200             ((not (consp next)) result)
 201           (setf (rest last) (first next))
 202           (setf last (last (first next)))))
 203        (t x))))
 204    (t (list x))))
 205
 206 (defun element-seq (x)
 207 "Args: (x)
 208 Returns sequence of the elements of compound item X."
 209   (check-compound x)
 210   (let ((seq (compound-data-seq x)))
 211     (if (any-compound-elements seq) (element-list seq) seq)))
 212
 213 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 214 ;;;;
 215 ;;;;                     Compound Data Objects
 216 ;;;;
 217 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 218
 219 (defproto compound-data-proto)
 220
 221 (defmeth compound-data-proto :data-length (&rest args) nil)
 222 (defmeth compound-data-proto :data-seq (&rest args) nil)
 223 (defmeth compound-data-proto :make-data (&rest args) nil)
 224 (defmeth compound-data-proto :select-data (&rest args) nil)
 225
 226 (defun compound-object-p (x) (kind-of-p x compound-data-proto))
 227
 228
 229
 230 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 231 ;;;;
 232 ;;;;                         Sorting Functions
 233 ;;;;
 234 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 235
 236 (defun sort-data (x)
 237 "Args: (sequence)
 238 Returns a sequence with the numbers or strings in the sequence X in order."
 239   (flet ((less (x y) (if (numberp x) (< x y) (string-lessp x y))))
 240     (stable-sort (copy-seq (compound-data-seq x)) #'less)))
 241
 242 (defun order (x)
 243 "Args (x)
 244 Returns a sequence of the indices of elements in the sequence of numbers
 245 or strings X in order."
 246   (let* ((seq (compound-data-seq x))
 247          (type (if (consp seq) 'list 'vector))
 248          (i -1))
 249     (flet ((entry (x) (setf i (+ i 1)) (list x i))
 250            (less (a b)
 251                  (let ((x (first a))
 252                        (y (first b)))
 253                    (if (numberp x) (< x y) (string-lessp x y)))))
 254       (let ((sorted-seq (stable-sort (map type #'entry seq) #'less)))
 255         (map type #'second sorted-seq)))))
 256
 257 ;; this isn't destructive -- do we document destructive only, or any
 258 ;; variant?
 259 (defun rank (x)
 260 "Args (x)
 261 Returns a sequence with the elements of the list or array of numbers or
 262 strings X replaced by their ranks."
 263   (let ((ranked-seq (order (order x))))
 264     (make-compound-data (compound-data-shape x) ranked-seq)))