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