Import Upstream version 2d2upstream/2d2

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*)