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,0981.270.973,8362200  100% 12% 13% 10%

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 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.Char(intToDigit); import Data.Maybe; import Data.Word(Word64); import Numeric(showIntAtBase);

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

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

left :: Mask
left = shift right (width-1)

right :: Mask
right = foldl' (\a b -> a .|. (shift 1 b)) 0 [0,width..width*(height-1)]

bottom :: Mask
bottom = 0x1f

top :: Mask
top = shift bottom (width*(height-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)

cells :: Piece -> Cell -> Maybe [Cell]
cells [] cell = Just [cell]
cells (d:ds) cell@(x,y) =
   case move (x,y) d of
      Nothing -> Nothing
      Just (x',y') ->
         case cells ds (x',y') of
            Nothing -> Nothing
            Just ps -> Just $ (x,y) : ps
            
bitCount :: Mask -> Int
bitCount 0 = 0
bitCount mask = (fromIntegral $ (mask .&. 1)) + (bitCount (shiftR mask 1))

floodFill :: Mask -> Mask -> Mask
floodFill mask fromBit
   | overlaps fromBit mask = mask
   | otherwise =   
      let mask' = mask .|. fromBit
      in foldl' (floodFill) mask' $ 
            map snd $ filter (\(a, b) -> not $ overlaps a fromBit) $ 
               zip [left, right, top, bottom] $ 
                  map (shift fromBit) [1,-1,width,-width]

findFreeBit :: Mask -> Mask
findFreeBit mask = fromJust $ find (not.(overlaps mask)) $ map (shift 1) [0..width*height-1]

noIslands :: Mask -> Bool
noIslands mask = not $ any (<5) $ diffs $ noIslands' mask where
   noIslands' mask
      | mask == fullMask = [bitCount mask]
      | otherwise = (bitCount mask): (noIslands' $ floodFill mask $ findFreeBit mask)
   diffs (x:y:[]) = [y-x]
   diffs (x:y:xs) = (y-x): (diffs $ y:xs)

bitmasksWithColor :: Array Color [Mask]
bitmasksWithColor = amap bitmasksWithColor' pieces where
   
   bitmasksWithColor' :: Piece -> [Mask]
   bitmasksWithColor' piece 
      | piece == [NW, W,  NW, SE, SW] = do 
         piece' <- (take 3 $ iterate rot piece) ++ (take 3 $ iterate rot $ flop piece)
         filter noIslands $ map mask $ mapMaybe (cells piece') allCells
         
      | otherwise = do 
         piece' <- (take 6 $ iterate rot piece) ++ (take 6 $ iterate rot $ flop piece)
         filter noIslands $ map mask $ mapMaybe (cells piece') allCells
   

bitmasksAtCell :: [Mask] -> Array Cell [Mask]
bitmasksAtCell masks = 
   let masks' = (bitmasksAtCell' (shift 1 $ width*height - 1) [] (reverse $ sort masks))
   in  array ((0,0),(4,9)) $ zip [(x,y) | y <- [9,8..0], x <- [4,3..0]] masks' where
      
      bitmasksAtCell' :: Mask -> [Mask] -> [Mask] -> [[Mask]]
      bitmasksAtCell' 1 cellMasks [] = [cellMasks] 
      bitmasksAtCell' cellMask cellMasks [] = cellMasks:(bitmasksAtCell' (shiftR cellMask 1) [] [])
      bitmasksAtCell' cellMask cellMasks masks@(m:ms)
         | overlaps cellMask m = bitmasksAtCell' cellMask (m:cellMasks) ms
         | otherwise = cellMasks : (bitmasksAtCell' (shiftR cellMask 1) [] masks)
         

bitmasksWithColorAtCell :: Array Color (Array Cell [Mask])
bitmasksWithColorAtCell = amap bitmasksAtCell bitmasksWithColor

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


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

legal :: Mask -> [Mask] -> [Mask]
legal boardMask masks = filter (not.(overlaps boardMask)) masks      


solutions :: [String]
solutions = solutions' 0 (width-1, height-1) [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 
      | overlaps board (mask cell) = solutions' board (nextCell cell) colorsLeft usedMasks
      | otherwise = do
         color <- colorsLeft
         mask <- legal board $ bitmasksWithColorAtCell!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) * (read $ showIntAtBase 2 intToDigit m "")) :: Integer) colorMasks

invertString :: String -> String
invertString s = [s!!(width-x-1 + (height-y-1)*width) | y <- [0..height-1], x <- [0 .. width-1]]

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

Wed, 16 Apr 2014 20:13:54 GMT

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

COMMAND LINE:
./meteor.ghc_run +RTS -N4 -RTS 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