-- $Id: ackermann.ghc,v 1.5 2001/06/16 01:33:06 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- shortened by Bryn Keller

import System(getArgs)

main = do
       ~[number] <- getArgs
       let n = read number in
       putStrLn ("Ack(3," ++ (show n) ++ "): " ++ (show (ack 3 n)))

ack :: Int -> Int -> Int
ack 0 n = n+1
ack m 0 = ack (m-1) 1
ack m n = ack (m-1) (ack m (n-1));

-- $Id: ary3.ghc,v 1.2 2001/06/01 17:56:49 doug Exp $
-- http://www.bagley.org/~doug/shootout/

-- TBD: try rewrite with STUArray or IOUArray

module Main where

import IArray
import System

make_x :: Int -> UArray Int Int
make_x len = array (1,len) [(i, i) | i <- [1..len]]

make_y0 :: Int -> UArray Int Int
make_y0 len = array (1,len) [(i, 0) | i <- [1..len]]

add_array :: Int -> UArray Int Int -> UArray Int Int -> UArray Int Int
add_array 0 a b = b
add_array len a b = array (1,len) [(i, ((a ! i) + (b ! i))) | i <- [1..len]]

add_arrays_n :: Int -> Int -> UArray Int Int -> UArray Int Int -> UArray Int Int
add_arrays_n 0 len a b = b
add_arrays_n n len a b =
    add_arrays_n (n-1) len a (add_array len a b)

ary3 :: Int -> IO ()
ary3 len = do putStr (show (y ! 1)) ; putStr " " ; putStrLn (show (y ! len))
             where y = add_arrays_n 1000 len (make_x len) (make_y0 len)

main = do
        ~[n] <- getArgs 
        ary3 (read n::Int)

-- $Id: wc.ghc,v 1.2 2001/05/24 14:05:53 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- from Brian Gregor

module Main where

-- compile with:  ghc -O -o wc -package lang wc.hs

import IO
import IOExts
import PackedString

main = do
         -- set buffer to 4k
         hSetBuffering stdin (BlockBuffering (Just 4096))
         -- these are mutable variables
         nL <- newIORef 0
         nW <- newIORef 0
     nC <- newIORef 0
         (nl,nw,nc) <- countAll nL nW nC
     putStrLn ((show nl)++" "++(show nw)++" "++(show nc))

countAll :: IORef Int -> IORef Int -> IORef Int -> IO (Int,Int,Int)
countAll nL nW nC = do 
         end <- hIsEOF stdin
         nl <- readIORef nL
        nw <- readIORef nW
         nc <- readIORef nC
         if (not end) 
            then (do  
              inStr <- hGetLine stdin
              -- using a packed string is a small speed win
              let str = packString inStr
              -- using IORefs makes it easy to force strict
              -- evaluation - how to easily do this without
              -- IORefs?
              writeIORef nL $! (nl + 1)
              writeIORef nW $! (nw + (length (wordsPS str)))
              writeIORef nC $! (nc + 1 + (lengthPS str))
              countAll nL nW nC)
            else  return (nl,nw,nc)

-- $Id: echo.ghc,v 1.2 2001/05/01 20:19:52 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- Haskell echo/client server
-- written by Brian Gregor
-- compile with:
--      ghc -O -o echo -package net -package concurrent -package lang echo.hs

module Main where

import SocketPrim
import Concurrent
import System (getArgs,exitFailure)
import Exception(finally)
import MVar

server_sock = do
    s <- socket AF_INET Stream 6
    setSocketOption s ReuseAddr 1
    bindSocket s (SockAddrInet (mkPortNumber portnum) iNADDR_ANY)
    listen s 2
    return s

