performance measurements

Each table row shows performance measurements for this Haskell GHC program with a particular command-line input value N.

 N  CPU secs Elapsed secs Memory KB Code B ≈ CPU Load
2,0980.920.932,7761891  0% 3% 1% 100%

Read the ↓ make, command line, and program output logs to see how this program was run.

Read meteor-contest benchmark to see what this program should do.

 notes

The Glorious Glasgow Haskell Compilation System, version 7.8.2

 meteor-contest Haskell GHC #2 program source code

{-
   The Computer Language Benchmarks Game
   http://benchmarksgame.alioth.debian.org/
   contributed by Olof Kraigher
-}

module Main where

import System.Environment; import Data.List; import Data.Bits; import Data.Array.IArray;
import Data.Word(Word64); import Data.Maybe; import Control.Monad;

data Direction = E | SE | SW | W | NW | NE deriving (Enum, Eq, Ord, Show)
type Piece = [Direction]
type Cell = (Int, Int)
type Mask = Word64
type Color = Int

class Rotatable a where
   rot :: a -> a 

class Floppable a where
   flop :: a -> a   
   
class Maskable a where
   mask :: a -> Mask

instance Rotatable Direction where
   rot NE = E
   rot d = succ d

instance Rotatable Piece where
   rot a = map rot a

instance Floppable Direction where
   flop E = W
   flop W = E
   flop SE = SW
   flop SW = SE
   flop NE = NW
   flop NW = NE

instance Floppable Piece where
   flop a = map flop a
   
instance Maskable Cell where
   mask (x,y) = bit (x + y*width)

instance Maskable [Cell] where
   mask p = foldl' (\a b -> a .|. mask b) 0 p

width :: Int
width = 5

height :: Int
height = 10

cells :: [Cell]
cells = [(x,y) | y <- [0..height-1], x <- [0..width-1]]

fullMask :: Mask
fullMask = 0x3FFFFFFFFFFFF 
      
pieces :: Array Color Piece
pieces = array (0,9) $ zip [0..9] $ 
      [   [E,    E,  E,  SE],
         [SE, SW, W,  SW],
         [W,  W,  SW, SE],
         [E,  E,  SW, SE],
         [NW, W,  NW, SE, SW],
         [E,  E,  NE, W],
         [NW, NE, NE, W],
         [NE, SE, E,  NE],
         [SE, SE, E,  SE],
         [E,  NW, NW, NW]]

valid :: Cell -> Maybe Cell
valid p@(x,y)
   | 0 <= x, x < width, 0 <= y, y < height = Just p
   |otherwise = Nothing

move :: Cell -> Direction -> Maybe Cell
move (x,y) E = valid (x+1,y)
move (x,y) W = valid (x-1,y)
move (x,y) NE = valid (x+(mod y 2),y-1)
move (x,y) NW = valid (x+(mod y 2)-1,y-1)
move (x,y) SE = valid (x+(mod y 2),y+1)
move (x,y) SW = valid (x+(mod y 2)-1,y+1)

overlap :: Mask -> Mask -> Bool
overlap a b = (a .&. b) /= 0

bitCount :: Mask -> Int
bitCount 0 = 0
bitCount mask = (fromIntegral $ (mask .&. 1)) + (bitCount (shiftR mask 1))

floodFill :: Mask -> Cell -> Mask
floodFill mask cell@(x,y)
   | overlap mask (bit $ x + y*width) = mask
   | otherwise = 
      let mask' = mask .|. (bit $ x + y*width)
      in   foldl' floodFill mask' $ mapMaybe (move cell) [E .. NE]

findFreeCell :: Mask -> Cell
findFreeCell mask = 
   fromJust $ find (\(x,y) -> not $ overlap mask (bit $ x + y*width)) cells

