Game Trees Benchmark

We present a small benchmark comparing time and space performance of a program whose original version is compared against the fused version obtained with HFusion. This example is taken from [1]. The results were measured by compiling the programs with the Glasgow Haskell Compiler (GHC) version 7.0.3 feeding it with the -O flag. The -O flag enables various optimizations incluiding the shortcut fusion implementation of GHC for functions in the standard libraries. This implies that the tests presented below always offered a chance to GHC to improve the programs via shortcut fusion, though it would do so only in the case of compositions of functions in the standard libraries.

The following table presents the time comparisons in seconds. The time ratio is calculated as 100 * F/O where O is the running time of the original program and F is the running time of the fused program.

Program O F time ratio
gametrees 24.2 19.6 81%

In the following table we present the comparisons of total allocated bytes. The space ratio is calculated as 100 * F/O where O is the count of kilobytes allocated by the original program and F is the count of kilobytes allocated by the fused program.

Program O F space ratio

gametrees 35,062,680 27,603,380 78%

The Code

We first present the original program followed by the fused program. Both programs were fed with the input:

gametrees.hs (original)

import Data.List(partition,nub,intersperse,maximumBy)
import Data.Function(on)
import Data.Char(isDigit)
import Data.Maybe(catMaybes,isNothing,isJust)
import Control.Arrow((***))
import MinMax


main = play (readPos "----------------")

boardSize :: Int
boardSize = 4

newtype Position = Position { unPos :: [Maybe Bool] }

pRow i = zip [boardSize*i..] . take boardSize . drop (boardSize*i)
pCol i p =  [ (j,p!!j) | j<-[i,i+boardSize,i+2*boardSize] ]
pDiag 0 p = [ (j,p!!j) | j<-[0,boardSize+1..boardSize*boardSize-1] ]
pDiag 1 p = [ (j,p!!j) | j<-[boardSize-1,2*boardSize-2..boardSize*(boardSize-1)] ]

rows :: Position -> [[(Int,Maybe Bool)]]
rows (Position p) = pDiag 0 p : pDiag 1 p : concat [ [pRow i p,pCol i p] | i<-[0..boardSize-1] ]

parity :: Position -> Bool
parity p = uncurry (<=)$ (length *** length)$ partition id$ catMaybes$ unPos p

gameEnded :: Position -> Bool
gameEnded p =
      all isJust (unPos p) 
       || wins True p
       || wins False p

wins :: Bool -> Position -> Bool
wins b = any ((==0) . length) . freePositions b

moves :: Position -> [Position]
moves p = if gameEnded p then [] else map Position$ moves' (parity p) (unPos p)
  where
   moves' par (Nothing:xs) = (Just par : xs) : map (Nothing:) (moves' par xs)
   moves' par (x:xs) = map (x:) (moves' par xs)
   moves' _ _ = []

sqr x = x*x

static :: Position -> Int
static p = if any ((==0) . length) fpFalse then 0
           else if any ((==0) . length) fpTrue then sqr boardSize*2+1
           else if par && any ((==1) . length) fpTrue then sqr boardSize*2
           else if not par && any ((==1) . length) fpFalse then 0
           else if (>1)$ length$ nub $ filter ((==1) . length) fpFalse then 0
           else if (>1)$ length$ nub $ filter ((==1) . length) fpTrue then sqr boardSize*2
           else sqr boardSize + length (concat (filter ((<boardSize) . length) fpTrue)) - length (concat (filter ((<boardSize) . length) fpFalse))
  where fpTrue = freePositions True p
        fpFalse = freePositions False p
        par = parity p


freePositions :: Bool -> Position -> [[Int]]
freePositions b p = catMaybes$ map eval (rows p)
  where eval :: [(Int,Maybe Bool)] -> Maybe [Int]
        eval r = if all (\(_,c) -> Just b==c || c==Nothing) r
                  then Just$ map fst$ filter (isNothing . snd) r
                  else Nothing

instance Show Position where
 show (Position p) = concat$ intersperse "\n"$ [ renderRow (take boardSize$ drop (boardSize*i) p) | i<-[0..boardSize-1] ]
  where renderRow r = map renderCell r
        renderCell Nothing      = '-'
        renderCell (Just True)  = 'o'
        renderCell (Just False) = 'x'

readPos :: String -> Position
readPos = Position . take (boardSize*boardSize) . (++repeat Nothing) . map readCell
  where readCell '-' = Nothing
        readCell 'x' = Just False
        readCell 'o' = Just True

