ゲームになった…か？

amazon:入門Haskellを参考に、判定を追加してみたものの。スコア計算をどうしたものか。困った。スマートな方法が思いついていません。

以下、コード。

import Graphics.UI.GLUT
import Control.Exception
import System.Exit
import Data.IORef
import System.Random

blue    = Color3 (0.0::Double) 0.0 1.0
green   = Color3 (0.0::Double) 1.0 0.0
cyan    = Color3 (0.0::Double) 1.0 1.0
red     = Color3 (1.0::Double) 0.0 0.0
magenta = Color3 (1.0::Double) 0.0 1.0
yellow  = Color3 (1.0::Double) 1.0 0.0
white   = Color3 (1.0::Double) 1.0 1.0
colorList = [blue, green, cyan, red, magenta, yellow, white]

main = do
  board <- (newIORef =<< makeBoard)
  score <- newIORef 0
  getArgsAndInitialize
  createWindow "Sample"
  initialDisplayMode    $= [RGBAMode]
  displayCallback       $= display board
  keyboardMouseCallback $= Just (keyboardMouse board score)
  clearColor            $= Color4 0.0 0.0 0.2 0.2
  mainLoop

display :: IORef [[Color3 Double]] -> IO ()
display board = do
  clear [ColorBuffer]
  bd <- readIORef board
  let posList = map (\ n -> n / 10) [-9, -7..]
  mapM_ drawPoint $ concat $ zipWith (\ x column -> zipWith (\ y c -> (x, y, c)) posList column) posList bd
  flush

drawPoint (x, y, c) = do
  color c
  renderPrimitive Polygon $ mapM_ vertex 
    [
    Vertex3 (-0.07 + x) (-0.07 + y) 0.0,
    Vertex3 ( 0.00 + x) (-0.10 + y) 0.0,
    Vertex3 ( 0.07 + x) (-0.07 + y) 0.0,
    Vertex3 ( 0.10 + x) ( 0.00 + y) 0.0,
    Vertex3 ( 0.07 + x) ( 0.07 + y) 0.0,
    Vertex3 ( 0.00 + x) ( 0.10 + y) 0.0,
    Vertex3 (-0.07 + x) ( 0.07 + y) 0.0,
    Vertex3 (-0.10 + x) ( 0.00 + y) (0.0 :: GLfloat)
    ]

makeBoard :: IO [[Color3 Double]]
makeBoard = do
  g <- getStdGen
  let colors = map (\ n -> colorList !! n) $ randomRs (0, length colorList - 1) g
  return $ take 10 $ getTable 10 colors
  where
    getTable n colors = column : getTable n rest
      where (column, rest) = splitAt n colors

keyboardMouse board score key keystate modifiers position = do
  case (key, keystate, position) of
    (MouseButton LeftButton, Down, Position x y) -> do
      (pos, Size width height) <- get viewport
      let x' = x * 10 `div` width
      let y' = 9 - (y * 10 `div` height)
      let point = (fromIntegral x', fromIntegral y')
      modifyIORef board $ pickBalls point
      display board
      board' <- readIORef board
      if isFinished board'
        then do
          putStrLn "Your score is "
          throwIO $ ExitException ExitSuccess
        else return ()
    (Char 'q', _, _) -> throwIO $ ExitException ExitSuccess
    (_, _, _)        -> return ()

pickBalls point board =
  if length marks > 1
    then filter ((/= 0).length) $ zipWith (\x column -> snd $ unzip $ filter (\(y, ball) -> notElem (x, y) marks) $ zip [0..] column) [0..] board
    else board
  where marks = markBalls point board

markBalls pt@(x, y) board = loop pt []
  where
    loop pt@(x, y) marks
      | isValidPos board pt && (board !! x !! y == ball) = foldr loop (pt:marks) $ balls marks
      | otherwise                                        = marks
    ball        = board !! x !! y
    balls marks = filter (flip notElem marks) [(x + 1, y), (x - 1, y), (x, y + 1), (x, y - 1)]

isValidPos [] _               = False
isValidPos (column:_) (0, y)  = (0 <= y) && (y < length column)
isValidPos (_:columns) (x, y) = isValidPos columns (x - 1, y)

isFinished board = and $ concat $ zipWith (\x column -> zipWith (\y _ -> (length (markBalls (x, y) board) <= 1)) [0..] column) [0..] board