;;;; 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' variable is 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-variable)
    (only lookup-table dict-keys dict-values alist->dict dict-ref)
    (only type-checks define-check+error-type check-list)
    (only type-errors warning-argument-type))

  (require-library
    srfi-1 data-structures
    error-utils list-utils symbol-utils
    record-variants
    variable-item
    lookup-table
    type-checks type-errors)

;;

(define-variable units-factor-scale * procedure? 'procedure)

(define-variable units-number-predicate number? procedure? '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?

<procedure>(unit? OBJ) => boolean</procedure>

<procedure>(check-unit LOC OBJ [ARGNAM]) => *</procedure>
<procedure>(error-unit LOC OBJ [ARGNAM])</procedure>

==== unit-name

<procedure>(unit-name UNIT) => symbol</procedure>

==== unit-factor

<procedure>(unit-factor UNIT) => number</procedure>

(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-variable default-units-system (make-units-system 'default)
  units-system? '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))

  ; <unit-spec> ::= (<symbol> . <value-spec-item>...)
  ; <value-spec-item> ::= <symbol>
  ;                     | <number>
  ;                     | (<value-spec-item>...) ;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))) )

  ; <resolved-unit-spec> ::= (<symbol> . <number>)
  ;
  ; resolve-unit-spec-value = (scale (resolve-factor <value-spec-item>)...)
  ; resolve-factor =
  ;   with item = <value-spec-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