Glasgow Haskell Compiler Back to the Win32 Shootout Back to dada's perl lab

[The Original Shootout]   [NEWS]   [FAQ]   [Methodology]   [Platform Details]   [Acknowledgements]   [Scorecard]
All Source For ghc
Ackermann's Function
```-- \$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));
```
Array Access
```-- \$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 =

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
```
Count Lines/Words/Chars
```-- \$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
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)
```
Echo Client/Server
```-- \$Id: echo.ghc,v 1.2 2001/05/01 20:19:52 doug Exp \$
-- http://www.bagley.org/~doug/shootout/
-- 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
listen s 2
return s

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

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

client_sock = do
s <- socket AF_INET Stream 6
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
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 ()
```
Exception Mechanisms
```-- \$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]
putStrLn ("Exceptions: HI=" ++ show nhi ++ " / LO=" ++ show nlo)
```
Fibonacci Numbers
```-- \$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)
```
Hash (Associative Array) Access
```-- \$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."
```
Heapsort
```-- \$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

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)
```
Hello World
```-- \$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"
```
List Operations
```-- \$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
```
Matrix Multiplication
```-- \$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 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)
_        -> 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]
```
Nested Loops
```-- \$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(..))

main = do
arg <- getArgs
case arg of
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
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
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 ()

main = do (a:_) <- getArgs
produced <- newIORef 0
consumed <- newIORef 0
channel <- newCVar
p <- myForkIO (producer n produced channel)
c <- myForkIO (consumer n consumed channel)
join p; join c
putStrLn (show prod ++ " " ++ show cons)
```
Random Number Generator
```-- \$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
```
Reverse a File
```-- \$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
```
Sieve of Erathostenes
```-- \$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]
```
Spell Checker
```-- \$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

main = do
interact \$ unlines . filter (\x -> not \$ elemFM x (addFM emptyFM (lines d))) . lines
```
Statistical Moments
```-- \$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

main = do input <- getContents
putAns (lines input)

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

-- 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)
```
String Concatenation
```-- \$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")

```
Sum a Column of Integers
```-- \$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

main = interact (flip (++) "\n" . show . sum . nums . lines)
where
```
Word Frequency Count
```-- \$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)

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)