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
8 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
16 (defpackage :lisp-stat-compound-data
18 :lisp-stat-object-system
)
19 (:import-from
:lisp-stat-fastmap
21 (:shadowing-import-from
:lisp-stat-object-system
26 (in-package :lisp-stat-compound-data
)
28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;;; Internal Support Functions
32 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
34 ;;; Predicate to determine if argument is compound. Most common
35 ;;; 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
))))
42 ;;; Returns first compound data item in LIST or NIL if there is none.
43 (defun find-compound-data (list)
44 (dolist (x list
) (if (cmpndp x
) (return x
))))
46 ;;; Checks for a compound element
47 (defun any-compound-elements (seq)
48 (cond ((consp seq
) (dolist (x seq
) (if (cmpndp x
) (return x
))))
50 (let ((n (length seq
)))
54 (let ((x (aref seq i
)))
55 (if (cmpndp x
) (return x
))))))
56 (t (error "argument must be a list or vector"))))
59 ;;; Returns sequence of data values for X.
60 (defun compound-data-sequence (x)
61 (declare (inline consp vectorp arrayp make-array array-total-size
))
63 ((or (consp x
) (vectorp x
)) x
)
64 ((arrayp x
) (make-array (array-total-size x
) :displaced-to x
))
65 (t (send x
:data-seq
))))
67 (defmacro sequence-type
(x) `(if (consp ,x
) 'list
'vector
))
69 ;;;; Construct a compound data item to match the shape of the first argument.
70 (defun make-compound-data (shape sequence
)
71 (let ((n (length (compound-data-sequence shape
))))
72 (if (/= n
(length sequence
)) (error "compound data not the same shape"))
74 ((consp shape
) (if (consp sequence
) sequence
(coerce sequence
'list
)))
76 (if (vectorp sequence
) sequence
(coerce sequence
'vector
)))
78 (make-array (array-dimensions shape
)
79 :displaced-to
(coerce sequence
'vector
)))
80 (t (send shape
:make-data sequence
)))))
82 ;;; Make a circular list of one element
83 (defun make-circle (x)
84 (declare (inline cons rplacd
))
85 (let ((x (cons x nil
)))
89 ;;; Signals an error if X is not compound
90 (defun check-compound (x)
91 (if (not (cmpndp x
)) (error "not a compound data item - ~a" x
)))
93 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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.
103 ;;; This implementation uses FASTMAP, a version of MAP that is assumed
106 ;;; a) work reasonable fast on any combination of lists and vectors
109 ;;; b) not hang if at least one of its arguments is not a circular
112 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
114 (defun fixup-map-elements-arglist (args)
115 (do* ((args args
(rest args
))
116 (x (car args
) (car args
)))
118 (declare (inline car
))
120 (if (cmpndp x
) (compound-data-sequence x
) (make-circle x
)))))
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
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
)))))))
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
)))))))
152 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
154 ;;;; Public Predicate and Accessor Functions
156 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
158 ;;; COMPOUND-DATA-P function
159 (defun compound-data-p (x)
161 Returns T if X is a compound data item, NIL otherwise."
164 ;;; COMPOUND-DATA-SEQ function
165 (defun compound-data-seq (x)
167 Returns data sequence in X."
169 (compound-data-sequence x
))
171 ;;; COMPOUND-DATA-LENGTH function
172 (defun compound-data-length (x)
174 Returns length of data sequence in X."
176 (length (compound-data-sequence x
)))
178 ;;; ELEMENT-SEQ function
179 (defun element-list (x)
182 (let ((x (concatenate 'list
(compound-data-seq x
)))) ; copies sequence
184 ((any-compound-elements x
)
185 (do ((next x
(rest next
)))
187 (setf (first next
) (element-list (first next
))))
188 (do ((result (first x
))
189 (last (last (first x
)))
190 (next (rest x
) (rest next
)))
191 ((not (consp next
)) result
)
192 (setf (rest last
) (first next
))
193 (setf last
(last (first next
)))))
197 (defun element-seq (x)
199 Returns sequence of the elements of compound item X."
201 (let ((seq (compound-data-seq x
)))
202 (if (any-compound-elements seq
) (element-list seq
) seq
)))
204 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
206 ;;;; Compound Data Objects
208 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
210 (defproto compound-data-proto
)
212 (defmeth compound-data-proto
:data-length
(&rest args
) nil
)
213 (defmeth compound-data-proto
:data-seq
(&rest args
) nil
)
214 (defmeth compound-data-proto
:make-data
(&rest args
) nil
)
215 (defmeth compound-data-proto
:select-data
(&rest args
) nil
)
217 (defun compound-object-p (x) (kind-of-p x compound-data-proto
))