Commit 1b3c3543 authored by Liam M. Healy's avatar Liam M. Healy
Browse files

Add utility definitions, port more physical-quantities files

parent 3a0429e8
;; Antik system definition
;; Liam Healy 2010-12-24 09:43:28EST antik.asd
;; Time-stamp: <2010-12-24 19:17:56EST antik.asd>
;; Time-stamp: <2010-12-25 12:28:38EST antik.asd>
;; Copyright 2011 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -43,6 +43,8 @@
((:file "package")
(:file "conditions")
(:file "generic")
(:file "utility")
(:file "object")
(:file "iterate")))
(:module grid
:components
......@@ -91,10 +93,10 @@
:components
((:file "units")
(:file "unit-definitions" :depends-on ("units"))
#|
(:file "sysunit-definitions"
:depends-on ("units" "unit-definitions"))
(:file "physical-quantities" :depends-on ("units"))
#|
(:file "undimension" :depends-on ("physical-quantities"))
(:file "arithmetic" :depends-on ("units" "undimension"))
(:file "iso8601")
......
;; The specification of a grid
;; Liam Healy 2009-11-21 14:48:34EST specification.lisp
;; Time-stamp: <2010-07-05 22:27:45EDT specification.lisp>
;; Time-stamp: <2010-12-25 12:34:08EST specification.lisp>
;;
;; Copyright 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -35,7 +35,7 @@
(defun spec-scalar-p (specification)
"Specification is for a scalar; if so, return that type."
(when (not (rest specification))
(when (antik:single specification)
(first specification)))
(defun make-specification (type dimensions element-type)
......
;; Generic functions for generalized numbers
;; Liam Healy Tue Feb 9 1999 - 21:38
;; Time-stamp: <2010-12-24 13:31:20EST generic.lisp>
;; Time-stamp: <2010-12-25 12:33:35EST generic.lisp>
;; Copyright 2011 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -132,7 +132,7 @@
(defun - (&rest args)
"Subtraction of generalized or regular numbers."
(if (not (rest args)) (-i (first args) nil) (reduce #'-i args)))
(if (single args) (-i (first args) nil) (reduce #'-i args)))
(defgeneric *i (a b)
(:documentation "Multiplication of generalized or regular numbers.")
......@@ -159,7 +159,7 @@
(defun * (&rest args)
"Multiplication of generalized or regular numbers with an
arbitrary number of arguments."
(if (not (rest args)) (first args) (reduce #'*i args)))
(if (single args) (first args) (reduce #'*i args)))
(defgeneric /i (a b)
(:documentation "Division of generalized or regular numbers, internal.
......@@ -189,7 +189,7 @@
(defun / (&rest args)
"Division of generalized or regular numbers for an
arbitrary number of arguments."
(if (not (rest args)) (/i 1 (first args)) (reduce #'/i args)))
(if (single args) (/i 1 (first args)) (reduce #'/i args)))
;;; Put these into with-generalized numbers?
(defmacro incf (ref &optional (delta 1))
......
;; Object (re)creation.
;; Liam Healy Sat Feb 23 2002 - 17:35
;; Time-stamp: <2010-12-25 12:27:27EST object.lisp>
;; $Id: $
;; Copyright 2011 Liam M. Healy
;; 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)
(export '(readably creation-form-readably creation-form creation-form-stream
print-readably *use-readable-print-form* def-make-load-form
serialize-binding))
(defun readably ()
(or *print-readably* *print-escape*))
(defmacro creation-form-readably (object non-readably)
"If we are printing readably, then rely on printed form
to create the new object."
`(if (readably)
,object
,non-readably))
;;; creation-form generates a form that creates the object,
;;; much like make-load-form, but can be used on objects of built-in class.
(defgeneric creation-form (object)
(:documentation "A form that creates the object.")
(:method ((object t)) (make-load-form object))
(:method ((object symbol)) `',object)
(:method ((object number)) object)
(:method ((object string)) object)
(:method ((object vector))
(creation-form-readably
object
`(vector ,@(map 'list #'creation-form object))))
(:method ((object list))
(creation-form-readably
object
`(list ,@(mapcar #'creation-form object))))
(:method ((object hash-table))
`(let ((tbl (make-hash-table
:test ',(hash-table-test object)
:size ,(hash-table-size object)
:rehash-size ,(hash-table-rehash-size object)
:rehash-threshold ,(hash-table-rehash-threshold object))))
(setf ,@(let ((pairs (list 0)))
(maphash
(lambda (k v)
(nconc pairs (list `(gethash ',k tbl)
(creation-form v))))
object)
(rest pairs)))
tbl)))
(defmacro def-make-load-form (object-type)
"Defmethod the make-load-form assuming creation-form exists."
`(defmethod make-load-form ((object ,object-type) &optional env)
(declare (ignore env))
(let ((*print-escape* nil) (*print-readably* nil))
(creation-form object))))
(defun print-readably (object &optional (stream t))
"If the CL-defined specials are defined appropriately, print readably
and return T, otherwise, return NIL."
(when (and *read-eval* (readably))
(format stream "#.~s" (creation-form object))
t))
(defparameter *use-readable-print-form* t
"Use the readable print form in creation-form if available.")
(defmacro serialize-binding (symbol)
"Generate a form that when loaded will redefine the object
and bind the variable to it."
`'(defparameter ,symbol ,(creation-form (symbol-value symbol))))
;; Utility definitions
;; Liam Healy 2010-12-25 12:14:58EST utility.lisp
;; Time-stamp: <2010-12-25 12:47:45EST utility.lisp>
;; Copyright 2011 Liam M. Healy, Paul Graham
;; 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)
(export '(mkstr symb single all-same stream-to-string transpose-list))
(defun mkstr (&rest args) ; From "On Lisp", copied with permission
"Make a string out of the printed representations of the arguments." ; LMH
(with-output-to-string (s)
(dolist (a args) (princ a s))))
(defun symb (&rest args) ; From "On Lisp", copied with permission
"Make a symbol out of the printed representations of the arguments." ; LMH
(values (intern (apply #'mkstr args))))
(defun single (lst) ; From "On Lisp", copied with permission
"Test list for one element." ; LMH
(and (consp lst) (not (cdr lst))))
(defun all-same (list &key (test #'eql))
"If all elements are the same, that value and T are returned;
if not, nil and nil are returned."
(if (every (lambda (x) (funcall test (first list) x)) list)
(values (first list) t)
(values nil nil)))
(defun stream-to-string (stream &key terminator terminate-if)
"Fill a string with the contents of the stream. Stop when an EOF
is encountered, or when the terminating character :terminator,
which is discarded, is reached, or the function :terminate-if
is satisfied on the character, which is returned to the stream.
Only one of :terminator and :terminate-if should be specified."
;; Both terminator and terminate-if can be specified,
;; but the unread-char might not work right.
(with-output-to-string
(out)
(loop for ch = (read-char stream nil nil)
until (or (null ch)
(and terminator (eq ch terminator))
(and terminate-if (funcall terminate-if ch)))
do (write-char ch out)
finally
(when terminate-if (unread-char ch stream)))))
;; Someday grid:transpose should perform this function.
(defun transpose-list (lists)
(assert (and lists (listp lists)) (lists) "Argument must be a list of lists.")
(cond ((some #'null lists) '())
(t (cons (mapcar #'car lists)
(transpose-list (mapcar #'cdr lists))))))
;; Objects that represent physical measurements.
;; Liam Healy Wed Mar 6 2002 - 09:04
;; Time-stamp: <2010-12-03 13:13:18EST physical-quantities.lisp>
(in-package :num)
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(make-pq pqval check-dimension
new-units with-pq define-physical-constant)))
;; Time-stamp: <2010-12-25 12:31:31EST physical-quantities.lisp>
;; Copyright 2011 Liam M. Healy
;; 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)
(export '(make-pq pqval check-dimension
new-units with-pq define-physical-constant))
;;;;****************************************************************************
;;;; The object and making it
......@@ -24,7 +39,7 @@
"Make a physical quantity directly from dimel, unless dimensionless, in which
case the plain number is returned."
(if (or (equal dimel (dimension 'dimensionless))
(when *zero-is-dimensionless* (gzerop mag)))
(when *zero-is-dimensionless* (zerop mag)))
mag
(nth-value
0
......@@ -65,7 +80,7 @@
(parse-units unit-expression sysunits)
(make-pq-dimel
(if convfact
(g* convfact magnitude)
(antik:* convfact magnitude)
(error
"~a is not a unit of measure but a physical dimension ~
and cannot be interpreted as a unit of measure ~
......@@ -186,7 +201,7 @@
(lambda (x dim) (check-dimension x dim error zeros-have-any-dimension))
obj units)
(let ((pu (parse-units units)))
(or (and zeros-have-any-dimension (ignore-errors (gzerop obj)))
(or (and zeros-have-any-dimension (ignore-errors (zerop obj)))
(and (typep obj 'physical-quantity)
(equal (pq-dimension obj) pu))
(equal pu (dimension 'dimensionless))
......@@ -198,11 +213,11 @@
;;;; Extracting values and printing
;;;;****************************************************************************
(define-parameter numerica-format :degrees
(define-parameter nf :degrees
t t
"Whether to format angles in degrees and angular rates in Hertz.")
(define-parameter numerica-format :time
(define-parameter nf :time
:tud (or null (member :tud :alternate))
"How to format time intervals:
:tud = ISO8601 time-unit designator (like P10H7M23.726979085813582S)
......@@ -210,12 +225,12 @@
nil = with the unit for time given by (nf-sysunits)
(like #_36443.72697908581_S.")
(define-parameter numerica-format :no-units
(define-parameter nf :no-units
nil t
"Don't print units.")
(defun nf-sysunits ()
"The system of units used in numerica-format."
"The system of units used in nf."
(augment-sysunits
(when (nf-option degrees) 'degree)
(when (nf-option degrees) 'hertz)))
......@@ -223,7 +238,7 @@
(defun pqval-nf (pq)
(pqval pq nil (nf-sysunits)))
(defmethod numerica-format
(defmethod nf
((pq physical-quantity) &optional (stream *standard-output*))
(multiple-value-bind (val units)
(pqval-nf pq)
......@@ -233,10 +248,10 @@
(princn (iso8601-time-interval pq (nf-option time))
stream))
(if (nf-option no-units)
(numerica-format val stream) ; format the number only
(nf val stream) ; format the number only
(format-units val units stream)))))
(defmethod numerica-format :around
(defmethod nf :around
((object sequence) &optional (stream *standard-output*))
(multiple-value-bind (values units all-same)
(pqval object)
......@@ -248,7 +263,7 @@
(defmethod print-object ((pq physical-quantity) stream)
(cl-readable-nf
(numerica-format pq stream)))
(nf pq stream)))
(defgeneric pqval (pq &rest sysunits-additional-units)
(:documentation
......@@ -265,7 +280,7 @@
(pq-dimension pq)
(apply #'augment-sysunits sysunits-additional-units))))
(values
(g/ (pq-magnitude pq) (nth-value 1 (parse-unit-sexp units)))
(antik:/ (pq-magnitude pq) (nth-value 1 (parse-unit-sexp units)))
units
t)))
......@@ -282,14 +297,14 @@
(apply #'pqval x sysunits-additional-units)))
pq))))
(multiple-value-bind (allsame-val allsame-same)
(lu:all-same (second mat) :test #'equal) ; all same units
(all-same (second mat) :test #'equal) ; all same units
(let* ((allsame-nz
;; all non-zero quantities have the same units
(when (and *pqval-allsame-sequence-collapse*
(not allsame-same)
*zero-is-dimensionless*)
;; Check again if zeros are gone
(let ((removed-zeros (remove-if #'gzerop pq)))
(let ((removed-zeros (remove-if 'zerop pq)))
(when (< (length removed-zeros) (length pq))
(multiple-value-bind (ignore units asnz)
(apply
......@@ -311,7 +326,7 @@
(apply #'pqval pq sysunits-additional-units)))
;;; This should really get a more generic name, as it will
;;; routinely replace numerica-format.
;;; routinely replace nf.
(defun new-units
(pq &optional (sysunits-additional-units (list *system-of-units*))
(stream *standard-output*))
......@@ -321,7 +336,7 @@
(time nil degrees nil)
(let ((*system-of-units*
(apply #'augment-sysunits sysunits-additional-units)))
(numerica-format pq stream))))
(nf pq stream))))
;;;;****************************************************************************
;;;; Interface
......
;********************************************************
; file: sysunit-definitions.lisp
; description: Definitions of systems of units
; date: Tue Mar 19 2002 - 18:07
; author: Liam M. Healy < >
; modified: Mon Jun 14 2004 - 22:25
;********************************************************
(in-package :num)
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(si *siu* *englishu* *cgsu*)))
;; Definitions of systems of units
;; Liam Healy Tue Mar 19 2002 - 18:07
;; Time-stamp: <2010-12-25 12:04:17EST sysunit-definitions.lisp>
;; Copyright 2011 Liam M. Healy
;; 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)
(export '(si *siu* *englishu* *cgsu*))
;;; The file unit-definitions must be compiled and loaded before this can
;;; be compiled.
......
;; Define physical dimensions and units of measure and systems of units.
;; Liam Healy Wed Feb 27 2002 - 13:18
;; Time-stamp: <2010-12-25 11:58:08EST units.lisp>
;; Time-stamp: <2010-12-25 12:34:19EST units.lisp>
;; Copyright 2011 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -360,7 +360,7 @@
(flet ((prod (lst)
(if (null lst)
nil
(if (not (rest lst)) (first lst) (cons '* lst))))
(if (single lst) (first lst) (cons '* lst))))
(pwr (name expon) (if (= expon 1) name `(expt ,name ,expon))))
(check-dimel dimel)
(loop for (unit expon) on (make-ue dimel sysunits) by #'cddr
......@@ -527,15 +527,6 @@
(defparameter *unit-symbol-macros* nil
"Unit symbols that were defined with unit-symbol-macro.")
(defun mkstr (&rest args) ; From "On Lisp"
"Make a string out of the printed representations of the arguments." ; LMH
(with-output-to-string (s)
(dolist (a args) (princ a s))))
(defun symb (&rest args) ; From "On Lisp"
"Make a symbol out of the printed representations of the arguments." ; LMH
(values (intern (apply #'mkstr args))))
(defmacro unit-symbol-macro (unit &optional (multiplier 1) prefix)
"Define a symbol macro to expand to the given unit."
(let ((sm (symb (or prefix "") unit)))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment