/mobile Handheld Friendly website

 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.680.562,4682919  13% 6% 11% 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 #5 program source code

--
-- The Computer Language Benchmarks Game
-- http://benchmarksgame.alioth.debian.org/
--
--   Sterling Clover's translation of Tim Hochberg's Clean implementation

module Main where
import System.Environment
import Data.Bits
import Data.List hiding (permutations)
import Data.Array.IArray
import Data.Array.Unboxed
import Control.Arrow

--- The Board ---
n_elem = 5
n_col = 5
n_row = 10

m_top :: Mask
m_top = 0x1F

cells :: [Cell]
cells = [0..49]

colors :: [Color]
colors = [0..9]

cellAt x y = x + n_col * y
coordOf i = snd &&& fst $ i `quotRem` n_col
isValid x y = 0 <= x && x < n_col && 0 <= y && y < n_row

--- Piece Operations ---
data Direction = E | SE | SW | W | NW | NE deriving (Enum, Eq, Ord)
type Piece = [Direction]
type CellCoord = (Int, Int)
type Mask = Int; type Color = Int; type Row = Int;
type Col = Int; type Tag = Int; type Cell = Int
type Solution = [Mask]

pieces :: Array Int 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]]

permutations :: Piece -> [Piece]
permutations p = take 12 (perms p)
    where
      perms p = p:(flip p) : perms (rotate p)
      rotate piece = map r piece
          where r E  = NE
                r NE = NW
                r NW = W
                r W  = SW
                r SW = SE
                r SE = E
      flip piece = map f piece
          where f E  = W
                f NE = NW
                f NW = NE
                f W  = E
                f SW = SE
                f SE = SW

--- Mask Operations ----
untag :: Mask -> Mask
untag mask   = mask .&. 0x1ffffff

retag :: Mask -> Tag -> Mask
retag mask n = untag mask .|. n `shiftL` 25

tagof :: Mask -> Tag
tagof mask   = mask `shiftR` 25

tag :: Mask -> Tag -> Mask
tag   mask n = mask .|. n `shiftL` 25

count1s :: Mask -> Int
count1s i 
    | i == 0 = 0
    | i .&. 1 == 1 = 1 + count1s (i `shiftR` 1)
    | otherwise = count1s (i `shiftR` 1)

first0 :: Mask -> Int
first0 i 
    | i .&. 1 == 0 = 0
    | otherwise = 1 + first0 (i `shiftR` 1)

--- Making the Bitmasks ---
mod2 x = x .&. 1
packSize a b = a*5+b
unpackSize n = quotRem n 5

move :: Direction -> CellCoord -> CellCoord
move E  (x, y) = (x+1, y)
move W  (x, y) = (x-1, y)
move NE (x, y) = (x+(mod2 y),   y-1)
move NW (x, y) = (x+(mod2 y)-1, y-1)
move SE (x, y) = (x+(mod2 y),   y+1)
move SW (x, y) = (x+(mod2 y)-1, y+1)

pieceBounds :: Piece -> Bool -> (Int, Int, Int, Int)
pieceBounds piece isodd = bnds piece 0 y0 0 y0 0 y0
  where
    y0 | isodd = 1 | otherwise = 0
    bnds [] _ _ xmin ymin xmax ymax = (xmin, ymin, xmax, ymax)
    bnds (d:rest) x y xmin ymin xmax ymax =
        bnds rest x' y' (min x' xmin) (min y' ymin) (max x' xmax) (max y' ymax)
            where (x', y') = move d (x, y)

pieceMask :: Piece -> (Mask, Mask)
pieceMask piece 
    | odd y1    = (tag (msk piece x2 y2 0) (packSize w2 h2),
                   tag (msk piece x1 (y1+1) 0 `shiftR` n_col) (packSize w1 h1))
    | otherwise = (tag (msk piece x1 y1 0) (packSize w1 h1),
                   tag (msk piece x2 (y2+1) 0 `shiftR` n_col) (packSize w2 h2))
    where
      (xmin, ymin, xmax, ymax) = pieceBounds piece False
      (x1, y1) = (-xmin, -ymin)
      w1 = xmax - xmin
      h1 = ymax - ymin
      (xmin', ymin', xmax', ymax') = pieceBounds piece True
      (x2, y2) = (-xmin', (-ymin')+1)
      w2 = xmax' - xmin'
      h2 = ymax' - ymin'
      msk :: Piece -> Col -> Row -> Mask -> Mask
      msk [] x y m = m `setBit` cellAt x y
      msk (d:rest) x y m = msk rest x' y' (m `setBit` cellAt x y)
          where (x', y') = move d (x, y)

templatesForColor :: Color -> ([Mask], [Mask])
templatesForColor c = (unzip . map pieceMask) perms
    where perms | c == 5 = take 6 ps | otherwise = ps
          ps = permutations $ pieces ! c

