chez-scmutils/scmutils/units/fbe-system.scm

#| -*-Scheme-*-

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
    Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme 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 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; Unit systems

;; (define* (define-unit-system system-name #:rest base-units)
;;   (let ((n (length base-units)))    
;;     (let ((base-specs
;; 	   (map (lambda (base-spec i)
;; 		  (let* ((unit-name (car base-spec))
;; 			 (exponents
;; 			  (make-initialized-vector n
;; 			    (lambda (j) (if (fix:= i j) 1 0))))
;; 			 (unit (make-unit system-name exponents 1)))
;; 		    (if (environment-bound? scmutils-base-environment
;; 					    unit-name)
;; 			(write-line `(clobbering ,unit-name)))
;; 		    (environment-define scmutils-base-environment
;; 					unit-name
;; 					unit)
;; 		    (append base-spec (list unit))))
;; 		base-units
;; 		(iota n))))
;;       (environment-define scmutils-base-environment
;; 			  system-name
;; 			  (list '*unit-system*
;; 				system-name
;; 				base-specs          ;base units
;; 				'()	            ;derived units
;; 				'()	            ;additional units
;; 				))))
;;   system-name)

(define-syntax define-unit-system
  (lambda (x)
    (syntax-case x ()
      ((_ (_ system-name) (_ (_ unit-name) unit-spec ...) ...)
       (with-syntax ((n (length #'(unit-name ...)))
                     ((index ...) (let f ((i 0) (ids #'(unit-name ...)))
                                    (if (null? ids)
                                        '()
                                        (cons i (f (+ i 1) (cdr ids)))))))
         #`(begin
             (define system-name
               (list '*unit-system* 'system-name
                     (list (append (list 'unit-name unit-spec ...)
                                   (list (make-unit 'system-name
                                           (make-initialized-vector
                                            n
                                            (lambda (j) (if (fix:= index j) 1 0)))
                                           1))) ...) ;base units
                     '()                 ;derived units
                     '()                 ;additional units
                     ))
             (define unit-name
               (make-unit 'system-name
                          (make-initialized-vector
                           n
                           (lambda (j) (if (fix:= index j) 1 0)))
                          1))
             ...
             ))))))

(define (unit-system? system)
  (and (pair? system)
       (eq? (car system) '*unit-system*)))

(define (unit-system-name system)
  (cadr system))

(define (base-units system)
  (caddr system))

(define (derived-units system)
  (cadddr system))

(define (alternate-units system)
  (car (cddddr system)))

;;; Data may be entered and results may be presented in derived units.

;; (define* (define-derived-unit system unit-name tex description content
;; 	                     #:optional scale-factor)
;;   (assert (unit-system? system))
;;   (if (environment-bound? scmutils-base-environment unit-name)
;;       (write-line `(clobbering ,unit-name)))
;;   (if (default-object? scale-factor)
;;       (set! scale-factor 1))
;;   (set! content
;; 	(make-unit (unit-system-name system)
;; 		   (unit-exponents content)
;; 		   (* (expression scale-factor) (unit-scale content))))
;;   (let ((unit-spec (list unit-name tex description content)))
;;     (define-derived-unit! system unit-spec)
;;     (environment-define scmutils-base-environment unit-name content)
;;     unit-name))

(define-syntax define-derived-unit
  (syntax-rules ()
    ((_ system (_ unit-name) tex description content-u)
     (define unit-name
       (let* ((scale-factor 1)
              (content (make-unit (unit-system-name system)
                         (unit-exponents content-u)
                         (* (expression scale-factor) (unit-scale content-u)))))
         (let ((unit-spec (list 'unit-name tex description content)))
           (define-derived-unit! system unit-spec)
           content))))
    ((_ system (_ unit-name) tex description content-u scale-factor)
     (define unit-name
       (let* ((content (make-unit (unit-system-name system)
                         (unit-exponents content-u)
                         (* (expression scale-factor) (unit-scale content-u)))))
         (let ((unit-spec (list 'unit-name tex description content)))
           (define-derived-unit! system unit-spec)
           content))))))

(define (define-derived-unit! system unit-spec)
  (set-car! (cdddr system)
	    (append (cadddr system)
		    (list unit-spec))))


;;; Data may be entered in additional units but results will not be
;;; presented in additional units.

;; (define* (define-additional-unit system unit-name tex description content
;; 	                        #:optional scale-factor)
;;   (assert (unit-system? system))
;;   (if (environment-bound? scmutils-base-environment unit-name)
;;       (write-line `(clobbering ,unit-name)))
;;   (if (default-object? scale-factor)
;;       (set! scale-factor 1))
;;   (set! content
;; 	(make-unit (unit-system-name system)
;; 		   (unit-exponents content)
;; 		   (* (expression scale-factor) (unit-scale content))))
;;   (let ((unit-spec (list unit-name tex description content)))
;;     (define-additional-unit! system unit-spec)
;;     (environment-define scmutils-base-environment unit-name content)
;;     unit-name))

(define-syntax define-additional-unit
  (syntax-rules ()
   ((_ system (_ unit-name) tex description content-u)
    (define unit-name
      (let* ((scale-factor 1)
             (content (make-unit (unit-system-name system)
                                 (unit-exponents content-u)
                                 (* (expression scale-factor) (unit-scale content-u)))))
        (let ((unit-spec (list 'unit-name tex description content)))
          (define-additional-unit! system unit-spec)
          content))))
   ((_ system (_ unit-name) tex description content-u scale-factor)
    (define unit-name
      (let ((content (make-unit (unit-system-name system)
                                (unit-exponents content-u)
                                (* (expression scale-factor) (unit-scale content-u)))))
        (let ((unit-spec (list 'unit-name tex description content)))
          (define-additional-unit! system unit-spec)
          content))))))

(define (define-additional-unit! system unit-spec)
  (set-car! (cddddr system)
	    (append (car (cddddr system))
		    (list unit-spec))))


;;; FBE: make it a parameter
(define *multiplier-names* (make-parameter '()))

;; (define (define-multiplier name tex-string log-value)
;;   (if (environment-bound? scmutils-base-environment name)
;;       (write-line `(clobbering ,name)))
;;   (set! *multiplier-names*
;; 	(cons (list name tex-string log-value)
;; 	      *multiplier-names*))
;;   (environment-define scmutils-base-environment
;; 		      name
;; 		      (expt 10 log-value)))

(define-syntax  define-multiplier
  (syntax-rules ()
    ((_ (_ name) tex-string log-value)
     (define name
       (let ()
         (*multiplier-names*
               (cons (list 'name tex-string log-value)
                     (*multiplier-names*)))
         (expt 10 log-value))))))

;;; FBE: make it a parameter
(define *numerical-constants* (make-parameter '()))

;; (define* (define-constant name tex-string description value units
;; 	                #:optional uncertainty)
;;   (if (environment-bound? scmutils-base-environment name)
;;       (write-line `(clobbering ,name)))
;;   (let ((constant (literal-number name)))
;;     (cond ((with-units? value)
;; 	   (assert (same-units? (u:units value) units))))
;;     (set! value (g:simplify (u:value value)))
;;     (add-property! constant 'name name)
;;     (add-property! constant 'numerical-value value)
;;     (add-property! constant 'units units)
;;     (add-property! constant 'tex-string tex-string)
;;     (add-property! constant 'description description)
;;     (if (real? value) (declare-known-reals name))
;;     (if (not (default-object? uncertainty))
;; 	(add-property! constant 'uncertainty uncertainty))
;;     (set! *numerical-constants* (cons constant *numerical-constants*))
;;     (environment-define scmutils-base-environment
;; 			name
;; 			(with-units value units))
;;     name))
(define-syntax define-constant
  (syntax-rules ()
   ((_ (_ name) tex-string description value-u units uncertainty)
    (define name
      (let ((constant (literal-number 'name))
            (value (g:simplify (u:value value-u))))
        (cond ((with-units? value)
               (assert (same-units? (u:units value) units))))
        (add-property! constant 'name 'name)
        (add-property! constant 'numerical-value value)
        (add-property! constant 'units units)
        (add-property! constant 'tex-string tex-string)
        (add-property! constant 'description description)
        (if (real? value) (declare-known-reals 'name))
        (add-property! constant 'uncertainty uncertainty)
        (*numerical-constants* (cons constant (*numerical-constants*)))
        (with-units value units))))
   ((_ (_ name) tex-string description value-u units)
    (define name
      (let ((constant (literal-number 'name))
            (value (g:simplify (u:value value-u))))
        (cond ((with-units? value)
               (assert (same-units? (u:units value) units))))
        (add-property! constant 'name 'name)
        (add-property! constant 'numerical-value value)
        (add-property! constant 'units units)
        (add-property! constant 'tex-string tex-string)
        (add-property! constant 'description description)
        (if (real? value) (declare-known-reals 'name))
        (*numerical-constants* (cons constant (*numerical-constants*)))
        (with-units value units))))))

;;; FBE start: comment out
;; (define* (numerical-constants #:optional units? constants)
;;   (if (default-object? units?) (set! units? #t))
;;   (if (default-object? constants) (set! constants (*numerical-constants*)))
;;   (for-each (lambda (c)
;; 	      (environment-assign!
;; 	       scmutils-base-environment
;; 	       (get-property c 'name)
;; 	       (if units?
;; 		   (with-units (get-property c 'numerical-value)
;; 		     (get-property c 'units))
;; 		   (g:* (get-property c 'numerical-value)
;; 			(unit-scale (get-property c 'units))))))
;; 	    constants))

;; (define* (symbolic-constants #:optional units? constants)
;;   (if (default-object? units?) (set! units? #t))
;;   (if (default-object? constants) (set! constants (*numerical-constants*)))
;;   (for-each (lambda (c)
;; 	      (environment-assign!
;; 	       scmutils-base-environment
;; 	       (get-property c 'name)
;; 	       (if units?
;; 		   (with-units (get-property c 'name)
;; 		     (get-property c 'units))
;; 		   (g:* (get-property c 'name)
;; 			(unit-scale (get-property c 'units))))))
;; 	    constants))
;;; FBE end

(define (get-constant-data name)
  (find-matching-item (*numerical-constants*)
    (lambda (c) (eq? (get-property c 'name) name))))

;;; & is used to attach units to a number, or to check that a number
;;; has the given units.

(define* (& value u1 #:optional u2)
  (let ((units (if (default-object? u2) u1 u2))
	(scale (if (default-object? u2) 1 u1)))
    (assert (and (not (units? value)) (number? scale) (units? units)))
    (if (with-units? value)
	(if (equal? (unit-exponents units)
		    (unit-exponents (u:units value)))
	    value
	    (error "Units do not match: &" value units))
	(with-units (g:* scale (unit-scale units) value)
	  (make-unit (unit-system units)
		     (unit-exponents units)
		     1)))))

(define *unit-constructor* '&)


;;; FBE: we comment the following definitions and move them after we
;;; create the 'generic-environment'.
;; (define unit-environment generic-environment)

;; (define (express-as num target-unit-expression)
;;   (let ((target-unit-expression-value
;; 	 (eval target-unit-expression unit-environment)))
;;     (cond ((with-units? target-unit-expression-value)
;; 	   (let ((target-val (u:value target-unit-expression-value))
;; 		 (target-units (u:units target-unit-expression-value)))
;; 	     (express-in-given-units (g:/ num target-val)
;; 				     target-units
;; 				     target-unit-expression)))
;; 	  ((units? target-unit-expression-value)
;; 	   (express-in-given-units num
;; 				   target-unit-expression-value
;; 				   target-unit-expression))
;; 	  (else num))))

(define (express-in-given-units num target-unit target-unit-expression)
  (cond ((with-units? num)
	 (let ((value (g:* (unit-scale (u:units num)) (u:value num)))
	       (vect (unit-exponents (u:units num))))
	   (if (not (equal? vect (unit-exponents target-unit)))
	       (error "Cannot express in given units"
		      num target-unit target-unit-expression))
	   (list *unit-constructor*
		 (g:/ (expression value) (unit-scale target-unit))
		 target-unit-expression)))
	((units? num)
	 (list *unit-constructor*
	       (g:/ (unit-scale num) (unit-scale target-unit))
	       target-unit-expression))
	(else num)))

(define (with-units->expression system num)
  (assert (unit-system? system))
  (cond ((with-units? num)
	 (let ((value (g:* (unit-scale (u:units num)) (u:value num)))
	       (vect (unit-exponents (u:units num))))
	   (make-unit-description value vect system)))
	((units? num)
	 (make-unit-description (unit-scale num)
				(unit-exponents num)
				system))
	(else num)))

(define (make-unit-description value exponent-vector system)
  (let ((available
	 (or (find-unit-description exponent-vector
				    (base-units system))
	     (find-unit-description exponent-vector
				    (derived-units system)))))
    (if available
	(let ((unit-name (car available))
	      (scale (unit-scale (list-ref available 3))))
	  (list *unit-constructor*
		(g:simplify (g:/ value scale))
		unit-name))
	(list *unit-constructor*
	      (g:simplify value)
	      (unit-expresson (vector->list exponent-vector)
			      (map car (base-units system)))))))


(define (find-unit-description vect ulist)
  (find-matching-item ulist
    (lambda (entry)
      (equal? (unit-exponents (list-ref entry 3))
	      vect))))

(define (find-unit-name vect ulist)
  (let ((v (find-unit-description vect ulist)))
    (if v (car v) #f)))

(define (unit-expresson exponents base-unit-names)
  (cons '*
	(apply append
	       (map (lambda (exponent base-name)
		      (cond ((g:zero? exponent) '())
			    ((g:one? exponent) (list base-name))
			    (else
			     (list (list 'expt base-name exponent)))))
		    exponents
		    base-unit-names))))

#|
(with-units->expression SI &foot)
;Value: (& .3048 &meter)

(with-units->expression SI (& 2 &foot))
;Value: (& .6096 &meter)

(with-units->expression SI (/ (* :k (& 300 &kelvin)) :e))
;Value: (& .02585215707677003 &volt)

(with-units->expression SI :c)
;Value: (& 299792458. (* &meter (expt &second -1)))

(with-units->expression SI :h)
;Value: (& 6.6260755e-34 (* (expt &meter 2) &kilogram (expt &second -1)))
|#


#|
;;; Work in progress

(define (foosh x)
  (let* ((logscale (round->exact (log10 x)))
	 (scale (expt 10 logscale))
	 )
    (list (/ x scale) scale)
  ))

(foosh 3/1000)
#|
(3 1/1000)
|#
|#