#!/u/annis/local/bin/csi -script
;;; -*- scheme -*-
;;; $Id: out.scm,v 1.3 2005-02-25 08:49:05-06 annis Exp $
;;; $Source: /u/annis/code/chicken/lib/RCS/out.scm,v $
;;;
;;; Copyright (c) 2005 William S. Annis.  All rights reserved.
;;; This is free software; you can redistribute it and/or modify it
;;; under the same terms as Perl (the Artistic Licence).  Developed at
;;; the Department of Biostatistics and Medical Informatics, University
;;; of Wisconsin, Madison.
;;;
;;; Hide format ugliness.
;;;
;;; Format's control strings can be a bit ugly.  For a lot of quite
;;; basic formatting, especially of numbers, the format control string
;;; is nasty all out of proportion to what it is supposed to accomplish.
;;; Also, it is vexing to have to do indexing by eyeballs, matching
;;; each ~a ~d, etc. to the correct variable.
;;;
;;; The out fuction attempts to make easy things easy.
;;;
;;; Inspired in part by the YTools out macro:
;;;     http://cs-www.cs.yale.edu/homes/dvm/papers/ytdoc.pdf
;;; But also a bit like C++ cout.
;;; For details on CL format see:
;;;     http://www-2.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/clm/node200.html
;;;

(require-extension format)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The manipulation environment - a vector of settings.
;;; Elements:
;;;   number width - how much padding
;;;   non-number width 
;;;   number-fill-character - what use when width is not met
;;;   non-number-fill - the non-numberic fill
;;;   precision - for floats, how much after the decimal point?
;;;   base-format D for decimal, B binary, O octal, X hex
;;; These are used to build a format string, so null strings are the
;;; default in many cases.

(define (make-m-env)
  (vector 0 0 "0" "" "" "D"))

(define (m-env-num-width-set! m-env w)
  (vector-set! m-env 0 w))

(define (m-env-width-set! m-env w)
  (vector-set! m-env 1 w))

(define (m-env-num-fill-set! m-env f)
  (vector-set! m-env 2 f))

(define (m-env-fill-set! m-env f)
  (vector-set! m-env 3 f))

(define (m-env-precision-set! m-env p)
  (vector-set! m-env 4 p))

(define (m-env-base-set! m-env b)
  (vector-set! m-env 5 b))

(define (m-env-reset! m-env)
  (m-env-num-width-set! m-env 0)
  (m-env-width-set! m-env 0)
  (m-env-num-fill-set! m-env "0")
  (m-env-fill-set! m-env " ")
  (m-env-precision-set! m-env "")
  (m-env-base-set! m-env "D"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Manipulation of the output stream is handled by guide keywords,
;;; which I call "manipulators" thanks to C++.

(define *out-manipulators* 
  '(#:nl #:width #:nwidth #:number-width 
         #:fillchar #:nfillchar #:number-fillchar #:dec #:hex #:oct #:bin
         #:reset #:precision))

(define (manipulator? s)
  (and (keyword? s)
       (member s *out-manipulators*)))

;;; Certain manipulators take an argument.  This test return the
;;; array incrementor so that any argument is skipped, not printed.
(define (manipulator-argc m)
  (if (member m '(#:width #:nwidth #:number-width
                  #:fillchar #:number-fillchar #:precision)) 2 1))

(define (handle-manipulator m m+1 m-env)
  (case m
    ((#:nl) (newline))
    ((#:dec) (m-env-base-set! m-env "D"))
    ((#:bin) (m-env-base-set! m-env "B"))
    ((#:oct) (m-env-base-set! m-env "O"))
    ((#:hex) (m-env-base-set! m-env "X"))
    ((#:reset) (m-env-reset! m-env))
    ((#:precision) (m-env-precision-set! m-env m+1))
    ((#:width) (m-env-width-set! m-env m+1))
    ((#:nwidth #:number-width) (m-env-num-width-set! m-env m+1))
    ((#:fillchar) (m-env-fill-set! m-env m+1))
    ((#:nfillchar #:number-fillchar) (m-env-num-fill-set! m-env m+1))))

;;; Use format to build a format string from the manipulation environment.
(define (format-string-env type m-env)
  (match-let ((#(n-width width n-fill fill precision basechar) m-env))
    (case type
      ((inexact) (format "~~~a,~a,,,'~af" n-width precision n-fill))
      ((exact) (format "~~~a,'~a~a" n-width n-fill basechar))
      (else (format "~~~a,,,'~a@a" width fill)))))

;;; Dispatch on type to the correct formatter.
(define (out-display s m-env)
  (cond ((and (number? s) (inexact? s))
         (display (format (format-string-env 'inexact m-env) s)))
        ((and (number? s) (exact? s))
         (display (format (format-string-env 'exact m-env) s)))
        (else (display (format (format-string-env 'else m-env) s)))))


;;; I start off by converting the arguments into a vector.  Several of
;;; the manipulators take arguments - the next item - and it's easier
;;; to alter an increment than do a test for cdr/cddr later.
(define (out . r)
  (let* ((s (apply vector r))
         (end (- (vector-length s) 1))
         (inc 1)
         (m-env (make-m-env)))
    (let loop ((i 0))
      ;; inc will be set to two for manipulators that take an argument
      (set! inc 1)
      (let ((current (vector-ref s i))
            (current+1 (if (< (+ i 1) end)
                           (vector-ref s (+ i 1))
                           #f)))
        (cond ((manipulator? current)
               (handle-manipulator current current+1 m-env)
               (set! inc (manipulator-argc current)))
              (else (out-display current m-env))))
      (if (< i end) (loop (+ i inc))))))


;;; Local Variables: ***
;;; mode: hen ***
;;; End: ***