マルバツゲーム in Haskell DouKaku?

マルバツゲームは３×３の格子に交互に○と×を書き込み、先に縦・横・斜めに記号をそろえたほうが勝ちというおなじみのゲームです。

「毎ターン乱数を使って手を決めるランダムプレイヤー同士を対戦させる」というのが今回のお題です。１万回対戦させ、勝ち・負け・引き分けの数を表示してください。そして先手が有利であることを確かめてください。

良い手を思考するプレイヤーについては別のお題にしようと思っています。プレイヤーを簡単に差し換えることができる設計を目指してください。

配列を複製しまくりで効率が悪いけど。

import Data.Array
import Data.Maybe
import Control.Monad
import System.Random

type Pos = (Int, Int)
type OX = Bool
type Board = Array Pos (Maybe OX)
type View = OX -> Bool
type Strategy m = Board -> View -> m Pos
type Player m = (Strategy m, View)

emptyBoard :: Board
emptyBoard = array ((0,0), (2,2)) [(p, Nothing) | p<-ps]
  where ps = [(x,y) | x<-[0..2], y<-[0..2]]

availablePos :: Board -> [Pos]
availablePos b = [p | (p, Nothing) <- assocs b]

win :: Board -> View -> Bool
win b v = any (all (fromMaybe False . fmap v . (b!))) xss
  where
    xss = [ [(x,y) | y<-[0..2]] | x<-[0..2] ] ++
          [ [(x,y) | x<-[0..2]] | y<-[0..2] ] ++
          [ [(0,0), (1,1), (2,2)], [(0,2), (1,1), (2,0)] ]

play :: Monad m => Strategy m -> Strategy m -> m (Maybe Bool)
play s1 s2 = go emptyBoard (s1, id) (s2, not)
  where
    go b p1@(s,v) p2
        | null ps = return Nothing
        | otherwise = do
            pos <- s b v
            let m = Just (v True)
                b' = b // [(pos, m)]
            if win b' v
              then return m
              else go b' p2 p1
      where ps = availablePos b

randStrategy :: Strategy IO
randStrategy b v = do
  let ps = availablePos b
  i <- getStdRandom (randomR (0, length ps - 1))
  when (i<0) $ putStrLn $ show ps
  return (ps!!i)

main :: IO ()
main = do
  let n = 10000
  xs <- replicateM n (play randStrategy randStrategy)
  let a = sum [1 | Just True <- xs]
      b = sum [1 | Just False <- xs]
      c = n - (a + b)
  putStrLn $ "player1 won: " ++ show a
  putStrLn $ "player2 won: " ++ show b
  putStrLn $ "draw: "  ++ show c
  putStrLn $ "total: " ++ show n

直線に３個揃っているかの判定を整数計算ですませる方法。

縦３本、横３本、斜め２本、計８本の直線に素数
2,3,5,7,11,13,17,19
を対応させる。
各マスには通っている直線の素数の積を対応させる。つまり
  2*7*17      2*11        2*13*19
  3*7         3*11*17*19  3*13
  5*7*19      5*11        5*13*17
のように整数を配置する。
  ○（または×）が置いてあるマスの場所の整数すべての積をとって
それが (2*3*5*7*11*13*17*19)^2 を
割り切ったらどの直線でも３個揃っていない、
割り切れなかったらどこかの直線で３個揃っている、
と判定できる。

コードはさかいさんの #6209 の判定関数のインタフェースをお借りしてます。

judgeTable :: Array Pos Integer
judgeTable = array ((0,0), (2,2)) [
  ((0,0), 2*7*17), ((0,1), 2*11      ), ((0,2), 2*13*19),
  ((1,0), 3*7   ), ((1,1), 3*11*17*19), ((1,2), 3*13   ),
  ((2,0), 5*7*19), ((2,1), 5*11      ), ((2,2), 5*13*17)]

win :: Board -> View -> Bool
win b v = (2*3*5*7*11*13*17*19)^2 `mod` pr /= 0 where
  pr = product [judgeTable!p | (p, ox) <- assocs b, ox == Just (v True)]

「プレイヤーを簡単に差し換えることができる設計を目指してください。」まったく考えずに作りました。

先手勝利=6162 後手勝利=2590 引き分け=1248

圧倒的に先手有利になりました。

import Random
import List

data WinDraw = First|Second|Draw deriving (Eq,Show)

-- shuffle
randomN :: Int->StdGen ->  (StdGen,[Int])
randomN n stdGen = mapAccumL (\r lim->swapTuple (randomR (0,lim) r)) stdGen [n-1,n-2..0]
  where swapTuple (a,b) = (b,a)

bingo ::Int->StdGen->([Int],StdGen)
bingo n stdGen = let (nextGen,xs)= (randomN n stdGen)
                 in  (snd $ mapAccumL f [1..n] xs,nextGen)
  where f xs x = (deleteAt x xs,xs !! x)
        deleteAt i xs = take i xs ++ tail (drop i xs)



whichWin xs = let (first,second) =  separate xs
                  turnFirst      = turnToWin first
                  turnSecond     = turnToWin second  
              in  case (turnFirst,turnSecond) of 
                    (Nothing,Nothing) -> Draw
                    (tf,Nothing)      -> First
                    (Nothing,ts)      -> Second
                    (tf,ts)|tf <= ts  -> First
                           |otherwise -> Second
--[1,2,3,4,5,6,7,8,9] -> ([1,3,5,7,9],[2,4,6,8])
separate xs = (map head $ every 2 xs,map head $ every 2 $ tail xs)

every n xs = unfoldr f xs 
    where f [] = Nothing
          f cs = Just (splitAt n cs)


-- how many turns do you need to win?
turnToWin xs = elemIndex True $ map isWinPattern $ inits xs

isWinPattern xs = or $ map (contain xs) [[1,2,3],[4,5,6],[7,8,9],[1,4,7],[2,5,8],[3,6,9],[1,5,9],[3,5,7]]

contain xs ys = length xs - (length (xs \\ ys) ) == length ys



--
test  n = whichWin $ fst $ bingo 9 (mkStdGen n) 

main = let wl =map test [1..10000]
       in  print $ [length $ filter (==First) wl,length $ filter (==Second) wl,length $ filter (==Draw) wl]

{-
*Main> main
[6162,2590,1248]
-}

DouKaku?

マルバツゲーム

Posted feedbacks - Haskell

Index

Feed

Other

Link

Pathtraq