; XEmacs: This file contains -*-Scheme-*- source code.

;;; compound: define primitive for a record type that holds information
;;; about the chemical and physical properties of inorganic compounds

;;; John David Stone
;;; Department of Mathematics and Computer Science
;;; Grinnell College
;;; stone@cs.grinnell.edu

;;; created April 21, 2000
;;; last revised April 30, 2001

;;; Thanks to Sam Rebelsky for pointing out an error in a previous
;;; version of this program.

;;; An inorganic compound is usually identified either by its name (e.g.,
;;; ``gadolinium iodide'') or by its chemical formula (``GdI3'').  The
;;; properties that we'll keep track of are its molecular weight (in atomic
;;; units), its melting and boiling points (in degrees Celsius), and its
;;; color (represented by a Scheme symbol).

;;; When we determine whether a real number actually represents a
;;; temperature in degrees Celsius, we'll need to compare it to the number
;;; that represents absolute zero on the Celsius scale.

(define absolute-zero -273.15)

;;; We'll use one particular list containing just the symbol 'COMPOUND as a
;;; difficult-to-forge mark of the compound type.

(define produce-type-mark
  (let ((type-mark (list 'compound)))
    (lambda () type-mark)))

;;; The constructor for a compound checks assembles a vector from the
;;; field values it is given, storing the type mark at the beginning.  It
;;; calls the mutator for each field so that an appropriate precondition
;;; test is performed on each of the given values. 

(define make-compound
  (lambda (name formula molecular-weight melting-point boiling-point color)
    (let ((result (make-vector 7)))
      (vector-set! result 0 (produce-type-mark))
      (compound-name-set! result name)
      (compound-formula-set! result formula)
      (compound-molecular-weight-set! result molecular-weight)
      (compound-melting-point-set! result melting-point)
      (compound-boiling-point-set! result boiling-point)
      (compound-color-set! result color)
      result)))

;;; To select a field, call VECTOR-REF to pick it out of the correct
;;; position.

(define compound-name
  (lambda (c)
    (vector-ref c 1)))

(define compound-formula
  (lambda (c)
    (vector-ref c 2)))

(define compound-molecular-weight
  (lambda (c)
    (vector-ref c 3)))

(define compound-melting-point
  (lambda (c)
    (vector-ref c 4)))

(define compound-boiling-point
  (lambda (c)
    (vector-ref c 5)))

(define compound-color
  (lambda (c)
    (vector-ref c 6)))

;;; To modify a field, perform the appropriate precondition test on the
;;; field value and invoke VECTOR-SET! if it is met.

(define compound-name-set!
  (lambda (c name)
    (if (string? name)
        (vector-set! c 1 name)
        (error 'compound-name-set!
               "The name of a compound must be a string."))))

(define compound-formula-set!
  (lambda (c formula)
    (if (string? formula)
        (vector-set! c 2 formula)
        (error 'compound-formula-set!
               "The formula for a compound must be a string."))))

(define compound-molecular-weight-set!
  (lambda (c molecular-weight)
    (if (and (real? molecular-weight)
             (positive? molecular-weight))
        (vector-set! c 3 molecular-weight)
        (error 'compound-molecular-weight-set!
               "The molecular weight of a compound must be a positive real number."))))

(define compound-melting-point-set!
  (lambda (c melting-point)
    (if (and (real? melting-point)
             (<= absolute-zero melting-point))
        (vector-set! c 4 melting-point)
        (error 'compound-melting-point-set!
               (string-append
                 "The melting point of a compound must be a real number greater than "
                 (number->string absolute-zero)
                 ".")))))

(define compound-boiling-point-set!
  (lambda (c boiling-point)
    (if (and (real? boiling-point)
             (<= absolute-zero boiling-point))
        (vector-set! c 5 boiling-point)
        (error 'compound-boiling-point-set!
               (string-append
                 "The boiling point of a compound must be a real number greater than "
                 (number->string absolute-zero)
                 ".")))))

(define compound-color-set!
  (lambda (c color)
    (if (symbol? color)
        (vector-set! c 6 color)
        (error 'compound-color-set!
               "The color of a compound must be a Scheme symbol."))))

;;; The type predicate, COMPOUND?, checks to make sure that the given
;;; object is a vector of the appropriate length, with the type mark as its
;;; first element, containing values that meet the various preconditions.

(define compound?
  (lambda (something)
    (and (vector? something)
         (= (vector-length something) 7)
         (eq? (vector-ref something 0) (produce-type-mark))
         (string? (vector-ref something 1))
         (string? (vector-ref something 2))
         (real? (vector-ref something 3))
         (positive? (vector-ref something 3))
         (real? (vector-ref something 4))
         (<= absolute-zero (vector-ref something 4))
         (real? (vector-ref something 5))
         (<= absolute-zero (vector-ref something 5))
         (symbol? (vector-ref something 6)))))

;;; We determine whether two compounds are identical by making sure that
;;; corresponding fields are equal in the appropriate sense.

(define compound=?
  (lambda (left right)
    (and (string-ci=? (compound-name left) (compound-name right))
         (string=? (compound-formula left) (compound-formula right))
         (= (compound-molecular-weight left)
            (compound-molecular-weight right))
         (= (compound-melting-point left) (compound-melting-point right))
         (= (compound-boiling-point left) (compound-boiling-point right))
         (eq? (compound-color left) (compound-color right)))))

;;; The copier for compounds allocates a new vector and stores in it
;;; separately allocated copies of the string fields, transferring the
;;; values of the other fields without change.

(define compound-copy
  (lambda (original)
    (make-compound (string-copy (compound-name original))
                   (string-copy (compound-formula original))
                   (compound-molecular-weight original)
                   (compound-melting-point original)
                   (compound-boiling-point original)
                   (compound-color original))))

;;; The displayer for compounds displays the value of each field, prefixed
;;; with the name of the field, a colon and a space.  The fields are
;;; enclosed in parentheses, and a comma and a space separate adjacent
;;; fields.  The whole is prefixed with #compound to indicate the type.

;;; The displayer expects a compound as its first argument and allows, but
;;; does not require, a second argument, which it expects to be an output
;;; port.  If the second argument is present, the compound is displayed
;;; through that port.  Otherwise, the current default output port is
;;; used.

(define compound-display
  (lambda (scribend . optional)
    (let ((out (if (null? optional) (current-output-port) (car optional))))
      (display "#compound(" out)
      (display "name" out)
      (display ": " out)
      (display (compound-name scribend) out)
      (display ", " out)
      (display "formula" out)
      (display ": " out)
      (display (compound-formula scribend) out)
      (display ", " out)
      (display "molecular-weight" out)
      (display ": " out)
      (display (compound-molecular-weight scribend) out)
      (display ", " out)
      (display "melting-point" out)
      (display ": " out)
      (display (compound-melting-point scribend) out)
      (display ", " out)
      (display "boiling-point" out)
      (display ": " out)
      (display (compound-boiling-point scribend) out)
      (display ", " out)
      (display "color" out)
      (display ": " out)
      (display (compound-color scribend) out)
      (display ")" out))))