Haskellでオセロ。2013年度前期の大学の課題ではない。(元ネタ: https://gist.github.com/oboenikui/6297337)

othello.hs

-- othello.hs
-- 
-- To run...
--     Prelude> control initialBoard initialTurn
-- 
-- controls...
--     cursor keys => move cursor
--     Z key       => put stones
--     P key       => pass the turn
--     Q key       => quit
--
--
-- Problems...
--     The cursor input doesn't work good...
--     The better solution should be using Graphic Libraries.

-- libraries for screen

cls :: IO ()
cls = putStr "\ESC[2J"

type Pos = (Int, Int)

goto :: Pos -> IO ()
goto (x,y) = putStr ("\ESC[" ++ show y ++ ";" ++ show x ++ "H")

writeat :: Pos -> String -> IO ()
writeat p xs = do goto p 
                  putStr xs

seqn :: [IO a] -> IO ()
seqn [] = return ()
seqn (a:as) = do a
                 seqn as


-- main

type Board = [[Pos]]
data Turn = Black | White
    deriving (Eq,Show)

width :: Int
width = 8

height :: Int
height = 8

boxU :: String
boxU = "+" ++ concat (replicate width "-+")
boxD :: String
boxD = "|" ++ concat (replicate width " |")

keys :: String
keys = "\ESC-[-A\ESC-[B\ESC-[C\ESC-[DZzPpQq\ESC"

showBoard :: IO ()
showBoard = seqn [writeat (1,y) xs | (y,xs) <- strlist]
    where
        strlist = zip [1..(height*2+1)] bs
        bs = mkls boxU boxD
        mkls u d = u:d:mkls u d

-- [[White],[Black],[Cursor]]
initialBoard :: Board
initialBoard = [[(4,4),(5,5)],[(4,5),(5,4)],[(4,4)]]

initialTurn :: Turn
initialTurn = Black

writePos :: Pos -> Pos
writePos (x,y) = (x*2,y*2)

showStones :: Board -> IO ()
showStones b = seqn (   [writeat (writePos p) "O" | p <- b!!0]
                     ++ [writeat (writePos p) "X" | p <- b!!1] )

showTurn :: Turn -> IO ()
showTurn t = writeat (1,height*2+2) ("It's " ++ show t ++ " turn!")

control :: Board -> Turn -> IO ()
control b t = do 
               cls
               showBoard
               showStones b
               showTurn t
               goto . writePos . head $ b!!2
               c <- getChar
               if elem c keys then
                   process b t c
               else
                   control b t

process :: Board -> Turn -> Char -> IO ()
process b t c 
    | elem c "\ESC-[-A" = cursor 0 7 b t -- Upper
    | elem c "\ESC-[-B" = cursor 0 3 b t -- Lower
    | elem c "\ESC-[-C" = cursor 1 2 b t -- Right
    | elem c "\ESC-[-D" = cursor 7 2 b t -- Left
    | elem c "Zz"       = chkSetStone b t
    | elem c "Pp"       = control b (chTurn t)
    | otherwise         = quit

quit :: IO ()
quit = goto (1,height*2+3)

cursor :: Int -> Int -> Board -> Turn -> IO ()
cursor x y b = control [b!!0, b!!1, [newpos]]
    where 
        oldpos = head $ b!!2
        newposx = if fst oldpos + x <= width  then fst oldpos + x else fst oldpos + x - width
        newposy = if snd oldpos + y <= height then snd oldpos + y else snd oldpos + y - height
        newpos = (newposx, newposy)

chkSetStone :: Board -> Turn -> IO ()
chkSetStone b t | isStoneHere b = control b t 
                | otherwise     = chkSandedStone b t

isStoneHere :: Board -> Bool
isStoneHere b = (elem (head $ b!!2) $ b!!0) || (elem (head $ b!!2) $ b!!1)

aroundCell :: Board -> Turn -> [Pos]
aroundCell b t | t == Black = [ (x+m, y+n) | (x,y) <- b!!2, m <- [-1..1], n <- [-1..1], elem (x+m, y+n) $ b!!0 ]
               | otherwise  = [ (x+m, y+n) | (x,y) <- b!!2, m <- [-1..1], n <- [-1..1], elem (x+m, y+n) $ b!!1 ]

chkSandedStone :: Board -> Turn -> IO ()
chkSandedStone b t | chkLine b t = setStone (turnedStones b t) t
                   | otherwise = control b t

chkLine :: Board -> Turn -> Bool
chkLine b t = or . map (isSanded b t) $ arLines b t 

isSanded :: Board -> Turn -> [Pos] -> Bool
isSanded _ _ [] = False
isSanded b t (x:xs) | isMine b t x = True
                    | isMine b (chTurn t) x = isSanded b t xs
                    | otherwise    = False

arLines :: [[Pos]] -> Turn -> [[Pos]]
arLines b t = map (takeWhile isInBoard . arLine pos) $ aroundCell b t
    where pos = head $ b!!2
          arLine (x,y) (z,w) = (z,w) : arLine (z,w) (2*z-x,2*w-y)

isInBoard :: Pos -> Bool
isInBoard (x,y) = and [x <= 8 , x >= 0, y <= 8, y >= 0]

turnedStones :: Board -> Turn -> Board
turnedStones b t | t == Black = [reduced $ b!!0, added $ b!!1, b!!2]
                 | otherwise  = [added $ b!!0, reduced $ b!!1, b!!2]
    where
        sandedLines  = [ xs | xs <- arLines b t, isSanded b t xs]
        sandedStones b t (x:xs) | isMine b (chTurn t) x = x:sandedStones b t xs
                                | otherwise             = []
        ssList = concat $ map (sandedStones b t) sandedLines
        reduced xs = filter (\x -> not $ elem x ssList) xs
        added   xs = xs ++ ssList

setStone :: Board -> Turn -> IO ()
setStone b t | t == Black = control [b!!0, b!!1 ++ b!!2, b!!2] (chTurn t)
             | otherwise  = control [b!!0 ++ b!!2, b!!1, b!!2] (chTurn t)

isMine :: Board -> Turn -> Pos -> Bool
isMine b t p | t == Black = elem p $ b!!1
             | otherwise  = elem p $ b!!0

chTurn :: Turn -> Turn
chTurn t | t == Black = White
         | otherwise  = Black