Hatena::Grouphaskell

wanparkの日記

 | 

2007-12-05

Haskellプログラミング(9)

えーと、なんだっけ、n目並べを作るんだっけ。あれだよね、評価関数を作ってmin-maxとかalpha-betaとかやるんだよね。本かwebかで見たことある。

思考はおいといて、とりあえずプログラムの骨組み部分。

import System
import List
import Char
import Text.Regex

main = do args <- getArgs
          let [w, h] = map read args
           in play [Human black, AI white stupid] w h


play :: [Player] -> Int -> Int -> IO ()
play players w h = play' (cycle players) (createBoard w h)
    where play' ps board = do putStr (showBoard board)
                              let p   = head ps
                                  tok = token p
                              pos <- next p board
                              let board' = update pos tok board
                              if maxNarabe pos tok board' >= nmoku
                                then win p board'
                                else play' (tail ps) (board')

win :: Player -> Board -> IO ()
win p board = do putStr (showBoard board)
                 putStrLn (showToken (token p) ++ " win!")


------------------------------------------------------------------------
-- Board とかの構造
------------------------------------------------------------------------

nmoku :: Int  -- n 目並べ
nmoku = 4


type Position = (Int, Int)


type Token = Int

blank :: Token
blank = 0
black :: Token
black = 1
white :: Token
white = 2


type Board = [[Token]]

cell :: Position -> Board -> Token
cell (x, y) board = board !! y !! x

rows :: Board -> [[Token]]
rows = id


------------------------------------------------------------------------
-- Board handling
------------------------------------------------------------------------

-- Show のインスタンスにしたかったんだけど
-- -flasgow-exts -fallow-overlapping-instances をつけてもだめだった
showToken :: Token -> String
showToken token | token == black = "#"
                | token == white = "O"
                | otherwise      = "."

showBoard :: Board -> String
showBoard board = unlines $ sandwitch id [header] (zipWith formatRow [1..] (rows board))
    where sandwitch f s t = s ++ t ++ f s
          header = "    " ++ (unwords $ map (:[]) $ take (width board) ['a'..])
          formatRow n row = unwords $ sandwitch reverse [show n, "|"] $ map showToken row


width :: Board -> Int
width = length . head . rows

height :: Board -> Int
height = length . rows

createBoard :: Int -> Int -> Board
createBoard w h = take h $ repeat $ take w $ repeat blank

inBounds :: Position -> Board -> Bool
inBounds (x, y) board = inBounds' x (0, width board) &&
                        inBounds' y (0, height board)
    where inBounds' t (s, e) = t >= s && t < e

canPlace :: Position -> Board -> Bool
canPlace pos@(x, y) board = inBounds pos board && cell (x, y) board == blank

update :: Position -> Token -> Board -> Board
update (x, y) tok = replace y (replace x (const tok))

replace :: Int -> (a -> a) -> [a] -> [a]
replace pos f xs = take pos xs ++ [f (xs !! pos)] ++ drop (pos + 1) xs


-- pos に tok をおいた場合に並ぶ数
maxNarabe :: Position -> Token -> Board -> Int
maxNarabe (x, y) tok board = maximum $ map narabe [(1, 0), (0, 1), (1, 1)]
    where narabe dir     = 1 + count dir + count (negate dir)
          negate (x, y)  = (-x, -y)
          count (dx, dy) = length $ takeWhile (\pos -> inBounds pos board && cell pos board == tok) $ map (\n -> (x + dx * n, y + dy * n)) [1..]


------------------------------------------------------------------------
-- Player
------------------------------------------------------------------------

data Player = Human Token
            | AI Token Eval

-- 評価関数
type Eval = Token -> Board -> Score
type Score = Int

token :: Player -> Token
token (Human tok) = tok
token (AI tok _)  = tok

next :: Player -> Board -> IO Position
next (Human tok)   board = getNext tok board
next (AI tok eval) board = do let pos = thinkNext tok eval board
                              putStrLn $ "next " ++ showToken tok ++ " : " ++ showPosition pos
                              return pos

-- ユーザーに次の手を聞く
getNext :: Token -> Board -> IO Position
getNext tok board = do putStr $ "next " ++ showToken tok ++ " : "
                       input <- getLine
                       case readPosition input of
                         Just pos -> if canPlace pos board
                                     then return pos
                                     else getNext tok board
                         Nothing  -> getNext tok board

readPosition :: String -> Maybe Position
readPosition str = case matchRegex (mkRegx "^([a-z])([0-9])") str of
                     Just [x, y] -> return (ord (head x) - ord 'a', digitToInt (head y) - 1)
                     otherwise   -> Nothing

showPosition :: Position -> String
showPosition (x, y) = [chr (ord 'a' + x), intToDigit (y + 1)]

-- 次の手を考える
thinkNext :: Token -> Eval -> Board -> Position
thinkNext tok eval board = maximumFst $ map pairWithScore $ candidate board
    where maximumFst        = snd . head . sortBy (\a b -> fst b `compare` fst a)
          pairWithScore pos = (eval tok (update pos tok board), pos)

candidate :: Board -> [Position]
candidate board = filter (flip canPlace board) [(x, y) | x <- [0 .. width board - 1], y <- [0 .. height board - 1]]


------------------------------------------------------------------------
-- 評価関数
------------------------------------------------------------------------

stupid :: Eval
stupid tok board = 0

うーん、長いな。

ゲスト



トラックバック - http://haskell.g.hatena.ne.jp/wanpark/20071205
 |