├── LICENSE ├── .gitignore ├── spec └── Main.hs ├── TODOS.markdown ├── src ├── ActionKid.hs ├── ActionKid │ ├── Globals.hs │ ├── Utils.hs │ ├── Internal.hs │ ├── Types.hs │ └── Core.hs └── Main.hs ├── Makefile ├── TROUBLESHOOTING.markdown ├── getting_sdl_working.markdown ├── ActionKid.cabal ├── README.markdown └── SOUND.markdown /LICENSE: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .* 2 | dist/* 3 | tags 4 | cabal.sandbox.config 5 | -------------------------------------------------------------------------------- /spec/Main.hs: -------------------------------------------------------------------------------- 1 | import Test.Hspec 2 | import ActionKid 3 | main = hspec $ do 4 | describe "specs" $ do 5 | it "should work" $ do 6 | 1 == 1 7 | -------------------------------------------------------------------------------- /TODOS.markdown: -------------------------------------------------------------------------------- 1 | - adding music? 2 | - need to ability to STOP a music track (ability to stop background music in a game). 3 | - builtin movieclips with MovieClip instances to make it easier to get started? 4 | 5 | - moveX/moveY signals as signal attrs? 6 | -------------------------------------------------------------------------------- /src/ActionKid.hs: -------------------------------------------------------------------------------- 1 | module ActionKid ( 2 | module ActionKid.Types, 3 | module ActionKid.Core, 4 | module Graphics.Gloss.Interface.IO.Game 5 | ) where 6 | import ActionKid.Types 7 | import ActionKid.Core 8 | import Graphics.Gloss.Interface.IO.Game 9 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # cabal options 2 | OPTIONS= 3 | 4 | destroy: 5 | cabal sandbox delete 6 | 7 | init: 8 | cabal sandbox init 9 | 10 | install: 11 | cabal install $(OPTIONS) 12 | 13 | run: 14 | cabal run 15 | 16 | all: install run 17 | 18 | spec: install 19 | cabal spec 20 | -------------------------------------------------------------------------------- /TROUBLESHOOTING.markdown: -------------------------------------------------------------------------------- 1 | # The game freezes 2 | 3 | Disable "Automatic GPU Switching" in System Preferences / Energy Saver. 4 | 5 | See: https://groups.google.com/forum/#!topic/haskell-gloss/VKYGVv2gzho 6 | 7 | 8 | # SDL throws a weird error 9 | 10 | SDL doesn't play nice with template haskell. I found a convoluted solution to the issue on IRC: http://ircbrowse.net/browse/haskell?id=17202052×tamp=1389138999#t1389138999 11 | -------------------------------------------------------------------------------- /src/ActionKid/Globals.hs: -------------------------------------------------------------------------------- 1 | module ActionKid.Globals where 2 | import Control.Concurrent 3 | import Data.IORef 4 | import qualified Data.Map as M 5 | import qualified Graphics.Gloss as G 6 | import System.IO.Unsafe 7 | 8 | -- | Set the IORef to the actual int 9 | setRef :: a -> IORef a 10 | setRef = unsafePerformIO . newIORef 11 | 12 | -- | Global variable to set board width 13 | boardWidth :: IORef Int 14 | boardWidth = setRef 0 15 | 16 | -- | Global variable to set board height 17 | boardHeight :: IORef Int 18 | boardHeight = setRef 0 19 | 20 | -- | Global variable to cache game images 21 | imageCache :: IORef (M.Map String G.Picture) 22 | imageCache = setRef M.empty 23 | -------------------------------------------------------------------------------- /getting_sdl_working.markdown: -------------------------------------------------------------------------------- 1 | `ghc-pkg` is what `cabal` uses under the hood. You can use it to view or edit info about your packages. For example, view the config of a package using: 2 | 3 | ghc-pkg describe PACKAGENAME 4 | 5 | In my case, the `ld-options` for the `SDL` package were configured wrongly. So I had to change them. Here were the steps: 6 | 7 | 1. Export config to a file 8 | 9 | ghc-pkg describe SDL > sdl.pkg 10 | 11 | 2. Edit the file 12 | 13 | vim sdl.pkg 14 | 15 | 3. Update the config in `ghc-pkg`: 16 | 17 | ghc-pkg update --global sdl.pkg 18 | 19 | Now check your packages with 20 | 21 | ghc-pkg list SDL 22 | 23 | you might see two packages! One `--user` and one `--global`. 24 | You can see which is which with 25 | 26 | ghc-pkg list --user SDL 27 | ghc-pkg list --global SDL 28 | 29 | Now unregister the user package: 30 | 31 | ghc-pkg unregister --user SDL 32 | 33 | And then 34 | 35 | ghc-pkg describe SDL 36 | 37 | should have your changes! 38 | -------------------------------------------------------------------------------- /src/ActionKid/Utils.hs: -------------------------------------------------------------------------------- 1 | module ActionKid.Utils where 2 | import Data.List 3 | import Graphics.Gloss 4 | import Control.Monad.State 5 | 6 | -- | Convenience function to make a box: 7 | -- 8 | -- > box 50 50 9 | box :: Int -> Int -> Picture 10 | box w_ h_ = polygon [p1, p2, p3, p4] 11 | where 12 | w = fromIntegral w_ 13 | h = fromIntegral h_ 14 | p1 = (0, 0) 15 | p2 = (0, w) 16 | p3 = (h, w) 17 | p4 = (h, 0) 18 | 19 | join elem list = concat $ intersperse elem list 20 | 21 | for :: [a] -> (a -> b) -> [b] 22 | for = flip map 23 | 24 | count :: Eq a => a -> [a] -> Int 25 | count x list = length $ filter (==x) list 26 | 27 | indices :: [a] -> [Int] 28 | indices arr = [0..(length arr - 1)] 29 | 30 | (//) :: Integral a => a -> a -> a 31 | a // b = floor $ (fromIntegral a) / (fromIntegral b) 32 | 33 | mapWithIndex func list = map func (zip list (indices list)) 34 | 35 | forWithIndex = flip mapWithIndex 36 | 37 | -- | convenient if you need to update a lot of attributes on a `MovieClip`. 38 | -- Example: 39 | -- 40 | -- > withMC person $ do 41 | -- x .= 100 42 | -- y .= 100 43 | -- name .= "adit" 44 | withMC state func = snd $ runState func state 45 | -------------------------------------------------------------------------------- /ActionKid.cabal: -------------------------------------------------------------------------------- 1 | name: ActionKid 2 | version: 0.1.1.0 3 | synopsis: An easy-to-use video game framework for Haskell. 4 | description: See examples and full readme on the Github page: https:\/\/github.com\/egonSchiele\/actionkid 5 | homepage: https://github.com/egonSchiele/actionkid 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Aditya Bhargava 9 | maintainer: bluemangroupie@gmail.com 10 | -- copyright: 11 | category: Game Engine 12 | build-type: Simple 13 | cabal-version: >=1.8 14 | 15 | executable actionkid 16 | build-depends: base >=4.6 && <5, gloss, StateVar, lens, gloss-juicy, mtl, template-haskell, containers >=0.5.0 && <0.6, OpenGL >=2.8.0 17 | hs-source-dirs: src 18 | main-is: Main.hs 19 | ghc-options: -rtsopts -threaded "-with-rtsopts=-M500m -N" 20 | 21 | Test-Suite test-actionkid 22 | type: exitcode-stdio-1.0 23 | build-depends: base >=4.6 && <5, hspec, ActionKid 24 | hs-source-dirs: spec 25 | main-is: Main.hs 26 | 27 | library 28 | build-depends: base >=4.6 && <5, gloss >= 1.9, StateVar, lens, gloss-juicy >=0.2, mtl, template-haskell, containers >=0.5.0 && <0.6, OpenGL >=2.8.0 29 | exposed-modules: ActionKid, ActionKid.Types, ActionKid.Core, ActionKid.Utils 30 | hs-source-dirs: src 31 | Other-modules: ActionKid.Internal, ActionKid.Globals 32 | ghc-options: -rtsopts -threaded "-with-rtsopts=-M500m -N" 33 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # ActionKid 2 | 3 | ![](http://static.adit.io/chips_screenshot.png) 4 | 5 | A game framework for Haskell. 6 | 7 | **Video tutorial**: http://vimeo.com/109663514 8 | 9 | The goal is to have an easy-to-use game framework for Haskell. For example, here's how you get a player on the screen: 10 | 11 | ```haskell 12 | -- create a new player data type 13 | data Player = Player { _pa :: Attributes } 14 | deriveMC ''Player 15 | 16 | -- describe what it should look like: 17 | instance Renderable Player where 18 | render p = image "images/player.png" 19 | ``` 20 | 21 | Here's how you move your player: 22 | 23 | ```haskell 24 | handle (EventKey (SpecialKey KeyLeft) Down _ _) = player.x -= 10 25 | handle (EventKey (SpecialKey KeyRight) Down _ _) = player.x += 10 26 | handle (EventKey (SpecialKey KeyUp) Down _ _) = player.y += 10 27 | handle (EventKey (SpecialKey KeyDown) Down _ _) = player.y -= 10 28 | ``` 29 | 30 | ## On OS X 31 | 32 | If you are playing on OS X, please disable "automatic GPU switching from system preferences -> energy saver first. Without this, the game may appear frozen. 33 | 34 | ## Similar modules 35 | 36 | - All the hard lifting in this package is done by [Gloss](https://hackage.haskell.org/package/gloss). ActionKid provides a lot of convenience functions. 37 | - [gloss-game](https://github.com/mchakravarty/gloss-game) is a similar module. 38 | 39 | ## Docs 40 | 41 | - [Check out the included example for more details](https://github.com/egonSchiele/actionkid/blob/master/src/Main.hs). 42 | - [Read the documentation on Hackage](https://hackage.haskell.org/package/ActionKid). 43 | -------------------------------------------------------------------------------- /SOUND.markdown: -------------------------------------------------------------------------------- 1 | Holy cow, getting sound working in Haskell has been an ENORMOUS pain. There is no library with a simple function `playSound` where you give the path to a sound file and it plays the sound. 2 | 3 | First I tried this: http://stackoverflow.com/questions/14005592/play-a-wav-file-with-haskell 4 | 5 | And I couldn't get the libraries installed. So I scoured the net and tried a bunch of other solutions, couldn't get anything working. Got back to that link and got it working (I had to install SDL and SDL_mixer through brew first). And THEN, those packages aren't configured for Haskell correctly, so I had to change the config manually using `ghc-pkg describe SDL > sdl.pkg`, update the file, and `ghc-pkg update --global sdl.pkg`. I added a basics entry on how to do this, check it out. 6 | 7 | THEN it turns out, I have to build with `-threaded`, and that wasn't working. 8 | Then that randomly started working with no change on my part, but it wasn't showing the window and playing sound in parallel! 9 | THEN I found out, SDL-mixer uses some unsafe functions, so they block all threads. I found a fix here: http://stackoverflow.com/questions/18155302/using-gloss-to-run-a-simulation-while-using-sdl-to-play-a-sound 10 | 11 | THEN it turns out that even though both are working together, something is eating up my CPU and I couldn't even move the character!! 12 | Then I decided to use a third-party command line app. I just used backticks to `mpg123` and played mp3 files through that. 13 | So now I could do both audio and graphics in parallel, and move the guy around. And I could even play multiple audio files at the same time, which was awesome. 14 | But now, when I close the window, the sound still keeps playing! I don't know why...when the main thread dies, all forked threads are supposed to die. But not in this case. Still can't figure it out. 15 | So in summary, audio is a giant pain. 16 | 17 | ...And we're back. I couldn't figure out the issue with sounds, and then Leaf pointed out that this library is now totally UN-portable...I require all my users to have mpg123 (which I already knew). So I tried going back to SDL. I added a threaddelay before I do anything else, and now it somehow magically works. WTF. 18 | 19 | And now I've started getting this error: 20 | 21 | actionkid(7549,0x10e5cb000) malloc: *** error for object 0x7fa808419570: pointer being freed was not allocated 22 | *** set a breakpoint in malloc_error_break to debug 23 | actionkid(7549,0x105004000) malloc: *** error for object 0x7fa808419570: pointer being freed was not allocated 24 | *** set a breakpoint in malloc_error_break to debug 25 | Abort trap: 6 26 | 27 | ...this is bullshit. 28 | -------------------------------------------------------------------------------- /src/ActionKid/Internal.hs: -------------------------------------------------------------------------------- 1 | module ActionKid.Internal where 2 | import ActionKid.Types 3 | import ActionKid.Utils 4 | import Control.Applicative 5 | import Control.Monad 6 | import Data.List 7 | import Data.Maybe 8 | import Text.Printf 9 | import Graphics.Gloss hiding (display) 10 | import Data.Monoid ((<>), mconcat) 11 | import Graphics.Gloss.Interface.IO.Game 12 | import Data.Ord 13 | import ActionKid.Globals 14 | import Data.StateVar 15 | import Control.Lens 16 | import qualified Debug.Trace as D 17 | 18 | -- bounding box for a series of points 19 | pathBox points = 20 | let minx = minimum $ map fst points 21 | miny = minimum $ map snd points 22 | maxx = maximum $ map fst points 23 | maxy = maximum $ map snd points 24 | in ((minx, miny), (maxx, maxy)) 25 | 26 | catPoints :: (Point, Point) -> [Point] 27 | catPoints (p1, p2) = [p1, p2] 28 | 29 | -- | Code borrowed from https://hackage.haskell.org/package/gloss-game-0.3.0.0/docs/src/Graphics-Gloss-Game.html 30 | -- Calculate bounding boxes for various `Picture` types. 31 | type Rect = (Point, Point) -- ^origin & extent, where the origin is at the centre 32 | boundingBox :: Picture -> Rect 33 | boundingBox Blank = ((0, 0), (0, 0)) 34 | boundingBox (Polygon path) = pathBox path 35 | boundingBox (Line path) = pathBox path 36 | boundingBox (Circle r) = ((0, 0), (2 * r, 2 * r)) 37 | boundingBox (ThickCircle t r) = ((0, 0), (2 * r + t, 2 * r + t)) 38 | boundingBox (Arc _ _ _) = error "ActionKid.Core.boundingbox: Arc not implemented yet" 39 | boundingBox (ThickArc _ _ _ _) = error "ActionKid.Core.boundingbox: ThickArc not implemented yet" 40 | boundingBox (Text _) = error "ActionKid.Core.boundingbox: Text not implemented yet" 41 | boundingBox (Bitmap w h _ _) = ((0, 0), (fromIntegral w, fromIntegral h)) 42 | boundingBox (Color _ p) = boundingBox p 43 | boundingBox (Translate dx dy p) = ((x1 + dx, y1 + dy), (x2 + dx, y2 + dy)) 44 | where ((x1, y1), (x2, y2)) = boundingBox p 45 | boundingBox (Rotate _ang _p) = error "Graphics.Gloss.Game.boundingbox: Rotate not implemented yet" 46 | 47 | -- TODO fix scale, this implementation is incorrect (only works if scale 48 | -- = 1). Commented out version is incorrect too 49 | boundingBox (Scale xf yf p) = boundingBox p 50 | -- let ((x1, y1), (x2, y2)) = boundingBox p 51 | -- w = x2 - x1 52 | -- h = y2 - y1 53 | -- scaledW = w * xf 54 | -- scaledH = h * yf 55 | -- in ((x1, x2), (x1 + scaledW, y1 + scaledH)) 56 | boundingBox (Pictures ps) = pathBox points 57 | where points = concatMap (catPoints . boundingBox) ps 58 | 59 | -- | Check if one rect is touching another. 60 | intersects :: Rect -> Rect -> Bool 61 | intersects ((min_ax, min_ay), (max_ax, max_ay)) ((min_bx, min_by), (max_bx, max_by)) 62 | | max_ax < min_bx = False 63 | | min_ax > max_bx = False 64 | | min_ay > max_by = False 65 | | max_ay < min_by = False 66 | | otherwise = True 67 | 68 | -- | For future, if I want to inject something into the step function, 69 | -- I'll do it here. Right now I just call the step function. 70 | onEnterFrame :: MovieClip a => (Float -> a -> IO a) -> Float -> a -> IO a 71 | onEnterFrame stepFunc num state = stepFunc num state 72 | 73 | -- | Called to draw the game. Translates the coordinate system. 74 | draw :: Renderable a => a -> IO Picture 75 | draw gs = do 76 | w <- get boardWidth 77 | h <- get boardHeight 78 | return $ translate (-(fromIntegral $ w // 2)) (-(fromIntegral $ h // 2)) $ 79 | display gs 80 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction #-} 2 | {-# OPTIONS_GHC -fno-full-laziness -fno-cse #-} 3 | import ActionKid 4 | import ActionKid.Utils 5 | import Control.Lens 6 | import Control.Monad.State 7 | 8 | -- This is an example of how to use ActionKid to make games with Haskell. 9 | -- ActionKid is inspired by Actionscript, so you will see some 10 | -- similarities. 11 | -- 12 | -- Every video game has some objects on the screen that interact with each 13 | -- other. For example, in a game of Mario, you will have Mario himself, 14 | -- goombas, mushrooms, pipes etc. These objects are called "movie clip"s in 15 | -- ActionKid terminology. Any data type that is an instance of the 16 | -- MovieClip class can be used in your game. 17 | 18 | -- So first, make a data type for every object you will have in your game. 19 | -- In this demo game, we just have a player that will move around. 20 | -- 21 | -- Every constructor must have `Attributes` as it's last field. 22 | data Player = Player { _pa :: Attributes } 23 | 24 | -- Ok, you have a Player type. Now before you can use it in your game, 25 | -- make it an instance of MovieClip. You can do this automatically with 26 | -- `deriveMC`: 27 | deriveMC ''Player 28 | 29 | -- Now that the player is a MovieClip, you can write code like this: 30 | -- 31 | -- > player.x += 10 32 | -- 33 | -- and the player will move 10 pixels to the right! 34 | -- More on this later. 35 | 36 | -- You also need a data type that will be the game state. 37 | data GameState = GameState { 38 | _player :: Player, 39 | _ga :: Attributes 40 | } 41 | 42 | -- Use this convenience function to make MovieClip instances 43 | -- for your data types automatically. 44 | deriveMC ''GameState 45 | 46 | -- Next, I suggest you make lenses for all of your data types. 47 | -- If you don't know how lenses work, check out the intro README here: 48 | -- https://github.com/ekmett/lens 49 | -- 50 | -- and this tutorial: 51 | -- https://www.fpcomplete.com/school/to-infinity-and-beyond/pick-of-the-week/basic-lensing 52 | -- 53 | -- Lenses are great for working with nested data structures, and writing 54 | -- functional code that looks imperative. Both are big plusses for game 55 | -- development. 56 | -- So this step is optional, but recommended. 57 | makeLenses ''Player 58 | makeLenses ''GameState 59 | 60 | -- Finally, you need to make both Player and GameState 61 | -- instances of Renderable. This defines how they will be shown on the 62 | -- screen. 63 | -- 64 | -- The `render` function returns a Gloss Picture: 65 | -- 66 | -- http://hackage.haskell.org/package/gloss-1.8.2.2/docs/Graphics-Gloss-Data-Picture.html 67 | 68 | instance Renderable Player where 69 | render p = color blue $ box 50 50 70 | 71 | -- Here we are just rendering the player as a blue box. With ActionKid, 72 | -- you can also use an image from your computer instead: 73 | -- 74 | -- > render p = image "images/player.png" 75 | 76 | -- To render the game state, we just render the player. 77 | -- To do that, use the `display` function. `display` will render 78 | -- the player at the right x and y coordinates. 79 | instance Renderable GameState where 80 | render gs = display (_player gs) 81 | 82 | -- If the game state has multiple items, you can render them all by 83 | -- concatenating them: 84 | -- 85 | -- > render gs = display (_player1 gs) <> display (_player2 gs) 86 | 87 | -- this is the default game state. The player starts at coordinates (0,0) 88 | -- (the bottom left of the screen). 89 | -- NOTE: For the `Attributes` field, you can just use `def`. This will set 90 | -- the correct default attributes for an object. 91 | -- 92 | -- So this creates the game state with a player in it. Both have default 93 | -- attributes. 94 | gameState = (GameState (Player def) def) 95 | 96 | -- All of the core game logic takes place in this monad transformer stack. 97 | -- The State is the default game state we just made. 98 | type GameMonad a = StateT GameState IO a 99 | 100 | -------------------------------------------------------------------------- 101 | -------------------------------------------------------------------------- 102 | -- Ok, now we are done specifying all the data types and how they should 103 | -- look! Now it's time to implement the core game logic. There are two 104 | -- functions you need to define: 105 | -- 106 | -- 1. An event handler (for key presses/mouse clicks) 107 | -- 2. A game loop. 108 | -- 109 | -- The event handler listens for user input, and moves the player etc. 110 | -- The game loop is where the rest of the logic happens: firing bullets, 111 | -- hitting an enemy, animations etc etc. 112 | -------------------------------------------------------------------------- 113 | -------------------------------------------------------------------------- 114 | 115 | -- This is the event handler. Since we are using lenses, this logic is 116 | -- really easy to write. 117 | eventHandler :: Event -> GameMonad () 118 | eventHandler (EventKey (SpecialKey KeyLeft) Down _ _) = player.x -= 10 119 | eventHandler (EventKey (SpecialKey KeyRight) Down _ _) = player.x += 10 120 | eventHandler (EventKey (SpecialKey KeyUp) Down _ _) = player.y += 10 121 | eventHandler (EventKey (SpecialKey KeyDown) Down _ _) = player.y -= 10 122 | eventHandler _ = return () 123 | 124 | -- This is the main loop. It does nothing right now. 125 | mainLoop :: Float -> GameMonad () 126 | mainLoop _ = return () 127 | 128 | -- Now lets run the game! The run function takes: 129 | -- 1. the title for the window of the game 130 | -- 2. the size of the window 131 | -- 3. the initial game state 132 | -- 4. the eventHandler function 133 | -- 5. the main loop function 134 | main = run "demo game" (500, 500) gameState eventHandler mainLoop 135 | -------------------------------------------------------------------------------- /src/ActionKid/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -- | Each game has several objects. For example, Mario has Mario, goombas, 3 | -- mushrooms etc. In ActionKid terminology, an object is called 4 | -- a `MovieClip`. To use one of your data types in a game, it needs to be 5 | -- an instance of two typeclasses `MovieClip` and `Renderable`. 6 | -- 7 | -- The `MovieClip` class does the book-keeping for an object. What are it's 8 | -- x and y position? scale? visibility? 9 | -- 10 | -- The `Renderable` class defines how your object will be rendered on 11 | -- screen. 12 | -- 13 | -- A `MovieClip` has several `Attributes`: x and y position, x and y scale, etc. So when you create a data type, the last 14 | -- field needs to be of type `Attributes`: 15 | -- 16 | -- > data Player = Player { _name :: String, _attrs :: Attributes } 17 | -- 18 | -- Then, ActionKid takes care of rendering the player on screen correctly. 19 | -- So you can write code like this: 20 | -- 21 | -- > player.x += 10 22 | -- 23 | -- And that updates the x field on the player's attributes. Then ActionKid will 24 | -- make sure the player's position gets updated on-screen. 25 | 26 | module ActionKid.Types where 27 | import Graphics.Gloss.Interface.IO.Game 28 | import ActionKid.Utils 29 | import ActionKid.Globals 30 | import Data.StateVar 31 | import Control.Monad hiding (join) 32 | import Control.Lens 33 | import System.IO.Unsafe 34 | import qualified Debug.Trace as D 35 | 36 | -- | Attributes that get added to each MovieClip. 37 | -- You won't use them raw, like this. Instead, each 38 | -- movieclip can access these attributes through lenses. 39 | data Attributes = Attributes { 40 | -- | x position 41 | _ax :: Float, 42 | -- | y position 43 | _ay :: Float, 44 | -- | scale 45 | _ascaleX :: Float, 46 | _ascaleY :: Float, 47 | -- | visibility 48 | _avisible :: Bool, 49 | -- | when this gets drawn. Note: unless you use 50 | -- the `displayAll` function, you have to handle 51 | -- zindex yourself! 52 | _azindex :: Int 53 | } deriving (Show, Eq) 54 | 55 | makeLenses ''Attributes 56 | 57 | -- | default Attributes. 58 | -- Every `MovieClip` will have `Attributes` has it's last field. 59 | -- When you create an instance of that movieclip, use the `def` function 60 | -- to specify default attributes. Example: suppose you have a data type 61 | -- like so: 62 | -- 63 | -- > data Player = Player { _name :: String, _attrs :: Attributes } 64 | -- 65 | -- You can instantiate a player like this: 66 | -- 67 | -- > adit = Player "adit" def 68 | -- 69 | -- Note that you don't need to specify x or y coordinates for the player... 70 | -- that's what the attributes are for. 71 | def = Attributes 0.0 0.0 1.0 1.0 True 1 72 | 73 | -- | Make your data type an instance of this class. 74 | -- For example, suppose you have a data type like this: 75 | -- 76 | -- > data Tile = Tile { _tileAttrs :: Attributes, _tileColor :: Color } 77 | -- 78 | -- Before you can use Tile in a game, it needs to be an instance of 79 | -- `MovieClip`. You can use `deriveMC` to do this automatically using 80 | -- TemplateHaskell: 81 | -- 82 | -- > deriveMC ''Tile 83 | -- 84 | -- Or write it yourself: https:\/\/gist.github.com\/egonSchiele\/e692421048cbd79acb26 85 | class MovieClip a where 86 | -- | your data type needs to have a field for attributes. 87 | -- This is a lens for that field. For example, in our above example 88 | -- of a player, you can get the player's attributes like this: 89 | -- 90 | -- > player ^. attrs 91 | -- 92 | -- You can also use the rest of the following lenses on the player: 93 | -- 94 | -- Get a player's position with: 95 | -- 96 | -- > player ^. x 97 | -- 98 | -- Set a player's position with: 99 | -- 100 | -- > x .~ 10 $ player 101 | -- 102 | -- The lens library gives you all kinds of pretty syntax for this 103 | -- stuff. 104 | attrs :: Lens a a Attributes Attributes 105 | 106 | x :: Lens a a Float Float 107 | x = lens (view $ attrs . ax) (flip $ set (attrs . ax)) 108 | 109 | y :: Lens a a Float Float 110 | y = lens (view $ attrs . ay) (flip $ set (attrs . ay)) 111 | 112 | scaleX :: Lens a a Float Float 113 | scaleX = lens (view $ attrs . ascaleX) (flip $ set (attrs . ascaleX)) 114 | 115 | scaleY :: Lens a a Float Float 116 | scaleY = lens (view $ attrs . ascaleY) (flip $ set (attrs . ascaleY)) 117 | 118 | visible :: Lens a a Bool Bool 119 | visible = lens (view $ attrs . avisible) (flip $ set (attrs . avisible)) 120 | 121 | zindex :: Lens a a Int Int 122 | zindex = lens (view $ attrs . azindex) (flip $ set (attrs . azindex)) 123 | 124 | -- | Before you can use your data type in a game, it also needs to be an 125 | -- instance of `Renderable`. This class defines how your data type will 126 | -- look on the screen. 127 | class MovieClip a => Renderable a where 128 | -- | Implement this method to tell ActionKid how to render your data 129 | -- type. Returns an instance of Picture (from the Gloss package). 130 | -- Example: 131 | -- 132 | -- > render tile = color blue $ circle 5 133 | render :: a -> Picture 134 | -- | This is the internal function that positions the MovieClip 135 | -- correctly, checks if it is visible, etc etc. 136 | -- DO NOT IMPLEMENT! 137 | display :: a -> Picture 138 | display mc 139 | | mc ^. visible = translate (mc ^. x) (mc ^. y) $ 140 | scale (mc ^. scaleX) (mc ^. scaleY) $ 141 | render mc 142 | | otherwise = D.trace "not rendering invisible movieclip" blank 143 | -------------------------------------------------------------------------------- /src/ActionKid/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module ActionKid.Core where 5 | import ActionKid.Globals 6 | import ActionKid.Internal 7 | import ActionKid.Types 8 | import ActionKid.Utils 9 | import Control.Applicative 10 | import Control.Concurrent 11 | import Control.Lens 12 | import Control.Monad 13 | import Control.Monad 14 | import Control.Monad.Fix 15 | import Control.Monad.State 16 | import Data.IORef 17 | import Data.List 18 | import qualified Data.Map as M 19 | import Data.Maybe 20 | import Data.Monoid (mconcat, (<>)) 21 | import Data.Ord 22 | import qualified Debug.Trace as D 23 | import Foreign.ForeignPtr 24 | import Graphics.Gloss hiding (display) 25 | import Graphics.Gloss.Interface.IO.Game 26 | import Graphics.Gloss.Juicy 27 | import Language.Haskell.TH 28 | import System.IO.Unsafe 29 | import Text.Printf 30 | 31 | -- | (Currently disabled) Given a path to an audio file, plays the file. 32 | playSound :: String -> Bool -> IO () 33 | playSound src loopSound = return () 34 | -- Needs some love...either SDL is buggy or I don't understand it... 35 | -- playSound src loopSound = do 36 | -- let audioRate = 22050 37 | -- audioFormat = Mix.AudioS16LSB 38 | -- audioChannels = 2 39 | -- audioBuffers = 4096 40 | -- anyChannel = (-1) 41 | 42 | -- forkOS $ do 43 | -- -- Don't ask why this is needed. If it isn't there, somehow 44 | -- -- this audio thread blocks all other execution, and you can't 45 | -- -- do anything else. But introducing it somehow prevents that. 46 | -- -- WTF. 47 | -- threadDelay 5000 48 | -- SDL.init [SDL.InitAudio] 49 | -- result <- openAudio audioRate audioFormat audioChannels audioBuffers 50 | -- audioData <- Mix.loadWAV src 51 | -- Mix.playChannel anyChannel audioData 0 52 | -- fix $ \loop -> do 53 | -- touchForeignPtr audioData 54 | -- threadDelay 500000 55 | -- stillPlaying <- numChannelsPlaying 56 | -- when (stillPlaying /= 0) loop 57 | -- Mix.closeAudio 58 | -- SDL.quit 59 | -- when loopSound $ 60 | -- playSound src loopSound 61 | -- return () 62 | -- return () 63 | 64 | -- cacheImage src pic = unsafePerformIO $ do 65 | -- modifyIORef' imageCache (\cache -> D.trace ("caching: " ++ src) $ M.insert src pic cache) 66 | -- cache <- readIORef imageCache 67 | -- putStrLn $ "new cache is: " ++ (show cache) 68 | -- return pic 69 | 70 | -- | Given a path, loads the image and returns it as a picture. It performs 71 | -- caching, so if the same path has been given before, it will just return 72 | -- the image from the cache. 73 | image :: String -> Picture 74 | image src = unsafePerformIO $ do 75 | pic_ <- loadJuicy src 76 | case pic_ of 77 | Nothing -> error $ "didn't find an image at " ++ src 78 | Just pic@(Bitmap w h _ _) -> do 79 | let x = fromIntegral w / 2 80 | y = fromIntegral h / 2 81 | newPic = translate x y pic 82 | cache <- readIORef imageCache 83 | case M.lookup src cache of 84 | Nothing -> do 85 | modifyIORef' imageCache (M.insert src newPic) 86 | return newPic 87 | Just cachedPic -> do 88 | return cachedPic 89 | 90 | {-# NOINLINE image #-} 91 | 92 | -- This will eventually be a function that takes a tile map png or jpg and 93 | -- cuts it up into the individual tiles and returns them as a 2-d array. 94 | -- http://hackage.haskell.org/package/vector-0.5/docs/Data-Vector-Unboxed.html 95 | -- http://www.haskell.org/haskellwiki/Numeric_Haskell:_A_Vector_Tutorial#Indexing_vectors 96 | -- http://www.haskell.org/haskellwiki/Numeric_Haskell:_A_Repa_Tutorial#Indexing_arrays 97 | -- http://hackage.haskell.org/package/repa-3.2.3.3/docs/Data-Array-Repa.html#t:Array 98 | -- loadTileMap :: String -> Int -> Int -> [[Picture]] 99 | -- loadTileMap src w h = 100 | -- where image = (fromRight . unsafePerformIO . readImage $ src) :: Img RGBA 101 | -- vec = toUnboxed image 102 | 103 | -- > :t vec 104 | -- vec :: U.Vector GHC.Word.Word8 105 | -- 106 | -- vec U.! 14 => gives you a number (word8) 107 | -- U.length vec == 4096 (4 channels, RGBA, so really 1024...and it's 108 | -- a 32x32 image. 32x32 = 1024). 109 | 110 | 111 | -- | Convenience function to make `MovieClip` instances for your data types. 112 | -- Suppose you have a data type like so: 113 | -- 114 | -- > data Tile = Empty { _ea :: Attributes } | Wall { _wa :: Attributes } | Chip { _ca :: Attributes } 115 | -- 116 | -- Just call: 117 | -- 118 | -- > deriveMC ''Tile 119 | -- 120 | -- Or you can write your instance by hand if you want. Something like this: 121 | -- https:\/\/gist.github.com\/egonSchiele\/e692421048cbd79acb26 122 | deriveMC :: Name -> Q [Dec] 123 | deriveMC name = do 124 | TyConI (DataD _ _ _ records _) <- reify name 125 | 126 | -- The following answers helped a lot: 127 | -- http://stackoverflow.com/questions/8469044/template-haskell-with-record-field-name-as-variable 128 | -- http://stackoverflow.com/questions/23400203/multiple-function-definitions-with-template-haskell 129 | [d|instance MovieClip $(conT name) where 130 | attrs = lens viewer mutator 131 | where viewer = $(mkViewer records) 132 | mutator = $(mkMutator records)|] 133 | 134 | -- | Used internally. Generates something like \mc -> case mc of ... 135 | mkViewer :: [Con] -> Q Exp 136 | mkViewer records = return $ LamE [VarP mc] (CaseE (VarE mc) $ map (mkMatch mc) records) 137 | where mc = mkName "mc" 138 | 139 | -- | Used internally. Generates something like \mc new -> case mc of ... 140 | mkMutator :: [Con] -> Q Exp 141 | mkMutator records = return $ LamE [VarP mc, VarP new] (CaseE (VarE mc) $ map (mkMutatorMatch mc new) records) 142 | where mc = mkName "mc" 143 | new = mkName "new" 144 | 145 | -- | Used internally by the `mkViewer` function to make all the cases 146 | mkMatch :: Name -> Con -> Match 147 | mkMatch mc (RecC n fields) = Match (ConP n (take (length fields) $ repeat WildP)) (NormalB body) [] 148 | where lastField = last $ map (\(name,_,_) -> name) fields 149 | body = AppE (VarE lastField) (VarE mc) 150 | 151 | -- THis works with data types without names for fields, but mkMutatorMatch 152 | -- doesn't work yet 153 | mkMatch mc (NormalC n fields) = Match (ConP n ((take ((length fields) - 1) $ repeat WildP) ++ [VarP mcAttrs])) (NormalB $ VarE mcAttrs) [] 154 | where mcAttrs = mkName "mcAttrs" 155 | 156 | -- | Used internally by the `mkMutator` function to make all the cases 157 | mkMutatorMatch :: Name -> Name -> Con -> Match 158 | mkMutatorMatch mc new (RecC n fields) = Match (ConP n (take (length fields) $ repeat WildP)) (NormalB body) [] 159 | where lastField = last $ map (\(name,_,_) -> name) fields 160 | body = RecUpdE (VarE mc) [(lastField, VarE new)] 161 | 162 | mkMutatorMatch mc new (NormalC n fields) = Match (ConP n (take (length fields) $ repeat WildP)) (NormalB body) [] 163 | where lastField = last $ map fst fields 164 | body = AppE (ConE n) (VarE new) -- NOTE: this only works for data types with only one attribute: Attributes. Like `data Color = Red Attributes`. Make it work for more than one. 165 | 166 | -- | Given a 2d array, returns a array of movieclips that make up a 167 | -- grid of tiles. Takes: 168 | -- 169 | -- 1. A 2d array of ints 170 | -- 171 | -- 2. A function that takes an int and returns the related `MovieClip` 172 | -- 173 | -- 3. (width, height) for the tiles in pixels 174 | renderTileMap :: MovieClip a => [[Int]] -> (Int -> a) -> (Int, Int) -> [a] 175 | renderTileMap tileMap f (w,h) = 176 | concat $ forWithIndex tileMap $ \(row, j) -> 177 | forWithIndex row $ \(tile, i) -> 178 | withMC (f tile) $ do 179 | x .= (fromIntegral $ i*w) 180 | y .= (fromIntegral $ boardH - h - j*h) 181 | 182 | where boardH = (*h) . length $ tileMap 183 | 184 | -- | Check if one `MovieClip` is hitting another. Example: 185 | -- 186 | -- > when player `hits` enemy $ die 187 | hits :: Renderable a => a -> a -> Bool 188 | hits a b = f a `intersects` f b 189 | where f = boundingBox . display 190 | 191 | -- | Call this to run your game. Takes: 192 | -- 193 | -- 1. Window title 194 | -- 195 | -- 2. (width, height) of window 196 | -- 197 | -- 3. Game state (a `MovieClip`) 198 | -- 199 | -- 4. an event handler function (for handling user input) 200 | -- 201 | -- 5. a function that keeps getting called in a loop (the main game loop) 202 | run :: (MovieClip a, Renderable a) => String -> (Int, Int) -> a -> (Event -> StateT a IO ()) -> (Float -> StateT a IO ()) -> IO () 203 | run title (w,h) state keyHandler stepFunc = do 204 | let boardWidth = setRef w 205 | let boardHeight = setRef h 206 | playIO 207 | (InWindow title (w,h) (1, 1)) 208 | white 209 | 30 210 | state 211 | draw 212 | (\k gs -> execStateT (keyHandler k) gs) 213 | (\i gs -> execStateT (stepFunc i) gs) 214 | 215 | 216 | -- | Convenience function. Given a list of movie clips, 217 | -- displays all of them. 218 | -- TODO support zindex. 219 | displayAll :: Renderable a => [a] -> Picture 220 | displayAll mcs = Pictures $ map display mcs 221 | --------------------------------------------------------------------------------