;;; File:
;;;   compound.ss
;;; Version:
;;;   1.3 of November 2006
;;; Purpose:
;;;   Define primitives for a record type that holds information
;;;   about the chemical and physical properties of inorganic compounds
;;;   (Sounds fascinating, doesn't it?)
;;; Authors:
;;;   John David Stone (original author)
;;;   Sam Rebelsky (updater)
;;; Contents:
;;;   Introductory Notes:
;;;   Constants:
;;;     absolute-zero: Lowest legal temperature
;;;   Utilities:
;;;     (compound-type-mark)
;;;       Create a hard-to-duplicate value to be used to mark
;;;       the type of the record.
;;;   Constructors:
;;;     (make-compound name formula molecular-weight 
;;;                    melting-point boiling-point color)
;;;       Make a new compound
;;;   Selectors:
;;;     (get-compound-name compound)
;;;     (get-compound-formula compound)
;;;     (get-compound-molecular-weight compound)
;;;     (get-compound-melting-point compound)
;;;     (get-compound-boiling-point compound)
;;;     (get-compound-color compound)
;;; History:
;;;;  At end.

; +--------------+----------------------------------------------------
; | Design Notes |
; +--------------+

; 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).

; Compounds are stored as vectors in which element 0 is a special
; value (the ``type mark'') which identifies the vector as something
; used to represent a compound.  The type mark is intentionally
; hard to reproduce.


; +-----------------+-------------------------------------------------
; | Local Constants |
; +-----------------+

;;; Name:
;;;   absolute-zero
;;; Type:
;;;   Real number
;;; Purpose:
;;;   To represent absolute zero in Celsius.  We can use this when
;;;   checking whether another number is a temperature.
(define absolute-zero -273.15)


; +-----------------+-------------------------------------------------
; | Local Utilities |
; +-----------------+

;;; Procedure:
;;;   compound-type-mark
;;; Parameters:
;;;   None
;;; Purpose:
;;;   To build a special identifier to mark this type.
;;; Produces:
;;;   type-mark, a type mark
;;; Preconditions:
;;;   None
;;; Postconditions:
;;;   type-mark will only be equivalent (eqv?) to itself.
;;; Note:
;;;   We'll use one particular list containing just the symbol 'compound 
;;;   as a difficult-to-forge mark of the compound type.  Why is this 
;;;   mark difficult to forge?  Because another (list 'compound) will 
;;;   use a different cons cell and therefore be different.
(define compound-type-mark
  (let ((type-mark (list 'compound)))
    (lambda () type-mark)))


; +--------------+----------------------------------------------------
; | Constructors |
; +--------------+

;;; Procedure:
;;;   make-compound
;;; Parameters:
;;;   name, a string
;;;   formula, a string
;;;   molecular-weight, a positive real number
;;;   melting-point, a real number
;;;   boiling-point, a real number
;;;   color, a symbol
;;; Purpose:
;;;   Assembles a compound from the field values it is given.
;;; Produces:
;;;   compound, a compound
;;; Preconditions:
;;;   The type preconditions above must be met [Verified].
;;; Postconditions:
;;;   compound is a valid compound.
;;; Implementation Note:
;;;   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 (compound-type-mark))
      (set-compound-name! result name)
      (set-compound-formula! result formula)
      (set-compound-molecular-weight! result molecular-weight)
      (set-compound-melting-point! result melting-point)
      (set-compound-boiling-point! result boiling-point)
      (set-compound-color! result color)
      result)))


; +-----------+-------------------------------------------------------
; | Selectors |
; +-----------+

;;; Procedures:
;;;   get-compound-name
;;;   get-compound-formula
;;;   get-compound-molecular-weight
;;;   get-compound-melting-point
;;;   get-compound-boiling-point
;;;   get-compound-color
;;; Purpose:
;;;   Extract a field from a compound.
;;; Produces:
;;;   A name, formula, ..., or color.
;;;   Names and formulae are strings.
;;;   Molecular weights, melting points, and boiling points
;;;     are real numbers.
;;;   Colors are symbols.
;;; Preconditions:
;;;   Must be a valid compound created by make-compound. [Unverified]
;;; Postconditions:
;;;   Returns the specified field.
;;; Implementation note:
;;;   To select a field, call VECTOR-REF to pick it out of the 
;;;   correct position.

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

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

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

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

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

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


; +----------+--------------------------------------------------------
; | Mutators |
; +----------+

