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.980.852,7241804  6% 5% 100% 6%

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 #3 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)
type Piece = [Direction]
type CellCoord = (Int, Int)
type CellIndex = Int
type Mask = Word64
type Color = Int
type Solution = String

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 d = toEnum $ mod ((fromEnum d) + 1) 6
instance Rotatable Piece 		where rot a = map rot a

instance Floppable Direction 	where flop d = toEnum $ mod (9 - (fromEnum d)) 6
instance Floppable Piece 		where flop a = map flop a

instance Maskable CellCoord 	where mask (x,y) = bit (x + y*width)
instance Maskable [CellCoord]	where mask p = foldl' (\a b -> a .|. mask b) 0 p
instance Maskable CellIndex 	where mask i = bit i


width :: Int
width = 5

height :: Int
height = 10

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

cellis :: [CellIndex]
cellis = [0..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 :: CellCoord -> Maybe CellCoord
valid p@(x,y)
	| 0 <= x, x < width, 0 <= y, y < height = Just p
	|otherwise = Nothing

move :: CellCoord -> Direction -> Maybe CellCoord
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

legal :: Mask -> Mask -> Bool
legal a b = not $ overlap a b

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

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

freeCell :: Mask -> CellCoord
freeCell mask = 
	fromJust $ find (\(x,y) -> legal mask (bit $ x + y*width)) cellcs

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

placePiece :: Piece -> CellCoord -> Maybe [CellCoord]
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') cellcs
		
		| otherwise = do
			piece' <- (take 6 $ iterate rot piece) ++ (take 6 $ iterate rot $ flop $ piece)
			filter noIslands $ map mask $ mapMaybe (placePiece piece') cellcs

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

format :: Color -> Mask -> Integer
format c m =  (fromIntegral c) * (binToDec m) where
	binToDec :: Mask -> Integer
	binToDec 0 = 0
	binToDec n = (fromIntegral (mod n 2)) + 10*(binToDec $ div n 2)
	
ps :: Solution -> IO ()		
ps solution = pe $ map (concatMap (\a -> [a,' '])) $ 
					take height $ map (take 5) $ iterate (drop width) solution where
	po [] = return ()
	po (s:ss) = do
		putStrLn $ ' ':s
		pe ss

	pe [] = return ()
	pe (s:ss) = do
		putStrLn s
		po ss

solutions :: [Solution]
solutions = solutions' 0 0 [0..9] (10^(width*height)) where

	solutions' :: Mask -> CellIndex -> [Color] -> Integer-> [Solution]
	solutions' _ _ [] i = 	let s = tail.show $ i in [s, reverse s]
	solutions' board cell colorsLeft i
		| overlap board (mask cell) = solutions' board (cell+1) colorsLeft i
		| otherwise = do
			color <- colorsLeft
			mask <- filter (legal board) $ pieceMasksAtCell!color!cell
			solutions' (board .|. mask) (cell+1) (delete color colorsLeft) (i + (format color mask))


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

 make, command-line, and program output logs

Wed, 16 Apr 2014 23:59:05 GMT

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

COMMAND LINE:
./meteor.ghc-3.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