;; write-real.ss: procedures for writing formatted real numbers in Scheme

;; John David Stone
;; Department of Mathematics and Computer Science
;; Grinnell College

;; April 10-11, 1997

;; My objective is to write out any given real number, to a specified
;; output port (assumed to be open), right-justified in a field of
;; specified width (as measured in columns), rounded to a specified number
;; of places after the decimal point.  For instance, the call 
;;
;;                   (write-real 3.14159 12 3 target)
;;
;; causes the twelve-character string "       3.142" to be written to the
;; output port that is the current value of TARGET. 

;; It is an error if the first argument is not a real number, or the second
;; argument is not an integer, or the third argument is not a natural
;; number, or the fourth argument is not an output port.

;; Chez Scheme's REAL? predicate returns #T for some values that are not,
;; in fact, real numbers -- IEEE floating-point positive and negative
;; infinites and NaN (``not a number'') values.  It is an error for the
;; first argument to be one of these.

;; If the real number is negative, a minus sign is written just before the
;; first digit of the number.  It is possible for the minus sign to precede
;; a numeral containing no digits other than zero; for instance, the call 
;;
;;                    (write-real -0.0001 6 2 target)
;;
;; writes " -0.00" to TARGET.  A digit is printed to the left of the
;; decimal point even if the real number is between -1 and +1.

;; If the number of characters in the written representation of the number,
;; rounded to the specified number of decimal places and prefixed if
;; necessary by the minus sign, is greater than the specified field width,
;; the full representation is nevertheless written to the specified output
;; port, with no leading spaces.  This condition is always satisfied if
;; the field-width is non-positive, so the programmer can supply a
;; field-width of, say, 0 to ensure that the numeral occupies the least
;; possible number of columns.

;; If the third argument (the ``fraction length'') is zero, the real number
;; is rounded to the nearest integer and the decimal point is suppressed.
;; It is possible for the written representation to be "-0" in this case,
;; too; this occurs whenever the value to be printed is less than 0 and
;; greater than -0.5.

;; The fourth argument may be omitted, in which case the formatted value
;; is written to the current output port.

