めもめも

このブログに記載の内容は個人の見解であり、必ずしも所属組織の立場、戦略、意見を代表するものではありません。

Hine Sweeper

はてなダイアリーのシンタックス・ハイライトが Haskell に対応してると聞きました。。。

hscurses ライブラリを入れてコンパイルしたら、TTY コンソールからこんな感じでお楽しみください。(移動:hjkl、マーク:x、開く:スペース)

####################
#   1x-1           #
#11 12-1           #
#x1  111           #
#11111           11#
#----1 1221   1111-#
#--211 1--1   1----#
#111   1221  12----#
#            1-----#
####################

当方は、この環境です。

$ ghc --version
The Glorious Glasgow Haskell Compilation System, version 6.10.2
-- hinesweeper.hs
-- Mine Sweeper written in Haskell
--
-- 2009/05/31 ver1.0 (Need hscurses library)
--
-- Usage : hinesweeper [number of mines]
-- Keys  : [ijkl] Move / [x] Mark / [Space] Open
--

{-# LANGUAGE ScopedTypeVariables #-}
import UI.HSCurses.Curses
import System
import System.Random
import System.Posix
import Data.Array.IO
import Control.Exception
import Prelude hiding (catch)

type Board = IOArray Int Int

xMax = 20 :: Int
yMax = 10 :: Int

-- misc functions --

nop = putStr ""
myFst (a,_,_) = a
mySnd (_,b,_) = b
myTrd (_,_,c) = c

rand :: Int -> IO Int
rand n = getStdRandom(randomR (0, n))

dualMap :: (Int -> Int -> IO a) -> [Int] -> [Int] -> IO [[a]]
dualMap f rangeX rangeY = mapM (\x -> mapM (\y -> f x y) rangeY) rangeX

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

getBoard :: Board -> Int -> Int -> IO Int
getBoard arr x y = readArray arr (y*xMax+x)

setBoard :: Board -> Int -> Int -> Int -> IO ()
setBoard arr x y i = writeArray arr (y*xMax+x) i

showBoard :: Board -> Window -> IO ()
showBoard brd scr = do
    dualMap (\x y -> readBoard brd x y >>= mvWAddStr scr y x)
            [0..(xMax-1)] [0..(yMax-1)]
    return ()

readBoard :: Board -> Int -> Int -> IO String
readBoard brd x y = do
    i <- getBoard brd x y
    case i of
        -1  -> return "#"
        -9  -> return "x"
        -99 -> return "*"
        0   -> return " "
        9   -> return "-"
        otherwise -> return $ show i

setMines :: Board -> Int -> IO ()
setMines brd n
        | n == 0    = return ()
        | otherwise = do
            x <- rand (xMax-3)
            y <- rand (yMax-3)
            setBoard brd (x+1) (y+1) 1
            setMines brd (n-1) -- Tail Recursion

getKey :: IO (Int, Int, Int)
getKey = do
    key <- getCh
    case key of
        KeyChar 'j' -> return ( 0, 1, 0)
        KeyChar 'k' -> return ( 0,-1, 0)
        KeyChar 'h' -> return (-1, 0, 0)
        KeyChar 'l' -> return ( 1, 0, 0)
        KeyChar ' ' -> return ( 0, 0, 1)
        KeyChar 'x' -> return ( 0, 0, 9)
        otherwise   -> return ( 0, 0, 0)

countMine :: Board -> Int -> Int -> IO Int
countMine mField px py = do
    a <- dualMap (\x y -> getBoard mField (px+x) (py+y)) [-1..1] [-1..1]
    return $ sum (concat a)

openEdges :: Board -> Board -> Int -> Int -> IO ()
openEdges mPanel mField px py = do
    dualMap (\x y -> openPanel mPanel mField (px+x) (py+y)) [-1..1] [-1..1]
    return ()

openPanel :: Board -> Board -> Int -> Int -> IO ()
openPanel mPanel mField px py = do
    p <- getBoard mPanel px py
    if ( p /= 9 || px == 0 || py == 0 || px == xMax - 1 || py == yMax -1 )
        then return ()
        else openPanel' mPanel mField px py
    where openPanel' :: Board -> Board -> Int -> Int -> IO ()
          openPanel' mPanel mField px py = do
              f <- getBoard mField px py
              c <- countMine mField px py
              if f == 1 then setBoard mPanel px py (-99)
                        else setBoard mPanel px py c
              if c == 0 then openEdges mPanel mField px py
                        else return ()

markMine :: Board -> Int -> Int -> IO ()
markMine mPanel px py = do
    p <- getBoard mPanel px py
    if abs p == 9 then setBoard mPanel px py (-p)
                  else nop

isOver :: Board -> Board -> IO (Maybe String)
isOver mField mPanel = do
    f <- dualMap (\x y -> getBoard mField x y) [1..(xMax-2)] [1..(yMax-2)]
    p <- dualMap (\x y -> getBoard mPanel x y) [1..(xMax-2)] [1..(yMax-2)]

    let over  = elem (-99) (concat p)
    let clear = isClear (concat f) (concat p)

    if over then               return $ Just "Game Over..."
            else if clear then return $ Just "Congratulations!"
                          else return Nothing

    where isClear :: [Int] -> [Int] -> Bool
          isClear f p = if not $ elem 9 p -- all opened
            then if length ( filter (1==) f ) == length ( filter (-9==) p )
                    then True
                    else False
            else False

gameOver :: Window -> String -> IO Bool
gameOver scr mes = do
    mvWAddStr scr yMax 0 mes
    mvWAddStr scr (yMax+1) 0 "Replay? (y/n)"
    refresh
    key <- getCh
    case key of
        KeyChar 'y' -> return True
        KeyChar 'n' -> return False
        otherwise   -> gameOver scr mes -- Tail Recursion

game :: Window -> Board -> Board -> Int -> Int -> IO Bool
game scr mField mPanel px py = do
    showBoard mPanel scr
    mvWAddStr scr py px ""
    refresh

    key <- getKey
    case myTrd key of
        9 -> markMine mPanel px py
        1 -> openPanel mPanel mField px py
        otherwise -> nop
    let xx = handleB px (myFst key) (xMax-1)
    let yy = handleB py (mySnd key) (yMax-1)

    res <- isOver mField mPanel
    case res of
        Just mes  -> showBoard mPanel scr >> gameOver scr mes -- Finish
        otherwise -> game scr mField mPanel (px+xx) (py+yy)   -- Tail Recursion

    where handleB p i m
              | (p + i) < 1 || (p + i) >= m = 0
              | otherwise                   = i

main :: IO ()
main = do
    args <- getArgs
    let n = head args
    nMines <- handle (\(_ :: SomeException) -> return 10) $ evaluate (read n)

    mField <- newArray (0, xMax*yMax) 0    :: IO(Board)
    mPanel <- newArray (0, xMax*yMax) (-1) :: IO(Board)
    dualMap (\x y -> setBoard mPanel x y 9) [1..(xMax-2)] [1..(yMax-2)]

    setMines mField nMines
    initCurses
    scr <- initScr
    wclear scr
    replay <- game scr mField mPanel 1 1
    endWin
    if replay then main    -- Tail Recursion
              else nop