play :: Position -> IO ()
play p' = do
  let p = computerMove p'
  print p
  if gameEnded p then
    if wins True p then putStrLn "You lost!"
      else if wins False p then putStrLn "You won!"
        else putStrLn "It's a draw."
   else do 
    putStr ("Your turn [1.."++show (boardSize*boardSize)++"]: ")
    s<-getLine
    putStrLn ""
    if s=="0" then do
       putStrLn (show$ freePositions True p)
       putStrLn (show$ freePositions False p)
       putStrLn (show$ static p)
       play p
     else play (playerMove s p)


computerMove :: Position -> Position
computerMove p = if gameEnded p then p
                   else snd$ maximumBy (compare `on` fst)$ zip (map (evaluate static moves) mvs) mvs
  where mvs = moves p

playerMove :: String -> Position -> Position
playerMove s (Position p) =
     let p' = makeMove (readDigit s) p
      in if p==p' then Position$ makeMove 0 p
          else Position p'
  where
    readDigit s | all isDigit s = (read s-1) :: Int
                | otherwise = 0
    makeMove i (Nothing : xs) | i<=0 = Just False : xs
    makeMove i (x : xs) = x : makeMove (i-1) xs
    makeMove i [] = []

MinMax.hs (original)

module MinMax where

import Data.List(partition,nub,intersperse,maximumBy)
import Data.Function(on)
import Data.Char(isDigit)
import Data.Maybe(catMaybes,isNothing,isJust)
import Control.Arrow((***))

data Tree a = Node a [Tree a]


reptree f a = Node a (map (reptree f) (f a))

maptree f (Node a chs) = Node (f a) (map (maptree f) chs)

prune :: Int -> Tree a -> Tree a
prune 0 (Node a _) = Node a []
prune n (Node a chs) = Node a (map (prune (n-1)) chs)

maximize :: Ord a => Tree a -> a
maximize = maximum . maximize'
minimize :: Ord a => Tree a -> a
minimize = minimum . minimize'

maximize' (Node n []) = [n]
maximize' (Node n chs) = mapmin (map minimize' chs)

minimize' (Node n []) = [n]
minimize' (Node n chs) = mapmax (map maximize' chs)

mapmin (xs:xss) = case minimum xs of m -> m : omitmin m xss
mapmax (xs:xss) = case maximum xs of m -> m : omitmax m xss

omitmin pot [] = []
omitmin pot l@(xs:xss) = if minleq xs pot then omitmin pot xss
                           else mapmin l

omitmax pot [] = []
omitmax pot l@(xs:xss) = if maxgeq xs pot then omitmax pot xss
                           else mapmax l

minleq [] pot = False
minleq (x:xs) pot = x <= pot || minleq xs pot

maxgeq [] pot = False
maxgeq (x:xs) pot = x >= pot || maxgeq xs pot


evaluate static moves = minimize . maptree static . prune 6 . reptree moves

gametrees.hs (fused)

import Data.List(partition,nub,intersperse,maximumBy)
import Data.Function(on)
import Data.Char(isDigit)
import Data.Maybe(catMaybes,isNothing,isJust)
import Control.Arrow((***))
import MinMaxFused


main = play (readPos "----------------")

boardSize :: Int
boardSize = 4

newtype Position = Position { unPos :: [Maybe Bool] }

pRow i = zip [boardSize*i..] . take boardSize . drop (boardSize*i)
pCol i p =  [ (j,p!!j) | j<-[i,i+boardSize,i+2*boardSize] ]
pDiag 0 p = [ (j,p!!j) | j<-[0,boardSize+1..boardSize*boardSize-1] ]
pDiag 1 p = [ (j,p!!j) | j<-[boardSize-1,2*boardSize-2..boardSize*(boardSize-1)] ]

rows :: Position -> [[(Int,Maybe Bool)]]
rows (Position p) = pDiag 0 p : pDiag 1 p : concat [ [pRow i p,pCol i p] | i<-[0..boardSize-1] ]

parity :: Position -> Bool
parity p = uncurry (<=)$ (length *** length)$ pc id$ unPos p

pc p [] = ([],[])
pc p (Nothing:ms) = pc p ms
pc p ((Just a):ms) =
        case pc p ms of
          (vs,ys) ->
              if p a then (a : vs,ys)
                else (vs,a : ys)

gameEnded :: Position -> Bool
gameEnded p =
      all isJust (unPos p) 
       || wins True p
       || wins False p

wins :: Bool -> Position -> Bool
wins b = anyFreePositions ((==0) . length) b

moves :: Position -> [Position]
moves p = if gameEnded p then [] else map Position$ moves' (parity p) (unPos p)
  where
   moves' par (Nothing:xs) = (Just par : xs) : map (Nothing:) (moves' par xs)
   moves' par (x:xs) = map (x:) (moves' par xs)
   moves' _ _ = []

