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