echo_server s = do
    (s', clientAddr) <- accept s
    proc <- read_data s' 0
    putStrLn ("server processed "++(show proc)++" bytes")
    sClose s'
    where
       read_data sock totalbytes = do
             (str,i) <- readSocket sock 19
         if (i >= 19) 
            then (do
              writ <- writeSocket sock str
              read_data sock $! (totalbytes+(length $! str)))
            else (return totalbytes)

local        = "127.0.0.1"        
message        = "Hello there sailor\n"
portnum     = 7001

client_sock = do
    s <- socket AF_INET Stream 6
    ia <- inet_addr local
    connect s (SockAddrInet (mkPortNumber portnum) ia)
    return s

echo_client n = do
    s <- client_sock
    drop <- server_echo s n
    sClose s
    where
      server_echo sock n 
          | n > 0 =(do 
                       writeSocket sock message
                   (str,i) <- readSocket sock 19
                       if (str /= message) then (do exitFailure)
                       else server_echo sock (n-1))
          | otherwise = (return [])

main = do 
     ~[n] <- getArgs
     -- server & client semaphores
         --get the server socket
         ssock <- server_sock 
     -- fork off the server
     s <- myForkIO (echo_server ssock)
     -- fork off the client
     c <- myForkIO (echo_client (read n::Int))
     -- let 'em run until they've signaled they're done
         join s ; join c

-- these are used to make the main thread wait until
-- the child threads have exited
myForkIO :: IO () -> IO (MVar ())
myForkIO io = do
  mvar <- newEmptyMVar
  forkIO (io `finally` putMVar mvar ())
  return mvar

join :: MVar () -> IO ()
join mvar = readMVar mvar

-- $Id: except.ghc,v 1.2 2001/05/20 00:21:36 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- from Simon Marlow

import System
import Exception
import IOExts

blowup n | even n    = throw (ErrorCall "H")
     | otherwise = throw (ErrorCall "L")

lo_function lo n = 
  Exception.catchAllIO (blowup n) 
    (\ex -> case ex of
        ErrorCall "L" -> do nlo <- readIORef lo
                    writeIORef lo (nlo + 1)
        _ -> throw ex
    )

hi_function hi lo n = 
  Exception.catchAllIO (lo_function lo n) 
    (\ex -> case ex of
        ErrorCall "H" -> do nhi <- readIORef hi
                    writeIORef hi (nhi + 1)
        _ -> throw ex
    )

some_function hi lo n = hi_function hi lo n

main = do
  [arg] <- getArgs
  let n = read arg :: Int
  hi <- newIORef (0 :: Int)
  lo <- newIORef (0 :: Int)
  mapM (some_function hi lo) [n,n-1..1]
  nhi <- readIORef hi
  nlo <- readIORef lo
  putStrLn ("Exceptions: HI=" ++ show nhi ++ " / LO=" ++ show nlo)

-- $Id: fibo.ghc,v 1.4 2001/06/14 23:55:06 doug Exp $
-- http://www.bagley.org/~doug/shootout/

import System(getArgs, getProgName, exitWith, ExitCode(..))

main = do
       arg <- getArgs
       case arg of
         [number] -> putStrLn (show (fib (read number)))
         _        -> do
                     progname <- getProgName
                     putStrLn ("Usage: " ++ progname ++ " number")
                     exitWith (ExitFailure 1)


fib :: Int -> Int
fib 0 = 1
fib 1 = 1
fib n = fib (n-2) + fib (n-1)

-- $Id: hash.ghc,v 1.3 2001/06/18 18:17:03 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- from Bryn Keller
-- build with ghc -O2 -package data hash.ghc

import System (getArgs)
import FiniteMap
import Numeric (showInt)

countKeys tbl 0 = 0
countKeys tbl n = case (lookupWithDefaultFM tbl False (show n)) of
                    True -> 1 + countKeys tbl (n - 1)
                    _    -> countKeys tbl (n - 1)

buildTable tbl max num | num <= max = buildTable (addToFM tbl (showHex num "") True) max (num + 1)
                       | otherwise = tbl

showHex n r = let (n',d) = quotRem n 16
                  r'     = toEnum (fromEnum '0' + fromIntegral d) : r
                  in if n' == 0 then r' else showHex n' r'

main = do  args <- getArgs
           case args of
            [number] -> let num = read number
                            tbl = buildTable emptyFM num 1
                    in do putStrLn $ show (countKeys tbl num)
            _        -> fail "You must enter a number."

-- $Id: heapsort.ghc,v 1.2 2001/05/08 02:46:59 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- from Julian Assange

module Main(main) where
import System(getArgs, exitWith, ExitCode(..))
import Numeric(showFFloat)

main = do
         arg <- getArgs
     case arg of
              [num] -> putStrLn (showFFloat (Just 10) answer "")
                   where
                     answer = last . heapsort .
                                      take (read num) . random $ 1.0
          _     -> exitWith (ExitFailure 1)

-- construct an infinite list of random numbers
random :: Double -> [Double]
random max = map norm . rand $ 42
           where norm x = (fromIntegral x) * (max / (fromIntegral im))
                 rand x = x' : (rand x')
                where x' = (x * ia + ic) `mod` im
             im     = 139968
                 ia     = 3877
                 ic     = 29573

-- fold up a list like a tree
treefold f z []      = z
treefold f z [x]     = x
treefold f z (a:b:l) = treefold f z (f a b : pairfold l)
                 where pairfold (x:y:rest) = f x y : pairfold rest
                   pairfold l          = l

-- heapfold using linked lists
data Heap a = Nil | Node a [Heap a]
heapsort :: Ord a => [a] -> [a]
heapsort = flatten_heap . merge_heaps . map heapify

    where heapify x   = Node x []

      merge_heaps :: Ord a => [Heap a] -> Heap a
          merge_heaps = treefold merge_heap Nil

          flatten_heap Nil            = []
          flatten_heap (Node x heaps) = x:flatten_heap (merge_heaps heaps)

          merge_heap Nil                     Nil = Nil
          merge_heap heap@(Node _ _)         Nil = heap
          merge_heap node_a@(Node a heaps_a) node_b@(Node b heaps_b)
                     | a < b     = Node a (node_b : heaps_a)
                     | otherwise = Node b (node_a : heaps_b)

-- $Id: hello.ghc,v 1.1 2001/06/17 22:00:34 doug Exp $
-- http://www.bagley.org/~doug/shootout/

main = do putStrLn "hello world"

-- $Id: lists.ghc,v 1.1 2001/06/12 04:47:12 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- from Michal Gajda

module Main(main) where

import Prelude

copy [] = []
copy (x:xs) = x:copy xs
-- to be honest, in pure functional language the RIGHT
-- thing is copy list = list, because it's not mutable anyway
-- (and the price is paid when doing reverse or (++) anyway)

-- `seq`s below force evaluation of isok1 and isok2
test :: Int -> Int
test size = isok1 `seq` length l3
  where single x = [x]
        l1 = [1..size] 
        l2 = copy l1 -- Should be just: "l1"
        l3 = foldl (++) [] (map single l2)
        l2' = foldr (++) [] (map single l3)
        l1' = reverse l1
        isok1 = head l1' == size
        isok2 = l1' == l2'
  
main = do s <- getLine
          putStrLn . show . test . read $ s

-- $Id: matrix.ghc,v 1.3 2001/06/01 17:56:49 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- from Julian Assange

-- TBD: try rewrite with STUArray or IOUArray?

module Main(main) where
import System(getArgs, exitWith, ExitCode(..))
import Numeric(readDec)
import List(transpose)
main = do
       arg <- getArgs
       case arg of
            [number] -> putStrLn (disp m 0 0 ++ " " ++
                  disp m 2 3 ++ " " ++
                  disp m 3 2 ++ " " ++
                  disp m 4 4)
                  where
              disp m row col  = show (m!!row!!col)
              m = powmat (fst (head (readDec number)))
            _        -> exitWith (ExitFailure 1)

size = 30

-- ghc is able to optimize out enough invariants so that the
-- traditional form this test runs in O(1)
--
-- this would have ghc trounce all other entrants, so to get
-- closer to the general meaning of the test, we cascade
-- matrix multiplications. this means the results are, by necessity,
-- different, but involve just as many mmults. i.e for n=1 the results
-- are identical.

powmat n = power n (mmult . transpose $ mkmat size) (mkmat size)
    where
    power n f | n > 0     = f . (power (n-1) f)
              | otherwise = id
    mkmat x    = [[(y-1)*x+1..y*x]| y <- [1..x]]
    mmult a b  = [[dot row col 0 | col <- a]| row <- b]
           where
           dot :: [Int] -> [Int] -> Int -> Int
           dot (x:xs) (y:ys) z = dot xs ys (z + x*y)
           dot  _      _     z = z 

-- slightly slower transposing mmult in one line:
--  mmult a b  = [[sum$zipWith (*) row col 0 | col <- transpose a]| row <-b]

-- $Id: nestedloop.ghc,v 1.1 2001/02/22 23:22:11 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- from Brian Gregor

module Main where

import System(getArgs, exitWith, ExitCode(..))
import Numeric(readDec)

main = do
        arg <- getArgs
        case arg of
         [number] -> let n = fst (head (readDec number)) in
                     putStrLn (show (loopA n n 0))
         _      -> exitWith (ExitFailure 1)

loopA :: Int -> Int -> Int -> Int
loopA n m x 
   | n > 0         = loopA (n-1) m (loopB m m x)
   | otherwise     = x

loopB :: Int -> Int -> Int -> Int
loopB n m x
   | n > 0         = loopB (n-1) m (loopC m m x)
   | otherwise     = x

loopC :: Int -> Int -> Int -> Int
loopC n m x
   | n > 0         = loopC (n-1) m (loopD m m x)
   | otherwise     = x

loopD :: Int -> Int -> Int -> Int
loopD n m x
   | n > 0         = loopD (n-1) m (loopE m m x)
   | otherwise     = x

loopE :: Int -> Int -> Int -> Int
loopE n m x
   | n > 0         = loopE (n-1) m (loopF m x)
   | otherwise     = x

loopF :: Int -> Int -> Int 
loopF n x
   | n > 0         = loopF (n-1) (x+1)
   | otherwise     = x

-- $Id: prodcons.ghc,v 1.1 2001/02/28 01:08:27 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- from Josef Svenningsson
 
module Main where

import CVar
import MVar
import Concurrent
import Exception
import IOExts
import System

producer :: Int -> IORef Int -> CVar Int -> IO ()
producer n p ch = sequence_ (map send [1..n])
  where send i = do writeCVar ch i
                    prod <- readIORef p
                    writeIORef p (prod+1)

consumer :: Int -> IORef Int -> CVar Int -> IO ()
consumer n c ch = cons 1
  where cons i | n <= i = return ()
        cons i
            = do i <- readCVar ch
                 con <- readIORef c
                 writeIORef c (con+1)
                 cons i

myForkIO :: IO () -> IO (MVar ())
myForkIO io = do
   mvar <- newEmptyMVar
   forkIO (io `finally` putMVar mvar ())
   return mvar

join :: MVar () -> IO ()
join mvar = readMVar mvar

main = do (a:_) <- getArgs
          let n = read a
          produced <- newIORef 0
          consumed <- newIORef 0
          channel <- newCVar
          p <- myForkIO (producer n produced channel)
          c <- myForkIO (consumer n consumed channel)
          join p; join c
          prod <- readIORef produced
          cons <- readIORef consumed
          putStrLn (show prod ++ " " ++ show cons)

-- $Id: random.ghc,v 1.5 2001/05/18 07:10:55 doug Exp $
-- http://www.bagley.org/~doug/shootout/

module Main(main) where
import System(getArgs)
import Numeric(showFFloat)

main = do
         ~[n] <- getArgs
         putStrLn (showFFloat (Just 9) (randloop (read n::Int) 42 0.0 100.0) "")
     return 1

randloop :: Int -> Int -> Double -> Double -> Double
randloop 0 seed r max = r
randloop n seed r max = randloop (n-1) newseed newrand max
    where normalize x max = (fromIntegral x) * (max / imd)
          newseed         = (seed * ia + ic) `mod` im
          newrand         = normalize newseed max
      im              = 139968
      imd             = fromIntegral im
      ia              = 3877
          ic              = 29573

-- $Id: reversefile.ghc,v 1.5 2001/02/26 17:18:27 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- from Julian Assange

main = interact $ unlines . reverse . lines

-- $Id: sieve.ghc,v 1.4 2001/07/26 13:16:43 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- from Roland Dowdeswell

module Main where

import System(getArgs)

main = getArgs >>= putStrLn . ("Count: "++) . show . mytest . read . headOr1
  where headOr1 x = if length x /= 1 then "1" else head x

-- here we try to force it to recompute at each step.  Note
-- that we are not naming `sieve [2..8192]' and we are forcing
-- a comparison with -1.  Of course there is still no guarantee
-- that any particular Haskell implementation will actually
-- recompute the value.
mytest :: Int -> Int
mytest 1 = length (sieve [2..8192])
mytest n | length (sieve [2..8192]) == -1 = error "doh"
         | otherwise                      = mytest (n-1)

-- we use Int rather than let Haskell default to Integer,
-- because we are trying to remain competetive with other
-- languages that do not do arbitrary precision math by
-- default...
sieve :: [Int] -> [Int]
sieve [] = []
sieve (h:t) = h : sieve [x| x<-t, x`mod`h /= 0]

-- $Id: spellcheck.ghc,v 1.1 2001/03/02 15:46:08 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- from Julian Assange

-- compile with: ghc -O -package data

module Main(main) where
import FiniteMap(addToFM_C,emptyFM,elemFM)

addFM fm [] = fm
addFM fm (x:xs) = addFM (addToFM_C (\_ _ -> ()) fm x ()) xs

main = do
         d <- readFile "Usr.Dict.Words"
         interact $ unlines . filter (\x -> not $ elemFM x (addFM emptyFM (lines d))) . lines

-- $Id: moments.ghc,v 1.1 2001/02/14 22:12:21 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- from Brian Gregor

module Main where

import IO 
import System
import Numeric

-- read the file
main = do input <- getContents
      putAns (lines input)         
        

-- print out the answers
putAns :: [String] -> IO ()
putAns st_nums = do
               putStrLn ("n:                  " ++ (showInt (truncate n) ""))
                   putStrLn ("median:             " ++ (showFFloat (Just 6) (median nums n) ""))
           putStrLn ("mean:               " ++ (showFFloat (Just 6) mean ""))
           putStrLn ("average_deviation:  " ++ (showFFloat (Just 6) avg_dev ""))
           putStrLn ("standard_deviation: " ++ (showFFloat (Just 6) std_dev ""))
           putStrLn ("variance:           " ++ (showFFloat (Just 6) var ""))
           putStrLn ("skew:               " ++ (showFFloat (Just 6) skew ""))
           putStrLn ("kurtosis:           " ++ (showFFloat (Just 6) kurt ""))
                 where
             n = fromIntegral (length nums)
           nums = strToDoub st_nums
           mean = (sum nums) / n
           deviation = [x-mean | x <- nums] 
           avg_dev = (sum [abs x | x <- deviation])/ n
           var = (sum [x**2 | x <- deviation]) / (n-1)
           std_dev = sqrt var
           skew = (sum [x**3 | x <- deviation]) / (n*var*std_dev)
           kurt = (sum [x**4 | x <- deviation]) / (n*var*var)-3.0


-- convert the strings to doubles
strToDoub :: [String] -> [Double]
strToDoub nums = map conv nums
    where  conv x = fst (head (readFloat x))

-- calculate the median
median :: [Double] -> Double -> Double
median nums n = mid (mSort nums)
       where 
         mid x 
           | odd (length x) = x!! midpt
           | otherwise       = ((x!!(midpt-1)) + (x!!midpt)) / 2.0
         midpt :: Int
         midpt = floor (n/2) 

-- Sorting: the various languages use various algorithms
-- here's  an optimized mergesort from 
-- "Algorithms - a Functional Approach" by
-- Fethi Rabhe & Guy Lapalme
split :: (Ord a) => [a] -> [[a]]
split [] = []
split (x:xs) = [x]:split xs

merge :: (Ord a) => [a] -> [a] -> [a]
merge [] b  = b
merge a [] = a
merge a@(x:xs) b@(y:ys)
    | (x<=y) = x : (merge xs b)
    | otherwise = y : (merge a ys)

mergepairs :: (Ord a) => [[a]] -> [[a]]
mergepairs [] = []
mergepairs x@[l] = x
mergepairs (l1:l2:rest) = (merge l1 l2) : (mergepairs $! rest)

-- The actual sort
mSort :: (Ord a) => [a] -> [a]
mSort l = ms (split l)
    where  ms [r] = r
           ms l   = ms (mergepairs l)

-- $Id: strcat.ghc,v 1.3 2001/06/16 01:24:09 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- from Josef Svenningsson
-- shortened by Bryn Keller

import System(getArgs, getProgName)

lengthNHellos n = length (concat (replicate n "hello\n"))

main = do
       arg <- getArgs
       case arg of
         [number] -> putStrLn $ show $ lengthNHellos (read number)
         _        -> do name <- getProgName; fail ("Usage: " ++ name ++ "number")

-- $Id: sumcol.ghc,v 1.4 2001/02/24 23:49:59 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- from Julian Assange

module Main where
import Numeric(readDec)

main = interact (flip (++) "\n" . show . sum . nums . lines)
       where
       nums  = map (fst . head . readDec)

-- $Id: wordfreq.ghc,v 1.2 2001/02/27 04:04:35 doug Exp $
-- http://www.bagley.org/~doug/shootout/
-- from Julian Assange

-- compile with:
-- ghc -O -package data wordfreq.hs -o wordfreq

module Main where
import List(sortBy)
import Char(toLower,isLower)
import FiniteMap(fmToList,emptyFM,addToFM_C)

main = interact $ unlines . pretty . sort . fmToList . makemap . cwords . lower
 where
       pretty l  = [pad 7 (show n) ++ "\t" ++ w | (w,n) <- l]
                   where
                         pad n s = replicate (n - length s) ' ' ++ s

       sort      = sortBy (\(w0,n0) (w1,n1) -> case compare n1 n0 of
                                               EQ -> compare w1 w0
                           x  -> x)

       makemap   = addFM emptyFM
               where addFM fm [] = fm
                 addFM fm (x:xs) = addFM (addToFM_C (+) fm x 1) xs

       cwords s  = case dropWhile (not . isLower) s of
                "" -> []
                        s' -> w : (cwords s'')
                              where (w, s'') = span isLower s' 

       lower     = map toLower