--- Looking for Islands ---
noLineIslands :: Mask -> Cell -> Cell -> Int -> Bool
noLineIslands mask start stop step
    | (fnd testBit . fnd ((not .) . testBit) . fnd testBit)  start > stop  = True
    | otherwise = False
  where
    fnd test !x
        | x >= 25     = 25
        | test mask x = x
        | otherwise   = fnd test (x+step)

noLeftIslands :: Mask -> Bool
noLeftIslands  mask  = noLineIslands mask 0 20 5
noRightIslands mask  = noLineIslands mask 4 24 5

noIslands :: Mask -> Bool
noIslands board = noisles board (count1s board)

noisles :: Mask -> Int -> Bool
noisles _ 30 = True
noisles board ones
    | (ones' - ones) `rem` n_elem /= 0 = False
    | otherwise = noisles board' ones'
    where board' = fill board (coordOf (first0 board))
          ones' = count1s board'

fill :: Mask -> CellCoord -> Mask
fill m cc@(x, y)
    | x < 0 || x >= n_col = m
    | y < 0 || y >= 6     = m
    | testBit m i = m
    | otherwise = foldl (\m d -> fill m (move d cc)) (setBit m i)
                  [E, NE, NW, W, SW, SE]
    where i = cellAt x y

--- More Mask Generation ---
masksForColor :: Color -> [(Row, Mask)]
masksForColor c = concatMap atCell cells
  where
    (evens, odds) = templatesForColor c
    atCell n
        | even y = [(y, retag (m `shiftL` x) c) | m <- evens , isok m x y]
        | odd  y = [(y, retag (m `shiftL` x) c) | m <- odds  , isok m x y]
        where (x, y) = coordOf n

isok :: Mask -> Row -> Col -> Bool
isok mask x y =
    isValid (x+width) (y+height) &&
            case (y == 0, y+height==9) of
              (False, False) -> noLeftIslands mask' && noRightIslands mask'
              (False, True)  -> noIslands (mask' `shiftL` (n_col * (y - 4)))
              (True, _ ) -> noIslands mask'
    where (width, height) = unpackSize (tagof mask)
          mask' = untag mask `shiftL` x

masksAtCell :: Array (Row,Col) (Array Color [Mask])
masksAtCell = trps $ map (masksAt cells . masksForColor) colors

masksAt :: [Int] -> [(Row,Mask)]-> [[Mask]]
masksAt [] _ = []
masksAt (n:ns) !masks = map snd t : masksAt ns f
    where
      (t, f) = partition test masks
      test (r, m) = n' >= 0 && n' < 25 &&  m `testBit` n'
          where n' = n - (n_col * r)

trps :: [[[Mask]]] -> Array (Row, Col) (Array Color [Mask])
trps !a = array ((0,0),(9,4)) $ concatMap (uncurry (map . first . (,))) $
          zip [0..9] [copy !! y | y <- [1,0,1,0,1,2,3,4,5,6]]
    where
      copy = [ [(x,copy' (cellAt x y)) | x <- [0..n_col-1]] |
               y <- [1,2,5,6,7,8,9]]
      copy' cell = array (0,9) $ map (\clr -> (clr,a !! clr !! cell)) colors

--- Formatting ---
format :: Bool -> String -> String
format _ [] = ""
format isodd chars | isodd = " " ++ str | otherwise = str
        where
          (cur, rest) = splitAt 5 chars
          str =  intersperse ' ' cur ++ " \n" ++ format (not isodd) rest

toString :: Solution -> String
toString !masks = map color cells
    where
      masksWithRows = withRows 0 0 (reverse masks)
      withRows _ _ [] = []
      withRows board r (m:rest) = (r', m) : withRows board' r' rest
          where delta = first0 board `quot` n_col
                board' = board `shiftR`  (delta * n_col) .|. untag m
                r' = r+delta
      color n = maybe '.' (("0123456789" !!) . tagof . snd)
                (find matches masksWithRows)
          where
            matches (r, m)
              | n' < 0 || n' > 30  = False
              | otherwise  = (untag m) `testBit` n'
              where n' = n - (n_col * r)

--- Generate the solutions ---
firstZero :: UArray Int Int
firstZero = array (0,31) $ zip [0..31]
            [0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,5]

solutions :: [String]
solutions = solveCell 0 colors 0 [] []

solveCell :: Row -> [Color] -> Mask -> Solution -> [String] -> [String]
solveCell _ [] board soln results = let s = toString soln
                                    in  s:(reverse s):results 
solveCell !row !todo !board !soln results
    | top/=m_top = foldr solveMask results
                   [(m, c) | c <- todo, m  <- masks ! c,  board .&. m == 0]
    | otherwise  = solveCell (row+1) todo (board `shiftR` n_col) soln results
    where top = board .&. m_top
          masks = masksAtCell ! (row, (firstZero ! top) )
          solveMask (!m,!c) results =
              solveCell row (delete c todo) (untag m .|. board) (m:soln) results

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

 make, command-line, and program output logs

Wed, 16 Apr 2014 23:58:57 GMT

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

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