From 87b82b5822ca54228cfa6df29be3ad9d4bc47d16 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:28 -0800 Subject: Import Upstream version 2d2 --- simetrix.scm | 246 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 246 insertions(+) create mode 100644 simetrix.scm (limited to 'simetrix.scm') 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*) -- cgit v1.2.3