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