sqr x = x*x

static :: Position -> Int
static p = if any ((==0) . length) fpFalse then 0
           else if any ((==0) . length) fpTrue then sqr boardSize*2+1
           else if par && any ((==1) . length) fpTrue then sqr boardSize*2
           else if not par && any ((==1) . length) fpFalse then 0
           else if (>1)$ length$ nub $ filter ((==1) . length) fpFalse then 0
           else if (>1)$ length$ nub $ filter ((==1) . length) fpTrue then sqr boardSize*2
           else sqr boardSize + v49 ((<boardSize) . length) fpTrue - v49 ((<boardSize) . length) fpFalse
  where fpTrue = freePositions True p
        fpFalse = freePositions False p
        par = parity p


freePositions :: Bool -> Position -> [[Int]]
freePositions b p = cm eval (rows p)
  where eval :: [(Int,Maybe Bool)] -> Maybe [Int]
        eval r = if all (\(_,c) -> Just b==c || c==Nothing) r
                  then Just$ map fst$ filter (isNothing . snd) r
                  else Nothing

anyFreePositions :: ([Int]->Bool) -> Bool -> Position -> Bool
anyFreePositions pr b p = anycm pr eval (rows p)
  where eval :: [(Int,Maybe Bool)] -> Maybe [Int]
        eval r = if all (\(_,c) -> Just b==c || c==Nothing) r
                  then Just$ map fst$ filter (isNothing . snd) r
                  else Nothing

v49 p [] = 0
v49 p (x16:xs32) =
        if p x16 then v50 p xs32 x16
          else v49 p xs32

v50 p v33 (_:xs) = 1 + (v50 p v33 xs)
v50 p v33 [] = v49 p v33


cm f [] = []
cm f (a:as) =
        case f a of
          Nothing -> cm f as
          Just a27 -> a27 : cm f as

anycm p f [] = False
anycm p f (a7:as6) =
        case f a7 of
          Just x -> p x || anycm p f as6
          _ -> anycm p f as6


instance Show Position where
 show (Position p) = concat$ intersperse "\n"$ [ renderRow (take boardSize$ drop (boardSize*i) p) | i<-[0..boardSize-1] ]
  where renderRow r = map renderCell r
        renderCell Nothing      = '-'
        renderCell (Just True)  = 'o'
        renderCell (Just False) = 'x'

readPos :: String -> Position
readPos = Position . take (boardSize*boardSize) . (++repeat Nothing) . map readCell
  where readCell '-' = Nothing
        readCell 'x' = Just False
        readCell 'o' = Just True

play :: Position -> IO ()
play p' = do
  let p = computerMove p'
  print p
  if gameEnded p then
    if wins True p then putStrLn "You lost!"
      else if wins False p then putStrLn "You won!"
        else putStrLn "It's a draw."
   else do 
    putStr ("Your turn [1.."++show (boardSize*boardSize)++"]: ")
    s<-getLine
    putStrLn ""
    if s=="0" then do
       putStrLn$ show$ freePositions True p
       putStrLn$ show$ freePositions False p
       putStrLn$ show$ static p
       play p
     else play$ playerMove s p


computerMove :: Position -> Position
computerMove p = if gameEnded p then p
                   else snd$ mzm (compare `on` fst) (evaluate static moves) mvs mvs
  where mvs = moves p

zipmap f [] v3 = []
zipmap f (a55:as17) (y:ys) = (f a55,y) : zipmap f as17 ys
zipmap f (_:_) v3 = []

mzm cmp f (a57:as20) (y2:ys2) =
        let x20 = (f a57,y2)
         in case (as20,ys2) of
              ([],_) -> x20
              (_:_,_:_) ->
                  let mxs = mzm cmp f as20 ys2
                   in case cmp x20 mxs of
                        GT -> x20
                        _ -> mxs
              (_:_,_) -> x20

playerMove :: String -> Position -> Position
playerMove s (Position p) =
     let p' = makeMove (readDigit s) p
      in if p==p' then Position$ makeMove 0 p
          else Position p'
  where
    readDigit s | all isDigit s = (read s-1) :: Int
                | otherwise = 0
    makeMove i (Nothing : xs) | i<=0 = Just False : xs
    makeMove i (x : xs) = x : makeMove (i-1) xs
    makeMove i [] = []

MinMax.hs (fused)

module MinMaxFused where

import Data.List(partition,nub,intersperse,maximumBy)
import Data.Function(on)
import Data.Char(isDigit)
import Data.Maybe(catMaybes,isNothing,isJust)
import Control.Arrow((***))


