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