Skip to content
Create a gist now

Instantly share code, notes, and snippets.

@paf31 /croco.hs
Last active Dec 15, 2015

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.