From 2103dc0dcf42fd2489d5f9e4fec46146f7cc9db5 Mon Sep 17 00:00:00 2001 From: "Juan J. Martinez" Date: Sat, 4 Feb 2023 21:20:12 +0000 Subject: Initial import --- .gitignore | 5 ++ CHANGELOG.md | 5 ++ LICENSE | 20 +++++++ README.md | 15 ++++++ app/Main.hs | 6 +++ data/map.json | 65 ++++++++++++++++++++++ data/sprites.json | 16 ++++++ data/sprites.png | Bin 0 -> 8068 bytes data/tiles.png | Bin 0 -> 6673 bytes game.cabal | 46 ++++++++++++++++ src/Game.hs | 143 +++++++++++++++++++++++++++++++++++++++++++++++++ src/Game/Controller.hs | 32 +++++++++++ src/Game/Entities.hs | 139 +++++++++++++++++++++++++++++++++++++++++++++++ src/Game/Map.hs | 120 +++++++++++++++++++++++++++++++++++++++++ src/Game/Sprites.hs | 88 ++++++++++++++++++++++++++++++ src/Game/Utils.hs | 19 +++++++ 16 files changed, 719 insertions(+) create mode 100644 .gitignore create mode 100644 CHANGELOG.md create mode 100644 LICENSE create mode 100644 README.md create mode 100644 app/Main.hs create mode 100644 data/map.json create mode 100644 data/sprites.json create mode 100644 data/sprites.png create mode 100644 data/tiles.png create mode 100644 game.cabal create mode 100644 src/Game.hs create mode 100644 src/Game/Controller.hs create mode 100644 src/Game/Entities.hs create mode 100644 src/Game/Map.hs create mode 100644 src/Game/Sprites.hs create mode 100644 src/Game/Utils.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8f704fe --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +/dist +/dist-newstyle +/cabal.project.local +/.ghc.environment.* +*~ diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..39cfcf8 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for ??? + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..79017cd --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2023 Juan J. Martinez + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..67cc616 --- /dev/null +++ b/README.md @@ -0,0 +1,15 @@ +# Haskell + Gamedev + +This is me playing with Haskell and SDL2. + +Using cabal: + +``` +cabal run +``` +## Author + +This was made by [Juan J. Martinez](https://www.usebox.net/jjm/about/me/). + +Homepage: https://git.usebox.net/space-plat-hs/ + diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..2f60e31 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import qualified Game + +main :: IO () +main = Game.main diff --git a/data/map.json b/data/map.json new file mode 100644 index 0000000..aecf250 --- /dev/null +++ b/data/map.json @@ -0,0 +1,65 @@ +{ "compressionlevel":-1, + "height":24, + "infinite":false, + "layers":[ + { + "data":[1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 1, 2, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 1, 2, 27, 28, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 27, 28, 1, 2, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 1, 2, 27, 28, 55, 56, 55, 56, 55, 56, 55, 56, 79, 80, 79, 80, 55, 56, 55, 56, 55, 56, 55, 56, 79, 80, 79, 80, 79, 80, 79, 80, 55, 56, 55, 56, 55, 56, 55, 56, 27, 28, 1, 2, 3, 3, 3, 3, 3, 3, 3, 3, 53, 54, 53, 54, 3, 3, 1, 2, 1, 2, 3, 3, 53, 54, 53, 54, 53, 54, 53, 54, 3, 3, 3, 3, 3, 3, 3, 3, 1, 2, 27, 28, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 27, 28, 27, 28, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 27, 28, 1, 2, 53, 54, 53, 54, 55, 56, 55, 56, 55, 56, 1, 2, 55, 56, 55, 56, 55, 56, 55, 56, 55, 56, 55, 56, 53, 54, 53, 54, 55, 56, 55, 56, 55, 56, 55, 56, 1, 2, 27, 28, 79, 80, 79, 80, 3, 3, 3, 3, 3, 3, 27, 28, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 79, 80, 79, 80, 3, 3, 3, 3, 3, 3, 3, 3, 27, 28, 1, 2, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 1, 2, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 1, 2, 27, 28, 55, 56, 55, 56, 55, 56, 55, 56, 55, 56, 27, 28, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 27, 28, 1, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 1, 2, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 1, 2, 27, 28, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 27, 28, 79, 80, 79, 80, 79, 80, 79, 80, 55, 56, 55, 56, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 27, 28, 1, 2, 53, 54, 53, 54, 53, 54, 55, 56, 55, 56, 1, 2, 53, 54, 53, 54, 55, 56, 55, 56, 1, 2, 1, 2, 55, 56, 55, 56, 53, 54, 53, 54, 53, 54, 53, 54, 1, 2, 27, 28, 79, 80, 79, 80, 79, 80, 3, 3, 3, 3, 27, 28, 79, 80, 79, 80, 3, 3, 3, 3, 27, 28, 27, 28, 3, 3, 3, 3, 79, 80, 79, 80, 79, 80, 79, 80, 27, 28, 1, 2, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 1, 2, 53, 54, 53, 54, 53, 54, 53, 54, 1, 2, 1, 2, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 53, 54, 1, 2, 27, 28, 55, 56, 55, 56, 55, 56, 55, 56, 55, 56, 27, 28, 79, 80, 79, 80, 55, 56, 55, 56, 27, 28, 27, 28, 55, 56, 55, 56, 79, 80, 79, 80, 79, 80, 79, 80, 27, 28, 1, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 53, 54, 53, 54, 3, 3, 3, 3, 1, 2, 1, 2, 3, 3, 3, 3, 53, 54, 53, 54, 53, 54, 53, 54, 1, 2, 27, 28, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 27, 28, 27, 28, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 79, 80, 27, 28, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 1, 2, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 27, 28, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], + "height":24, + "id":1, + "name":"Base", + "opacity":1, + "type":"tilelayer", + "visible":true, + "width":40, + "x":0, + "y":0 + }, + { + "data":[0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], + "height":24, + "id":3, + "name":"Overlay", + "opacity":1, + "type":"tilelayer", + "visible":true, + "width":40, + "x":0, + "y":0 + }, + { + "data":[0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 4, 4, 4, 4, 4, 0, 0, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 4, 4, 4, 4, 4, 0, 0, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], + "height":24, + "id":4, + "name":"Blocked", + "opacity":0.25, + "type":"tilelayer", + "visible":true, + "width":40, + "x":0, + "y":0 + }], + "nextlayerid":5, + "nextobjectid":1, + "orientation":"orthogonal", + "renderorder":"right-down", + "tiledversion":"1.7.2", + "tileheight":8, + "tilesets":[ + { + "columns":26, + "firstgid":1, + "image":"tiles.png", + "imageheight":80, + "imagewidth":208, + "margin":0, + "name":"Tileset", + "spacing":0, + "tilecount":260, + "tileheight":8, + "tilewidth":8 + }], + "tilewidth":8, + "type":"map", + "version":"1.6", + "width":40 +} \ No newline at end of file diff --git a/data/sprites.json b/data/sprites.json new file mode 100644 index 0000000..af3e33e --- /dev/null +++ b/data/sprites.json @@ -0,0 +1,16 @@ +{ + "player": { + "frames": [ + { "x": 0, "y": 0, "width": 16, "height": 24 }, + { "x": 16, "y": 0, "width": 16, "height": 24 }, + { "x": 32, "y": 0, "width": 16, "height": 24 }, + { "x": 48, "y": 0, "width": 16, "height": 24 }, + { "x": 64, "y": 0, "width": 16, "height": 24 }, + { "x": 80, "y": 0, "width": 16, "height": 24 } + ], + "sets": [ + [0, 1, 0, 2], + [5, 4, 5, 3] + ] + } +} diff --git a/data/sprites.png b/data/sprites.png new file mode 100644 index 0000000..7ee2136 Binary files /dev/null and b/data/sprites.png differ diff --git a/data/tiles.png b/data/tiles.png new file mode 100644 index 0000000..b290fac Binary files /dev/null and b/data/tiles.png differ diff --git a/game.cabal b/game.cabal new file mode 100644 index 0000000..513a37e --- /dev/null +++ b/game.cabal @@ -0,0 +1,46 @@ +cabal-version: 2.4 +name: game +version: 0.1.0.0 + +synopsis: A gamedev experiment (2D platform game). +homepage: https://git.usebox.net/space-plat-hs/ + +license: MIT +license-file: LICENSE +author: Juan J. Martinez +maintainer: jjm@usebox.net + +extra-source-files: CHANGELOG.md, README.md, LICENCE + + +library + exposed-modules: + Game + Game.Map + Game.Sprites + Game.Entities + Game.Controller + Game.Utils + build-depends: + base + , mtl + , text >= 1.1.0.0 && < 2.1 + , sdl2 + , sdl2-image + , json + + ghc-options: -Wall -Werror -O2 -j + default-extensions: + OverloadedStrings + hs-source-dirs: src + default-language: Haskell2010 + +executable game + main-is: Main.hs + build-depends: + base + , game + ghc-options: -Wall -Werror -O2 + + hs-source-dirs: app + default-language: Haskell2010 diff --git a/src/Game.hs b/src/Game.hs new file mode 100644 index 0000000..0d5ae45 --- /dev/null +++ b/src/Game.hs @@ -0,0 +1,143 @@ +module Game (main) where + +import Control.Monad.Reader +import Data.IORef +import Data.Maybe (fromMaybe) +import Data.Text (pack) +import Foreign.C.Types (CInt) +import qualified Game.Controller as C +import qualified Game.Entities as E +import qualified Game.Map as M +import qualified Game.Sprites as S +import Game.Utils (isPressed) +import SDL (($=), ($~)) +import qualified SDL +import qualified SDL.Image +import SDL.Vect (V2 (..)) + +name :: String +name = "Haskell gamedev [Space Platformer]" + +gameWidth, gameHeight :: CInt +(gameWidth, gameHeight) = (320, 180) + +gameScale :: CInt +gameScale = 3 + +windowWidth, windowHeight :: CInt +(windowWidth, windowHeight) = (gameWidth * gameScale, gameHeight * gameScale) + +version :: String +version = "0.1.0" + +data Env = Env + { _window :: SDL.Window, + _renderer :: SDL.Renderer, + _canvas :: SDL.Texture, + _fullscreen :: IORef Bool, + _renderRect :: IORef (SDL.Rectangle CInt), + _controls :: IORef C.Controls, + _map :: M.Map, + _sprites :: S.SpriteSheet, + _entities :: IORef [E.Entity] + } + +defaultRenderRect :: SDL.Rectangle CInt +defaultRenderRect = SDL.Rectangle (SDL.P $ V2 0 0) (V2 windowWidth windowHeight) + +main :: IO () +main = do + SDL.initialize [SDL.InitVideo] + window <- + SDL.createWindow + (pack $ name ++ " " ++ version) + SDL.defaultWindow {SDL.windowInitialSize = SDL.V2 windowWidth windowHeight} + renderer <- + SDL.createRenderer + window + (-1) + SDL.RendererConfig + { SDL.rendererType = SDL.AcceleratedVSyncRenderer, + SDL.rendererTargetTexture = True + } + SDL.HintRenderScaleQuality $= SDL.ScaleNearest + canvas <- SDL.createTexture renderer SDL.RGBA8888 SDL.TextureAccessTarget (V2 gameWidth gameHeight) + fullscreen <- newIORef False + renderRect <- newIORef defaultRenderRect + tsTexture <- SDL.Image.loadTexture renderer "data/tiles.png" + ssTexture <- SDL.Image.loadTexture renderer "data/sprites.png" + controls <- newIORef C.init + map' <- M.load "data/map.json" tsTexture + sprites <- S.load "data/sprites.json" ssTexture + entities <- newIORef ([] :: [E.Entity]) + player <- E.mkPlayer sprites 32 104 controls (M.isBlocked map') + entities $~ (player :) + runReaderT gameLoop (Env window renderer canvas fullscreen renderRect controls map' sprites entities) + SDL.destroyWindow window + SDL.quit + +toggleFullscreen :: ReaderT Env IO () +toggleFullscreen = do + env <- ask + let fullscreen = _fullscreen env + renderRect = _renderRect env + renderer = _renderer env + window = _window env + fullscreen $~ not + fs <- SDL.get fullscreen + let mode = if fs then SDL.FullscreenDesktop else SDL.Windowed + in SDL.setWindowMode window mode + + vp <- if fs then SDL.get $ SDL.rendererViewport renderer else pure Nothing + let newRenderRect = case vp of + Nothing -> defaultRenderRect + Just (SDL.Rectangle _ (V2 w h)) -> + SDL.Rectangle (SDL.P $ V2 rx ry) (V2 rw rh) + where + scale = min (w `div` gameWidth) (h `div` gameHeight) + rx = (w - (gameWidth * scale)) `div` 2 + ry = (h - (gameHeight * scale)) `div` 2 + rw = gameWidth * scale + rh = gameHeight * scale + in renderRect $= newRenderRect + +gameLoop :: ReaderT Env IO () +gameLoop = do + env <- ask + let renderer = _renderer env + canvas = _canvas env + renderRect = _renderRect env + controls = _controls env + map' = _map env + entities = _entities env + + events <- map SDL.eventPayload <$> SDL.pollEvents + + -- F11 for fullscreen / windowed + when (fromMaybe False $ isPressed SDL.KeycodeF11 events) toggleFullscreen + + -- ESC or close the window to quit + let quit = fromMaybe False (isPressed SDL.KeycodeEscape events) || SDL.QuitEvent `elem` events + unless quit $ do + -- update controls + controls $~ C.update events + + SDL.rendererRenderTarget renderer $= Just canvas + SDL.clear renderer + + -- update entities filtering out the ones that have been destroyed + updated <- liftIO $ fmap (filter (not . E.eDestroy)) (traverse (\e -> E.eUpdate e e) =<< readIORef entities) + entities $= updated + + -- render map and entities + void $ liftIO $ do + M.render renderer map' + traverse (E.render renderer) updated + + SDL.rendererRenderTarget renderer $= Nothing + rect <- SDL.get renderRect + SDL.copy renderer canvas Nothing (Just rect) + + SDL.present renderer + + gameLoop diff --git a/src/Game/Controller.hs b/src/Game/Controller.hs new file mode 100644 index 0000000..3ec7e4c --- /dev/null +++ b/src/Game/Controller.hs @@ -0,0 +1,32 @@ +module Game.Controller (Controls (..), init, update) where + +import Data.Maybe (fromMaybe) +import Game.Utils (isPressed) +import qualified SDL +import Prelude hiding (init) + +data Controls = Controls + { cUp :: Bool, + cDown :: Bool, + cLeft :: Bool, + cRight :: Bool, + cA :: Bool, + cB :: Bool, + cMenu :: Bool + } + deriving (Show) + +init :: Controls +init = Controls False False False False False False False + +update :: [SDL.EventPayload] -> Controls -> Controls +update events controls = + controls + { cUp = fromMaybe (cUp controls) $ isPressed SDL.KeycodeUp events, + cDown = fromMaybe (cDown controls) $ isPressed SDL.KeycodeDown events, + cLeft = fromMaybe (cLeft controls) $ isPressed SDL.KeycodeLeft events, + cRight = fromMaybe (cRight controls) $ isPressed SDL.KeycodeRight events, + cA = fromMaybe (cA controls) $ isPressed SDL.KeycodeZ events, + cB = fromMaybe (cB controls) $ isPressed SDL.KeycodeX events, + cMenu = fromMaybe (cMenu controls) $ isPressed SDL.KeycodeReturn events + } diff --git a/src/Game/Entities.hs b/src/Game/Entities.hs new file mode 100644 index 0000000..0d37632 --- /dev/null +++ b/src/Game/Entities.hs @@ -0,0 +1,139 @@ +module Game.Entities (Entity (..), toSpriteSet, mkPlayer, render) where + +import Data.IORef +import qualified Game.Controller as C +import qualified Game.Sprites as S +import qualified SDL + +data Dir = DirRight | DirLeft deriving (Eq) + +data Type = TypePlayer -- \| TypeEnemy | TypeItem + +toSpriteSet :: Dir -> Int +toSpriteSet DirRight = 0 +toSpriteSet DirLeft = 1 + +frameDelay :: Int +frameDelay = 6 + +jumpFrame :: Int +jumpFrame = 3 + +gravityOff :: Int +gravityOff = -1 + +gravityUp :: Int +gravityUp = 0 + +gravityDown :: Int +gravityDown = 16 + +gravityTable :: [Int] +gravityTable = [0, 6, 4, 4, 2, 2, 2, 2, 1, 1, 1, 0, 0, 0, 0, 0, 0, 1, 1, 2, 3] + +data Entity = Entity + { eType :: Type, + eX :: Int, + eY :: Int, + eDelay :: Int, + eFrame :: Int, + eFrameLimit :: Int, + eGravity :: Int, + eDir :: Dir, + eSprite :: S.Sprite, + eUpdate :: Entity -> IO Entity, + eBlocked :: Int -> Int -> Bool, + eDestroy :: Bool + } + +mkPlayer :: S.SpriteSheet -> Int -> Int -> IORef C.Controls -> (Int -> Int -> Bool) -> IO Entity +mkPlayer sprites x y controls isBlocked = do + s <- S.get sprites "player" + pure $ Entity TypePlayer x y 0 0 3 gravityOff DirRight s (updatePlayer controls) isBlocked False + +updateFrame :: Bool -> Entity -> Entity +updateFrame updated e + | isGravityOn = e + | delay > 0 = e {eDelay = delay - 1} + | frame < eFrameLimit e = e {eDelay = frameDelay, eFrame = if updated then frame + 1 else 0} + | otherwise = e {eDelay = frameDelay, eFrame = 0} + where + isGravityOn = eGravity e > gravityOff + frame = eFrame e + delay = eDelay e + +updateHorizontal :: Bool -> Bool -> Entity -> Entity +updateHorizontal left right e + -- prevent pressing both directions (keyboard) + | left && right = e + -- change direction first + | left && eDir e /= DirLeft = e {eDir = DirLeft, eDelay = 0} + | right && eDir e /= DirRight = e {eDir = DirRight, eDelay = 0} + | left && isGoingDown = if isBlocked (x - 1) (y + 23) then e else e {eX = x - 1} + | left && not isGoingDown = if isBlocked (x - 1) (y + 23) && isBlocked (x - 1) (y + 17) then e else e {eX = x - 1} + | right && isGoingDown = if isBlocked (x + 17) (y + 23) then e else e {eX = x + 1} + | right && not isGoingDown = if isBlocked (x + 17) (y + 23) && isBlocked (x + 17) (y + 17) then e else e {eX = x + 1} + | otherwise = e + where + x = eX e + y = eY e + isBlocked = eBlocked e + gravity = eGravity e + isGoingDown = gravity == gravityOff || gravity >= gravityDown + +updateVertical :: Bool -> Entity -> Entity +updateVertical jump e + | jump && gravity == gravityOff = e {eGravity = gravityUp, eFrame = jumpFrame} + | otherwise = e + where + gravity = eGravity e + +applyGravity :: Int -> Entity -> Entity +applyGravity v e + | v == 0 = e + -- hit the floor + | isGoingDown + && (isBlocked (x + 2) (y + 24) || isBlocked (x + 12) (y + 24)) + && not (isBlocked (x + 2) (y + 23)) + && not (isBlocked (x + 12) (y + 23)) = + e {eGravity = gravityOff, eDelay = 0, eFrame = 0} + | otherwise = applyGravity (v - 1) e {eY = y + change} + where + gravity = eGravity e + isGoingDown = gravity >= gravityDown + change = if isGoingDown then 1 else -1 + x = eX e + y = eY e + isBlocked = eBlocked e + +updateGravity :: Entity -> Entity +updateGravity e + | current > gravityOff = applyGravity (gravityTable !! current) e {eGravity = new} + | not (isBlocked (x + 2) (y + 24) || isBlocked (x + 12) (y + 24)) = e {eGravity = gravityDown, eFrame = jumpFrame} + | otherwise = e + where + current = eGravity e + new = if current > gravityOff && current < length gravityTable - 1 then current + 1 else current + x = eX e + y = eY e + isBlocked = eBlocked e + +updatePlayer :: IORef C.Controls -> Entity -> IO Entity +updatePlayer controls e = do + ctl <- readIORef controls + pure $ + updateGravity $ + updateVertical (C.cA ctl) $ + updateHorizontal (C.cLeft ctl) (C.cRight ctl) $ + -- left or right, but not both (keyboard) + updateFrame ((C.cLeft ctl || C.cRight ctl) && (C.cLeft ctl /= C.cRight ctl)) e + +render :: SDL.Renderer -> Entity -> IO () +render renderer ent = + S.render renderer sp x y set frame + where + sp = eSprite ent + x = eX ent + y = eY ent + set = toSpriteSet $ eDir ent + frame = eFrame ent diff --git a/src/Game/Map.hs b/src/Game/Map.hs new file mode 100644 index 0000000..7866f97 --- /dev/null +++ b/src/Game/Map.hs @@ -0,0 +1,120 @@ +module Game.Map + ( Map, + load, + render, + isBlocked, + ) +where + +import Control.Monad +import qualified Game.Utils as U +import qualified SDL +import Text.JSON +import Text.JSON.Types + +data Tileset = Tileset + { tsCols :: Int, + tsWidth :: Int, + tsHeight :: Int, + tsFirstGid :: Int + } + deriving (Show) + +data TileLayer = TileLayer + { tlName :: String, + tlTiles :: [Int] + } + deriving (Show) + +data MapData = MapData + { mWidth :: Int, + mHeight :: Int, + mTileset :: Tileset, + mLayers :: [TileLayer] + } + deriving (Show) + +data Map = Map MapData SDL.Texture + +instance JSON Tileset where + showJSON = undefined + readJSON (JSArray [JSObject obj]) = do + Tileset + <$> valFromObj "columns" obj + <*> valFromObj "tilewidth" obj + <*> valFromObj "tileheight" obj + <*> valFromObj "firstgid" obj + readJSON _ = mzero + +instance JSON TileLayer where + showJSON = undefined + readJSON (JSObject obj) = + case get_field obj "type" of + Just "tilelayer" -> + TileLayer + <$> valFromObj "name" obj + <*> valFromObj "data" obj + _ -> Error "unsupported layer type" + readJSON _ = mzero + +instance JSON MapData where + showJSON = undefined + readJSON (JSObject obj) = + MapData + <$> valFromObj "width" obj + <*> valFromObj "height" obj + <*> valFromObj "tilesets" obj + <*> valFromObj "layers" obj + readJSON _ = mzero + +-- | Loads a map from a JSON file. +load :: String -> SDL.Texture -> IO Map +load filename tex = do + d <- readFile filename + case decode d :: Result MapData of + Ok s -> pure $ Map s tex + Error e -> error e + +-- | Check for collision detection vs "Blocked" TileLayer that MUST be last layer. +-- x and y in pixels. +isBlocked :: Map -> Int -> Int -> Bool +isBlocked (Map (MapData width _ ts layers) _) x y = + tiles !! ((x `div` tw) + (y `div` th) * width) >= firstgid + where + tiles = tlTiles (last layers) + tw = tsWidth ts + th = tsHeight ts + firstgid = tsFirstGid ts + +-- | Renders a map. +render :: SDL.Renderer -> Map -> IO () +render renderer (Map mapData tex) = do + mapM_ + ( \layer -> + mapM_ + ( \(x, y) -> + renderTile x y $ tlTiles layer !! (x + (y * mWidth mapData)) + ) + index + ) + (init $ mLayers mapData) + where + mw = mWidth mapData + mh = mHeight mapData + index = [(x, y) | x <- [0 .. mw - 1], y <- [0 .. mh - 1]] + + ts = mTileset mapData + firstgid = tsFirstGid ts + cols = tsCols ts + tileWidth = tsWidth ts + tileHeight = tsHeight ts + + renderTile :: Int -> Int -> Int -> IO () + renderTile x y tile + | tile < firstgid = pure () + | otherwise = do + let tx = (tile - firstgid) `rem` cols + ty = (tile - firstgid) `div` cols + src = U.rect (tx * tileWidth) (ty * tileHeight) tileWidth tileHeight + dst = U.rect (x * tileWidth) (y * tileHeight) tileWidth tileHeight + SDL.copy renderer tex (Just src) (Just dst) diff --git a/src/Game/Sprites.hs b/src/Game/Sprites.hs new file mode 100644 index 0000000..de949b5 --- /dev/null +++ b/src/Game/Sprites.hs @@ -0,0 +1,88 @@ +module Game.Sprites + ( SpriteSheet, + Sprite, + load, + get, + render, + ) +where + +import Control.Monad +import Data.List (find) +import Foreign.C.Types (CInt) +import qualified Game.Utils as U +import qualified SDL +import SDL.Vect (V2 (..)) +import Text.JSON + +-- | Sprite sheet contains description of the different sprites. +-- +-- Load a sprite sheet from JSON with `load`. +-- Use `get` to get a specific sprite. +data SpriteSheet = SpriteSheet Sprites SDL.Texture + +-- | A sprite description that can be rendered. +-- +-- Can be rendered with `render`. +data Sprite = Sprite [[SDL.Rectangle CInt]] SDL.Texture + +newtype SpriteData = SpriteData [[SDL.Rectangle CInt]] deriving (Show) + +newtype Sprites = Sprites [(String, SpriteData)] deriving (Show) + +data Frame = Frame Int Int Int Int deriving (Show) + +setsToRects :: [Frame] -> [Int] -> [SDL.Rectangle CInt] +setsToRects frames = + map + ( \s -> do + case frames !! s of + Frame x y w h -> U.rect x y w h + ) + +instance JSON Frame where + showJSON = undefined + readJSON (JSObject obj) = do + Frame + <$> valFromObj "x" obj + <*> valFromObj "y" obj + <*> valFromObj "width" obj + <*> valFromObj "height" obj + readJSON _ = mzero + +instance JSON SpriteData where + showJSON = undefined + readJSON (JSObject obj) = do + frames <- valFromObj "frames" obj + sets <- valFromObj "sets" obj + Ok $ SpriteData $ map (setsToRects frames) sets + readJSON _ = mzero + +instance JSON Sprites where + showJSON = undefined + readJSON obj = + Sprites + <$> decJSDict "sprites" obj + +-- | Loads a spritesheet described on a JSON file. +load :: String -> SDL.Texture -> IO SpriteSheet +load filename tex = do + d <- readFile filename + case decode d :: Result Sprites of + Ok s -> pure $ SpriteSheet s tex + Error e -> error e + +-- | Gets a named sprite from the spritesheet. +get :: SpriteSheet -> String -> IO Sprite +get (SpriteSheet (Sprites sprites) tex) sid = + case fmap snd (find (\(name, _) -> name == sid) sprites) of + Nothing -> error $ "sprite '" ++ sid ++ "' not found" + Just (SpriteData frames) -> pure $ Sprite frames tex + +-- | Renders a sprite on position (x, y) selecting a set and a frame within that set. +render :: SDL.Renderer -> Sprite -> Int -> Int -> Int -> Int -> IO () +render renderer (Sprite frames tex) x y set frame = do + let src = (frames !! set) !! frame + dst = case src of + SDL.Rectangle _ (V2 w h) -> U.rect x y (fromIntegral w) (fromIntegral h) + SDL.copy renderer tex (Just src) (Just dst) diff --git a/src/Game/Utils.hs b/src/Game/Utils.hs new file mode 100644 index 0000000..acfab6f --- /dev/null +++ b/src/Game/Utils.hs @@ -0,0 +1,19 @@ +module Game.Utils (rect, isPressed) where + +import Foreign.C.Types (CInt) +import qualified SDL +import SDL.Vect (V2 (..)) + +rect :: Int -> Int -> Int -> Int -> SDL.Rectangle CInt +rect x y w h = SDL.Rectangle (SDL.P $ V2 (fromIntegral x) (fromIntegral y)) (V2 (fromIntegral w) (fromIntegral h)) + +isPressed :: SDL.Keycode -> [SDL.EventPayload] -> Maybe Bool +isPressed code events + -- TODO: gamepad support + | any (isEventKey SDL.Pressed code) events = Just True + | any (isEventKey SDL.Released code) events = Just False + | otherwise = Nothing + where + isEventKey :: SDL.InputMotion -> SDL.Keycode -> SDL.EventPayload -> Bool + isEventKey expected keycode (SDL.KeyboardEvent (SDL.KeyboardEventData _ motion False ksym)) = expected == motion && SDL.keysymKeycode ksym == keycode + isEventKey _ _ _ = False -- cgit v1.2.3