public
Last active

Croco Magneto remake in Haskell

  • Download Gist
croco.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251
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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.