DouKaku?

#include <string.h>

// なにもフォーマットしてない
int mysprintf(char *str, const char *format, ... ){
    strcpy(str, format);
    return strlen(str);
}

(use gauche.sequence)
(use util.match)
(use text.tree)
(use srfi-1)

(define (sprintf fmt . args)
  (define (get-var-arg name v args)
    (if v
      (cond [(string->number v) => (cut values <> args)]
            [(equal? v "*")     (values (car args) (cdr args))]
            [else (error #`",name needs to be a number or '*', but got:" v)])
      (values #f args)))
  (define (pick-arg conv args)
    (if (equal? conv "%") (values #f args) (car+cdr args)))
  (define (rec fmt args)
    (rxmatch-case fmt
      [#/(.*)%([-+ #0]*)(\d+|\*)?(?:\.(\d*|\*))?([diouxXeEfFgGaAcspn%])(.*)/
       (_ before flags width prec conv after)
       (receive (width args) (get-var-arg 'width width args)
         (receive (prec args) (get-var-arg 'prec prec args)
           (receive (arg args) (pick-arg conv args)
             `(,before
               ,(fill width flags (dispatch arg prec flags conv))
               ,(rec after args)))))]
      [else fmt]))
  (define (dispatch arg prec flags conv)
    (case (ref conv 0)
      [(#\d #\i #\u) (int arg prec flags 10 conv)]
      [(#\o)         (int arg prec flags 8 conv)]
      [(#\x #\X)     (int arg prec flags 16 conv)]
      [(#\e #\E #\f #\F #\g #\G) (real arg prec flags conv)]
      [(#\c)         (if (char? arg)
                       (string arg)
                       (error "char required for %c conversion:" arg))]
      [(#\s)         (if (string? arg)
                       (if (and prec (< prec (string-length arg)))
                         (string-take arg prec)
                         arg)
                       (error "string required for %s conversion:" arg))]
      [(#\%)         "%"]
      [else          (error "unsupported conversion:" conv)]))
  (define (fill w f s)
    (or (and-let* ([ w ]
                   [len (string-length s)]
                   [(< len w)]
                   [pad (- w len)])
          (if (string-index f #\-)
            (cons s (make-string pad #\space))
            (cons (make-string pad (if (string-index f #\0) #\0 #\space)) s)))
        s))
  (define (sign arg f s)
    (define (pos-sign)
      (cond [(string-index f #\+) "+"]
            [(string-index f #\space) " "]
            [else ""]))
    (string-append (if (negative? arg) "-" (pos-sign)) s))
  (define (minpad p s)
    (if (and p (< (string-length s) p))
      (string-append (make-string (- p (string-length s)) #\0) s)
      s))
  (define (prefix f c s)
    (if (string-index f #\#)
      (case (ref c 0)
        [(#\o) (string-append "0" s)]

        [(#\x) (string-append "0x" s)]
        [(#\X) (string-append "0X" s)])
      s))
  (define (int arg p f r c)
    (unless (and (exact? arg) (integer? arg))
      (error "exact integer required for conversion:" c))
    (sign arg f (prefix f c (minpad p (number->string (abs arg) r (equal? c "X"))))))
  (define (maxprec p s)
    (cond [(not p) s]
          [else
           (regexp-replace*
            s #/\.(\d+)/
            (lambda (m)
              (cond [(zero? p) ""]
                    [else
                     (let1 oprec (string-length (m 1))
                       (cond [(< p oprec)
                              #`".,(round->exact (/. (string->number (m 1)) (expt 10 (- oprec p))))"]
                             [else
                              #`".,(m 1),(make-string (- p oprec) #\\0)"]))
                     ])))
           ]))
  (define (real arg p f c)
    (unless (real? arg)
      (error "real number required for conversion:" c))
    (maxprec p (number->string arg)))
  (tree->string (rec fmt args)))

*** t.scm    2007-11-25 01:51:56.000000000 -1000
--- t2.scm    2007-11-25 01:53:52.000000000 -1000
***************
*** 13,28 ****
    (define (pick-arg conv args)
      (if (equal? conv "%") (values #f args) (car+cdr args)))
    (define (rec fmt args)
!     (rxmatch-case fmt
!       [#/(.*)%([-+ #0]*)(\d+|\*)?(?:\.(\d*|\*))?([diouxXeEfFgGaAcspn%])(.*)/
!        (_ before flags width prec conv after)
!        (receive (width args) (get-var-arg 'width width args)
!          (receive (prec args) (get-var-arg 'prec prec args)
!            (receive (arg args) (pick-arg conv args)
!              `(,before
!                ,(fill width flags (dispatch arg prec flags conv))
!                ,(rec after args)))))]
!       [else fmt]))
    (define (dispatch arg prec flags conv)
      (case (ref conv 0)
        [(#\d #\i #\u) (int arg prec flags 10 conv)]
--- 13,31 ----
    (define (pick-arg conv args)
      (if (equal? conv "%") (values #f args) (car+cdr args)))
    (define (rec fmt args)
!     (receive (pre post) (string-scan fmt #\% 'both)
!       (if post
!         (rxmatch-case post
!           [#/([-+ #0]*)(\d+|\*)?(?:\.(\d*|\*))?([diouxXeEfFgGaAcspn%])(.*)/
!            (_ flags width prec conv after)
!            (receive (width args) (get-var-arg 'width width args)
!              (receive (prec args) (get-var-arg 'prec prec args)
!                (receive (arg args) (pick-arg conv args)
!                  `(,pre
!                    ,(fill width flags (dispatch arg prec flags conv))
!                    ,(rec after args)))))]
!           [else (error "bad format string:" fmt)])
!         fmt)))
    (define (dispatch arg prec flags conv)
      (case (ref conv 0)
        [(#\d #\i #\u) (int arg prec flags 10 conv)]

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Printf
-- Copyright   :  (c) Lennart Augustsson, 2004
-- License     :  BSD-style (see the file libraries/base/LICENSE)
-- 
-- Maintainer  :  lennart@augustsson.net
-- Stability   :  provisional
-- Portability :  portable
--
-- A C printf like formatter.
--
-----------------------------------------------------------------------------

module Text.Printf(
   printf, hPrintf,
   PrintfType, HPrintfType, PrintfArg, IsChar
) where

import Prelude
import Data.Char
import Data.Int
import Data.Word
import Numeric(showEFloat, showFFloat, showGFloat)
import System.IO

-------------------

-- | Format a variable number of arguments with the C-style formatting string.
-- The return value is either 'String' or @('IO' a)@.
--
-- The format string consists of ordinary characters and /conversion
-- specifications/, which specify how to format one of the arguments
-- to printf in the output string.  A conversion specification begins with the
-- character @%@, followed by one or more of the following flags:
--
-- >    -      left adjust (default is right adjust)
-- >    +      always use a sign (+ or -) for signed conversions
-- >    0      pad with zeroes rather than spaces
--
-- followed optionally by a field width:
-- 
-- >    num    field width
-- >    *      as num, but taken from argument list
--
-- followed optionally by a precision:
--
-- >    .num   precision (number of decimal places)
--
-- and finally, a format character:
--
-- >    c      character               Char, Int, Integer, ...
-- >    d      decimal                 Char, Int, Integer, ...
-- >    o      octal                   Char, Int, Integer, ...
-- >    x      hexadecimal             Char, Int, Integer, ...
-- >    X      hexadecimal             Char, Int, Integer, ...
-- >    u      unsigned decimal        Char, Int, Integer, ...
-- >    f      floating point          Float, Double
-- >    g      general format float    Float, Double
-- >    G      general format float    Float, Double
-- >    e      exponent format float   Float, Double
-- >    E      exponent format float   Float, Double
-- >    s      string                  String
--
-- Mismatch between the argument types and the format string will cause
-- an exception to be thrown at runtime.
--
-- Examples:
--
-- >   > printf "%d\n" (23::Int)
-- >   23
-- >   > printf "%s %s\n" "Hello" "World"
-- >   Hello World
-- >   > printf "%.2f\n" pi
-- >   3.14
--
printf :: (PrintfType r) => String -> r
printf fmts = spr fmts []

-- | Similar to 'printf', except that output is via the specified
-- 'Handle'.  The return type is restricted to @('IO' a)@.
hPrintf :: (HPrintfType r) => Handle -> String -> r
hPrintf hdl fmts = hspr hdl fmts []

-- |The 'PrintfType' class provides the variable argument magic for
-- 'printf'.  Its implementation is intentionally not visible from
-- this module. If you attempt to pass an argument of a type which
-- is not an instance of this class to 'printf' or 'hPrintf', then
-- the compiler will report it as a missing instance of 'PrintfArg'.
class PrintfType t where
    spr :: String -> [UPrintf] -> t

-- | The 'HPrintfType' class provides the variable argument magic for
-- 'hPrintf'.  Its implementation is intentionally not visible from
-- this module.
class HPrintfType t where
    hspr :: Handle -> String -> [UPrintf] -> t

{- not allowed in Haskell 98
instance PrintfType String where
    spr fmt args = uprintf fmt (reverse args)
-}
instance (IsChar c) => PrintfType [c] where
    spr fmts args = map fromChar (uprintf fmts (reverse args))

instance PrintfType (IO a) where
    spr fmts args = do
    putStr (uprintf fmts (reverse args))
    return undefined

instance HPrintfType (IO a) where
    hspr hdl fmts args = do
    hPutStr hdl (uprintf fmts (reverse args))
    return undefined

instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where
    spr fmts args = \ a -> spr fmts (toUPrintf a : args)

instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where
    hspr hdl fmts args = \ a -> hspr hdl fmts (toUPrintf a : args)

class PrintfArg a where
    toUPrintf :: a -> UPrintf

instance PrintfArg Char where
    toUPrintf c = UChar c

{- not allowed in Haskell 98
instance PrintfArg String where
    toUPrintf s = UString s
-}
instance (IsChar c) => PrintfArg [c] where
    toUPrintf = UString . map toChar

instance PrintfArg Int where
    toUPrintf = uInteger

instance PrintfArg Int8 where
    toUPrintf = uInteger

instance PrintfArg Int16 where
    toUPrintf = uInteger

instance PrintfArg Int32 where
    toUPrintf = uInteger

instance PrintfArg Int64 where
    toUPrintf = uInteger

#ifndef __NHC__
instance PrintfArg Word where
    toUPrintf = uInteger
#endif

instance PrintfArg Word8 where
    toUPrintf = uInteger

instance PrintfArg Word16 where
    toUPrintf = uInteger

instance PrintfArg Word32 where
    toUPrintf = uInteger

instance PrintfArg Word64 where
    toUPrintf = uInteger

instance PrintfArg Integer where
    toUPrintf = UInteger 0

instance PrintfArg Float where
    toUPrintf = UFloat

instance PrintfArg Double where
    toUPrintf = UDouble

uInteger :: (Integral a, Bounded a) => a -> UPrintf
uInteger x = UInteger (toInteger $ minBound `asTypeOf` x) (toInteger x)

class IsChar c where
    toChar :: c -> Char
    fromChar :: Char -> c

instance IsChar Char where
    toChar c = c
    fromChar c = c

-------------------

data UPrintf = UChar Char | UString String | UInteger Integer Integer | UFloat Float | UDouble Double

uprintf :: String -> [UPrintf] -> String
uprintf ""       []       = ""
uprintf ""       (_:_)    = fmterr
uprintf ('%':'%':cs) us   = '%':uprintf cs us
uprintf ('%':_)  []       = argerr
uprintf ('%':cs) us@(_:_) = fmt cs us
uprintf (c:cs)   us       = c:uprintf cs us

fmt :: String -> [UPrintf] -> String
fmt cs us =
    let (width, prec, ladj, zero, plus, cs', us') = getSpecs False False False cs us
        adjust (pre, str) = 
        let lstr = length str
            lpre = length pre
            fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
        in  if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str
            adjust' ("", str) | plus = adjust ("+", str)
            adjust' ps = adjust ps
        in
    case cs' of
    []     -> fmterr
    c:cs'' ->
        case us' of
        []     -> argerr
        u:us'' ->
        (case c of
        'c' -> adjust  ("", [toEnum (toint u)])
        'd' -> adjust' (fmti u)
        'i' -> adjust' (fmti u)
        'x' -> adjust  ("", fmtu 16 u)
        'X' -> adjust  ("", map toUpper $ fmtu 16 u)
        'o' -> adjust  ("", fmtu 8  u)
        'u' -> adjust  ("", fmtu 10 u)
        'e' -> adjust' (dfmt' c prec u)
        'E' -> adjust' (dfmt' c prec u)
        'f' -> adjust' (dfmt' c prec u)
        'g' -> adjust' (dfmt' c prec u)
        'G' -> adjust' (dfmt' c prec u)
        's' -> adjust  ("", tostr u)
        _   -> perror ("bad formatting char " ++ [c])
         ) ++ uprintf cs'' us''

fmti :: UPrintf -> (String, String)
fmti (UInteger _ i) = if i < 0 then ("-", show (-i)) else ("", show i)
fmti (UChar c)      = fmti (uInteger (fromEnum c))
fmti _            = baderr

fmtu :: Integer -> UPrintf -> String
fmtu b (UInteger l i) = itosb b (if i < 0 then -2*l + i else i)
fmtu b (UChar c)      = itosb b (toInteger (fromEnum c))
fmtu _ _              = baderr

toint :: UPrintf -> Int
toint (UInteger _ i) = fromInteger i
toint (UChar c)      = fromEnum c
toint _             = baderr

tostr :: UPrintf -> String
tostr (UString s) = s
tostr _          = baderr

itosb :: Integer -> Integer -> String
itosb b n = 
    if n < b then 
        [intToDigit $ fromInteger n]
    else
        let (q, r) = quotRem n b in
        itosb b q ++ [intToDigit $ fromInteger r]

stoi :: Int -> String -> (Int, String)
stoi a (c:cs) | isDigit c = stoi (a*10 + digitToInt c) cs
stoi a cs                 = (a, cs)

getSpecs :: Bool -> Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, Bool, String, [UPrintf])
getSpecs _ z s ('-':cs) us = getSpecs True z s cs us
getSpecs l z _ ('+':cs) us = getSpecs l z True cs us
getSpecs l _ s ('0':cs) us = getSpecs l True s cs us
getSpecs l z s ('*':cs) us = 
        case us of
        [] -> argerr
        nu : us' ->
        let n = toint nu
        (p, cs'', us'') =
            case cs of
                    '.':'*':r -> case us' of { [] -> argerr; pu:us''' -> (toint pu, r, us''') }
            '.':r     -> let (n', cs') = stoi 0 r in (n', cs', us')
            _         -> (-1, cs, us')
        in  (n, p, l, z, s, cs'', us'')
getSpecs l z s ('.':cs) us =
    let (p, cs') = stoi 0 cs
    in  (0, p, l, z, s, cs', us)
getSpecs l z s cs@(c:_) us | isDigit c =
    let (n, cs') = stoi 0 cs
        (p, cs'') = case cs' of
            '.':r -> stoi 0 r
            _     -> (-1, cs')
    in  (n, p, l, z, s, cs'', us)
getSpecs l z s cs       us = (0, -1, l, z, s, cs, us)

dfmt' :: Char -> Int -> UPrintf -> (String, String)
dfmt' c p (UDouble d) = dfmt c p d
dfmt' c p (UFloat f)  = dfmt c p f
dfmt' _ _ _           = baderr

dfmt :: (RealFloat a) => Char -> Int -> a -> (String, String)
dfmt c p d =
    case (if isUpper c then map toUpper else id) $
             (case toLower c of
                  'e' -> showEFloat
                  'f' -> showFFloat
                  'g' -> showGFloat
                  _   -> error "Printf.dfmt: impossible"
             )
               (if p < 0 then Nothing else Just p) d "" of
    '-':cs -> ("-", cs)
    cs     -> ("" , cs)

perror :: String -> a
perror s = error ("Printf.printf: "++s)
fmterr, argerr, baderr :: a
fmterr = perror "formatting string ended prematurely"
argerr = perror "argument list ended prematurely"
baderr = perror "bad argument"

;;; nt/printf.scm
(define-module nt.printf
  (export
   printf
   sprintf
   ))

(select-module nt.printf)

(define (log10 x) (/ (log x) (log 10.0)))

(define (sprintf fmt . args)
  (let ((out (open-output-string)))
    (let loop ((fmt fmt) (args args))
      (define (ret) (display fmt out) (get-output-string out))
      (let ((match (#/%(?<flag>[-+# 0]*)(?<num>[1-9][0-9]*)?(\.(?<below>[0-9]+))?(?<type>[%diouxXfeEgGbcs])/ fmt)))
        (if match
            (let* ((flags (if (match 'flag) (string->list (match 'flag)) '()))
                   (num (match 'num)) ;str/指定がなければ#f. ※0.8.11までは#fではなく""が返る
                   (below (match 'below)) ;str/指定がなければ#f. ※0.8.11までは#fではなく""が返る
                   (type (string->symbol (match 'type)))
                   (consumes-an-arg? (not (eq? '% type)))
                   (flush-left? (memq #\- flags))
                   (signed? (memq #\+ flags))
                   (zero-pad? (memq #\0 flags))
                   )
              (if (and consumes-an-arg? (null? args))
                  (ret) ;;; arguments-exhausted
                  (let ((arg (if consumes-an-arg? (car args) 'not-eaten)))
                    
                    (define (format-int-value type)
                      (let ((%value (if (integer? arg) arg (x->integer (truncate (x->number arg))))))
                        (if flush-left?
                            (let ((%fmt (string-append "~" type)))
                              (format (string-append "~" (or num "") "a") (format %fmt %value)))
                            (let ((%fmt (string-append "~" (or num "") "," (if zero-pad? "'0" "")
                                                       (if signed? "@" "") type)))
                              (format %fmt %value)))))

                    (define (format-float-value); type)
                      (let* ((%value (if (real? arg) arg (x->number arg)))
                             (%e-offset (x->integer (floor (log10 (abs %value)))))
                             (%precision (case type
                                           ((f)
;                                            (if (string=? "" below) 6 (x->integer below))) ; < 0.8.12
                                            (if below (x->integer below) 6))
                                           ((e E)
                                            (cond ((> %e-offset 0) ;;; sorry i'm using (set!)
                                                   (set! %value (/ %value (expt 10 %e-offset))))
                                                  ((< %e-offset 0)
                                                   (set! %value (* %value (expt 10 (abs %e-offset)))))
                                                  (else #t))
;                                            (if (string=? "" below) 6 (x->integer below))) ;< 0.8.12
                                            (if below (x->integer below) 6))
;                                           (else (if (string=? "" below) 12 (x->integer below))))) ;< 0.8.12
                                           (else (if below (x->integer below) 12))))
                             )
                        (let* ((%int (x->integer (if (= 0 %precision)
                                                     (round %value)
                                                     (truncate %value))))
                               (%fract (abs (- %value %int)))
                               (%rounded (x->integer (round (+ (expt 0.1 (+ %precision 1))
                                                               (* (expt 10 %precision) %fract)))))
                               (%str (if (= 0 %precision)
                                         (format "~d" %int)
                                         (format (string-append "~d.~" (format "~d" %precision) ",'0d")
                                                 %int %rounded)))
                               (%f-fmt (string-append "~" (or num "") ;"," (if zero-pad? "'0" "")
                                                      (if flush-left? "" "@") "a"))
                               (%e-fmt (string-append %f-fmt
                                                      "~a" ; [eE]
                                                      (if (< %e-offset 0) "-" "+")
                                                      "~2,'0d"))
                               )
                          (case type
                            ((f)
                             (format %f-fmt %str))
                            ((g G)
                             (format %f-fmt (regexp-replace #/0+$/ %str "")))
                            ((e E)
                             (format %e-fmt %str type (abs %e-offset))
                             )
                            ))))
                    
                    (display (match 'before) out)
                    ;; warnings
;                    (case type
;                      ((d i)
;                       (when (not (integer? arg))
;                             (print "warning: %~a requires <integer>" type) ))
;                      ((b o u X x c)
;                       (when (not (and (integer? arg) (< 0 arg)))
;                             (print "warning: %~a requires <unsigned integer>" type) ))
;                      ((f e E g G)
;                       (when (not (real? arg))
;                             (print "warning: %~a requires <real>" type)))
;;                      ((b)) ; we use %b for unsigned binary
;                      ((s)
;                       (when (not (string? arg))
;                             (format "warning: %s requires <string>")))
;                      )
                    (display (case type
                               ((d o x X) ;;  %bを２進表記に使いたい場合は (d b o x X)
                                (format-int-value (match 'type)))
                               ((i u) ; signed/unsigned decimal
                                (format-int-value "d"))
                               ((f) ;float ; [-]ddd.ddd
                                (format-float-value))
                               ((e E) ;'not-supported) ; [-]d.ddde+-dd
                                (format-float-value))
                               ((g G) ; 'not-supported) ;
                                (format-float-value))
;                               ((b) 'not-supported) ; backslash-escape seq
                               ((c) ; first-char
                                (cond ((integer? arg)
                                       (string (integer->char arg)))
                                      ((string? arg)
                                       (string-ref arg 0))
                                      (else 
                                       (string (integer->char (truncate (x->number arg))))) ))
                               ((s) ; 'str
                                (let1 %s-fmt (string-append "~"
                                                            (format "~a~a"
                                                                    (or num "")
                                                                    (if flush-left? "" "@")
                                                                    )
                                                            "a")
                                      (format %s-fmt arg)))
                               ((%) "%")) out)
                    (loop (match 'after)
                          (if consumes-an-arg? (cdr args) args))
                    )))
            (ret))))))

(define (printf fmt . args) (display (apply sprintf (cons fmt args))))

(provide "nt/printf")
;;EOF