Documentation organization
[CommonLispStat.git] / compound.lsp
blob5f6626f44a725761aee4ce661652165727633e84
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.
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 ;;;;
12 ;;;;
13 ;;;; Package Setup
14 ;;;;
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
27 compound-data-seq compound-data-length
28 element-list element-seq
30 sort-data order rank
32 ;; export sequence-related functionality
34 ;; export matrix-related functionality (not sure??)
37 (in-package :lisp-stat-compound-data)
39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
40 ;;;
41 ;;; Internal Support Functions
42 ;;;
43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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))))
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))))
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"))))
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))))
77 (defmacro sequence-type (x) `(if (consp ,x) 'list 'vector))
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)))))
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))
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)))
104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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.
114 ;;; This implementation uses FASTMAP, a version of MAP that is assumed
115 ;;; to
117 ;;; a) work reasonable fast on any combination of lists and vectors
118 ;;; as its arguments
120 ;;; b) not hang if at least one of its arguments is not a circular
121 ;;; list.
123 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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)))))
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)))))))
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)))))))
163 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
164 ;;;;
165 ;;;; Public Predicate and Accessor Functions
166 ;;;;
167 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
169 (defun compound-data-p (x)
170 "Args: (x)
171 Returns T if X is a compound data item, NIL otherwise."
172 (cmpndp x))
174 (defun compound-data-seq (x)
175 "Args (x)
176 Returns data sequence in X."
177 (check-compound x)
178 (compound-data-sequence x))
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)))
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))))
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)))
211 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
212 ;;;;
213 ;;;; Compound Data Objects
214 ;;;;
215 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
217 (defproto compound-data-proto)
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)
224 (defun compound-object-p (x) (kind-of-p x compound-data-proto))
228 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
229 ;;;;
230 ;;;; Sorting Functions
231 ;;;;
232 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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)))
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)))))
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)))