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