Reversi in Haskell. There is a bug in negamax, it's working, but the program should be stronger ;)

reversi.hs

import Data.Array (Array, array, (//), (!), assocs, elems)
import Data.List (sortBy, groupBy, group)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Control.Monad (forever, when)
import Data.Maybe (isJust, isNothing)
import Data.Ord (comparing)


data Player =  Black | White deriving (Show, Eq)

type Position = (Int, Int)
type Direction = (Int, Int)
type Board = Array Position (Maybe Player)
type Square = Maybe Player

data Game = Game Board Player

opponent :: Player -> Player
opponent Black = White
opponent White = Black


isBlack :: Square -> Bool
isBlack (Just Black) = True
isBlack _ = False


isWhite :: Square -> Bool
isWhite (Just White) = True
isWhite _ = False


initialBoard :: Board
initialBoard = 
    emptyBoard // [ ((3, 3), Just White), 
                    ((4, 4), Just White),
                    ((4, 3), Just Black),
                    ((3, 4), Just Black) ]
    where
      emptyBoard = array ((0,0), (7,7)) [ ((i, j), Nothing) | 
                                          i <- [0..7], j <- [0..7] ]


initialGame :: Game
initialGame = Game initialBoard White


showBoard :: Board -> String
showBoard board = 
    numbers ++ ( unlines $  [(show n) ++ "| " ++ showLine l ++ "|" ++(show n) | 
                             (n, l) <- zip [0..] lineList])
                ++ numbers
    where 
      lineList =  groupBy (\ ((a, _), _) ((b, _), _) -> a == b) (assocs board)
      showLine :: [((Int, Int), Maybe Player)] -> String
      showLine l = concat [ showCell c | ((_, _), c) <- l ]
      showCell Nothing = "- "
      showCell (Just Black) = "@ "
      showCell (Just White) = "O "
      numbers = "   0 1 2 3 4 5 6 7\n"


isPositionValid :: Position -> Bool
isPositionValid (x, y) = x >= 0 && x < 8 && y >= 0 && y < 8


findSequence :: Board -> Direction -> Player -> Position -> [Position] 
findSequence board (dx, dy) player (x, y) = 
    findSeq (x + dx, y + dy) []
    where
      findSeq :: Position -> [Position] -> [Position]
      findSeq pos@(a, b) accu
          | not $ isPositionValid pos = []
          | otherwise = 
              case board ! pos of
                Nothing -> []
                Just p -> if p == player 
                          then accu 
                          else findSeq ((a + dx), (b + dy)) (pos : accu)


findFlipped :: Board -> Position -> Player -> [Position]
findFlipped board pos player =
    concat [ findSequence board dir player pos | 
             dir <- [ (0, 1), (0, -1), (-1, 0), (1, 0), 
                      (-1, -1), (1, -1), (-1, 1), (1, 1) ] ] 


isFlippingSome :: Board -> Position -> Player -> Bool
isFlippingSome board pos player = (not . null) $ findFlipped board pos player


canPlayPos :: Board -> Position -> Player -> Bool
canPlayPos board pos player =
    isPositionValid pos && (board ! pos == Nothing) && 
                    isFlippingSome board pos player


findPlayablePositions :: Board -> Player -> [Position] 
findPlayablePositions board player = 
    [ pos | (pos, p) <- assocs board,
                       isNothing p,
                       isFlippingSome board pos player]


play :: Board -> Position -> Player -> Board
play board pos player =
    board // ((pos, Just player) : [ (f, Just player) | f <- flipped ])
    where flipped = findFlipped board pos player


isLeaf :: Board -> Bool
isLeaf = (all isJust) . elems


eval :: Board -> Int
eval board = 
    whites - blacks
    where
      whites = length $ filter isWhite squares
      blacks = length $ filter isBlack squares
      squares = elems board


minimax ::  Board -> Player -> Int -> Int
minimax board player n =
    if isLeaf board || n > 4
    then eval board
    else 
        if null playable 
        then 0
        else (target player) [ minimax (play board pos player) other (n+1) | 
                   pos <- playable ]
    where 
      other = opponent player
      playable = findPlayablePositions board player
      target Black = minimum
      target White = maximum


doPlay :: IORef Game -> IO ()
doPlay refGame = do
  Game board player <- readIORef refGame
  pos <- case player of 
           White -> readLn :: IO (Int, Int)
           Black -> return $ snd $ head $ sortBy (comparing fst)        
                           [ (minimax (play board pos player) player 0, pos) | 
                                     pos <- findPlayablePositions board player]
  when (canPlayPos board pos player) $ 
       writeIORef refGame $ Game (play board pos player) (opponent player)
  printRefGame refGame


printRefGame :: IORef Game -> IO ()
printRefGame refGame = do 
         Game board player <- readIORef refGame 
         (putStrLn . showBoard) board
         putStrLn $ (show  player) ++ " is playing"
         putStrLn ( "Possible play = " ++
                    show (findPlayablePositions board player) )


main :: IO ()
main = do
  refGame <- newIORef initialGame
  printRefGame refGame
  forever $ doPlay refGame