noIslands :: Mask -> Bool
noIslands mask = not $ any (<5) $ diffs $ noIslands' mask where
   noIslands' mask
      | mask == fullMask = [bitCount mask]
      | otherwise = (bitCount mask) : (noIslands' $ floodFill mask $ findFreeCell mask)
   diffs l = zipWith (-) (tail l) l
   

placePiece :: Piece -> Cell -> Maybe [Cell]
placePiece [] cell = Just [cell]
placePiece (p:ps) cell = move cell p >>= (placePiece ps) >>= return . (cell:)

pieceMasks :: Array Color [Mask]
pieceMasks = amap pieceMasks' pieces where      
   pieceMasks' piece
      | piece == (pieces!5) = do
         piece' <- (take 3 $ iterate rot piece) ++ (take 3 $ iterate rot $ flop $ piece)
         filter noIslands $ map mask $ mapMaybe (placePiece piece') cells
      
      | otherwise = do
         piece' <- (take 6 $ iterate rot piece) ++ (take 6 $ iterate rot $ flop $ piece)
         filter noIslands $ map mask $ mapMaybe (placePiece piece') cells

pieceMasksAtCell :: Array Color (Array Cell [Mask])
pieceMasksAtCell = amap pieceMasksAtCell' pieceMasks where
   pieceMasksAtCell' masks = array ((0,0),(width-1,height-1)) $ pieceMasksAtCell'' masks cells where
      pieceMasksAtCell'' masks [] = []
      pieceMasksAtCell'' masks (c:cs) = 
         let (a,b) = partition (overlap (mask c)) masks
         in (c,a) : (pieceMasksAtCell'' b cs)

nextCell :: Cell -> Cell
nextCell (4,y) = (0,y+1)
nextCell (x,y) =  (x+1,y)

solutions :: [String]
solutions = solutions' 0 (0,0) [0..9] [] where

   solutions' :: Mask -> Cell -> [Color] -> [(Color, Mask)]-> [String]
   solutions' _ _ [] usedMasks =    let s = stringOfColorMasks usedMasks in   [s, invertString s]
   solutions' board cell colorsLeft usedMasks 
      | overlap board (mask cell) = solutions' board (nextCell cell) colorsLeft usedMasks
      | otherwise = do
         color <- colorsLeft
         mask <- filter (not.(overlap board)) $ pieceMasksAtCell!color!cell
         solutions' (board .|. mask) (nextCell cell) (colorsLeft \\ [color]) ((color, mask):usedMasks)

stringOfColorMasks :: [(Color, Mask)] -> String
stringOfColorMasks colorMasks = 
   tail.show.(+10^(width*height)).sum $ map (\(c,m) -> (fromIntegral c) * (binToDec m)) colorMasks where
   binToDec :: Mask -> Integer
   binToDec 0 = 0
   binToDec n = (fromIntegral (mod n 2)) + 10*(binToDec $ div n 2)

invertString :: String -> String
invertString s = map (\(x,y) -> s!!(width-x-1 + (height-y-1)*width)) cells

printSolution :: String -> IO ()
printSolution solution = printSolution' 0 solution where
   printSolution' cell [] = return ()
   printSolution' cell (s:ss) = do
      putStr $ s:" "
      case mod (cell+1) width of
         0 -> case mod (cell+1) (2*width) of
            0 -> putStr "\n"
            _ -> putStr "\n "
         _ -> return ()

      printSolution' (cell+1) ss

main = do 
   (n :: Int) <- return.read.head =<< getArgs
   let nsolutions = take n solutions
   putStrLn $ (show $ length nsolutions) ++ " solutions found\n"
   printSolution $ minimum nsolutions
   putStr "\n"
   printSolution $ maximum nsolutions
   putStr "\n"

 make, command-line, and program output logs

Thu, 17 Apr 2014 01:27:38 GMT

MAKE:
mv meteor.ghc-2.ghc meteor.ghc-2.hs
/usr/local/src/ghc-7.8.2/bin/ghc --make -fllvm -O2 -XBangPatterns -rtsopts -XScopedTypeVariables -XTypeSynonymInstances -XFlexibleInstances meteor.ghc-2.hs -o meteor.ghc-2.ghc_run
[1 of 1] Compiling Main             ( meteor.ghc-2.hs, meteor.ghc-2.o )
Linking meteor.ghc-2.ghc_run ...
rm meteor.ghc-2.hs
4.84s to complete and log all make actions

COMMAND LINE:
./meteor.ghc-2.ghc_run  2098

PROGRAM OUTPUT:
2098 solutions found

0 0 0 0 1 
 2 2 2 0 1 
2 6 6 1 1 
 2 6 1 5 5 
8 6 5 5 5 
 8 6 3 3 3 
4 8 8 9 3 
 4 4 8 9 3 
4 7 4 7 9 
 7 7 7 9 9 

9 9 9 9 8 
 9 6 6 8 5 
6 6 8 8 5 
 6 8 2 5 5 
7 7 7 2 5 
 7 4 7 2 0 
1 4 2 2 0 
 1 4 4 0 3 
1 4 0 0 3 
 1 1 3 3 3 

Revised BSD license

  Home   Conclusions   License   Play