Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Sébastien Villemot
antik
Commits
1b3c3543
Commit
1b3c3543
authored
Dec 25, 2010
by
Liam M. Healy
Browse files
Add utility definitions, port more physical-quantities files
parent
3a0429e8
Changes
8
Hide whitespace changes
Inline
Side-by-side
antik.asd
View file @
1b3c3543
;; Antik system definition
;; Liam Healy 2010-12-24 09:43:28EST antik.asd
;; Time-stamp: <2010-12-2
4
1
9:17:56
EST antik.asd>
;; Time-stamp: <2010-12-2
5
1
2:28:38
EST 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")
...
...
grid/specification.lisp
View file @
1b3c3543
;; The specification of a grid
;; Liam Healy 2009-11-21 14:48:34EST specification.lisp
;; Time-stamp: <2010-
07-05 22:27:45ED
T specification.lisp>
;; Time-stamp: <2010-
12-25 12:34:08ES
T 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
)
...
...
init/generic.lisp
View file @
1b3c3543
;; Generic functions for generalized numbers
;; Liam Healy Tue Feb 9 1999 - 21:38
;; Time-stamp: <2010-12-2
4
1
3
:3
1:20
EST generic.lisp>
;; Time-stamp: <2010-12-2
5
1
2
:3
3:35
EST 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
))
...
...
init/object.lisp
0 → 100644
View file @
1b3c3543
;; 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
))))
init/utility.lisp
0 → 100644
View file @
1b3c3543
;; 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
))))))
physical-quantities/physical-quantities.lisp
View file @
1b3c3543
;; 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*
(
g
zerop
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
(
g
zerop
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
n
umerica-format
:degrees
(
define-parameter
n
f
:degrees
t
t
"Whether to format angles in degrees and angular rates in Hertz."
)
(
define-parameter
n
umerica-format
:time
(
define-parameter
n
f
: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
n
umerica-format
:no-units
(
define-parameter
n
f
:no-units
nil
t
"Don't print units."
)
(
defun
nf-sysunits
()
"The system of units used in n
umerica-format
."
"The system of units used in n
f
."
(
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
n
umerica-format
(
defmethod
n
f
((
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
)
(
n
umerica-format
val
stream
)
; format the number only
(
n
f
val
stream
)
; format the number only
(
format-units
val
units
stream
)))))
(
defmethod
n
umerica-format
:around
(
defmethod
n
f
: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
(
n
umerica-format
pq
stream
)))
(
n
f
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
#'
g
zerop
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 n
umerica-format
.
;;; routinely replace n
f
.
(
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
)))
(
n
umerica-format
pq
stream
))))
(
n
f
pq
stream
))))
;;;;****************************************************************************
;;;; Interface
...
...
physical-quantities/sysunit-definitions.lisp
View file @
1b3c3543
;********************************************************
; 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.
...
...
physical-quantities/units.lisp
View file @
1b3c3543
;; Define physical dimensions and units of measure and systems of units.
;; Liam Healy Wed Feb 27 2002 - 13:18
;; Time-stamp: <2010-12-25 1
1:58:08
EST units.lisp>
;; Time-stamp: <2010-12-25 1
2:34:19
EST 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
)))
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment