summaryrefslogtreecommitdiffstats
path: root/simetrix.scm
diff options
context:
space:
mode:
Diffstat (limited to 'simetrix.scm')
-rw-r--r--simetrix.scm246
1 files changed, 246 insertions, 0 deletions
diff --git a/simetrix.scm b/simetrix.scm
new file mode 100644
index 0000000..3a3f16b
--- /dev/null
+++ b/simetrix.scm
@@ -0,0 +1,246 @@
+;;;; "simetrix.scm" SI Metric Interchange Format for Scheme
+;;; Copyright (C) 2000, 2001 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, and to use it for any purpose is
+;granted, subject to the following restrictions and understandings.
+;
+;1. Any copy made of this software must include this copyright notice
+;in full.
+;
+;2. I have made no warrantee or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3. In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+;; Implements "Representation of numerical values and SI units in
+;; character strings for information interchanges"
+;; http://swissnet.ai.mit.edu/~jaffer/MIXF.html
+
+(require 'precedence-parse)
+
+;;; Combine alists
+(define (SI:adjoin unitlst SIms)
+ (for-each (lambda (new)
+ (define pair (assoc (car new) SIms))
+ (if pair
+ (set-cdr! pair (+ (cdr new) (cdr pair)))
+ (set! SIms (cons (cons (car new) (cdr new)) SIms))))
+ unitlst)
+ SIms)
+
+;;; Combine unit-alists
+(define (SI:product unit1 unit2)
+ (define nunits '())
+ (set! unit1 (SI:expand-unit unit1))
+ (set! unit2 (SI:expand-unit unit2))
+ (cond ((and unit1 unit2)
+ (set! nunits (SI:adjoin unit1 nunits))
+ (set! nunits (SI:adjoin unit2 nunits))
+ nunits)
+ (else #f)))
+
+(define (SI:quotient unit1 . units)
+ (apply SI:product unit1
+ (map (lambda (unit) (SI:pow unit -1)) units)))
+
+(define (SI:pow unit expon)
+ (define punit (SI:expand-unit unit))
+ (and punit (number? expon)
+ (map (lambda (unit-pair)
+ (cons (car unit-pair) (* (cdr unit-pair) expon)))
+ punit)))
+
+;;; Parse helper functions.
+(define (SI:solidus . args)
+ (if (and (= 2 (length args))
+ (number? (car args))
+ (number? (cadr args)))
+ (/ (car args) (cadr args))
+ (apply SI:quotient args)))
+
+(define (SI:e arg1 arg2)
+ (cond ((and (number? arg1) (number? arg2)
+ (exact? arg2))
+ (let ((expo (string->number
+ (string-append "1e" (number->string arg2)))))
+ (and expo (* arg1 expo))))
+ (else (SI:product arg1 arg2))))
+
+(define (SI:dot arg1 arg2)
+ (cond ((and (number? arg1) (number? arg2)
+ (exact? arg1) (exact? arg2)
+ (positive? arg2))
+ (string->number
+ (string-append (number->string arg1) "." (number->string arg2))))
+ (else (SI:product arg1 arg2))))
+
+(define (SI:minus arg) (and (number? arg) (- arg)))
+
+(define (SI:identity . args) (and (= 1 (length args)) (car args)))
+
+;;; Binary prefixes are (zero? (modulo expo 10))
+(define SI:prefix-exponents
+ '(("Y" 24) ("Z" 21) ("E" 18) ("P" 15)
+ ("T" 12) ("G" 9) ("M" 6) ("k" 3) ("h" 2) ("da" 1)
+ ("d" -1) ("c" -2) ("m" -3) ("u" -6) ("n" -9)
+ ("p" -12) ("f" -15) ("a" -18) ("z" -21) ("y" -24)
+
+ ("Ei" 60) ("Pi" 50) ("Ti" 40) ("Gi" 30) ("Mi" 20) ("Ki" 10)
+ ))
+
+(define SI:unit-infos
+ `(
+ ("s" all #f)
+ ("min" none "60.s")
+ ("h" none "3600.s")
+ ("d" none "86400.s")
+ ("Hz" all "s^-1")
+ ("Bd" pos "s^-1")
+ ("m" all #f)
+ ("L" neg "dm^3")
+ ("rad" neg #f)
+ ("sr" neg "rad^2")
+ ("r" pos ,(string-append (number->string (* 8 (atan 1))) ".rad"))
+ ("o" neg ,(string-append (number->string (/ 360)) ".r"))
+ ("bit" bin #f)
+ ("B" pin "8.b")
+ ("g" all #f)
+ ("t" pos "Mg")
+ ("u" none "1.66053873e-27.kg")
+ ("mol" all #f)
+ ("kat" all "mol/s")
+ ("K" all #f)
+ ("oC" neg #f)
+ ("cd" all #f)
+ ("lm" all "cd.sr")
+ ("lx" all "lm/m^2")
+ ("N" all "m.kg/s^2")
+ ("Pa" all "N/m^2")
+ ("J" all "N.m")
+ ("eV" all "1.602176462e-19.J")
+ ("W" all "J/s")
+ ("Np" neg #f)
+ ("dB" none ,(string-append (number->string (/ (log 10) 20)) ".Np"))
+ ("A" all #f)
+ ("C" all "A.s")
+ ("V" all "W/A")
+ ("F" all "C/V")
+ ("Ohm" all "V/A")
+ ("S" all "A/V")
+ ("Wb" all "V.s")
+ ("T" all "Wb/m^2")
+ ("H" all "Wb/A")
+ ("Bq" all "s^-1")
+ ("Gy" all "m^2.s^-2")
+ ("Sv" all "m^2.s^-2")
+ ))
+
+(define (SI:try-split preSI SIm)
+ (define expo (assoc preSI SI:prefix-exponents))
+ (define stuff (assoc SIm SI:unit-infos))
+ (if expo (set! expo (cadr expo)))
+ (if stuff (set! stuff (cdr stuff)))
+ (and expo stuff
+ (let ((equivalence (cadr stuff)))
+ (and (case (car stuff) ;restriction
+ ((all) (not (zero? (modulo expo 10))))
+ ((pos) (and (positive? expo) (not (zero? (modulo expo 10)))))
+ ((bin) #t)
+ ((pin) (positive? expo))
+ ((neg) (and (negative? expo) (not (zero? (modulo expo 10)))))
+ ((none) #f)
+ (else #f))
+ (if (and (positive? expo) (zero? (modulo expo 10)))
+ (if equivalence
+ (let ((eqv (SI:expand-equivalence equivalence)))
+ (and eqv
+ (SI:adjoin (list (cons 1024 (quotient expo 10)))
+ eqv)))
+ (list (cons 1024 (quotient expo 10))
+ (cons SIm 1)))
+ (if equivalence
+ (let ((eqv (SI:expand-equivalence equivalence)))
+ (and eqv (SI:adjoin (list (cons 10 expo)) eqv)))
+ (list (cons 10 expo) (cons SIm 1))))))))
+
+(define (SI:try-simple SIm)
+ (define stuff (assoc SIm SI:unit-infos))
+ (if stuff (set! stuff (cdr stuff)))
+ (and stuff (if (cadr stuff)
+ (SI:expand-equivalence (cadr stuff))
+ (list (cons SIm 1)))))
+
+(define (SI:expand-unit str)
+ (if (symbol? str) (set! str (symbol->string str)))
+ (cond
+ ((pair? str) str)
+ ((number? str) (list (cons str 1)))
+ ((string? str)
+ (let ((len (string-length str)))
+ (let ((s1 (and (> len 1)
+ (SI:try-split (substring str 0 1) (substring str 1 len))))
+ (s2 (and (> len 2)
+ (SI:try-split (substring str 0 2) (substring str 2 len))))
+ (sn (and (SI:try-simple str))))
+ (define cnt (+ (if s1 1 0) (if s2 1 0) (if sn 1 0)))
+ (if (> cnt 1) (slib:warn 'ambiguous s1 s2 sn))
+ (or s1 s2 sn))))
+ (else #f)))
+
+(define (SI:expand-equivalence str)
+ (call-with-input-string
+ str (lambda (sport)
+ (define result (prec:parse SI:grammar 'EOS sport))
+ (cond ((eof-object? result) (list (cons 1 0)))
+ ((symbol? result) (SI:expand-unit result))
+ (else result)))))
+
+;;;; advertised interface
+(define (SI:conversion-factor to-unit from-unit)
+ (let ((funit (SI:expand-equivalence from-unit))
+ (tunit (SI:expand-equivalence to-unit)))
+ (if (and funit tunit)
+ (let loop ((unit-pairs (SI:quotient funit tunit))
+ (flactor 1))
+ (cond ((null? unit-pairs) flactor)
+ ((zero? (round (* 2 (cdar unit-pairs))))
+ (loop (cdr unit-pairs) flactor))
+ ((number? (caar unit-pairs))
+ (loop (cdr unit-pairs)
+ ((if (negative? (cdar unit-pairs)) / *)
+ flactor
+ (expt (caar unit-pairs)
+ (abs (cdar unit-pairs))))))
+ (else 0)))
+ (+ (if tunit 0 -1) (if funit 0 -2)))))
+
+(define SI:grammar #f)
+
+;;;; The parse tables.
+;;; Definitions accumulate in top-level variable *SYN-DEFS*.
+;;(trace-all (in-vicinity (program-vicinity) "simetrix.scm"))
+
+;;; Character classes
+(prec:define-grammar (tok:char-group 70 #\^ list->string))
+(prec:define-grammar (tok:char-group 49 #\. list->string))
+(prec:define-grammar (tok:char-group 50 #\/ list->string))
+(prec:define-grammar (tok:char-group 51 #\- list->string))
+(prec:define-grammar (tok:char-group 40 tok:decimal-digits
+ (lambda (l) (string->number (list->string l)))))
+(prec:define-grammar (tok:char-group 44
+ (string-append tok:upper-case tok:lower-case "@_")
+ list->string))
+
+(prec:define-grammar (prec:prefix '- SI:minus 130))
+(prec:define-grammar (prec:infix "." SI:dot 120 120))
+(prec:define-grammar (prec:infix '("e" "E") SI:e 115 125))
+(prec:define-grammar (prec:infix '/ SI:solidus 100 150))
+(prec:define-grammar (prec:infix '^ SI:pow 160 140))
+(prec:define-grammar (prec:matchfix #\( SI:identity #f #\)))
+
+(set! SI:grammar *syn-defs*)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-21 20:53:00 +0000