|
| 1 | +module AffGameSnakeJs.Main where |
| 2 | + |
| 3 | +import Prelude |
| 4 | + |
| 5 | +import Color (Color, black, white) |
| 6 | +import Color.Scheme.Clrs (green, red) |
| 7 | +import Control.Monad.Rec.Loops (iterateWhile) |
| 8 | +import Data.Array.NonEmpty (NonEmptyArray, cons, cons', dropEnd, head, singleton) |
| 9 | +import Data.Int (toNumber) |
| 10 | +import Data.Maybe (Maybe(..), maybe) |
| 11 | +import Data.Traversable (elem, for_) |
| 12 | +import Data.Tuple.Nested ((/\)) |
| 13 | +import Data.Vector.Polymorphic (Vector2, makeRect, (><)) |
| 14 | +import Effect (Effect) |
| 15 | +import Effect.Class (liftEffect) |
| 16 | +import Effect.Exception (throw) |
| 17 | +import Game.Aff (AffGame, FPS(..), launchGame_, mkAffGame, mkReducer) |
| 18 | +import Game.Aff.AnimationFrame (animationFrameMatchInterval) |
| 19 | +import Game.Aff.Web.Event (_keyboardEvent, documentEventTarget, keydown) |
| 20 | +import Game.Util (asksAt) |
| 21 | +import Graphics.Canvas (Context2D, getCanvasElementById, getContext2D, setCanvasDimensions) |
| 22 | +import Graphics.CanvasAction (class MonadCanvasAction, fillRect, filled, liftCanvasAction) |
| 23 | +import Graphics.CanvasAction.Run (CANVAS, runCanvas) |
| 24 | +import Random.LCG (randomSeed) |
| 25 | +import Run.State (get, modify) |
| 26 | +import Test.QuickCheck.Gen (Gen, GenState, chooseInt, runGen) |
| 27 | +import Web.DOM.Document (createElement) |
| 28 | +import Web.DOM.Element (setAttribute, setId) |
| 29 | +import Web.DOM.Element as Element |
| 30 | +import Web.DOM.Node (appendChild, setTextContent) |
| 31 | +import Web.HTML (window) |
| 32 | +import Web.HTML.HTMLDocument as HTMLDocument |
| 33 | +import Web.HTML.HTMLElement as HTMLElement |
| 34 | +import Web.HTML.Window (document) |
| 35 | +import Web.UIEvent.KeyboardEvent (key) |
| 36 | + |
| 37 | +-- CONSTANTS |
| 38 | +-- |
| 39 | +xmax :: Int |
| 40 | +xmax = 25 |
| 41 | + |
| 42 | +ymax :: Int |
| 43 | +ymax = 25 |
| 44 | + |
| 45 | +cellSize :: Int |
| 46 | +cellSize = 10 |
| 47 | + |
| 48 | +cellSizeNum :: Number |
| 49 | +cellSizeNum = toNumber cellSize |
| 50 | + |
| 51 | +ticksPerSecond :: Number |
| 52 | +ticksPerSecond = 12.0 |
| 53 | + |
| 54 | +-- Using opposite colors for the bg and the snake, so it's a little different |
| 55 | +-- from the Signal version. |
| 56 | +snakeColor :: Color |
| 57 | +snakeColor = black |
| 58 | + |
| 59 | +bgColor :: Color |
| 60 | +bgColor = white |
| 61 | + |
| 62 | +foodColor :: Color |
| 63 | +foodColor = red |
| 64 | + |
| 65 | +wallColor :: Color |
| 66 | +wallColor = green |
| 67 | + |
| 68 | +-- STATE MODEL AND TYPES |
| 69 | +-- |
| 70 | +type Point = Vector2 Int |
| 71 | + |
| 72 | +data Direction |
| 73 | + = Left |
| 74 | + | Right |
| 75 | + | Up |
| 76 | + | Down |
| 77 | + |
| 78 | +derive instance eqDirection :: Eq Direction |
| 79 | + |
| 80 | +type Snake |
| 81 | + = NonEmptyArray Point |
| 82 | + |
| 83 | +-- The type of our game state |
| 84 | +type Model |
| 85 | + = { food :: Point |
| 86 | + , snake :: Snake |
| 87 | + , direction :: Direction |
| 88 | + , genState :: GenState |
| 89 | + } |
| 90 | + |
| 91 | +-- Some initial state values |
| 92 | +initialDirection :: Direction |
| 93 | +initialDirection = Right |
| 94 | + |
| 95 | +initialSnake :: Snake |
| 96 | +initialSnake = singleton (1 >< 1) |
| 97 | + |
| 98 | +-- Actions that can change our state. |
| 99 | +data Action |
| 100 | + = Tick |
| 101 | + | SetDir Direction |
| 102 | + |
| 103 | +--- UPDATE |
| 104 | +-- |
| 105 | +-- How we update our model with each Action. |
| 106 | +-- For example, changing direction or moving a step. |
| 107 | +update :: Action -> Model -> Model |
| 108 | +update (SetDir d) m = m { direction = d } |
| 109 | +update Tick m = |
| 110 | + let |
| 111 | + -- Determine where snake head will move |
| 112 | + nextPoint = head m.snake + getMove m.direction |
| 113 | + |
| 114 | + -- Check if next move will kill snake |
| 115 | + willDie = outOfBounds nextPoint || ateTail nextPoint m.snake |
| 116 | + |
| 117 | + -- Check if next move will eat food |
| 118 | + willEat = nextPoint == m.food |
| 119 | + in |
| 120 | + case willDie, willEat of |
| 121 | + -- Snake died. Reset snake to starting size and position. |
| 122 | + true, _ -> m { snake = initialSnake, direction = initialDirection } |
| 123 | + -- Snake still alive, but did not find food. Move snake without growing. |
| 124 | + false, false -> m { snake = moveSnakeNoGrow nextPoint m.snake } |
| 125 | + -- Snake still alive, and found food. |
| 126 | + false, true -> |
| 127 | + let |
| 128 | + -- Grow and move snake |
| 129 | + biggerSnake = moveSnakeAndGrow nextPoint m.snake |
| 130 | + -- Find next random food location |
| 131 | + food /\ genState = runGen (availableRandomPoint biggerSnake) m.genState |
| 132 | + in |
| 133 | + m |
| 134 | + { snake = biggerSnake |
| 135 | + , food = food |
| 136 | + , genState = genState |
| 137 | + } |
| 138 | + |
| 139 | +-- Convert direction to a change in coordinates |
| 140 | +getMove :: Direction -> Point |
| 141 | +getMove = case _ of |
| 142 | + Left -> (-1 >< 0) |
| 143 | + Right -> (1 >< 0) |
| 144 | + Up -> (0 >< -1) |
| 145 | + Down -> (0 >< 1) |
| 146 | + |
| 147 | +-- Check if Point (Snake head) is out of bounds |
| 148 | +outOfBounds :: Point -> Boolean |
| 149 | +outOfBounds (x >< y) = x <= 0 || y <= 0 || x > xmax || y > ymax |
| 150 | + |
| 151 | +-- Check if Snake ate its tail |
| 152 | +ateTail :: Point -> Snake -> Boolean |
| 153 | +ateTail = elem |
| 154 | + |
| 155 | +-- Add Point to beginning of Snake |
| 156 | +moveSnakeAndGrow :: Point -> Snake -> Snake |
| 157 | +moveSnakeAndGrow = cons |
| 158 | + |
| 159 | +-- Add Point to beginning of Snake, and remove the last Point |
| 160 | +moveSnakeNoGrow :: Point -> Snake -> Snake |
| 161 | +moveSnakeNoGrow pt s = cons' pt $ dropEnd 1 s |
| 162 | + |
| 163 | +-- RANDOM |
| 164 | +-- |
| 165 | +-- Generate a random food location |
| 166 | +randomPoint :: Gen Point |
| 167 | +randomPoint = do |
| 168 | + x <- chooseInt 1 xmax |
| 169 | + y <- chooseInt 1 ymax |
| 170 | + pure (x >< y) |
| 171 | + |
| 172 | +{- Generate a random food location that's not |
| 173 | +currently occupied by the Snake. |
| 174 | +It's possible that this guess-and-check strategy |
| 175 | +may stall the game loop with lots of unlucky guesses. |
| 176 | +A more deterministic strategy is to fist find all |
| 177 | +unoccupied points, and then randomly choose from those. |
| 178 | +But for small snakes, this simple approach is fine. |
| 179 | +-} |
| 180 | +availableRandomPoint :: Snake -> Gen Point |
| 181 | +availableRandomPoint s = iterateWhile (_ `elem` s) randomPoint |
| 182 | + |
| 183 | +-- RENDERING |
| 184 | +-- |
| 185 | +drawPoint :: forall m. MonadCanvasAction m => Color -> Point -> m Unit |
| 186 | +drawPoint color (x >< y) = liftCanvasAction do |
| 187 | + filled color do |
| 188 | + fillRect $ makeRect |
| 189 | + (cellSizeNum * toNumber x) |
| 190 | + (cellSizeNum * toNumber y) |
| 191 | + cellSizeNum |
| 192 | + cellSizeNum |
| 193 | + |
| 194 | +{- |
| 195 | +Note that we're currently keeping things simple and re-rendering |
| 196 | +the entire canvas from scratch from each state. |
| 197 | +We could be more efficient and just overwrite the cells |
| 198 | +that change, but that increases complexity. |
| 199 | +-} |
| 200 | +render :: forall m. MonadCanvasAction m => Model -> m Unit |
| 201 | +render m = liftCanvasAction do |
| 202 | + -- Walls |
| 203 | + filled wallColor do |
| 204 | + -- If we want a rectangle to be drawn at (0, 0), we can pass a `Vector2` |
| 205 | + -- containing just the dimensions, to `fillRect`. This works because of |
| 206 | + -- `Vector2`s `ToRegion` instance: |
| 207 | + -- https://pursuit.purescript.org/packages/purescript-polymorphic-vectors/1.1.1/docs/Data.Vector.Polymorphic.Class#v:toRegionVector2 |
| 208 | + fillRect |
| 209 | + $ cellSizeNum * toNumber (xmax + 2) |
| 210 | + >< cellSizeNum * toNumber (ymax + 2) |
| 211 | + -- Interior |
| 212 | + filled bgColor do |
| 213 | + fillRect $ makeRect |
| 214 | + cellSizeNum |
| 215 | + cellSizeNum |
| 216 | + (cellSizeNum * toNumber xmax) |
| 217 | + (cellSizeNum * toNumber ymax) |
| 218 | + -- Snake |
| 219 | + for_ m.snake (drawPoint snakeColor) |
| 220 | + -- Food |
| 221 | + drawPoint foodColor m.food |
| 222 | + |
| 223 | + |
| 224 | +-- AFFGAME |
| 225 | +-- |
| 226 | + |
| 227 | +{- |
| 228 | +We're using the `CANVAS` effect (from `Graphics.CanvasAction.Run`) to draw to |
| 229 | +the canvas. We note this in the type of `AffGame`, aliasing it as `Extra` for |
| 230 | +convenience. |
| 231 | +-} |
| 232 | +type Extra = (canvas :: CANVAS) |
| 233 | + |
| 234 | +{- |
| 235 | +We're using `Unit` as our environment, since we don't have any resources or |
| 236 | +constants we need in our game that requires `Effect` or `Aff` to acquire. |
| 237 | +-} |
| 238 | +type Env = Unit |
| 239 | + |
| 240 | +game :: AffGame Extra Unit |
| 241 | +game = mkAffGame |
| 242 | + -- We generate the apple position and the generator state in the |
| 243 | + -- initialization of the game, and put them in the initial state |
| 244 | + { init: liftEffect do |
| 245 | + -- Setup first piece of random food |
| 246 | + newSeed <- randomSeed |
| 247 | + let |
| 248 | + -- You may hardcode a constant seed value for an |
| 249 | + -- identical sequence of pseudorandom food locations |
| 250 | + -- on each page refresh. |
| 251 | + -- newSeed = mkSeed 42 |
| 252 | + initialGenState = { newSeed, size: 1 } |
| 253 | + |
| 254 | + -- Run generator to get food location |
| 255 | + food /\ genState = runGen (availableRandomPoint initialSnake) initialGenState |
| 256 | + |
| 257 | + initState = |
| 258 | + { food |
| 259 | + , genState |
| 260 | + , snake: initialSnake |
| 261 | + , direction: initialDirection |
| 262 | + } |
| 263 | + pure |
| 264 | + { env: unit :: Env |
| 265 | + -- We're using our `Model` type as the state of the game. |
| 266 | + , initState: initState :: Model |
| 267 | + } |
| 268 | + , updates: |
| 269 | + -- We have a `keydown` update that updates the state with the direction we |
| 270 | + -- pressed |
| 271 | + [ keydown documentEventTarget do |
| 272 | + mDir <- asksAt _keyboardEvent $ key >>> case _ of |
| 273 | + "ArrowLeft" -> Just Left |
| 274 | + "ArrowUp" -> Just Up |
| 275 | + "ArrowRight" -> Just Right |
| 276 | + "ArrowDown" -> Just Down |
| 277 | + _ -> Nothing |
| 278 | + for_ mDir \dir -> modify (update (SetDir dir)) |
| 279 | + -- We also have an update that runs at our `ticksPerSecond` interval, |
| 280 | + -- but approximated to the closest (future) animation frame. We simply |
| 281 | + -- update the state, then read it again and render it to the canvas. |
| 282 | + , animationFrameMatchInterval (pure $ FPS ticksPerSecond) do |
| 283 | + modify (update Tick) |
| 284 | + get >>= render |
| 285 | + ] |
| 286 | + } |
| 287 | + |
| 288 | + |
| 289 | + |
| 290 | +-- MAIN |
| 291 | +-- |
| 292 | +main :: Effect Unit |
| 293 | +main = do |
| 294 | + -- Get canvas context to render into |
| 295 | + ctx <- getRenderNode |
| 296 | + -- Run our game in `Effect`. This is where we tell the game how to handle |
| 297 | + -- the `CANVAS` effect we specified as part of the `Extra` type. |
| 298 | + launchGame_ (mkReducer do runCanvas ctx) game |
| 299 | + |
| 300 | +-- HTML WORKAROUND |
| 301 | +-- |
| 302 | +-- Create our HTML and return a canvas to render into. |
| 303 | +-- Note that this is much more concise concise if written in HTML, |
| 304 | +-- but we need to use this workaround for compatibility with the |
| 305 | +-- TryPureScript environment, which doesn't yet allow providing |
| 306 | +-- custom HTML. |
| 307 | +getRenderNode :: Effect Context2D |
| 308 | +getRenderNode = do |
| 309 | + htmlDoc <- document =<< window |
| 310 | + body <- maybe (throw "Could not find body element") pure =<< HTMLDocument.body htmlDoc |
| 311 | + let |
| 312 | + doc = HTMLDocument.toDocument htmlDoc |
| 313 | + noteElem <- createElement "pre" doc |
| 314 | + canvasElem <- createElement "canvas" doc |
| 315 | + setId "canvas" canvasElem |
| 316 | + setAttribute "style" "border: 1px solid black" canvasElem |
| 317 | + let |
| 318 | + bodyNode = HTMLElement.toNode body |
| 319 | + |
| 320 | + noteNode = Element.toNode noteElem |
| 321 | + |
| 322 | + canvasNode = Element.toNode canvasElem |
| 323 | + setTextContent |
| 324 | + """ |
| 325 | +Click on page to set focus. |
| 326 | +Use Arrow keys to turn. |
| 327 | +""" |
| 328 | + noteNode |
| 329 | + void $ appendChild noteNode bodyNode |
| 330 | + void $ appendChild canvasNode bodyNode |
| 331 | + canvas <- maybe (throw "Could not find canvas") pure =<< getCanvasElementById "canvas" |
| 332 | + let |
| 333 | + width = toNumber $ cellSize * (xmax + 2) |
| 334 | + height = toNumber $ cellSize * (ymax + 2) |
| 335 | + _ <- setCanvasDimensions canvas { height, width } |
| 336 | + ctx <- getContext2D canvas |
| 337 | + pure ctx |
0 commit comments