(define write-real
  (lambda (num field-width fraction-length . optional-target)

    ;; Recover the optional argument, if it is present.

    (let ((target
           (cond ((null? optional-target)
                  (current-output-port))
                 ((null? (cdr optional-target))
                  (car optional-target))
                 (else (error 'write-real 
                              "No more than four arguments are permitted")))))

      ;; Make sure the preconditions are satisfied.

      (if (not (strictly-real? num))
          (error 'write-real "The first argument must be a real number"))
      (if (not (integer? field-width))
          (error 'write-real "The field width must be an integer"))
      (if (or (not (integer? fraction-length))
              (negative? fraction-length))
          (error 'write-real "The fraction length must be a natural number"))
      (if (not (output-port? target))
          (error 'write-real "The fourth argument must be an output port"))

      ;; The plan is to build the numeral as a string, compute the number
      ;; of spaces needed to pad it to the correct field width, write out 
      ;; exactly that many spaces, and then write out the numeral.

      (let* ((numeral (number->numeral num fraction-length))
             (len (string-length numeral)))
        (if (< len field-width)
            (display (make-string (- field-width len) #\space) target))
        (display numeral target)))))

;; The STRICTLY-REAL? procedure determines whether its argument is a real
;; number in the strict sense -- an IEEE floating-point value other than an
;; infinity or a not-a-number.

(define strictly-real?
  (lambda (obj)
    (and (real? obj)
         (or (<= obj 0) (<= 0 obj)) ; A not-a-number value fails this test.
         (or (zero? obj)
             (not (= obj (/ obj 2))))))) ; An infinity fails this test.

;; The hard work of actually building the numeral is deferred to the
;; NUMBER->NUMERAL procedure, which takes a real number and the number of
;; decimal places that are supposed to be visible and returns the string
;; denoting the appropriately rounded value.

(define number->numeral
  (lambda (num fraction-length)

    ;; Test the preconditions.

    (if (not (strictly-real? num))
        (error 'number->numeral
               "The first argument must be a real number"))
    (if (or (not (integer? fraction-length))
            (negative? fraction-length))
        (error 'number->numeral
               "The second argument must be a natural number"))

    ;; Determine first whether a minus sign is needed, and subsequently
    ;; consider only the absolute value of the number until the very last
    ;; step.

    (let ((sign (if (negative? num) "-" ""))
          (absnum (abs num)))

      ;; Separate the number into its whole and fractional parts.

      (let* ((whole (trunc absnum))        ;; WHOLE is an exact integer.
             (fraction (- absnum whole)))

        ;; As an intermediate stage, ``explode'' WHOLE into a list of
        ;; single-digit integers.

        (let ((whole-digit-list (explode-into-digits whole)))

          ;; Recover the first FRACTION-LENGTH digits of FRACTION as
          ;; another list of single-digit integers; retain the left-over
          ;; remainder, appropriately scaled up.

          (let ((recovered
                 (recover-digits-from-fraction fraction fraction-length)))

            ;; The reason for keeping the residue around is to be able to
            ;; round the last digit of the numeral correctly; it must be 
            ;; rounded up if the residue is 0.5 or more.  A difficulty
            ;; arises if the digit to be rounded up is a 9:  The rounding
            ;; causes a carry, which must be propagated through
            ;; successively more significant digits as long as all of them
            ;; are 9s.  The PROPAGATE-CARRY procedure manages the details
            ;; of this process and returns a pair in which the car is the
            ;; list of digits of the whole part and the cdr is the list of
            ;; digits of the fractional part, now correctly rounded. 
            
            (let ((digit-lists (propagate-carry whole-digit-list
                                                (car recovered)
                                                (cdr recovered))))

              ;; Now we have all the pieces.  Recover the revised
              ;; digit-lists and convert each digit to the appropriate
              ;; character representation.  String together the sign, the
              ;; digits making up the whole part, a decimal point if
              ;; necessary, and the digits making up the fractional part;
              ;; return the resulting string. 

              (string-append
               sign
               (apply string (map digit->char (car digit-lists)))
               (if (zero? fraction-length) "" ".")
               (apply string (map digit->char (cdr digit-lists)))))))))))

;; The TRUNC procedure recovers the integer part of any non-negative
;; real, as an exact value.

(define trunc
  (lambda (num)

    ;; Test the precondition.

    (if (or (not (strictly-real? num))
            (negative? num))
        (error 'trunc "The argument must be a non-negative real number"))

    ;; Apply TRUNCATE and force the result to be exact.

    (inexact->exact (truncate num))))

;; The EXPLODE-INTO-DIGITS procedure takes any non-negative exact integer as
;; argument and returns the list of single-digit integers that are the
;; positional weights of the digits of the decimal numeral for the given
;; integer.  For instance, the call
;;
;;                      (explode-into-digits 3875)
;;
;; yields the list (3 8 7 5).

;; The first element of the list returned by EXPLODE-INTO-DIGITS is never
;; 0, except that (explode-into-digits 0) returns (0).

(define explode-into-digits
  (lambda (num)

    ;; Test the precondition.

    (if (or (not (integer? num))
            (inexact? num)
            (negative? num))
        (error 'explode-into-digits
               "The argument must be an exact non-negative integer"))

    ;; Start with the least significant digit of NUM; place it on the list
    ;; SO-FAR of digits so far recovered.  Divide by 10.  If the result is
    ;; zero, you're done; otherwise, prepend the least significant digit
    ;; of the remaining number to SO-FAR and repeat.

    (let loop ((rest (quotient num 10))
               (so-far (list (remainder num 10))))
      (if (zero? rest)
          so-far
          (loop (quotient rest 10)
                (cons (remainder rest 10) so-far))))))

;; The RECOVER-DIGITS-FROM-FRACTION procedure takes two arguments, the
;; first of which is a non-negative real number less than 1 and the second
;; of which is a natural number, and recovers a number of digits specified
;; by the second argument from the decimal expansion of the first argument.
;; It returns a pair in which the car is a list of integers in the range
;; from 0 to 9, giving the successive digits of the fractional part (most
;; significant digit first) and the cdr is a ``residue'' -- the part of the
;; fractional part that is left over after these digits have been
;; generated, scaled up by a factor of 10^PLACES.

;; For example, the call
;;
;;              (recover-digits-from-fraction 0.00390625 5)
;;
;; yields ((0 0 3 9 0) . 0.625) -- the car (0 0 3 9 0), the cdr 0.625.

(define recover-digits-from-fraction
  (lambda (fraction places)

    ;; Test the preconditions.

    (if (or (not (real? fraction))
            (negative? fraction)
            (<= 1 fraction))
        (error 'recover-digits-from-fraction
               "The first argument must be a non-negative real less than 1"))
    (if (or (not (integer? places))
            (negative? places))
        (error 'recover-digits-from-fraction
               "The second argument must be a natural number"))

    ;; In the following loop, RESIDUE is again the part of FRACTION not
    ;; yet reduced to digits, PLACES-LEFT is the number of digits that 
    ;; remain to be recovered from RESIDUE, and RESULT is the list of
    ;; the digits so far recovered.

    (let loop ((residue fraction)
               (places-left places)
               (result '()))
      (if (zero? places-left)

          ;; At the end of the process, simply pair off the list of digits,
          ;; reversed to bring the most significant digit to the front, and
          ;; the residue.

          (cons (reverse result) residue)

          ;; Otherwise, recover the next digit by multiplying the residue
          ;; by 10 and truncating.  Subtract away the value of this digit
          ;; to obtain the next residue, reduce by 1 the number of digits
          ;; yet to be recovered, and attach the newly recovered digit to
          ;; the list.

          (let* ((scaled-residue (* residue 10))
                 (digit (trunc scaled-residue)))
            (loop (- scaled-residue digit)
                  (- places-left 1)
                  (cons digit result)))))))

;; The PROPAGATE-CARRY procedure takes three arguments, two lists of
;; integers in the range from 0 to 9, representing respectively some number
;; of digits preceding and following the decimal point in a numeral that is
;; ultimately to be printed, and a ``residue'' (which must be a
;; non-negative real number less than 1).  If the residue is less than 1/2,
;; the procedure simply constructs and returns a pair from the two lists; but
;; if the residue is greater than or equal to 1/2, PROPAGATE-CARRY adds 1
;; to the least significant digit in the list of digits that will follow
;; the decimal point (or, if that list is empty, to the least significant
;; digit of the other list of digits).  This has the effect of rounding up
;; the least significant digit of the numeral to be printed. 

;; It is, however, possible that the digit to which 1 is added is a 9,
;; in which case the sum is no longer a digit.  In this case, the resulting
;; 10 is changed to a 0, and the increment is carried to the next digit and
;; processed similarly.  If a carry is generated by the most significant
;; digit in the list of digits to follow the decimal point, it is
;; propagated to the least significant digit in the list of digits to
;; that will precede the decimal point; if the carry is propagated all the
;; way to the most significant digit on that list as well, an additional
;; digit 1 is prepended. PROPAGATE-CARRY then pairs the revised lists and
;; returns the pair. 

;; For example, the call
;;
;;               (propagate-carry '(1 4 9) '(9 9 9 9) 0.6)
;;
;; yields the result ((1 5 0) 0 0 0 0) -- the car is (1 5 0), the revised
;; version of (1 4 9), and the cdr is (0 0 0 0), the revised version of
;; (9 9 9 9).  In this case the carry has been propagated through all the
;; digits that will wind up to the right of the decimal point and also
;; through the least significant digit to the left of the decimal point.

(define propagate-carry
  (lambda (before-point after-point residue)

    ;; Test the preconditions.

    (if (or (not (list-of-digits? after-point))
            (not (list-of-digits? before-point)))
        (error 'propagate-carry
               (string-append "The first and second arguments must be "
                              "lists of single-digit integers")))
    (if (or (not (real? residue))
            (negative? residue)
            (<= 1 residue))
        (error 'propagate-carry
               "The third argument must be a non-negative real less than 1"))

    ;; If the residue is less than 1/2, repackage the lists and return.

    (if (< residue 1/2)
        (cons before-point after-point)

        ;; Otherwise, try handling the carry inside AFTER-POINT list.

        (let ((first-try (propagate-through-list after-point)))

          ;; If that works, bundle BEFORE-POINT with the revised list.

          (cons (if (car first-try)
                    before-point

                    ;; Otherwise, try handling the carry inside
                    ;; BEFORE-POINT.

                    (let ((second-try (propagate-through-list before-point)))

                      ;; If that works, bundle the revised lists.

                      (if (car second-try)
                          (cdr second-try)

                          ;; Otherwise, attach a 1 and then bundle.

                          (cons 1 (cdr second-try)))))

                (cdr first-try))))))

;; The LIST-OF-DIGITS? procedure determines whether its argument is a list
;; of integers in the range from 0 to 9 inclusive.

(define list-of-digits?
  (lambda (ls)
    (or (null? ls)
        (and (pair? ls)
             (integer? (car ls))
             (<= 0 (car ls) 9)
             (list-of-digits? (cdr ls))))))

;; The PROPAGATE-THROUGH-LIST procedure takes a list of digits, most
;; significant digit first, and returns a pair in which the car is a
;; Boolean indicating whether it found a digit other than 9 and the cdr
;; is a similar list, but with each 9 that is not followed by any other
;; digit replaced with 0 and the last digit other than 9 (if there is one)
;; incremented by 1. 

;; For instance, the call
;;
;;                 (propagate-through-list '(7 1 2 9 9))
;;
;; yields (#t 7 1 3 0 0) -- the car is #t, indicating that the carry was
;; handled inside the list, and the cdr is (7 1 3 0 0), the revised version
;; of (7 1 2 9 9).

(define propagate-through-list
  (lambda (ls)

    ;; Test the precondition.

    (if (not (list-of-digits? ls))
        (error 'propagate-through-list
               "The argument must be a list of digits"))

    ;; Reverse LS to bring the least significant digit to the front, then
    ;; traverse down the list until either the end of the list or a digit
    ;; other than 9 is encountered.

    (let loop ((rest (reverse ls))
               (so-far '()))

      ;; If there are no more digits to test, the carry cannot be
      ;; accommodated, so return a pair with #F as its car and SO-FAR as
      ;; its cdr.

      (cond ((null? rest) (cons #f so-far))

            ;; If the leading digit of REST is a 9, attach a 0 to SO-FAR
            ;; and recurse.

            ((= (car rest) 9) (loop (cdr rest) (cons 0 so-far)))

            ;; Otherwise, add 1 to the leading digit and return a pair
            ;; consisting of #T and the revised list.

            (else (cons #t (append (reverse (cdr rest))
                                   (list (+ (car rest) 1))
                                   so-far)))))))

;; The DIGIT->CHAR procedure finds and returns the character that
;; represents a given integer in the range from 0 to 9.  It presupposes
;; that the characters #\0 through #\9 are in successive positions in the
;; character set, as they are in ASCII.

(define digit->char
  (lambda (digit)

    ;; Test the precondition.

    (if (or (not (integer? digit))
            (not (<= 0 digit 9)))
        (error 'digit->char "The argument must be a single-digit integer"))

    ;; Think of the digit as a ``distance beyond #\0'' in the character
    ;; set.  Start at the code for #\0, add the distance, return the
    ;; character at the resulting position in the character set.

    (integer->char (+ (char->integer #\0) digit))))

;; Given the utility procedures developed here, it's also easy to put
;; together a corresponding WRITE-INTEGER procedure that outputs an integer
;; value, right-justified in a field of specified (minimum) width:

(define write-integer
  (lambda (num field-width . optional-target)

    ;; Recover the optional argument, if it is present.

    (let ((target
           (cond ((null? optional-target)
                  (current-output-port))
                 ((null? (cdr optional-target))
                  (car optional-target))
                 (else (error 'write-integer
                              "No more than three arguments are permitted")))))

      ;; Make sure the preconditions are satisfied.

      (if (not (strictly-integer? num))
          (error 'write-integer "The first argument must be an integer"))
      (if (not (integer? field-width))
          (error 'write-integer "The field width must be an integer"))
      (if (not (output-port? target))
          (error 'write-integer "The third argument must be an output port"))

      ;; The plan is to build the numeral as a string, compute the number
      ;; of spaces needed to pad it to the correct field width, write out 
      ;; exactly that many spaces, and then write out the numeral.

      (let* ((numeral (integer->numeral num))
             (len (string-length numeral)))
        (if (< len field-width)
            (display (make-string (- field-width len) #\space) target))
        (display numeral target)))))

;; The CONJOIN procedure forms the conjunction of two predicates of arity
;; 1.

(define conjoin
  (lambda (first? second?)
    (lambda (obj)
      (and (first? obj)
           (second? obj)))))

;; In Chez Scheme, the IEEE infinities satisfy INTEGER?, so we need a
;; STRICTLY-INTEGER? procedure that excludes them.

(define strictly-integer?
  (conjoin strictly-real? integer?))

;; The INTEGER->NUMERAL procedure takes any integer as argument and returns,
;; as a string, the decimal numeral for that integer.

(define integer->numeral
  (lambda (num)

    ;; Test the precondition.

      (if (not (strictly-integer? num))
          (error 'integer->numeral "The argument must be an integer"))

    (string-append
     (if (negative? num) "-" "")
     (apply string
            (map digit->char
                 (explode-into-digits (abs (inexact->exact num))))))))


;;;;; write-integer.ss: procedures for writing formatted real numbers in Scheme

;; Henry M. Walker
;; Department of Mathematics and Computer Science
;; Grinnell College

;; January 15, 1998

;;;The following procedure, based on lab work from April 13, 1997, 
;;;prints a formatted integer.

(define formatted-integer
   (lambda (int-value width)
      (if (not (integer? int-value))
          (error 'formatted-integer "cannot format non-integer as integer"))
      (let* ((int-string (number->string int-value))
             (int-length (string-length int-string))
             (number-init-blanks (max (- width int-length) 0))
             (blank-string (make-string number-init-blanks #\space)))
         (string-append blank-string int-string)
      )
   )
)

(define write-int
   (lambda (int-value width . optional-target)
    (let ((target
           (cond ((null? optional-target)
                  (current-output-port))
                 ((null? (cdr optional-target))
                  (car optional-target))
                 (else (error 'write-real 
                              "No more than three arguments are permitted")))))

      ;; Make sure the preconditions are satisfied.

      (if (not (integer? int-value))
          (error 'write-int "The first argument must be an integer"))
      (if (not (integer? width))
          (error 'write-int "The field width must be an integer"))
      (if (not (output-port? target))
          (error 'write-int "The third argument must be an output port"))

      ;; Formatted-integer produces desired string
      (display (formatted-integer int-value width) target))))