physical-quantities.lisp 13 KB
Newer Older
1
2
;; Objects that represent physical measurements.                             
;; Liam Healy Wed Mar  6 2002 - 09:04
3
;; Time-stamp: <2013-11-23 09:50:54EST physical-quantities.lisp>
4

5
;; Copyright 2011, 2012, 2013 Liam M. Healy
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
;; 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/>.

(in-package :antik)

23
(export '(pqval check-dimension with-pq))
24

25
26
27
28
29
30
31
32
33
34
;;;;****************************************************************************
;;;; Parsing unit names
;;;;****************************************************************************

;;; (parse-units "m-kg^2/s^2")
;;; (parse-units 'm-kg^2/s^2)
;;; (parse-units '(/ (* M KG KG) (* S S)))
;;; All return
;;; (1 -2 2 0 0 0 0 0 0)
;;; 1.0
35
36
37
(defun parse-units (unit-expression)
  "Find the dimel representation of the dimensions from a string, symbol, or unit sexp."
  (parse-unit-sexp (find-unit-expr (parse-pq-string unit-expression))))
38
39
40
41
42
43
44

;;; (parse-pq-string "m-kg^2/s^2")
;;; (/ (* M KG KG) (* S S))
(defun parse-pq-string (string)
  "Parse a string or symbol specifying units into lists."
  (if (listp string)
      string
liam's avatar
liam committed
45
46
47
      (flet ((symbolize (str)
	       (when (plusp (length str))
		 ;; Empty strings become nil, e.g. "/m" is (/ nil meter)
48
		 (antik-symbol str))))
49
50
51
52
	(flet ((lexprod (s)
		 (let ((trms
			(mapcan
			 (lambda (x)
53
			   (let ((prod (split-sequence:split-sequence #\^ x)))
54
55
56
57
58
			     (if (single prod)
				 (list (symbolize (first prod)))
				 (make-list
				  (parse-integer (second prod))
				  :initial-element (symbolize (first prod))))))
59
			 (split-sequence:split-sequence-if
60
61
62
63
64
			  (lambda (x) (member x '(#\- #\*)))
			  s))))
		   (if (single trms) (first trms) (cons '* trms)))))
	  (let ((str (if (symbolp string) (symbol-name string) string)))
	    (destructuring-bind (num &optional den)
65
		(split-sequence:split-sequence #\/ str)
66
67
68
	      (if den
		  (list '/ (lexprod num) (lexprod den))
		  ;; / with no numerator is reciprocal
Liam M. Healy's avatar
Liam M. Healy committed
69
		  (if (eq (cl:aref str 0) #\/)
70
71
72
		      (list '/ (lexprod num))
		      (lexprod num)))))))))

73
74
75
76
77
78
79
(defun check-dimension-or-type (object type)
  "Return T if the object is of the type specified, and, if a physical-quantity, is of the physical-dimension specified in type."
  (or (if (and (typep object 'physical-quantity)
	       (ignore-errors (antik::parse-unit-sexp type)))
	  (check-dimension object type nil))
      (typep object type)))

80
81
(setf *parameter-check-function* 'check-dimension-or-type)

82
83
(defun check-dimension
    (obj units
84
     &optional (errorp t) (zeros-have-any-dimension *zero-is-dimensionless*))
85
  "T if one of these cases hold:
86
    - obj is a pdq and units have the same dimension as obj,
87
    - obj is zero and zeros-have-any-dimension is T,
88
    - obj and units represent a dimensionless quantity,
89
    - obj and units are grids of the same length, and for 
90
      each pair of corresponding elements, one of the above is true."
91
92
93
  (if (physical-quantity-p obj)
      (if (and obj (grid:gridp obj) (not (scalar-dimension obj)))
	  (loop for i from 0 below (grid:total-size obj)
Liam M. Healy's avatar
Liam M. Healy committed
94
		always (equal-dimension (grid:aref* obj i) (grid:aref* obj i)))
95
96
	  (equal-dimension obj (parse-units units) errorp zeros-have-any-dimension t))
      (eq units 'dimensionless)))
97
98
99
100

(defun equal-dimension
    (x y
     &optional
101
102
103
       (errorp t)
       (zeros-have-any-dimension *zero-is-dimensionless*)
       match-dimensionless)
104
  "If the pdq are equal physical dimension, return that dimel.
105
106
   If one quantity is zero and zeros-have-any-dimension, return the
   dimel of the other and disregard whether they're the same physical
107
   dimension.  If y represents a dimensionless quantity,
108
109
110
111
112
113
114
115
   and match-dimensionless is true, return the dimel of x.
   Return two values: the dimel and whether it is scalar dimension."
  (cond ((and zeros-have-any-dimension (zerop x))
	 (values (dimel-or-not y) (scalar-dimension y)))
	((and zeros-have-any-dimension (zerop y))
	 (values (dimel-or-not x) (scalar-dimension x)))
	((equalp (dimel-or-not x) (dimel-or-not y))
	 (values (dimel-or-not x) (scalar-dimension x)))
116
117
118
	;; If one or both has scalar units, break out the individual dimensions.
	((and (grid:gridp x) (grid:gridp y)
	      (or (not (scalar-dimension y)) (not (scalar-dimension x))))
119
120
	 ;; All same units, possibly one has scalar dimension
	 (all-same		       ; repurposing 2nd return value 
121
122
123
124
125
	  (concatenate
	   'list
	   (if (scalar-dimension x) (list (pq-dimension x)) (pq-dimension x))
	   (if (scalar-dimension y) (list (pq-dimension y)) (pq-dimension y)))
	  :test #'cl:equal))
126
127
128
129
130
131
	((and match-dimensionless (equal (dimel-or-not y) (dimel-or-not nil)))
	 (dimel-or-not x))
	(errorp (error "The quantities ~a and ~a are not both physical ~
               quantities with the same physical dimension." x y))))

(defun dimel-or-not (object)
132
  "Find the dimel for this object (a physical dimension quantity or a dimel), or
133
   return the dimensionless dimel."
134
135
  (cond ((physical-quantity-p object)
	 (values (pq-dimension object) (scalar-dimension object)))
136
137
	((dimelp object) object)
	(t (dimension 'dimensionless))))
138

139
140
141
142
143
144
145
146
147
148
(defun equal-dimensions
    (list &optional (zero-is-dimensionless *zero-is-dimensionless*))
  "If all elements of the list have the same physical dimension, return that dimel."
  (let* ((flist (alexandria:flatten list))
	 (short-list (if zero-is-dimensionless (remove-if #'zerop flist) flist)))
    (all-same
     short-list
     :test (alexandria:rcurry #'equal-dimension nil)
     :post-function #'dimel-or-not)))

healy's avatar
healy committed
149
150
151
152
;;;;****************************************************************************
;;;; Extracting values and printing
;;;;****************************************************************************

153
(defmethod nf
154
    ((pq physical-quantity) &optional (stream *standard-output*))
155
156
  (if (and (grid:gridp pq)		
	   (not (and (typep pq 'physical-quantity) (scalar-dimension pq))))
157
      ;; If a grid that is either not a pdq or is a pdq with non-scalar
158
159
      ;; dimensions, call the T method of nf, so that it will call
      ;; nf-grid.
Liam M. Healy's avatar
Liam M. Healy committed
160
161
      (call-next-method)
      (multiple-value-bind (val units)
162
	  (pqval pq)
163
	(if (and (nf-option :time)
Liam M. Healy's avatar
Liam M. Healy committed
164
165
166
		 (not (grid:gridp (pq-magnitude pq)))
		 (check-dimension pq 'time nil nil))
	    (progn
167
	      (unless texstyle (when (nf-readably) (princ "#d" stream)))
168
	      (princn (iso8601-time-interval pq (nf-option :time))
Liam M. Healy's avatar
Liam M. Healy committed
169
		      stream))
170
	    (if (nf-option :system-of-units)
171
172
		(format-units val units (scalar-dimension pq) stream)
		(nf val stream))))))	; format the number only
173

174
(defmethod print-object ((pq physical-quantity) stream)
175
176
177
178
179
180
181
182
183
184
185
186
187
188
  "Print the physical-quantity using nf."
  #+debug
  (print-unreadable-object (pq stream)
    (format stream "Physical dimension quantity [debug] mag ~a"
	    (pq-magnitude pq)))
  #-debug
  (let ((dim (pq-dimension pq)))
    (if (or (null (nf-option :system-of-units))
	    (and dim (arrayp dim) (null (row-major-aref dim 0))))
	;; units not set yet
	(print-unreadable-object (pq stream)
	  (format stream "Physical dimension quantity mag ~a, dimensions ~a"
		  (pq-magnitude pq)
		  (when dim
189
190
		    (with-system-of-units
			(basis-physical-dimensions)
191
192
		      (make-unit-sexp dim t)))))
	(cl-readable-nf (nf pq stream)))))
healy's avatar
healy committed
193

194
(defgeneric pqval (pq)
195
  (:documentation
196
   "Get the numerical value and the units of the physical dimension quantity.  Returns the magnitude, the units, and whether units are the same for each element of a sequence or grid.")
197
  (:method (pq)
198
    (values pq nil nil)))
199

200
(defmethod pqval ((pq physical-quantity))
201
202
  (if (scalar-dimension pq)
      (let ((units (make-unit-sexp (pq-dimension pq) t)))
Liam M. Healy's avatar
Liam M. Healy committed
203
	(values
204
205
	 (antik:/ (pq-magnitude pq) (nth-value 1 (parse-unit-sexp units)))
	 units
206
207
208
209
210
211
212
213
214
215
	 t))
      (values
       (grid:map-grid
	:source pq
	:destination-specification (grid:specification (pq-magnitude pq))
	:element-function 'pqval)
       (grid:map-grid
	:source (pq-dimension pq)
	:destination-specification (grid:specification (pq-dimension pq))
	:element-function (alexandria:rcurry 'make-unit-sexp t)))))
216

217
218
219
220
(defparameter *pqval-allsame-sequence-collapse* t
  "If a sequence passed to pqval has all the same units,
   collapse to one unit specification.")

221
(defmethod pqval ((pq sequence))
222
223
224
225
226
  (let ((mat
	 (transpose-list
	  (map 'list
	       (lambda (x)
		 (multiple-value-list
227
		  (pqval x)))
228
229
	       pq))))
    (multiple-value-bind (allsame-val allsame-same)
230
	(all-same (second mat) :test #'equal) ; all same units
231
232
233
234
235
      (let* ((allsame-nz
	      ;; all non-zero quantities have the same units
	      (when (and *pqval-allsame-sequence-collapse*
			 (not allsame-same)
			 *zero-is-dimensionless*)
236
		;; Check again if zeros are gone
237
		(let ((removed-zeros (remove-if 'zerop pq)))
238
239
		  (when (< (length removed-zeros) (length pq))
		    (multiple-value-bind (ignore units asnz)
240
			(pqval removed-zeros)
241
242
		      (declare (ignore ignore))
		      (when asnz units))))))
243
244
245
246
247
248
249
250
251
	     (as (and *pqval-allsame-sequence-collapse*
		      (or allsame-same allsame-nz))))
	(values
	 (if (vectorp pq) (coerce (first mat) 'vector) (first mat))
	 ;; If all units are the same, return them, else return a list of units.
	 (if as
	     (if allsame-same allsame-val allsame-nz)
	     (second mat))
	 as)))))
252

253
(defun pqval-seq (pq)
254
  (let ((*pqval-allsame-sequence-collapse* nil))
255
    (pqval pq)))
256

257
258
259
260
;;;;****************************************************************************
;;;; Interface
;;;;****************************************************************************

261
262
263
264
265
266
267
268
269
270
271
272
273
(defun format-units (value units &optional scalar-dimension (stream *standard-output*))
  "Format the pieces of the physical dimension quantity.  If formatting of
   unit alone is desired, value should be nil."
  (when units
    (if texstyle
	(if (and value (grid:gridp value))
	    (progn
	      (nf value stream)
	      (format-units nil units scalar-dimension stream))
	    (if (and (listp units) (member (first units) '(/ cl:/)))
		(format
		 stream "\\unitfrac~@[[~a]~]{~a}{~a}"
		 (when value (nf-string value))
274
275
276
		 (make-pq-string (second units) (nf-option :style))
		 (make-pq-string (third units) (nf-option :style)))
		(if (and (eq (nf-option :degrees) :dms) (eq units 'degree))
277
278
279
280
281
		    (format-dms value stream)
		    (format
		     stream
		     (if (eq units 'degree) "~@[~a~]~a" "\\unit~@[[~a]~]{~a}")
		     (when value (nf-string value))
282
		     (make-pq-string units (nf-option :style))))))
283
284
	;; Plain style
	(if scalar-dimension
285
		(if (and (eq (nf-option :degrees) :dms) (eq units 'degree))
286
287
288
289
290
291
292
293
294
295
296
297
298
		(format-dms value stream)
		(format stream
			(if (nf-readably) "~@[#_~a_~]~a" "~@[~a~]~a")
			(when value (nf-string value))
			(make-pq-string units)))
	    ;; iterate over the grid
	    (loop for i from 0 below (grid:total-size value)
		  do
		     (format stream
			     (if (nf-readably) "~@[#_~a_~]~a" "~@[~a~]~a")
			     (when value (nf-string (grid:aref value i)))
			     (make-pq-string (grid:aref units i))))))))

299
(defmacro with-pq (physical-quantities &body body)
300
  "Ensure that the named physical dimension quantities are of the right dimensions, or convert them from plain numbers using the current system of units as specified by (nf-option :system-of-units)."
301
302
  ;; should I have the option to return plain numbers
  ;; in some system of units as well?
303
304
  `(let ,(mapcar
	  ;; check that value is non-nil before make-pq
305
	  (lambda (vu)
306
	    (destructuring-bind (v u) vu `(,v (and ,v (make-pq ,v ',u)))))
307
308
309
	  physical-quantities)
     ,@body))

310
(defun read-pq-from-string (string units)
311
  "Read the next number and interpret as a pdq, if units is non-nil.
312
313
314
315
316
317
318
   The special 'pointer gives the starting location to read
   and is updated after the read." 
  (declare (special pointer))
  (multiple-value-bind (mag ptr)
      (read-from-string
       string nil nil :start (if (boundp 'pointer) pointer 0))
    (setf pointer ptr)
319
    (if units (make-pq mag units) mag)))
320

321
322
323
(defun scalar-units-p (units)
  (ignore-errors (parse-units units)))

324
;;; Use #_ for physical dimension quantities, e.g. #_90_degree
325
326
327
328
(set-dispatch-macro-character
 #\# #\_
 (lambda (stream subchar arg)
   (declare (ignore subchar arg))
329
330
331
332
333
   (let ((*zero-is-dimensionless* nil)
	 numerical-value units)
     ;; Tell the reader to read the things
     (setf numerical-value (stream-to-string stream :terminator #\_)
	   units (read stream t nil t))
334
     ;; Make the PDQ if reading is not suppressed
335
336
337
     (unless *read-suppress*
       (make-pq
	(read-from-string numerical-value)
338
	units
339
	(scalar-units-p units))))))
340

341
(defmethod creation-form ((pq physical-quantity))
342
 (creation-form-readably
343
   pq
344
   `(let ((*zero-is-dimensionless* nil))
345
346
      (make-pq-object
       ,(creation-form (pq-magnitude pq))
347
       ,(creation-form (pq-dimension pq))
348
       ,(scalar-dimension pq)))))
349

350
(def-make-load-form physical-quantity)