guile/module/slib/simetrix.scm

;;;; "simetrix.scm" SI Metric Interchange Format for Scheme
;;; Copyright (C) 2000, 2001 Aubrey Jaffer.
;
;Permission to copy this software, to redistribute it, 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*)