cond-values/units.scm

;;; Copyright 2024 Peter McGoron
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;; 
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;; 
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
;;; implied. See the License for the specific language governing
;;; permissions and limitations under the License.
;;; 
;;; Example of COND-VALUES using units.

(load "cond-values.scm")

(define *si-prefixes*
  '((quetta . #e1e30)
    (ronna . #e1e27)
    (yotta . #e1e24)
    (zetta . #e1e21)
    (exa . #e1e18)
    (peta . #e1e15)
    (tera . #e1e12)
    (giga . #e1e9)
    (mega . #e1e6)
    (kilo . #e1e3)
    (hecto . #e1e2)
    (deka . #e1e1)
    (deci . #e1e-1)
    (centi . #e1e-2)
    (milli . #e1e-3)
    (micro . #e1e-6)
    (nano . #e1e-9)
    (pico . #e1e-12)
    (femto . #e1e-15)
    (atto . #e1e-18)
    (zepto . #e1e-21)
    (yocto . #e1e-24)
    (ronto . #e1e-27)
    (quecto . #e1e-30)))

(define *si-algebra*
  `((/ . ,/)
    (* . ,*)))

(define (atom-d unit)
  (after ((when (or (symbol? unit)
                    (and (number? unit) (exact? unit)))))
    unit))

(define (prefixed-d unit)
  (after ((let (length* unit 2) => (head unit))
          (let (assq-d head *si-prefixes*) => (factor)))
    (values factor unit)))

(define (power-d unit)
  (after ((let (length* unit 3) => (head number unit))
          (when (eq? head '^)))
    (values number unit)))

(define (algebra-function-d unit)
  (after ((let (length-at-least unit 3) => (head . rest))
          (let (assq-d head *si-algebra*) => (procedure)))
    (values head procedure rest)))

(define (remove-prefixes unit)
  (cond-values
    (after ((let (atom-d unit) => (unit)))
      (values 1 unit))
    ;; 
    (after ((let (prefixed-d unit) => (factor unit)))
      (let-values (((sub-factor unit-w/o-factors)
                    (remove-prefixes unit)))
        (values (* sub-factor factor) unit-w/o-factors)))
    ;; 
    (after ((let (power-d unit) => (power unit)))
      (let-values (((sub-factor sub-unit)
                    (remove-prefixes unit)))
        (values (expt sub-factor power)
                (list '^ power sub-unit))))
    ;; 
    (after ((let (algebra-function-d unit) => (head proc units)))
      (let-values (((factors units)
                    (map-values remove-prefixes units)))
        (values (apply proc factors)
                (cons head units))))
    (else (error "invalid unit" unit))))

(remove-prefixes '(/ (* (centi meter) (centi meter))
                     volt
                     second))
(remove-prefixes '(/ (^ 2 (centi meter))
                     volt
                     second))

(define (make-unit-destructor atom prefixed power algebra-function on-else)
  (lambda (unit)
    (cond-values
      (apply-after (atom-d unit) atom)
      (apply-after (prefixed-d unit) prefixed)
      (apply-after (power-d unit) power)
      (apply-after (algebra-function-d unit) algebra-function)
      (else (on-else unit)))))

(import r7rs)

(define (remove-prefixes unit)
  (define (on-atom unit)
    (values 1 unit))
  (define (on-prefixed prefix-factor unit)
    (let-values (((sub-prefix sub-unit) (remove-prefixes unit)))
      (values (* prefix-factor sub-prefix) sub-unit)))
  (define (on-power power unit)
    (let-values (((sub-prefix sub-unit) (remove-prefixes unit)))
      (values (expt sub-prefix power) sub-unit)))
  (define (on-algebra-function symbol procedure units)
    (let-values (((prefixes units) (map-values remove-prefixes units)))
      (values (apply procedure prefixes)
              (cons symbol units))))
  (define (on-else unit)
    (error "invalid unit" 'remove-prefixes unit))
  (define remove-prefixes
      (make-unit-destructor on-atom
                            on-prefixed
                            on-power
                            on-algebra-function))
  (remove-prefixes unit))

(define remove-prefixes-destructors '())
(define remove-prefixes-handlers '())

(define (add-remove-prefixes-handler destructor handler)
  (set! remove-prefixes-destructors
        (cons destructor remove-prefixes-destructors))
  (set! remove-prefixes-handlers
        (cons handler remove-prefixes-handlers)))

(define (remove-prefixes unit)
  (cond-values
    (any-values (lambda (destructor handler)
                  (apply-after (destructor unit) handler))
                remove-prefixes-destructors
                remove-prefixes-handlers)
    (else (error "invalid unit" unit))))

(add-remove-prefixes-handler atom-d (lambda (unit)
                                      (values 1 unit)))

(remove-prefixes 'gram)
(remove-prefixes '(kilo gram))

(add-remove-prefixes-handler prefixed-d
                             (lambda (factor unit)
                               (let-values (((sub-factor sub-unit)
                              (remove-prefixes unit)))
                                 (values (* factor sub-factor) sub-unit))))

(add-remove-prefixes-handler
 algebra-function-d
 (lambda (head procedure units)
   (let-values (((factors units) (map-values remove-prefixes units)))
     (values (apply procedure factors)
             (cons head units)))))

(remove-prefixes '(/ (kilo meter) (micro second)))