Skip to content

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Croco Magneto remake in Haskell
module Main where
import Data.List
import Data.Maybe
import Control.Monad
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLUT as GLUT
import qualified Graphics.UI.GLUT.Callbacks.Window as W
import qualified Data.Map as M
import Graphics.UI.GLUT.State
import Graphics.UI.GLUT (get, set, ($=), Position)
import Data.IORef
data Brick = White | Green | Red deriving (Show, Eq)
type Time = Int
type Speed = Float
type Maze = M.Map (Int, Int) Brick
type Coord = GLUT.GLfloat
data GameStatus = InProgress | GameOver deriving (Show)
data Direction = MovingLeft | MovingRight deriving (Show)
data KeyState = MovingUp | MovingDown | NoKeyState deriving (Show)
data GameState = GameState
{ gsLastTime :: Maybe Time
, gsMaze :: Maze
, gsPosX :: Coord
, gsPosY :: Coord
, gsSpeed :: Speed
, gsStatus :: GameStatus
, gsKeyState :: KeyState
, gsDirection :: Direction } deriving (Show)
parseMaze :: [String] -> Maze
parseMaze = M.fromList . map (\(k, v) -> (k, fromJust v)) . filter (isJust . snd) . concat . snd . mapAccumL (\n s -> (n + 1, parseLine n s)) 0
where
parseLine n = snd . mapAccumL (\m c -> (m + 1, ((m, n), parseChar c))) 0
parseChar '#' = Just White
parseChar 'R' = Just Red
parseChar 'G' = Just Green
parseChar _ = Nothing
defaultMaze :: Maze
defaultMaze = parseMaze
[ "######################################################################"
, "#G #R G#GG RRR #"
, "#G R#R # G#GG ######### #"
, "#G # # G#############RGG ######### #"
, "#G # #"
, "#G # #R G############# ######### #"
, "#G R#R # G#GG ######### #"
, "#G # G#GG RRR #"
, "#################################GG###################################"
, "#G G#GG R#"
, "#G R#R # G#RRRRRRRRRR ###########"
, "#G #G G# GGGG#"
, "#G # R# G#RRRRRRRRRR ###########"
, "#G R#G G# G# GGGG#"
, "#R G#GGGGGG GGGG#"
, "###########################################RRRRRRRRRRRRRRRR###########" ]
defaultOptions :: GameState
defaultOptions = GameState
{ gsLastTime = Nothing
, gsMaze = defaultMaze
, gsPosX = 4.0
, gsPosY = 4.0
, gsSpeed = 10.0
, gsStatus = GameOver
, gsKeyState = NoKeyState
, gsDirection = MovingRight }
square :: IO ()
square = GL.renderPrimitive GL.TriangleFan $ do
GL.vertex ((GL.Vertex2 (-1.0) (-1.0)) :: GL.Vertex2 GLUT.GLfloat)
GL.vertex ((GL.Vertex2 1.0 (-1.0)) :: GL.Vertex2 GLUT.GLfloat)
GL.vertex ((GL.Vertex2 1.0 1.0 ) :: GL.Vertex2 GLUT.GLfloat)
GL.vertex ((GL.Vertex2 (-1.0) 1.0 ) :: GL.Vertex2 GLUT.GLfloat)
circle :: IO ()
circle = GL.renderPrimitive GL.TriangleFan $ mapM_ GL.vertex points where
points = flip map [0..20] $ \deg ->
GL.Vertex2 (sin (2 * pi * deg / 20))
(cos (2 * pi * deg / 20)) :: GL.Vertex2 GLUT.GLfloat
checkCollision :: GameState -> (Coord, Coord) -> Maybe ((Int, Int), Brick)
checkCollision state (x, y) =
let (ix, iy) = nearestBrick (gsDirection state) x y in
msum [ checkCollision' state (ix, iy), checkCollision' state (ix, iy - 1), checkCollision' state (ix, iy + 1) ]
where
nearestBrick MovingLeft x y = (floor x, round y)
nearestBrick MovingRight x y = (ceiling x, round y)
checkCollision' state p@(ix,iy) =
let dist = sqrt $ (fromIntegral iy - y) ^ 2 + (fromIntegral ix - x) ^ 2 in
if dist >= 0.7 then
Nothing
else
fmap (\b -> (p, b)) $ M.lookup p (gsMaze state)
brick :: Brick -> IO ()
brick White = do
GL.color (GL.Color4 0.75 0.75 0 1 :: GL.Color4 GLUT.GLclampf)
square
GL.color (GL.Color4 0.75 0.5 0 1 :: GL.Color4 GLUT.GLclampf)
GLUT.preservingMatrix $ do
GL.scale (0.8 :: GLUT.GLfloat) (0.8 :: GLUT.GLfloat) (0.8 :: GLUT.GLfloat)
square
brick Red = do
GL.color (GL.Color4 0 1 0 1 :: GL.Color4 GLUT.GLclampf)
circle
GL.color (GL.Color4 0 0.5 0 1 :: GL.Color4 GLUT.GLclampf)
GLUT.preservingMatrix $ do
GL.scale (0.8 :: GLUT.GLfloat) (0.8 :: GLUT.GLfloat) (0.8 :: GLUT.GLfloat)
circle
brick Green = do
GL.color (GL.Color4 1 0 0 1 :: GL.Color4 GLUT.GLclampf)
square
GL.color (GL.Color4 0 0 1 1 :: GL.Color4 GLUT.GLclampf)
GLUT.preservingMatrix $ do
GL.scale (0.8 :: GLUT.GLfloat) (0.8 :: GLUT.GLfloat) (0.8 :: GLUT.GLfloat)
square
maze :: Maze -> IO ()
maze m = flip mapM_ (M.toList m) $ \((x, y), b) -> GL.preservingMatrix $ do
GL.translate (GLUT.Vector3 (fromIntegral x) (fromIntegral y) 0 :: GLUT.Vector3 GLUT.GLfloat)
GL.scale (0.4 :: GLUT.GLfloat) (0.4 :: GLUT.GLfloat) (1.0 :: GLUT.GLfloat)
brick b
ball :: Coord -> Coord -> IO ()
ball x y = GL.preservingMatrix $ do
GL.translate (GLUT.Vector3 x y 0 :: GLUT.Vector3 GLUT.GLfloat)
GL.color (GL.Color4 0 0.5 1 1 :: GL.Color4 GLUT.GLclampf)
GL.scale (0.3 :: GLUT.GLfloat) (0.3 :: GLUT.GLfloat) (1.0 :: GLUT.GLfloat)
circle
applyKeyState :: GameState -> Float -> Coord
applyKeyState state d = case gsKeyState state of
MovingUp ->
let location = nearestBrick (gsPosX state) (gsPosY state - d) in
let brick = M.lookup location (gsMaze state) in
if brick == Just White then gsPosY state else gsPosY state - d
where nearestBrick x y = (round x, floor y)
MovingDown ->
let location = nearestBrick (gsPosX state) (gsPosY state + d) in
let brick = M.lookup location (gsMaze state) in
if brick == Just White then gsPosY state else gsPosY state + d
where nearestBrick x y = (round x, ceiling y)
NoKeyState -> gsPosY state
moveBall :: GameState -> Time -> (Coord, Coord)
moveBall state elapsed =
let d = (fromIntegral elapsed) * (gsSpeed state) / 1000.0 in
let newY = applyKeyState state d in
case gsDirection state of
MovingLeft -> (gsPosX state - d, newY)
MovingRight -> (gsPosX state + d, newY)
collide :: GameState -> (Int, Int) -> (Coord, Coord) -> Brick -> GameState
collide state _ (x, y) White =
case gsDirection state of
MovingLeft -> state { gsDirection = MovingRight }
MovingRight -> state { gsDirection = MovingLeft }
collide state _ _ Red =
state { gsStatus = GameOver }
collide state key _ Green =
let newMaze = M.delete key (gsMaze state) in
let newStatus = if null $ filter (== Green) $ map snd $ M.toList $ gsMaze state then GameOver else InProgress in
case gsDirection state of
MovingLeft -> state { gsMaze = newMaze, gsDirection = MovingRight, gsStatus = newStatus }
MovingRight -> state { gsMaze = newMaze, gsDirection = MovingLeft, gsStatus = newStatus }
updateGameState :: GameState -> Time -> GameState
updateGameState state elapsed =
let (newX, newY) = moveBall state elapsed in
case checkCollision state (newX, newY) of
Nothing -> state { gsPosX = newX, gsPosY = newY }
Just (key, brick) -> collide state key (newX, newY) brick
tick :: GameState -> Time -> GameState
tick state elapsedTime = do
case gsStatus state of
GameOver -> state
InProgress -> updateGameState state elapsedTime
render :: IORef GameState -> IO ()
render stateRef = do
state <- get stateRef
time <- get elapsedTime
let lastTime = gsLastTime state
let elapsedTime = maybe 0 id $ (time -) `fmap` lastTime
let state' = tick state elapsedTime
let state'' = state' { gsLastTime = Just time }
stateRef $= state''
GL.clearColor $= GL.Color4 0 0 0 1
GL.clear [GL.ColorBuffer, GL.DepthBuffer]
GL.matrixMode $= GL.Modelview 0
GL.loadIdentity
GL.translate (GLUT.Vector3 (-gsPosX state'') (-gsPosY state'') 0 :: GLUT.Vector3 GLUT.GLfloat)
maze (gsMaze state'')
ball (gsPosX state'') (gsPosY state'')
GL.flush
GLUT.swapBuffers
GLUT.postRedisplay Nothing
changeKeyState :: IORef GameState -> KeyState -> IO ()
changeKeyState stateRef newState = do
state <- get stateRef
case gsStatus state of
InProgress -> stateRef $= state { gsKeyState = newState }
_ -> return ()
keyboardMouse :: IORef GameState -> W.Key -> W.KeyState -> W.Modifiers -> Position -> IO ()
keyboardMouse stateRef (W.SpecialKey W.KeyUp) W.Down _ _ = changeKeyState stateRef MovingUp
keyboardMouse stateRef (W.SpecialKey W.KeyDown) W.Down _ _ = changeKeyState stateRef MovingDown
keyboardMouse stateRef (W.SpecialKey _) W.Up _ _ = changeKeyState stateRef NoKeyState
keyboardMouse stateRef (W.Char ' ') W.Down _ _ = do
state <- get stateRef
case gsStatus state of
GameOver -> stateRef $= defaultOptions { gsStatus = InProgress }
_ -> return ()
keyboardMouse _ _ _ _ _ = return ()
resize :: GLUT.Size -> IO ()
resize s@(GLUT.Size w h) = do
let aspect = fromIntegral w / fromIntegral h
GL.matrixMode $= GL.Projection
GL.loadIdentity
GL.ortho (-10 * aspect) (10 * aspect) 10 (-10) (-10) 10
GL.viewport $= (GLUT.Position 0 0, s)
main :: IO ()
main = do
state <- newIORef defaultOptions
GLUT.initialDisplayMode $= [ GLUT.RGBAMode,
GLUT.Multisampling,
GLUT.DoubleBuffered,
GLUT.WithAlphaComponent ]
GLUT.initialWindowSize $= GL.Size 600 600
_ <- GLUT.getArgsAndInitialize
GLUT.createWindow "Croco Magneto"
GLUT.displayCallback $= render state
GLUT.keyboardMouseCallback $= Just (keyboardMouse state)
GLUT.reshapeCallback $= Just resize
GLUT.mainLoop
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.