functions.lisp 11.8 KB
Newer Older
1
2
;; Functions on grids
;; Liam Healy 2010-06-19 22:25:17EDT functions.lisp
3
;; Time-stamp: <2013-11-23 09:44:34EST functions.lisp>
Liam M. Healy's avatar
Liam M. Healy committed
4

Liam M. Healy's avatar
Liam M. Healy committed
5
;; Copyright 2010, 2011, 2012, 2013 Liam M. Healy
Liam M. Healy's avatar
Liam M. Healy committed
6
7
8
9
10
11
12
13
14
15
16
17
18
19
;; Distributed under the terms of the GNU General Public License
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
20
21
22

(in-package :grid)

23
(export '(*grid-types* gridp grid rank dimensions total-size
Liam M. Healy's avatar
Liam M. Healy committed
24
	  specification make-grid aref aref* contents))
25
26
(export '(make-simple-grid grid *default-grid-type*
	  *default-element-type* *default-dimensions*))
Liam M. Healy's avatar
Liam M. Healy committed
27
28
29
30
31

;;;;****************************************************************************
;;;; Grid type
;;;;****************************************************************************

Liam M. Healy's avatar
Liam M. Healy committed
32
33
34
(defparameter *grid-types* '(array)
  "A list of (disjoint) types that are accepted as grids.  Not every
  object of the given type is necessarily a grid, however.")
Liam M. Healy's avatar
Liam M. Healy committed
35

Liam M. Healy's avatar
Liam M. Healy committed
36
37
38
(defvar *additional-gridp-test* nil
  "NIL or a function of one argument, that will determine if that object is a grid.")

Liam M. Healy's avatar
Liam M. Healy committed
39
40
(defun gridp (object)
  "Object is a grid; type is returned."
Liam M. Healy's avatar
Liam M. Healy committed
41
42
  (or (find-if (lambda (type) (typep object type)) *grid-types*)
      (when *additional-gridp-test* (funcall *additional-gridp-test* object))))
43

44
45
(deftype grid () '(satisfies gridp))

46
47
48
49
;;;;****************************************************************************
;;;; Properties of the grid
;;;;****************************************************************************

50
(defgeneric rank (grid)
51
52
53
  (:documentation "The rank (number of dimensions) of the generalized array."))

(defgeneric dimensions (grid)
54
55
  (:documentation "A list representing the dimensions of the generalized array.")
  (:method ((object list))
56
57
58
59
60
    (if object
	(cons (length object)
	      (when (listp (first object))
		(dimensions (first object))))
	(list 0))))
61

Liam Healy's avatar
Liam Healy committed
62
63
64
65
(defgeneric total-size (grid)
  (:method ((grid t))
    (total-size-from-dimension (dimensions grid))))

66
67
68
(defgeneric specification (grid)
  (:documentation "The grid specification.")
  (:method ((grid t))
69
70
    (unless (gridp grid)
      (error "No specification for a non-grid ~a." grid))
71
    (cons
Liam M. Healy's avatar
Liam M. Healy committed
72
     (cons (gridp grid) (dimensions grid))
73
74
75
76
77
     (list (element-type grid)))))

(defgeneric affi (grid)
  (:documentation "The grid's affi."))

78
79
80
81
82
83
84
85
86
(defgeneric element-type (grid)
  (:documentation "The element type of the grid.")
  (:method ((grid list))
    ;; Generally lists don't have a type, so we'll go on the type of the first atom.
    ;; This may be not what we want, however; SBCL gives (type-of 1) -> BIT.
    (if (atom (first grid))
	(type-of (first grid))
	(element-type (first grid)))))

Liam M. Healy's avatar
Liam M. Healy committed
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
;;;;****************************************************************************
;;;; Simple grid
;;;;****************************************************************************

;;; A simple grid is one that has only one layer with a specified element type.
;;; Both 'array and 'foreign-array are simple grids.

(defparameter *default-grid-type* 'array)
(defparameter *default-element-type* 'double-float)
(defparameter *default-dimensions* '(3))

(defun make-simple-grid
    (&rest args
     &key (grid-type *default-grid-type*)
     (dimensions *default-dimensions*)
     (element-type *default-element-type*)
     (initial-element (coerce-value *default-numerical-value* element-type))
     initial-contents)
  (declare (ignorable initial-element initial-contents))
106
  "Make a simple grid by specfying the grid-type (default *default-grid-type*), dimensions (*default-dimensions*), element-type (*default-element-type*), and optionally initial-element or initial-contents."
Liam M. Healy's avatar
Liam M. Healy committed
107
108
109
110
111
  (apply
   'make-grid
   (make-specification grid-type dimensions element-type)
   (alexandria:remove-from-plist args :grid-type :dimensions :element-type)))

112
113
114
115
116
;;; Make simple grid from contents
(defun grid (&rest args)
  "Make the simple grid with default properties and elements as specified in args."
  (make-simple-grid :initial-contents args))

117
118
119
120
121
;;;;****************************************************************************
;;;; Make grid
;;;;****************************************************************************

(defun make-grid
122
123
    (specification &rest keys &key
     (initial-contents nil initial-contents-p)
124
     (initial-element nil)
Liam M. Healy's avatar
Liam M. Healy committed
125
     &allow-other-keys)
126
  "Make a grid object with no or literal values specified.
127
128
129
130
131
   The specification is of the form
   ((component-type dimensions...) ... element-type)
   If initial-contents are specified, the dimensions may be
   omitted, 
   ((component-type) ... element-type)."
132
  (declare (ignore initial-element))
Liam M. Healy's avatar
Liam M. Healy committed
133
  (when initial-contents-p (check-initial-contents initial-contents))
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
  (let ((spec
	 (if initial-contents
	     ;; If initial-contents are given, then its dimensions
	     ;; override what's given in the specification
	     (let ((spec (copy-tree specification)))
	       (setf (specification-dimensions spec) (dimensions initial-contents))
	       spec)
	     specification)))
    (when (find-if 'zerop (specification-dimensions spec))
      (error "Making grid with zero total dimension."))
    (apply 'make-grid-data
	   (top-spec-type spec)
	   (top-spec-dimensions spec)
	   (rest spec)
	   keys)))
149

Liam M. Healy's avatar
Liam M. Healy committed
150
151
152
(defun check-initial-contents (ic)
  (unless ic (error "Initial-contents specified as NIL.")))

153
154
155
156
157
158
(defgeneric make-grid-data
    (type dimensions rest-spec &rest keys &key &allow-other-keys)
  (:documentation
   "Make the object(s) required for storage of the data,
    if it consists of CL arrays and lists."))

159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
;;;;****************************************************************************
;;;; Reader macro #m
;;;;****************************************************************************

;;; The reader macro #m will read a list of arguments, evaluating the
;;; contents, and construct a grid from it.  If the symbol ^
;;; occurs in the list, it indicates the object being made is a
;;; matrix, and this symbol indicates the end of each row.  It is also
;;; possible to give a list of numeric values may be given for each
;;; row also.

(defparameter *hashm-numeric-code-alist*
  '((nil . double-float)
    (1 . double-float)
    (2 . (complex double-float))
    (3 . single-float)
    (4 . (complex single-float))
    (7 . (signed-byte 8))
    (8 . (unsigned-byte 8))
    (15 . (signed-byte 16))
    (16 . (unsigned-byte 16))
    (31 . (signed-byte 32))
    (32 . (unsigned-byte 32))
    (63 . (signed-byte 64))
    (64 . (unsigned-byte 64))))

(defun hashm-eltype (n)
  "Get the appropriate element type for the numeric code n"
  (rest (assoc (if (numberp n) (mod n 100) n) *hashm-numeric-code-alist*)))

(defun hashm-numeric-code (eltype)
  "Get the appropriate element type for the numeric code n"
  (first (rassoc eltype *hashm-numeric-code-alist* :test 'equal)))

(defparameter *hashm-grid-type-alist*
  nil)

(defun hashm-grid-type (n)
  (or (and (numberp n)
	   (rest (assoc (floor n 100) *hashm-grid-type-alist*)))
      *default-grid-type*))

(defvar *row-separator* '^)
(export *row-separator*)

;;; Use #m to make the foreign-array
(set-dispatch-macro-character
 #\# #\m
 (lambda (stream subchar arg)
   (declare (ignore subchar))
   (read-char stream)
   (let ((list (read-delimited-list #\) stream)))
211
212
213
214
215
216
217
218
219
220
     (unless *read-suppress*
       (check-initial-contents list)
       (make-grid
	;; Specification without dimensions, they will be filled in
	;; with initial-contents in make-grid.
	`((,(hashm-grid-type arg)) ,(hashm-eltype arg))
	:initial-contents
	(if (find *row-separator* list)
	    (split-sequence:split-sequence *row-separator* list)
	    list))))))
221
222


Liam M. Healy's avatar
Liam M. Healy committed
223
224
225
226
227
228
;;;;****************************************************************************
;;;; Simple math functions
;;;;****************************************************************************

(defmethod antik:zerop ((grid array))
  (loop for ind from 0 below (total-size grid)
Liam M. Healy's avatar
Liam M. Healy committed
229
	always (antik:zerop (aref* grid ind))))
Liam M. Healy's avatar
Liam M. Healy committed
230

231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
(defmethod antik::+i ((a sequence) b)		; b is a scalar
  (if (gridp b)
      (call-next-method)
      (map (type-of a) (lambda (x) (antik::+i x b)) a)))

(defmethod antik::+i (a (b sequence))		; a is a scalar
  (if (gridp a)
      (call-next-method)
      (map (type-of b) (lambda (x) (antik::+i a x)) b)))

(defmethod antik::-i ((a sequence) b)		; b is a scalar
  (if (gridp b)
      (call-next-method)
      (map (type-of a) (lambda (x) (antik::-i x b)) a)))

(defmethod antik::-i (a (b sequence))		; a is a scalar
  (if (null b)
      (antik::*i -1 a)
      (if (gridp a)
	  (call-next-method)
	  (map (type-of b) (lambda (x) (antik::-i a x)) b))))

  ;; Scalar multiplication of sequences
(defmethod antik::*i ((a sequence) b)		; b is a scalar
  (if (gridp b)
      (call-next-method)
      (map (type-of a) (lambda (x) (antik::*i x b)) a)))

(defmethod antik::*i (a (b sequence))		; a is a scalar
  (if (null b)
      a				      ; null second arg - return first
      (if (gridp a)
	  (call-next-method)
	  (map (type-of b) (lambda (x) (antik::*i a x)) b))))

;; Scalar division of sequences
(defmethod antik::/i ((a sequence) b)
  (if (gridp b)
      (call-next-method)
      (map (type-of a) (lambda (x) (antik::/i x b)) a)))

(defmethod antik::/i (a (b sequence))
  (if (gridp a)
      (call-next-method)
      (map (type-of b) (lambda (x) (antik::/i a x)) b)))

277
278
279
280
;;;;****************************************************************************
;;;; Element reference
;;;;****************************************************************************

Liam M. Healy's avatar
Liam M. Healy committed
281
(defgeneric aref (grid &rest indices)
282
283
  (:documentation "Select the element from the grid."))

Liam M. Healy's avatar
Liam M. Healy committed
284
(defgeneric (setf aref) (value grid &rest indices)
285
286
  (:documentation "Set the element from the grid."))

Liam M. Healy's avatar
Liam M. Healy committed
287
(defgeneric aref* (grid linearized-index)
288
289
290
291
292
  (:documentation "Select the element from the grid using a linearized index.")
  ;; Check the type for debugging purposes; it can be removed for production.
  (:method :before (grid linearized-index)
	   (check-type linearized-index (integer 0))))

Liam M. Healy's avatar
Liam M. Healy committed
293
(defgeneric (setf aref*) (value grid linearized-index)
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
  (:documentation "Set the element from the grid using a linearized index.")
  ;; Check the type for debugging purposes; it can be removed for production.
  (:method :before (value grid linearized-index)
	   (check-type linearized-index (integer 0))))

(defun listify (function dimensions)
  "Make the dimension list."
  (declare (type function function))
  (if dimensions
      (loop for i from 0 below (first dimensions)
	 collect (listify (alexandria:curry function i) (rest dimensions)))
      (funcall function)))

(defun contents (grid)
  "The contents of the grid as nested lists.  This can
   be used as the :initial-contents argument in making
   a new grid."
Liam M. Healy's avatar
Liam M. Healy committed
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
  (listify (alexandria:curry 'aref grid) (dimensions grid)))

;;;;****************************************************************************
;;;; Compatibility
;;;;****************************************************************************

;;; The predecessor system to Antik had array element access through
;;; the functions gref and gref*.  These are provided here for
;;; compatibility.

(export '(gref gref*))

(defun gref (grid &rest indices)
  "Obsolete; use grid:aref."
  (apply #'aref grid indices))

(defun gref* (grid linearized-index)
  "Obsolete; use grid:aref*."
  (aref* grid linearized-index))

(defun (setf gref) (value grid &rest indices)
  "Obsolete; use grid:aref."
  (apply #'(setf aref) value grid indices))

(defun (setf gref*) (value grid linearized-index)
  "Obsolete; use grid:aref*."
  (funcall #'(setf aref*) value grid linearized-index))