compound.lsp

   1 ;;;; compound -- Compound data and element-wise mapping functions
   2 ;;;;
   3 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
   4 ;;;; unrestricted use.
   5 ;;;;
   6
   7 (provide "compound")
   8
   9 ;;;;
  10 ;;;; Package Setup
  11 ;;;;
  12
  13 #+:CLtL2
  14 (in-package lisp-stat-basics)
  15 #-:CLtL2
  16 (in-package 'lisp-stat-basics)
  17
  18 (export '(compound-data-p map-elements compound-data-seq
  19           compound-data-length element-seq compound-data-proto))
  20
  21 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22 ;;;
  23 ;;;                    Internal Support Functions
  24 ;;;
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26
  27 ;;; Predicate to determine if argument is compound. Most common
  28 ;;; non-compound types are checked first.
  29 (defun cmpndp (x)
  30   (declare (inline numberp symbolp stringp consp arrayp array-total-size))
  31   (cond ((or (numberp x) (symbolp x) (stringp x)) nil)
  32          ((or (consp x) (and (arrayp x) (< 0 (array-total-size x)))) t)
  33          (t (compound-object-p x))))
  34
  35 ;;; Returns first compound data item in LIST or NIL if there is none.
  36 (defun find-compound-data (list)
  37   (dolist (x list) (if (cmpndp x) (return x))))
  38
  39 ;;; Checks for a compound element
  40 (defun any-compound-elements (seq)
  41   (cond ((consp seq) (dolist (x seq) (if (cmpndp x) (return x))))
  42         ((vectorp seq)
  43          (let ((n (length seq)))
  44            (declare (fixnum n))
  45            (dotimes (i n)
  46              (declare (fixnum i))
  47              (let ((x (aref seq i)))
  48                (if (cmpndp x) (return x))))))
  49         (t (error "argument must be a list or vector"))))
  50
  51
  52 ;;; Returns sequence of data values for X.
  53 (defun compound-data-sequence (x)
  54   (declare (inline consp vectorp arrayp make-array array-total-size))
  55   (cond
  56    ((or (consp x) (vectorp x)) x)
  57    ((arrayp x) (make-array (array-total-size x) :displaced-to x))
  58    (t (send x :data-seq))))
  59
  60 (defmacro sequence-type (x) `(if (consp ,x) 'list 'vector))
  61
  62 ;;;; Construct a compound data item to match the shape of the first argument.
  63 (defun make-compound-data (shape sequence)
  64   (let ((n (length (compound-data-sequence shape))))
  65     (if (/= n (length sequence)) (error "compound data not the same shape"))
  66     (cond
  67      ((consp shape) (if (consp sequence) sequence (coerce sequence 'list)))
  68      ((vectorp shape)
  69       (if (vectorp sequence) sequence (coerce sequence 'vector)))
  70      ((arrayp shape)
  71       (make-array (array-dimensions shape)
  72                   :displaced-to (coerce sequence 'vector)))
  73      (t (send shape :make-data sequence)))))
  74
  75 ;;; Make a circular list of one element
  76 (defun make-circle (x)
  77   (declare (inline cons rplacd))
  78   (let ((x (cons x nil)))
  79     (rplacd x x)
  80     x))
  81
  82 ;;; Signals an error if X is not compound
  83 (defun check-compound (x)
  84   (if (not (cmpndp x)) (error "not a compound data item - ~a" x)))
  85
  86 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  87 ;;;
  88 ;;; MAP-ELEMENTS function
  89 ;;; Applies a function to arguments. If all arguments are simple (i. e.
  90 ;;; not compound) then MAP-ELEMENTS acts like funcall. Otherwise all
  91 ;;; compound arguments must be of the same shape and simple arguments
  92 ;;; are treated as if they were compound arguments of the appropriate
  93 ;;; shape. This is implemented by replacin all simple arguments by
  94 ;;; circular lists of one element.
  95 ;;;
  96 ;;; This implementation uses FASTMAP, a version of MAP that is assumed
  97 ;;; to
  98 ;;;
  99 ;;;     a) work reasonable fast on any combination of lists and vectors
 100 ;;;        as its arguments
 101 ;;;
 102 ;;;     b) not hang if at least one of its arguments is not a circular
 103 ;;;        list.
 104 ;;;
 105 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 106
 107 (defun fixup-map-elements-arglist (args)
 108   (do* ((args args (rest args))
 109         (x (car args) (car args)))
 110        ((null args))
 111     (declare (inline car))
 112     (setf (car args)
 113           (if (cmpndp x) (compound-data-sequence x) (make-circle x)))))
 114
 115 (defun map-elements (fcn &rest args)
 116 "Args: (fcn &rest args)
 117 Applies FCN elementwise. If no arguments are compound MAP-ELEMENTS
 118 acts like FUNCALL. Compound arguments must all be the same shape. Non
 119 compound arguments, in the presence of compound ones, are treated as
 120 if they were of the same shape as the compound items with constant data
 121 values."
 122   (let ((first-compound (find-compound-data args)))
 123     (cond ((null first-compound) (apply fcn args))
 124           (t (fixup-map-elements-arglist args)
 125              (let* ((seq (compound-data-sequence first-compound))
 126                     (type (sequence-type seq)))
 127                (make-compound-data first-compound
 128                                    (apply #'fastmap type fcn args)))))))
 129
 130 (defun recursive-map-elements (base-fcn fcn &rest args)
 131 "Args: (base-fcn fcn &rest args)
 132 The same idea as MAP-ELEMENTS, except arguments are in a list and the
 133 base and recursive cases can use different functions. Modified to check
 134 for second level of compounding and use base-fcn if there is none."
 135   (let ((first-compound (find-compound-data args)))
 136     (cond ((null first-compound) (apply base-fcn args))
 137           (t (fixup-map-elements-arglist args)
 138              (let* ((seq (compound-data-sequence first-compound))
 139                     (type (sequence-type seq))
 140                     (f (if (any-compound-elements seq) fcn base-fcn)))
 141                (make-compound-data first-compound
 142                                    (apply #'fastmap type f args)))))))
 143
 144
 145 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 146 ;;;;
 147 ;;;;             Public Predicate and Accessor Functions
 148 ;;;;
 149 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 150
 151 ;;; COMPOUND-DATA-P function
 152 (defun compound-data-p (x)
 153 "Args: (x)
 154 Returns T if X is a compound data item, NIL otherwise."
 155   (cmpndp x))
 156
 157 ;;; COMPOUND-DATA-SEQ function
 158 (defun compound-data-seq (x)
 159 "Args (x)
 160 Returns data sequence in X."
 161   (check-compound x)
 162   (compound-data-sequence x))
 163
 164 ;;; COMPOUND-DATA-LENGTH function
 165 (defun compound-data-length (x)
 166 "Args (x)
 167 Returns length of data sequence in X."
 168   (check-compound x)
 169   (length (compound-data-sequence x)))
 170
 171 ;;; ELEMENT-SEQ function
 172 (defun element-list (x)
 173   (cond
 174    ((compound-data-p x)
 175     (let ((x (concatenate 'list (compound-data-seq x)))) ; copies sequence
 176       (cond
 177        ((any-compound-elements x)
 178         (do ((next x (rest next)))
 179             ((not (consp next)))
 180           (setf (first next) (element-list (first next))))
 181         (do ((result (first x))
 182              (last (last (first x)))
 183              (next (rest x) (rest next)))
 184             ((not (consp next)) result)
 185           (setf (rest last) (first next))
 186           (setf last (last (first next)))))
 187        (t x))))
 188    (t (list x))))
 189
 190 (defun element-seq (x)
 191 "Args: (x)
 192 Returns sequence of the elements of compound item X."
 193   (check-compound x)
 194   (let ((seq (compound-data-seq x)))
 195     (if (any-compound-elements seq) (element-list seq) seq)))
 196
 197 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 198 ;;;;
 199 ;;;;                     Compound Data Objects
 200 ;;;;
 201 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 202
 203 (defproto compound-data-proto)
 204
 205 (defmeth compound-data-proto :data-length (&rest args) nil)
 206 (defmeth compound-data-proto :data-seq (&rest args) nil)
 207 (defmeth compound-data-proto :make-data (&rest args) nil)
 208 (defmeth compound-data-proto :select-data (&rest args) nil)
 209
 210 (defun compound-object-p (x) (kind-of-p x compound-data-proto))