[add missing regression tests and missing Text.Printf module
John Meacham <john@repetae.net>**20070926004953] addfile ./regress/tests/9_nofib/digits-of-e1.hs
addfile ./regress/tests/3_shootout/BinaryTrees.hs
addfile ./regress/tests/3_shootout/Mandelbrot.hs
addfile ./regress/tests/3_shootout/PartialSums.hs
addfile ./lib/base/Text/Printf.hs
hunk ./lib/base/Text/Printf.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- 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 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)
+-- >    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
+-- >    u      unsigned decimal        Char, Int, Integer
+-- >    f      floating point          Float, Double
+-- >    g      general 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 fmt = spr fmt []
+
+-- | 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 fmt = hspr hdl fmt []
+
+-- |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 fmt args = map fromChar (uprintf fmt (reverse args))
+
+instance PrintfType (IO a) where
+    spr fmt args = do
+	putStr (uprintf fmt (reverse args))
+	return undefined
+
+instance HPrintfType (IO a) where
+    hspr hdl fmt args = do
+	hPutStr hdl (uprintf fmt (reverse args))
+	return undefined
+
+instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where
+    spr fmt args = \ a -> spr fmt (toUPrintf a : args)
+
+instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where
+    hspr hdl fmt args = \ a -> hspr hdl fmt (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 s = UString (map toChar s)
+
+instance PrintfArg Int where
+    toUPrintf i = UInt i
+
+instance PrintfArg Integer where
+    toUPrintf i = UInteger i
+
+instance PrintfArg Float where
+    toUPrintf f = UFloat f
+
+instance PrintfArg Double where
+    toUPrintf d = UDouble d
+
+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 | UInt Int | UInteger 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, cs', us') = getSpecs 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
+        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)
+		'x' -> adjust ("", fmtu 16 u)
+		'o' -> adjust ("", fmtu 8  u)
+		'u' -> adjust ("", fmtu 10 u)
+		'e' -> adjust (dfmt' c prec u)
+		'f' -> adjust (dfmt' c prec u)
+		'g' -> adjust (dfmt' c prec u)
+		's' -> adjust ("", tostr u)
+		c   -> perror ("bad formatting char " ++ [c])
+		 ) ++ uprintf cs'' us''
+
+fmti (UInt i)     = if i < 0 then
+			if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i))
+		    else
+			("", itos i)
+fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i)
+fmti (UChar c)    = fmti (UInt (fromEnum c))
+fmti u		  = baderr
+
+fmtu b (UInt i)     = if i < 0 then
+			  if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i))
+		      else
+			  itosb b (toInteger i)
+fmtu b (UInteger i) = itosb b i
+fmtu b (UChar c)    = itosb b (toInteger (fromEnum c))
+fmtu b u            = baderr
+
+maxi :: Integer
+maxi = (toInteger (maxBound::Int) + 1) * 2
+
+toint (UInt i)     = i
+toint (UInteger i) = toInt i
+toint (UChar c)    = fromEnum c
+toint u		   = baderr
+
+tostr (UString s) = s
+tostr u		  = baderr
+
+itos n =
+	if n < 10 then
+	    [toEnum (fromEnum '0' + toInt n)]
+	else
+	    let (q, r) = quotRem n 10 in
+	    itos q ++ [toEnum (fromEnum '0' + toInt r)]
+
+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 + fromEnum c - fromEnum '0') cs
+stoi a cs                 = (a, cs)
+
+getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf])
+getSpecs l z ('-':cs) us = getSpecs True z cs us
+getSpecs l z ('0':cs) us = getSpecs l True cs us
+getSpecs l z ('*':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, cs'', us'')
+getSpecs l z ('.':cs) us =
+	let (p, cs') = stoi 0 cs
+	in  (0, p, l, z, cs', us)
+getSpecs l z 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, cs'', us)
+getSpecs l z cs       us = (0, -1, l, z, cs, us)
+
+dfmt' c p (UDouble d) = dfmt c p d
+dfmt' c p (UFloat f)  = dfmt c p f
+dfmt' c p u           = baderr
+
+dfmt c p d =
+	case (case c of 'e' -> showEFloat; 'f' -> showFFloat; 'g' -> showGFloat)
+               (if p < 0 then Nothing else Just p) d "" of
+	'-':cs -> ("-", cs)
+	cs     -> ("" , cs)
+
+perror s = error ("Printf.printf: "++s)
+fmterr = perror "formatting string ended prematurely"
+argerr = perror "argument list ended prematurely"
+baderr = perror "bad argument"
+
+toInt :: (Integral a) => a -> Int
+toInt x = fromInteger (toInteger x)
hunk ./regress/regress.prl 229
-    system "mv $results_dir/latest $results_dir/last";
+    system "mv -f $results_dir/latest $results_dir/last";
hunk ./regress/tests/3_shootout/BinaryTrees.hs 1
+{-# OPTIONS_GHC -fglasgow-exts -O2 -optc-O3 -funbox-strict-fields #-}
+-- The Great Computer Language Shootout
+-- http://shootout.alioth.debian.org/
+-- Simon Marlow
+-- Shortened by Don Stewart
+-- De-optimized by Isaac Gouy
+
+import System; import Text.Printf; import Control.Monad
+
+data Tree = Nil | Node !Int Tree Tree
+
+min' = 4 :: Int
+
+main = do max' <- getArgs >>= return . max (min'+2) . read . head
+          printf "stretch tree of depth %d\t check: %d\n" (max'+1) (itemCheck $ make 0 (max'+1))
+          depthLoop min' max'
+          printf "long lived tree of depth %d\t check: %d\n" max' (itemCheck $ make 0 max')
+
+depthLoop :: Int -> Int -> IO ()
+depthLoop d m = when (d <= m) $ do
+        printf "%d\t trees of depth %d\t check: %d\n" (2*n) d (sumLoop n d 0)
+        depthLoop (d+2) m
+    where n = 2^(m - d + min')
+
+sumLoop 0 d acc = acc
+sumLoop k d acc = c `seq` sumLoop (k-1) d (acc + c + c')
+    where (c,c')  = (itemCheck (make k d), itemCheck (make (-1*k) d))
+
+-- make i (0::Int) = i `seq` Nil
+make :: Int -> Int -> Tree
+make i 0 = Node i Nil Nil
+make i d = Node i (make ((2*i)-1) (d-1)) (make (2*i) (d-1))
+
+itemCheck Nil = 0
+itemCheck (Node x l r) = x + itemCheck l - itemCheck r
hunk ./regress/tests/3_shootout/Mandelbrot.hs 1
+-- The Great Computer Language Shootout
+-- http://shootout.alioth.debian.org/
+-- Based on the SML version, written by Matthias Blume.
+-- Implemented in Haskell by Don Stewart
+--
+import System; import Data.Bits; import Data.Word; import Text.Printf; import Data.Char
+
+main = do (w::Word32) <- getArgs >>= readIO . head
+          printf "P4\n%d %d\n" (fromIntegral w::Int) (fromIntegral w::Int) >> yl 0 w w
+
+yl y h w = if y < h then xl 0 y 0 8 h w else return ()
+
+xl x y b n h w
+    | x == w    = putChar (chr $ b `shiftL` n) >> yl (y+1) h w
+    | otherwise = do
+        (b',n') <- if n == 0 then putChar (chr b) >> return (0,8) else return (b,n)
+        xl (x+1) y (b'+b'+ fromEnum (p x y w h)) (n'-1) h w
+
+p (x::Word32) y w h = lp 0.0 0.0 50 (f x * 2.0 / f w - 1.5) (f y * 2.0 / f h - 1.0)
+    where f = fromIntegral
+
+lp r i k cr ci | r2 + i2 > (4.0 :: Double) = 0 :: Word32
+               | k == (0 :: Word32)        = 1
+               | otherwise                 = lp (r2-i2+cr) ((r+r)*i+ci) (k-1) cr ci
+    where r2 = r*r ; i2 = i*i
hunk ./regress/tests/3_shootout/PartialSums.hs 1
+--
+-- The Great Computer Language Shootout
+-- http://shootout.alioth.debian.org/
+--
+-- Haskell version of Isaac Gouy's Clean version, translated by Don Stewart
+--
+
+import System; import Numeric
+
+main = do n <- getArgs >>= readIO . head
+          let sums     = loop (1::Int) n 1 0 0 0 0 0 0 0 0 0
+              fn (s,t) = putStrLn $ (showFFloat (Just 9) s []) ++ "\t" ++ t
+          mapM_ (fn :: (Double, String) -> IO ()) (zip sums names)
+
+names = ["(2/3)^k", "k^-0.5", "1/k(k+1)", "Flint Hills", "Cookson Hills"
+        , "Harmonic", "Riemann Zeta", "Alternating Harmonic", "Gregory"]
+
+loop i n alt a1 a2 a3 a4 a5 a6 a7 a8 a9
+    | i !n !alt !a1 !a2 !a3 !a4 !a5 !a6 !a7 !a8 !a9 !False = undefined -- strict
+    | k > n     = [ a1, a2, a3, a4, a5, a6, a7, a8, a9 ]
+    | otherwise = loop (i+1) n (-alt)
+                       (a1 + (2/3) ** (k-1))
+                       (a2 + 1 / sqrt k)
+                       (a3 + 1 / (k * (k + 1)))
+                       (a4 + 1 / (k3 * sk * sk))
+                       (a5 + 1 / (k3 * ck * ck))
+                       (a6 + dk)
+                       (a7 + 1 / k2)
+                       (a8 + alt * dk)
+                       (a9 + alt / (2 * k - 1))
+    where k3 = k2*k; k2 = k*k; dk = 1/k; k = fromIntegral i; sk = sin k; ck = cos k; x!y = x`seq`y
hunk ./regress/tests/9_nofib/digits-of-e1.hs 1
+{-
+Compute the digits of "e" using continued fractions.
+Original program due to Dale Thurston, Aug 2001
+-}
+
+import System
+
+type ContFrac = [Integer]
+
+{-
+Compute the decimal representation of e progressively.
+
+A continued fraction expansion for e is
+
+[2,1,2,1,1,4,1,1,6,1,...]
+-}
+
+eContFrac :: ContFrac
+eContFrac = 2:aux 2 where aux n = 1:n:1:aux (n+2)
+
+{-
+We need a general function that applies an arbitrary linear fractional
+transformation to a legal continued fraction, represented as a list of
+positive integers.  The complicated guard is to see if we can output a
+digit regardless of what the input is; i.e., to see if the interval
+[1,infinity) is mapped into [k,k+1) for some k.
+-}
+
+-- ratTrans (a,b,c,d) x: compute (a + bx)/(c+dx) as a continued fraction
+ratTrans :: (Integer,Integer,Integer,Integer) -> ContFrac -> ContFrac
+-- Output a digit if we can
+ratTrans (a,b,c,d) xs |
+  ((signum c == signum d) || (abs c < abs d)) && -- No pole in range
+  (c+d)*q <= a+b && (c+d)*q + (c+d) > a+b       -- Next digit is determined
+     = q:ratTrans (c,d,a-q*c,b-q*d) xs
+  where q = b `div` d
+ratTrans (a,b,c,d) (x:xs) = ratTrans (b,a+x*b,d,c+x*d) xs
+
+-- Finally, we convert a continued fraction to digits by repeatedly multiplying by 10.
+
+toDigits :: ContFrac -> [Integer]
+toDigits (x:xs) = x:toDigits (ratTrans (10,0,0,1) xs)
+
+e :: [Integer]
+e = toDigits eContFrac
+
+main = do
+    [digits] <- getArgs
+    print (take (read digits) e)
+
+