;;;;
;;;; 48.stk    -- Implementation of SRFI-48
;;;;
;;;; Copyright © 2004-2022 Erick Gallesio - I3S-CNRS/ESSI <eg@essi.fr>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@essi.fr]
;;;;    Creation date: 23-Apr-2004 21:19 (eg)
;;;;
;;;;
;;;; Most of the implementation is done in C. The part which are
;;;; implemented here, are the
;;;;     ~H format (to avoid to load a big string in the interpreter
;;;;     ~wF format
;;;;
;;;; They are taken from the reference implementation given in the
;;;; SRFI itself. This implementation has the following copyright
;;;;
;;;;     Copyright (C) Kenneth A Dickey (2003). All Rights Reserved.
;;;;
;;;;     This document and translations of it may be copied and furnished
;;;;     to others, and derivative works that comment on or otherwise
;;;;     explain it or assist in its implementation may be prepared,
;;;;     copied, published and distributed, in whole or in part, without
;;;;     restriction of any kind, provided that the above copyright notice
;;;;     and this paragraph are included on all such copies and derivative
;;;;     works. However, this document itself may not be modified in any
;;;;     way, such as by removing the copyright notice or references to
;;;;     the Scheme Request For Implementation process or editors, except
;;;;     as needed for the purpose of developing SRFIs in which case the
;;;;     procedures for copyrights defined in the SRFI process must be
;;;;     followed, or as required to translate it into languages other
;;;;     than English.
;;;;
;;;;     The limited permissions granted above are perpetual and will not
;;;;     be revoked by the authors or their successors or assigns.
;;;;
;;;;     This document and the information contained herein is provided on
;;;;     an "AS IS" basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL
;;;;     WARRANTIES, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY
;;;;     WARRANTY THAT THE USE OF THE INFORMATION HEREIN WILL NOT INFRINGE
;;;;     ANY RIGHTS OR ANY IMPLIED WARRANTIES OF MERCHANTABILITY OR
;;;;     FITNESS FOR A PARTICULAR PURPOSE.

(define-module srfi/48
  (import SCHEME)
  (export format srfi48:help srfi48:format-fixed)

(define srfi48:help
  (let ((str "(format []  [...]) --  is #t, #f or an output-port
OPTION  [MNEMONIC]  DESCRIPTION -- Implementation Assumes ASCII Text
                                           Encoding
~H  [Help]      output this text
~A  [Any]       (display arg) for humans
~S  [Slashified]    (write arg) for parsers
~W  [WriteCircular] like ~s but outputs circular and recursive data
                        structures
~~  [tilde]     output a tilde
~T  [Tab]       output a tab character
~%  [Newline]   output a newline character
~&  [Freshline] output a newline character if the previous output
                        was not a newline
~D  [Decimal]   the arg is a number which is output in decimal radix
~X  [heXadecimal]   the arg is a number which is output in hexadecimal
                        radix
~O  [Octal]     the arg is a number which is output in octal radix
~B  [Binary]    the arg is a number which is output in binary radix
~w,dF   [Fixed]     the arg is a string or number which has width w and
                        d digits after the decimal
~C  [Character] character arg is output by write-char
~_  [Space]     a single space character is output
~Y  [Yuppify]   the list arg is pretty-printed to the output
~?  [Indirection]   recursive format: next 2 args are format-string and
                        list of arguments
~K  [Indirection]   same as ~?\n"))
    (lambda (port)
      (format port "~A" str))))





(define (srfi48:format-fixed number-or-string width digits) ; returns a string
  ;; Following three procedures are used by format ~F .
  ;; 'inexact-number->string' determines whether output is fixed-point
  ;; notation or exponential notation. In the current definition,
  ;; the notation depends on the implementation of 'number->string'.
  ;; 'exact-number->string' is expected to output only numeric characters
  ;; (not including such as '#', 'e', '.', '/') if the input is an positive
  ;; integer or zero.
  ;; 'real-number->string' is used when the digits of ~F is not specified.
  (define (inexact-number->string x) (number->string (exact->inexact x)))
  (define (exact-number->string x)   (number->string (inexact->exact x)))
  (define (real-number->string x)    (number->string x))

  (define (string-grow str len char)
    (let ( (off (- len (string-length str))) )
      (if (positive? off)
          (string-append (make-string off char) str)
          str)))

  (define (compose-with-digits digits pre-str frac-str exp-str)
    (let ( (frac-len (string-length frac-str)) )
      (cond
       ((< frac-len digits) ;; grow frac part, pad with zeros
        (string-append pre-str "."
                       frac-str (make-string (- digits frac-len) #\0)
                       exp-str)
        )
       ((= frac-len digits) ;; frac-part is exactly the right size
        (string-append pre-str "."
                       frac-str
                       exp-str)
        )
       (else ;; must round to shrink it
        (let* ( (minus-flag (and (> (string-length pre-str) 0)
                                 (char=? (string-ref pre-str 0) #\-)))
                (pre-str*   (if minus-flag
                                (substring pre-str 1 (string-length pre-str))
                                pre-str))
                (first-part (substring frac-str 0 digits))
                (last-part  (substring frac-str digits frac-len))
                (temp-str
                 (string-grow
                  (exact-number->string
                   (round (string->number
                           (string-append pre-str* first-part "." last-part))))
                  digits
                  #\0))
                (temp-len   (string-length temp-str))
                (new-pre    (substring temp-str 0 (- temp-len digits)))
                (new-frac   (substring temp-str (- temp-len digits) temp-len))
                )
          (string-append
           (if minus-flag "-" "")
           (if (string=? new-pre "")
               ;; check if the system displays integer part of numbers
               ;; whose absolute value is 0 < x < 1.
               (if (and (string=? pre-str* "")
                        (> digits 0)
                        (not (= (string->number new-frac) 0)))
                   "" "0")
               new-pre)
           "."
           new-frac
           exp-str)))
       ) ) )
         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (cond
   ((string? number-or-string)
    (string-grow number-or-string width #\space)
    )
   ((number? number-or-string)
    (let ( (real (real-part number-or-string))
           (imag (imag-part number-or-string))
           )
      (cond
       ((not (zero? imag))
        (string-grow
         (string-append (srfi48:format-fixed real 0 digits)
                        (if (negative? imag) "" "+")
                        (srfi48:format-fixed imag 0 digits)
                        "i")
         width
         #\space)
        )
       (digits
        (let* ( (num-str   (inexact-number->string real))
                (dot-index (string-position "." num-str))
                (exp-index (string-position  "e" num-str ))
                (length    (string-length num-str))
                (pre-string
                 (if dot-index
                     (substring num-str 0 dot-index)
                     (if exp-index
                         (substring num-str 0 exp-index)
                         num-str))
                 )
                (exp-string
                 (if exp-index
                     (substring num-str exp-index length)
                     "")
                 )
                (frac-string
                 (if dot-index
                     (if exp-index
                         (substring num-str (+ dot-index 1) exp-index)
                         (substring num-str (+ dot-index 1) length))
                     "")
                 )
                )
          ;; check +inf.0, -inf.0, +nan.0, -nan.0
          (if (string-position "n" num-str)
              (string-grow num-str width #\space)
              (string-grow
               (compose-with-digits digits
                                    pre-string
                                    frac-string
                                    exp-string)
               width
               #\space))
          ))
       (else ;; no digits
        (string-grow (real-number->string real) width #\space)))
      ))
   (else
    (error
     (format "FORMAT: ~~F requires a number or a string, got ~s" number-or-string)))
   ))
)

;; srfi48:help srfi48:format-fixed are autoload in STklos module ==> import
;; them in STklos to have a complete implementation of SRFI-48
(define-module STklos
  (import (only (srfi 48) srfi48:help srfi48:format-fixed)))


(provide "srfi/48")