;;; Procedures:
;;;   set-compound-name!
;;;   set-compound-formula!
;;;   set-compound-molecular-weight!
;;;   set-compound-melting-point!
;;;   set-compound-boiling-point!
;;;   set-compound-color!
;;; Parameters:
;;;   c, a compound
;;;   val, a value of the appropriate tpe
;;; Purpose:
;;;   Sets one field of a compound record.
;;; Produces:
;;;   [Nothing.  Called only for side effects.]
;;; Preconditions:
;;;   val is a valid value for the appropriate field.  For
;;;     example, for set-compound-melting-point!, it must be
;;;     a real number at least as large as absolute zero.
;;; Postconditions:
;;;   The compound has been modified appropriately.
;;; Plan:
;;;   To modify a field, perform the appropriate precondition test 
;;;   on the field value and invoke VECTOR-SET! if it is met.

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

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

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

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

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

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

;;; Procedure:
;;;   compound?
;;; Parameters:
;;;   something, a Scheme value
;;; Purpose:
;;;   Determine if something is a compound.
;;; Produces:
;;;   is-compound, a truth value.
;;; Preconditions:
;;;   [None]
;;; Postconditions:
;;;   is-compound is true if something is a vector of the appropriate 
;;;     length, with the type mark as its first element, containing 
;;;     values that meet the various preconditions.
;;;   is-compound is false otherwise.
(define compound?
  (lambda (something)
    (and (vector? something)
         (= (vector-length something) 7)
         (eq? (vector-ref something 0) (compound-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)))))

;;; Procedure:
;;;   compound=?
;;; Parameters:
;;;   left, a compound
;;;   right, a compound
;;; Purpose:
;;;   Determines whether left and right are the same compound.
;;; Produces:
;;;   same-compound, a truth value
;;; Preconditions:
;;;   [Standard]
;;; Postconditions:
;;;   same-compound is true of the two compounds have the same formula,
;;;     molecular weight, melting point, boiling point, and color.
;;;   same-compound is false otherwise.
;;; Philosophy:
;;;   The name of the compound isn't really relevant, so it's not
;;;     used in comparisons.
(define compound=?
  (lambda (left right)
    (and (string=? (get-compound-formula left) (get-compound-formula right))
         (= (get-compound-molecular-weight left)
            (get-compound-molecular-weight right))
         (= (get-compound-melting-point left) 
            (get-compound-melting-point right))
         (= (get-compound-boiling-point left) 
            (get-compound-boiling-point right))
         (eq? (get-compound-color left) (get-compound-color right)))))


;;; Procedure:
;;;   compound-copy
;;; Parameters:
;;;   original, a compound
;;; Purpose:
;;;   Make a copy of original.
;;; Produces:
;;;   duplicate, a compound
;;; Preconditions:
;;;   [Standard]
;;; Postconditions:
;;;   duplicate is a compound that is equal to the original and
;;;     has the same name.
;;; Plan:
;;;   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 (get-compound-name original))
                   (string-copy (get-compound-formula original))
                   (get-compound-molecular-weight original)
                   (get-compound-melting-point original)
                   (get-compound-boiling-point original)
                   (get-compound-color original))))


; +--------+----------------------------------------------------------
; | Output |
; +--------+

;;; Procedure:
;;;   compound-display
;;; Parameters:
;;;   scribend, a compound
;;;   port, an output port [optional]
;;; Purpose:
;;;   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 newline and indentation separate 
;;;     fields.  The whole is prefixed with #compound to indicate 
;;;     the type.
;;; Produces:
;;;   [Nothing. Called for the side effect.]
;;; Preconditions:
;;;   port, if included, is open for writing.
;;; Postconditions:
;;;  If the port is included, the compound is displayed through that port.  
;;;  Otherwise, the compound is displayed to the current default
;;;    output port.
(define compound-display
  (lambda (scribend . optional)
    (let ((out (if (null? optional) (current-output-port) (car optional))))
      (display "#compound(" out)
      (display "name: " out)
      (display (get-compound-name scribend) out)
      (newline out)
      (display "          " out)
      (display "formula: " out)
      (display (get-compound-formula scribend) out)
      (newline out)
      (display "          " out)
      (display "molecular-weight: " out)
      (display (get-compound-molecular-weight scribend) out)
      (newline out)
      (display "          " out)
      (display "melting-point: " out)
      (display (get-compound-melting-point scribend) out)
      (newline out)
      (display "          " out)
      (display "boiling-point: " out)
      (display (get-compound-boiling-point scribend) out)
      (newline out)
      (display "          " out)
      (display "color: " out)
      (display (get-compound-color scribend) out)
      (display ")" out)
      (newline out))))

; +---------+---------------------------------------------------------
; | History |
; +---------+

; April 21, 2000 [JDS, v1.0]
; * Created

; Monday, 27 November 2000 [SR, v1.1]
; * Updated some comments
; * Still have lots more to go!

; Monday, 30 April 2001 [SR, v1.1.1]
; * Continued updating comments.

; Tuesday, 29 April 2003 [SR, v1.1.2]
; * Finished adding and updating comments.

; Sunday, 19 November 2006 [SR, v 1.3]
; * Converted to new commenting style.
; * Other, minor, updates.