;;;; simple-units.scm
;;;; Kon Lovett, Aug '10
;; Issues
;;
;; - Quantity is not 1st-class.
;;
;; This requires extending the numeric tower!
;;
;; - No "dimension".
;;
;; - No units-systems catalog.
;;
;; - Cannot remove a units from a units-system.
;;
;; - Cannot extend a units.
;;
;; - The units-factor-scale & -predicate variable are a kludge.
;;
;; - Cannot create derived units.
;;
;; (define cm^2 (make-unit cm ^ 2))
;; (define 50cm^2 (quantity 50 cm^2))
;;
;; (define mph (make-unit mile / h))
;; (define 23mph (quantity 23 mph))
;;
;; even better:
;;
;; (define-unit C C 1 bogus-SI:)
;; (define-unit C/kg (C / kg)) ; or (define-unit C/kg (bogus-SI:C / kg))
;; (define-unit roentgen 2.58e-4C/kg R)
;;
;; 23R ;=> (quantity 59.34e-4 roentgen)
;;
;; 2.58e-4C/kg ;=> (quantity 2.58e-4 C/kg) ;not (quantity 59.34e-4 roentgen)!
;; Notes
;;
;; - Rather than eager value resolution could be lazy.
;;
;; - When a value is not a factor use a promise & then force at point of
;; reference.
(module simple-units
(;export
;
factor? check-factor error-factor
;
units-factor-scale
units-number-predicate
units-number-system
;
(make-units *make-units)
(make-units* *make-units)
units? check-units error-units
units-name
units-base-name
units-units-system
units-unit-names
units-unit-factor
units=?
;
quantity
make-quantity
;
default-units-system
make-units-system
units-system? check-units-system error-units-system
units-system-name
units-system-catalog
units-system-units
units-system-units/unit
units-system-add-units!)
(import
scheme
chicken
(only data-structures sort! intersperse)
(only srfi-1 every find delete list-copy remove)
(only record-variants define-record-type-variant)
(only list-utils plist->alist)
(only symbol-utils symbol-printname)
(only variable-item define-checked-variable)
(only lookup-table
dict-keys dict-values alist->dict dict-ref)
(only type-checks
define-check+error-type
check-procedure check-list)
(only type-errors warning-argument-type))
(require-library
srfi-1 data-structures
record-variants
list-utils symbol-utils
variable-item
lookup-table
type-checks type-errors)
;;
(define-checked-variable units-factor-scale * procedure)
(define-checked-variable units-number-predicate number? procedure)
(define (units-number-system . args)
(cond
((null? args)
(values (units-factor-scale) (units-number-predicate)) )
(else
(units-factor-scale (car args))
(units-number-predicate (cadr args)) ) ) )
;; Basic Types
; exposition purposes only
(define unit-name? symbol?)
(define units-name? symbol?)
(define units-system-name? symbol?)
(define-check+error-type unit-name)
(define-check+error-type units-name)
(define-check+error-type units-system-name)
(define (factor? x) ((units-number-predicate) x))
(define-check+error-type factor)
;; Unit Type
(define (%make-unit name factor) (cons name factor))
#; ;UNUSED
(define (%unit? obj) (pair? obj))
(define (%unit-name unit) (car unit))
#; ;UNUSED
(define (%unit-factor unit) (cdr unit))
; For use with an unresolved unit
(define (%unit-value unit) (cdr unit))
#| ;UNUSED
==== unit?
(unit? OBJ) => boolean
(check-unit LOC OBJ [ARGNAM]) => *
(error-unit LOC OBJ [ARGNAM])
==== unit-name
(unit-name UNIT) => symbol
==== unit-factor
(unit-factor UNIT) => number
(define (unit? obj)
(and (%unit? obj)
(unit-name? (%unit-name obj))
(factor? (%unit-factor obj))) )
(define-check+error-type unit)
(define (unit-name unit)
(%unit-name (check-unit 'unit-name unit)) )
(define (unit-factor unit)
(%unit-factor (check-unit 'unit-factor unit)) )
|#
;; Units Type (aka Unitset)
(define-record-type-variant units (unsafe unchecked inline)
(%make-units nam bas tbl qdb)
%units?
(nam %units-name)
(bas %units-base)
(tbl %units-table)
(qdb %units-database) )
(define (%units=? a b)
(and (eq? (%units-name a) (%units-name b))
(eq? (%units-base a) (%units-base b))
(every
eq?
(sort! (dict-keys (%units-table a)) symbol-printname)
(sort! (dict-keys (%units-table b)) symbol-printname)) ) )
#; ;UNUSED
(define (%units-resolved? units)
(every (units-number-predicate) (dict-values (%units-table units))) )
(define (%make-units-database units)
(alist->dict units) )
; returns the units unit or #f
#; ;UNUSED
(define (%units-ref units name)
(and-let* ((factor (dict-ref (%units-table units) name)))
(%make-unit name factor) ) )
; returns the units unit's factor or #f
(define (%units-unit-factor units name)
(dict-ref (%units-table units) name) )
;;
(define-check+error-type units %units?)
(define (units? obj) (%units? obj))
(define (units=? a b)
(%units=?
(check-units 'units=? a 'units-a)
(check-units 'units=? b 'units-b)) )
(define (units-name units)
(%units-name (check-units 'units-name units)) )
(define (units-base-name units)
(%units-base (check-units 'units-base-unit-nam units)) )
(define (units-unit-names units)
(dict-keys (%units-table (check-units 'units-list units))) )
(define (units-unit-factor units name)
(%units-unit-factor
(check-units 'units-list units)
(check-unit-name 'units-unit-factor name)) )
(define (units-units-system units)
(%units-database (check-units 'units-list units)) )
;; Units-System Type
(define (%make-units-system name)
(cons name '()) )
(define (%units-system-name db)
(car db) )
(define (%units-system-catalog db)
(cdr db) )
(define (%units-system-catalog-set! db catalog)
(set-cdr! db catalog) )
(define (%units-system-add-units! db units)
(%units-system-catalog-set! db
(cons units (%units-system-catalog db))) )
; the units in db
(define (%units-system-find-units db name)
(find
(lambda (units) (eq? name (%units-name units)))
(%units-system-catalog db)) )
; the 1st units in db with unit
(define (%units-system-find-units/unit db name)
; %units-unit-factor used here as an existence test
(find
(lambda (units) (and (%units-unit-factor units name) units))
(%units-system-catalog db)) )
; returns the actual unit or #f
#; ;UNUSED
(define (%units-system-find-unit db name)
(find
(lambda (units) (%units-ref units name))
(%units-system-catalog db)) )
; returns the actual unit or #f
(define (%units-system-unit-factor db name)
(find
(lambda (units) (%units-unit-factor units name))
(%units-system-catalog db)) )
; remove the units object
#; ;UNUSED
(define (%units-system-delete-units! db units)
(%units-system-catalog-set! db
(delete units (%units-system-catalog db) eq?)) )
; remove every units with the same name
(define (%units-system-remove-units!/name db name)
(%units-system-catalog-set! db
(remove
(lambda (units) (eq? name (%units-name units)))
(%units-system-catalog db))) )
(define (%units-system-update-units! db units)
(let ((units-catalog (%units-system-catalog db))
(name (%units-name units)) )
(cond
((memq units units-catalog)
)
((%units-system-find-units db name)
(%units-system-remove-units!/name db name)
(%units-system-add-units! db units) )
(else
(%units-system-add-units! db units) ) ) ) )
;;
(define (units-system? obj)
(and (pair? obj)
(units-system-name? (car obj))
(every units? (cdr obj))) )
(define-check+error-type units-system)
(define (make-units-system name)
(%make-units-system (check-units-system-name 'make-units-system name)) )
(define-checked-variable default-units-system
(make-units-system 'default)
units-system)
(define (units-system-name #!optional (db (default-units-system)))
(%units-system-name (check-units-system 'units-system-units db)) )
(define (units-system-catalog #!optional (db (default-units-system)))
(list-copy
(%units-system-catalog (check-units-system 'units-system-catalog db))) )
; returns the units in unit-system by name
(define (units-system-units name #!optional (db (default-units-system)))
(%units-system-find-units (check-units-system 'units-system-units db) name) )
; returns the units in unit-system with unit by name
(define (units-system-units/unit name #!optional (db (default-units-system)))
(%units-system-find-units/unit (check-units-system 'units-system-units db) name) )
; adds units to db catalog, replacing any existing units of the same name
(define (units-system-add-units! units #!optional (db (default-units-system)))
(%units-system-update-units! (check-units-system 'units-system-units db) units) )
;; Quantity Value
(define-syntax quantity
(syntax-rules (system:)
((_ ?n ?unit-name system: ?db)
(quantity ?n ?unit-name (units-system-units/unit '?unit-name ?db)) )
((_ ?n ?unit-name ?units-name system: ?db)
(quantity ?n ?unit-name (units-system-units '?units-name ?db)) )
((_ ?n ?unit-name)
(quantity ?n ?unit-name system: (default-units-system)) )
((_ ?n ?unit-name ?units)
(make-quantity ?n '?unit-name ?units) ) ) )
(define (make-quantity n name units)
(check-units 'make-quantity units)
((units-factor-scale) n (%units-unit-factor units name)) )
;;
(define-syntax make-units
(syntax-rules ()
((_ ?arg ...)
(muaux #f ?arg ...) ) ) )
(define-syntax make-units*
(syntax-rules ()
((_ ?arg ...)
(muaux #t ?arg ...) ) ) )
(define-syntax muaux
(syntax-rules (system:)
((_ ?lonely? ?name ?base system: ?db ?units ...)
(*make-units '?name '?base (list '?units ...) ?lonely? ?db) )
((_ ?lonely? ?name ?base ?units ...)
(muaux ?lonely? ?name ?base system: (default-units-system) ?units ...) ) ) )
;;
; Any external unit dependencies must be on resolved units!
; Only internal unresolved unit dependencies handled.
(define (*make-units name base units-spec standalone? db)
; cannot change during resolution
(define factor? (units-number-predicate))
(define scale (units-factor-scale))
; during resolution a units is an alist
(define (unit-ref name units-tbl) (assq name units-tbl))
; ::= ( . ...)
; ::=
; |
; | (...) ;what does this mean?
(define (check-unit unit-spec)
; check unit-spec-value
(define (check-unit-value x)
(cond
((or (factor? x) (unit-name? x))
x )
((pair? x)
(let ((hd (check-unit-value (car x))))
; don't follow empty tail
(if (null? (cdr x)) hd
(let ((tl (check-unit-value (cdr x))) )
(if (list? hd) (append hd tl) ;flatten for now
(cons hd tl) ) ) ) ) )
(else
(error 'make-units
"invalid unit-value - not a unit value specification" x) ) ) )
(cons
(check-unit-name 'make-units (car unit-spec))
(check-unit-value (cdr unit-spec))) )
; ::= ( . )
;
; resolve-unit-spec-value = (scale (resolve-factor )...)
; resolve-factor =
; with item =
; ((factor? item) -> item)
; ((name? item) -> (unit-value (resolve-unit-ref item)))
;
; resolve-unit-ref =
(define (resolve-unit unit units trail)
(define (error-depends name trail)
(error 'make-units
(apply string-append
(intersperse (map symbol->string (reverse (cons name trail)))
" depends on "))) )
(define (check-depends name trail)
(if (memq name trail) (error-depends name trail)
name ) )
; resolves the value-spec only so returns a number
(define (resolve-value value trail)
; value is an unresolved unit value specificaton
(cond
; already resolved?
((factor? value)
value )
; unresolved unit reference?
((unit-name? value)
; look in this units first for a dependency
(let* ((name (check-depends value trail)) ;check for a dependency loop
(unit (unit-ref name units)) )
; a dependency on unit in this units is resolved recursively
(if unit
(resolve-value (%unit-value unit) (cons (%unit-name unit) trail))
; maybe dependency on unit in an external units
; (external units unit must be resolved to factor)
(let ((val (%units-system-unit-factor db name)))
(cond
((not val)
(error 'make-units "dependence on undefined unit" name) )
((factor? val)
val )
(else
(error 'make-units "dependence on unresolved unit" name) ) ) ) ) ) )
; scale by remaining unresolved unit-value-spec
; we know that the 1st value-spec-item here is a number
(else
(scale (car value) (resolve-value (cdr value) trail)) ) ) )
(let ((value (cdr unit)))
; when already resolved (w/o dependenies) just return the identity
(if (factor? value) unit
; value = (factor ... unit-name)
(let ((name (car unit)))
; resolve unit-value expression
(%make-unit
(check-depends name trail) ;check for a dependency loop
(resolve-value value (cons name trail))) ) ) ) )
;
(check-units-name 'make-units name "units-name")
(check-unit-name 'make-units base "base-unit-name")
(check-units-system 'make-units db "units-system")
(check-list 'make-units units-spec)
; Refine unitset form -> units type
(let ((units (plist->alist units-spec)) )
(let ((units (cons (%make-unit base 1) (map check-unit units))))
(let ((units (map (cut resolve-unit <> units '()) units)))
(let ((units (%make-units name base (%make-units-database units) db)))
(unless standalone? (%units-system-update-units! db units))
units ) ) ) ) )
) ;module simple-units