data Tree a = Node a [Tree a]


reptree f a = Node a (map (reptree f) (f a))

maptree f (Node a chs) = Node (f a) (map (maptree f) chs)

prune :: Int -> Tree a -> Tree a
prune 0 (Node a _) = Node a []
prune n (Node a chs) = Node a (map (prune (n-1)) chs)

maximize :: Ord a => Tree a -> a
maximize = maximum . maximize'
minimize :: Ord a => Tree a -> a
minimize = minimum . minimize'


maximize' (Node n []) = [n]
maximize' (Node n (c:chs)) = mapminmap minimize' (minimize' c) chs

minimize' (Node n []) = [n]
minimize' (Node n (c:chs)) = mapmaxmap maximize' (maximize' c) chs


mapmin (xs:xss) = case minimum xs of m -> m : omitmin m xss
mapmax (xs:xss) = case maximum xs of m -> m : omitmax m xss

omitmin pot [] = []
omitmin pot l@(xs:xss) = if minleq xs pot then omitmin pot xss
                           else mapmin l

omitmax pot [] = []
omitmax pot l@(xs:xss) = if maxgeq xs pot then omitmax pot xss
                           else mapmax l

minleq [] pot = False
minleq (x:xs) pot = x <= pot || minleq xs pot

maxgeq [] pot = False
maxgeq (x:xs) pot = x >= pot || maxgeq xs pot


evaluate static moves = minimum .  minimizemaptreeprunereptree static moves 6


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

mapminmap f xs v9 =
        let m = minimum xs
         in m : v13 f m v9

v13 f pot [] = []
v13 f pot (x8:ys4) =
        let xs18 = f x8
         in if minleq xs18 pot then v13 f pot ys4
              else mapminmap f xs18 ys4

mapmaxmap f xs v9 =
        let m = maximum xs
         in m : v14 f m v9

v14 f pot [] = []
v14 f pot (x8:ys4) =
        let xs18 = f x8
         in if maxgeq xs18 pot then v14 f pot ys4
              else mapmaxmap f xs18 ys4


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

prunereptree f 0 a12 = Node a12 []
prunereptree f v1 a12 = Node a12 (v29 f (v1 - 1) (f a12))

v29 f n0 [] = []
v29 f n0 (y10:ys20) = prunereptree f n0 y10 : v29 f n0 ys20


maptreeprunereptree f f4 0 a12 = Node (f a12) (map1 f [])
maptreeprunereptree f f4 v1 a12 =
        Node (f a12) (v39 f f4 (v1 - 1) (f4 a12))

v39 f f5 n0 [] = []
v39 f f5 n0 (y13:ys23) =
        maptreeprunereptree f f5 n0 y13 : v39 f f5 n0 ys23


mapmaxmap0 xs v9 =
        let m = maximum xs
         in m : v43 m v9

v43 pot [] = []
v43 pot (x8:ys4) =
        let xs18 = maximize' x8
         in if maxgeq xs18 pot then v43 pot ys4
              else mapmaxmap0 xs18 ys4



mapminmap0 xs v9 =
        let m = minimum xs
         in m : v16 m v9

v16 pot [] = []
v16 pot (x8:ys4) =
        let xs18 = minimize' x8
         in if minleq xs18 pot then v16 pot ys4
              else mapminmap0 xs18 ys4



minimizemaptreeprunereptree f f4 0 a28 =
        let v59 = map1 f []
         in case v59 of
              [] -> f a28 : []
              _ -> case v59 of c:chs -> mapmaxmap0 (maximize' c) chs
minimizemaptreeprunereptree f f4 v57 a28 =
        case (v57 - 1,f4 a28) of
          (_,[]) -> f a28 : []
          (n24,y23:ys48) -> mapmaxmap0 (v71 f f4 n24 y23) (v39 f f4 n24 ys48)

v71 f f4 0 a29 =
        let v66 = map1 f []
         in case v66 of
              [] -> f a29 : []
              _ -> case v66 of c:chs -> mapminmap0 (minimize' c) chs
v71 f f4 v64 a29 =
        case (v64 - 1,f4 a29) of
          (_,[]) -> f a29 : []
          (n25,y24:ys49) ->
              mapminmap0
                (minimizemaptreeprunereptree f f4 n25 y24)
                (v39 f f4 n25 ys49)

map1 f [] = []
map1 f (y:ys) = maptree f y : map1 f ys

[1] J. Hughes, Why functional programming matters. The Computer Journal, 32(2):98-107, April 1989.

Program	O	F	space ratio
gametrees	35,062,680	27,603,380	78%