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