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