├── .gitignore ├── README.md ├── cabal.project ├── reactimate-game ├── CHANGELOG.md ├── LICENSE ├── README.md ├── bench │ └── Main.hs ├── examples │ ├── basic-example │ │ └── Main.hs │ ├── image-example │ │ ├── Main.hs │ │ └── marbles.jpg │ ├── mouse-example │ │ └── Main.hs │ └── snake-example │ │ └── Main.hs ├── reactimate-game.cabal ├── screenshot.png ├── src │ └── Reactimate │ │ ├── Game.hs │ │ └── Game │ │ ├── Assets.hs │ │ ├── Environment.hs │ │ ├── Graphics.hs │ │ ├── Input.hs │ │ ├── Projection2D.hs │ │ ├── Setup.hs │ │ ├── Shapes.hs │ │ └── Tasks.hs └── test │ └── Main.hs ├── reactimate-ldtk ├── CHANGELOG.md ├── LICENSE ├── README.md ├── examples │ └── basic-example │ │ ├── Main.hs │ │ └── basic-examples.ldtk ├── reactimate-ldtk.cabal └── src │ └── Reactimate │ └── LDtk.hs ├── reactimate-physics ├── CHANGELOG.md ├── LICENSE ├── README.md ├── examples │ ├── basic-example │ │ └── Main.hs │ ├── collision-example │ │ └── Main.hs │ └── subspaces-example │ │ └── Main.hs ├── reactimate-physics.cabal ├── screenshot.png ├── src │ └── Reactimate │ │ └── Physics2D.hs └── test │ └── Main.hs └── reactimate ├── CHANGELOG.md ├── LICENSE ├── README.md ├── bench └── Main.hs ├── reactimate.cabal └── src ├── Reactimate.hs └── Reactimate ├── Basic.hs ├── Delay.hs ├── Event.hs ├── Random.hs ├── Run.hs ├── Sampling.hs ├── Setup.hs ├── Signal.hs ├── Stateful.hs ├── Switching.hs └── Time.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle 2 | scratch 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Reactimate 2 | 3 | [reactimate](reactimate) is a library implementing the AFRP paradigm. In contrast to other libraries, `reactimate` uses `IO` effects to increase performance and a concrete base type to eliminate typeclass performance problems. 4 | In addition, `reactimate` has some support for pull-based FRP, making it possible to deal with events which happen in-between simulation cycles. 5 | 6 | # Reactimate Game 7 | 8 | [reactimate-game](reactimate-game) is a library for basic 2D games using `SDL`. 9 | 10 | ![reactimate-games examples](reactimate-game/screenshot.png) 11 | 12 | # Reactimate Physics 13 | 14 | [reactimate-physics](reactimate-physics) provides bindings to the `chipmunk` 2D physics library. 15 | 16 | # Reactimate LDtk 17 | 18 | [reactimate-ldtk](reactimate-ldtk) provides loading functionality for LDtk level files. 19 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: reactimate, reactimate-game, reactimate-ldtk, reactimate-physics 2 | 3 | allow-newer: hashable 4 | -------------------------------------------------------------------------------- /reactimate-game/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for reactimate-game 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /reactimate-game/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2024, Simre1 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Simre1 nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /reactimate-game/README.md: -------------------------------------------------------------------------------- 1 | # Reactimate Game 2 | 3 | `reactimate-game` is a library for `reactimate` which implements some common functionality for simple 2D games. 4 | 5 | ## Examples 6 | 7 | There are some examples in the `examples` folder. Check them out for a quickstart into the library. 8 | 9 | ## Rendering 10 | 11 | Rendering is done with the `render` signal which renders the given `Picture` with the `Camera` to the screen. The following example renders a red rectangle in the bottom left corner of the screen. 12 | ```haskell 13 | import Reactimate 14 | import Reactimate.Game 15 | import qualified Data.Vector.Storable as VS 16 | import Data.Colour.Names 17 | 18 | main :: IO () 19 | main = 20 | reactimate $ 21 | limitSampleRate 60 $ 22 | setupGame (GameConfig "Basic Example" defaultWindow) $ \gameEnv -> 23 | constant (Camera (V2 0 0) (V2 800 600), picture) >>> render gameEnv >>> constant Nothing 24 | 25 | picture :: Picture 26 | picture = makePicture 0 $ drawRectangle (packColour red) $ Rectangle (V2 0 0) (V2 500 300) 27 | ``` 28 | 29 | ## Reactimate Game Examples 30 | 31 | 32 | ![reactimate-game examples](screenshot.png) 33 | -------------------------------------------------------------------------------- /reactimate-game/bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Data.Vector.Storable qualified as VS 6 | import Gauge (Config (timeLimit)) 7 | import Gauge.Main 8 | import Gauge.Main.Options (defaultConfig) 9 | import Reactimate 10 | import Reactimate.Game 11 | import Data.Colour.Names 12 | import Control.Monad (forM_) 13 | 14 | renderRectangles :: GameEnv -> Signal Int () 15 | renderRectangles gameEnv = constant (camera, picture) >>> renderGame gameEnv 16 | where 17 | rectsAmount = 1000 18 | camera = Camera (V2 0 300) (V2 rectsAmount 20) 19 | picture = makePicture 0 $ forM_ [1..rectsAmount] $ \x -> 20 | drawRectangle (packColour black) $ Rectangle (V2 x 300) (V2 10 10) 21 | 22 | main :: IO () 23 | main = do 24 | defaultMainWith 25 | defaultConfig {timeLimit = Just 10} 26 | [ bench "Render rectangles" $ 27 | nfIO $ 28 | sample (setupGame (GameConfig "Bench" defaultWindow maxBound) renderRectangles) [0 .. 360] 29 | ] 30 | -------------------------------------------------------------------------------- /reactimate-game/examples/basic-example/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Control.Arrow 6 | import Data.Bool (bool) 7 | import Data.Colour.Names 8 | import Reactimate 9 | import Reactimate.Game 10 | import Reactimate.Stateful (sumUp) 11 | 12 | main :: IO () 13 | main = 14 | reactimate $ 15 | setupGame (GameConfig "Basic Example" defaultWindow 60) $ \gameEnv -> 16 | game >>> renderGame gameEnv >>> bool Nothing (Just ()) <$> sampleBehavior (gameShouldQuit gameEnv) 17 | 18 | game :: Signal () (Camera, Picture) 19 | game = constant 0.01 >>> sumUp >>> arr (\x -> (camera, shapes x)) 20 | 21 | shapes :: Float -> Picture 22 | shapes x = 23 | translatePicture (V2 400 300) $ 24 | rotatePicture (2 * pi * x) $ 25 | makePicture 0 $ do 26 | drawRectangle (packColour red) $ 27 | Rectangle (V2 (-50) (-50)) (V2 100 100) 28 | drawRectangle (packColour blue) $ 29 | Rectangle (V2 200 (-50)) (V2 100 100) 30 | 31 | camera :: Camera 32 | camera = Camera (V2 0 0) (V2 800 600) 33 | -------------------------------------------------------------------------------- /reactimate-game/examples/image-example/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.Text (Text, pack) 2 | import Reactimate 3 | import Reactimate.Game 4 | import Reactimate.Stateful (sumUp) 5 | import System.Environment (getArgs) 6 | 7 | main :: IO () 8 | main = do 9 | args <- getArgs 10 | case args of 11 | [imagePath] -> 12 | reactimate $ 13 | setupGame (GameConfig (pack "Image Example") defaultWindow 60) $ \gameEnv -> 14 | game gameEnv (pack imagePath) >>> renderGame gameEnv >>> constant Nothing 15 | _ -> putStrLn "Run this example with the image path as the argument" 16 | pure () 17 | 18 | game :: GameEnv -> Text -> Signal () (Camera, Picture) 19 | game gameEnv imagePath = withImage gameEnv imagePath $ \image -> 20 | constant 0.01 21 | >>> sumUp 22 | >>> arr 23 | ( \x -> 24 | ( camera, 25 | picture image x 26 | ) 27 | ) 28 | where 29 | picture image x = 30 | translatePicture (V2 400 300) $ 31 | rotatePicture x $ 32 | makePicture 0 $ 33 | blitImage [Blit (Rectangle (V2 0 0) image.size) (Rectangle (V2 (-200) (-150)) (V2 400 300))] image 34 | 35 | camera :: Camera 36 | camera = Camera (V2 0 0) (V2 800 600) 37 | -------------------------------------------------------------------------------- /reactimate-game/examples/image-example/marbles.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Simre1/reactimate/5f25cf93bc1fc62c069876fb0881b1b1e52c0ad9/reactimate-game/examples/image-example/marbles.jpg -------------------------------------------------------------------------------- /reactimate-game/examples/mouse-example/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | import Data.Bool (bool) 5 | import Data.Colour.Names 6 | import Data.Vector.Storable qualified as VS 7 | import Reactimate 8 | import Reactimate.Game 9 | 10 | main :: IO () 11 | main = reactimate $ setupGame (GameConfig "Mouse example" defaultWindow 60) $ \gameEnv -> 12 | constant camera 13 | >>> mousePosition gameEnv 14 | >>> game 15 | >>> renderGame gameEnv 16 | >>> bool Nothing (Just ()) 17 | <$> sampleBehavior (gameShouldQuit gameEnv) 18 | 19 | camera :: Camera 20 | camera = Camera (V2 0 0) (V2 800 600) 21 | 22 | picture :: V2 Int -> Picture 23 | picture pos = 24 | makePicture 0 $ 25 | drawRectangle (packColour blue) $ Rectangle pos (V2 100 100) 26 | 27 | game :: Signal (V2 Int) (Camera, Picture) 28 | game = arr $ \pos -> (camera, picture pos) 29 | -------------------------------------------------------------------------------- /reactimate-game/examples/snake-example/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | import Data.Colour.Names (red) 5 | import Data.Colour.SRGB (sRGB24) 6 | import Data.Foldable (toList) 7 | import Data.List (group) 8 | import Data.Vector.Storable qualified as VS 9 | import Reactimate 10 | import Reactimate.Game 11 | import SDL qualified 12 | import Control.Monad 13 | 14 | gameConfig :: GameConfig 15 | gameConfig = 16 | GameConfig 17 | { name = "Snake", 18 | window = defaultWindow {windowInitialSize = fromIntegral . (* 30) <$> gameBounds}, 19 | fps = 11 20 | } 21 | 22 | main :: IO () 23 | main = reactimate $ setupGame gameConfig $ \gameEnv -> 24 | captureInput gameEnv >>> (feedback initialGameState stepGame >>> render gameEnv) &&& shouldQuit >>> arr snd 25 | 26 | data Input = MoveLeft | MoveRight | MoveUp | MoveDown | NoAction | Quit deriving (Eq, Ord, Show) 27 | 28 | data GameState = GameState 29 | { snake :: [V2 Int], 30 | direction :: V2 Int, 31 | food :: Maybe (V2 Int), 32 | running :: Bool, 33 | score :: Int 34 | } 35 | 36 | captureInput :: GameEnv -> Signal () Input 37 | captureInput gameEnv = 38 | sampleEvent collectInput [] (inputEvents gameEnv) 39 | >>> feedback [] (arr $ \(newActions, oldActions) -> fmap head $ group $ drop 1 oldActions ++ newActions) 40 | >>> arr 41 | ( \case 42 | (i : _) -> i 43 | [] -> NoAction 44 | ) 45 | where 46 | collectInput [Quit] _ = [Quit] 47 | collectInput is event = case SDL.eventPayload event of 48 | SDL.QuitEvent -> [Quit] 49 | SDL.KeyboardEvent keyboardEvent -> 50 | if SDL.keyboardEventKeyMotion keyboardEvent == SDL.Pressed 51 | then case SDL.keysymScancode $ SDL.keyboardEventKeysym keyboardEvent of 52 | SDL.ScancodeLeft -> is ++ [MoveLeft] 53 | SDL.ScancodeRight -> is ++ [MoveRight] 54 | SDL.ScancodeUp -> is ++ [MoveUp] 55 | SDL.ScancodeDown -> is ++ [MoveDown] 56 | _ -> is 57 | else is 58 | _ -> is 59 | 60 | initialGameState :: GameState 61 | initialGameState = 62 | GameState 63 | { snake = [V2 5 5], 64 | direction = V2 1 0, 65 | food = Just (V2 10 10), 66 | running = False, 67 | score = 0 68 | } 69 | 70 | gameBounds :: V2 Int 71 | gameBounds = V2 32 18 72 | 73 | stepGame :: Signal (Input, GameState) GameState 74 | stepGame = 75 | generateRandomRange (V2 1 1, gameBounds - V2 2 2) 76 | &&& identity 77 | >>> arrIO 78 | ( \(rngV2, (input, GameState snake direction food running score)) -> 79 | if running 80 | then 81 | let nextDirection = adaptDirection input direction 82 | nextHead = nextDirection + head snake 83 | snakeEats = Just nextHead == food 84 | nextSnake = 85 | if snakeEats || length snake == 1 86 | then nextHead : snake 87 | else nextHead : init snake 88 | nextFood = if snakeEats then Just rngV2 else food 89 | nextScore = if snakeEats then score + 1 else score 90 | in if isDead nextSnake 91 | then do 92 | putStrLn $ "Score: " ++ show score 93 | pure $ GameState nextSnake nextDirection nextFood False nextScore 94 | else pure $ GameState nextSnake nextDirection nextFood True nextScore 95 | else 96 | if shouldStartGame input 97 | then pure $ initialGameState {running = True} 98 | else pure $ GameState snake direction food False score 99 | ) 100 | where 101 | shouldStartGame i = case i of 102 | MoveLeft -> True 103 | MoveRight -> True 104 | MoveUp -> True 105 | MoveDown -> True 106 | _ -> False 107 | isDead snake = 108 | let snakeHead@(V2 x y) = head snake 109 | (V2 maxX maxY) = gameBounds 110 | in snakeHead `elem` tail snake || x < 0 || x >= maxX || y < 0 || y >= maxY 111 | adaptDirection i d = 112 | let wantedDirection = case i of 113 | MoveLeft -> V2 (-1) 0 114 | MoveRight -> V2 1 0 115 | MoveUp -> V2 0 1 116 | MoveDown -> V2 0 (-1) 117 | _ -> d 118 | in if wantedDirection + d == V2 0 0 then d else wantedDirection 119 | 120 | render :: GameEnv -> Signal GameState () 121 | render gameEnv = arr (\gs -> (camera, gameStatePicture gs)) >>> renderGame gameEnv 122 | where 123 | gameStatePicture (GameState snake _ food _ _) = makePicture 0 $ do 124 | zipWithM_ snakeShape [0 ..] snake 125 | drawFood food 126 | snakeShape (i' :: Int) pos = do 127 | let i = fromIntegral $ abs $ (i' `mod` 160) - 80 128 | drawRectangle (packColour $ sRGB24 0 (255 - i * 2) (i * 3)) (Rectangle pos (V2 1 1)) 129 | drawFood = maybe mempty $ \pos -> drawRectangle (packColour red) (Rectangle pos (V2 1 1)) 130 | camera = Camera (V2 0 0) gameBounds 131 | 132 | shouldQuit :: Signal Input (Maybe ()) 133 | shouldQuit = arr $ \i -> if i == Quit then Just () else Nothing 134 | -------------------------------------------------------------------------------- /reactimate-game/reactimate-game.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: reactimate-game 3 | version: 0.1.0.0 4 | -- synopsis: 5 | -- description: 6 | license: BSD-3-Clause 7 | license-file: LICENSE 8 | author: Simre1 9 | maintainer: simre4775@gmail.com 10 | -- copyright: 11 | category: Game 12 | build-type: Simple 13 | extra-doc-files: CHANGELOG.md 14 | -- extra-source-files: 15 | -- data-files: shaders 16 | 17 | common common 18 | ghc-options: -Wall 19 | default-language: GHC2021 20 | default-extensions: 21 | OverloadedRecordDot 22 | DuplicateRecordFields 23 | LambdaCase 24 | build-depends: 25 | base ^>=4.17.2.1, 26 | vector, 27 | linear, 28 | text, 29 | colour, 30 | sdl2 31 | 32 | library 33 | import: common 34 | other-modules: Paths_reactimate_game 35 | autogen-modules: Paths_reactimate_game 36 | exposed-modules: 37 | Reactimate.Game, 38 | Reactimate.Game.Setup, 39 | Reactimate.Game.Graphics, 40 | Reactimate.Game.Projection2D, 41 | Reactimate.Game.Shapes, 42 | Reactimate.Game.Input, 43 | Reactimate.Game.Environment, 44 | Reactimate.Game.Assets, 45 | Reactimate.Game.Tasks, 46 | 47 | hs-source-dirs: src 48 | build-depends: 49 | sdl2-gfx, 50 | sdl2-image >= 2.1.0.0, 51 | containers, 52 | pqueue, 53 | reactimate, 54 | text, 55 | filepath, 56 | hashtables, 57 | hashable, 58 | transformers 59 | 60 | executable basic-example 61 | import: common 62 | main-is: Main.hs 63 | hs-source-dirs: examples/basic-example 64 | build-depends: 65 | reactimate, 66 | reactimate-game 67 | 68 | executable mouse-example 69 | import: common 70 | main-is: Main.hs 71 | hs-source-dirs: examples/mouse-example 72 | build-depends: 73 | reactimate, 74 | reactimate-game 75 | 76 | executable image-example 77 | import: common 78 | main-is: Main.hs 79 | hs-source-dirs: examples/image-example 80 | build-depends: 81 | reactimate, 82 | reactimate-game 83 | 84 | executable snake-example 85 | import: common 86 | main-is: Main.hs 87 | hs-source-dirs: examples/snake-example 88 | build-depends: 89 | reactimate, 90 | reactimate-game, 91 | containers 92 | 93 | executable bench 94 | import: common 95 | main-is: Main.hs 96 | hs-source-dirs: bench 97 | build-depends: 98 | reactimate, 99 | reactimate-game, 100 | gauge 101 | 102 | 103 | test-suite reactimate-game-test 104 | import: common 105 | type: exitcode-stdio-1.0 106 | hs-source-dirs: test 107 | main-is: Main.hs 108 | build-depends: 109 | reactimate-game 110 | -------------------------------------------------------------------------------- /reactimate-game/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Simre1/reactimate/5f25cf93bc1fc62c069876fb0881b1b1e52c0ad9/reactimate-game/screenshot.png -------------------------------------------------------------------------------- /reactimate-game/src/Reactimate/Game.hs: -------------------------------------------------------------------------------- 1 | module Reactimate.Game 2 | ( module Setup, 3 | module Environment, 4 | module Graphics, 5 | module Shapes, 6 | module Input, 7 | V2 (..), 8 | V4 (..), 9 | ) 10 | where 11 | 12 | import Linear 13 | import Reactimate.Game.Environment as Environment 14 | import Reactimate.Game.Graphics as Graphics 15 | import Reactimate.Game.Input as Input 16 | import Reactimate.Game.Setup as Setup 17 | import Reactimate.Game.Shapes as Shapes 18 | -------------------------------------------------------------------------------- /reactimate-game/src/Reactimate/Game/Assets.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Reactimate.Game.Assets (Assets, makeAssets, Asset (..), withAsset) where 5 | 6 | import Data.HashTable.IO qualified as H 7 | import Data.Hashable (Hashable) 8 | import Data.Proxy 9 | import GHC.Exts (Any) 10 | import Reactimate 11 | import System.Mem.Weak 12 | import Type.Reflection 13 | import Unsafe.Coerce 14 | 15 | -- | `Assets` holds references to your loaded assets (e.g. images) 16 | newtype Assets = Assets (H.LinearHashTable SomeTypeRep (AssetStore Any)) 17 | 18 | newtype AssetStore k = AssetStore (H.LinearHashTable k (Weak (AssetValue k))) 19 | 20 | makeAssets :: IO Assets 21 | makeAssets = Assets <$> H.new 22 | 23 | -- 24 | class (Hashable key, Typeable key) => Asset key where 25 | -- | The asset you want to load. The key determines the type of the asset. 26 | type AssetValue key 27 | -- | The environment you need for the asset loading. BEWARE that this environment must be the same if the `AssetKey` is the same! 28 | type AssetEnv key 29 | -- | Load an asset with the asset environment and the key. 30 | loadAsset :: AssetEnv key -> key -> IO (AssetValue key) 31 | -- | Free the asset after no one uses it anymore. This action might not run if the program exits. 32 | freeAsset :: key -> AssetValue key -> IO () 33 | 34 | getAssetStore :: forall key. (Asset key) => Assets -> IO (AssetStore key) 35 | getAssetStore (Assets assets) = do 36 | let typeKey = someTypeRep $ Proxy @key 37 | maybeAssetStore <- H.lookup assets typeKey 38 | case maybeAssetStore of 39 | Just assetStore -> pure $ unsafeCoerce assetStore 40 | Nothing -> do 41 | assetStore <- AssetStore <$> H.new 42 | H.insert assets typeKey $ unsafeCoerce assetStore 43 | pure assetStore 44 | 45 | lookupAsset :: (Asset key) => Assets -> key -> IO (Maybe (AssetValue key)) 46 | lookupAsset assets key = do 47 | AssetStore assetStore <- getAssetStore assets 48 | maybeWeakAsset <- H.lookup assetStore key 49 | case maybeWeakAsset of 50 | Just weakAsset -> deRefWeak weakAsset 51 | Nothing -> pure Nothing 52 | 53 | insertAsset :: (Asset key) => Assets -> key -> AssetValue key -> IO () 54 | insertAsset assets key value = do 55 | (AssetStore assetStore) <- getAssetStore assets 56 | weakAsset <- mkWeakPtr value (Just $ freeAsset key value) 57 | H.insert assetStore key weakAsset 58 | 59 | -- | Load an asset during the `setup` phase. Getting the same asset with the same 60 | -- key multiple times only loads the asset once and reuses it. 61 | withAsset :: forall key a b. (Asset key) => Assets -> AssetEnv key -> key -> (AssetValue key -> Signal a b) -> Signal a b 62 | withAsset assets env key = withSetup $ do 63 | maybeAssetValue <- lookupAsset assets key 64 | case maybeAssetValue of 65 | Just asset -> pure asset 66 | Nothing -> do 67 | asset <- loadAsset env key 68 | insertAsset assets key asset 69 | pure asset 70 | 71 | -- An `AssetHandle` is a reference to an asset. An `AssetHandle` may change its referenced asset. For example, 72 | -- an asset might be loaded asynchronically, replacing the default asset with the loaded asset. 73 | -- newtype AssetHandle a = AssetHandle (IO a) deriving (Functor, Applicative, Monad, Semigroup, Monoid) 74 | -------------------------------------------------------------------------------- /reactimate-game/src/Reactimate/Game/Environment.hs: -------------------------------------------------------------------------------- 1 | module Reactimate.Game.Environment (GameEnv (..)) where 2 | 3 | import Reactimate.Game.Assets (Assets) 4 | import SDL qualified 5 | import Reactimate.Time (Time) 6 | 7 | data GameEnv = GameEnv 8 | { window :: !SDL.Window, 9 | renderer :: !SDL.Renderer, 10 | assets :: !Assets, 11 | time :: !Time 12 | } 13 | -------------------------------------------------------------------------------- /reactimate-game/src/Reactimate/Game/Graphics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Reactimate.Game.Graphics 5 | ( renderGame, 6 | Camera (..), 7 | 8 | -- * Picture 9 | Picture, 10 | makePicture, 11 | staticPicture, 12 | 13 | -- ** Image projections 14 | translatePicture, 15 | rotatePicture, 16 | projectPicture, 17 | 18 | -- * Rendering 19 | drawRectangle, 20 | drawPolygon, 21 | blitImage, 22 | Blit (..), 23 | 24 | -- ** Colours 25 | packColour, 26 | Colour, 27 | packAlphaColour, 28 | AlphaColour, 29 | 30 | -- ** Image loading 31 | Image (..), 32 | withImage, 33 | ) 34 | where 35 | 36 | import Control.Monad 37 | import Data.Bifunctor (Bifunctor (..)) 38 | import Data.Colour 39 | import Data.Colour.SRGB (RGB (..), toSRGB24) 40 | import Data.Foldable (toList) 41 | import Data.Hashable (Hashable (..)) 42 | import Data.Hashable.Generic (genericHashWithSalt) 43 | import Data.IntMap.Strict qualified as IM 44 | import Data.Sequence qualified as S 45 | import Data.Text (Text, unpack) 46 | import Data.Vector.Storable qualified as VS 47 | import Data.Word (Word8) 48 | import Foreign (Storable (..)) 49 | import Foreign.C (CInt) 50 | import Foreign.Ptr 51 | import GHC.Generics (Generic) 52 | import Linear.V2 53 | import Linear.V4 54 | import Reactimate (Signal, arrIO, once) 55 | import Reactimate.Game.Assets (Asset (..), withAsset) 56 | import Reactimate.Game.Environment (GameEnv (..)) 57 | import Reactimate.Game.Projection2D 58 | import Reactimate.Game.Shapes 59 | import SDL qualified 60 | import SDL.Image qualified as SDL 61 | import SDL.Primitive qualified as SDL 62 | import SDL.Raw.Types qualified as SDLRaw 63 | 64 | -- | Renders the given `Picture` with the `Camera` each frame. 65 | renderGame :: GameEnv -> Signal (Camera, Picture) () 66 | renderGame gameEnv = 67 | arrIO $ 68 | uncurry (renderScreen gameEnv.window gameEnv.renderer) 69 | {-# INLINE renderGame #-} 70 | 71 | -- | A `Picture` is a collection of `PictureAtoms`. `Picture` implements `Semigroup`, 72 | -- so multiple `Picture`s can be combined. 73 | newtype Picture = Picture 74 | { pictureParts :: IM.IntMap PicturePart 75 | } 76 | 77 | instance Semigroup Picture where 78 | (Picture objects1) <> (Picture objects2) = 79 | Picture $ 80 | IM.unionWith (<>) objects1 objects2 81 | 82 | instance Monoid Picture where 83 | mempty = Picture IM.empty 84 | 85 | data PicturePart 86 | = PicturePart 87 | { projection :: !(Projection2D Int), 88 | pictureParts :: S.Seq PicturePart 89 | } 90 | | PictureRender 91 | { render :: Render () 92 | } 93 | 94 | instance Semigroup PicturePart where 95 | pp1@(PicturePart movement1 parts1) <> pp2@(PicturePart movement2 parts2) = 96 | if movement1 == movement2 97 | then PicturePart movement1 (parts1 <> parts2) 98 | else PicturePart idProjection $ S.fromList [pp1, pp2] 99 | pp1 <> pp2@(PictureRender _) = pp1 <> PicturePart idProjection (S.singleton pp2) 100 | pp1@(PictureRender _) <> pp2 = PicturePart idProjection (S.singleton pp1) <> pp2 101 | 102 | -- | `PictureAtoms` are the building blocks of `Picture`s. 103 | -- data PictureAtoms 104 | -- = BasicShapes !(VS.Vector (ColouredShape BasicShape)) 105 | -- | Texture !Image !(VS.Vector Blit) 106 | -- deriving (Eq) 107 | 108 | -- | A `Blit` contains source and target rectangles. They are used to copy 109 | -- parts of some source texture onto a target texture. For `PictureAtoms`, the target is the screen. 110 | data Blit = Blit 111 | { source :: !Rectangle, 112 | target :: !Rectangle 113 | } 114 | deriving (Eq, Show) 115 | 116 | instance Storable Blit where 117 | sizeOf _ = sizeOf (undefined :: V2 Rectangle) 118 | alignment _ = alignment (undefined :: V2 Rectangle) 119 | peek ptr = do 120 | V2 r1 r2 <- peek $ castPtr ptr 121 | pure $ Blit r1 r2 122 | poke ptr (Blit r1 r2) = do 123 | poke (castPtr ptr) (V2 r1 r2) 124 | 125 | -- | A `Camera` can move around and zoom out and in. 126 | data Camera = Camera 127 | { position :: {-# UNPACK #-} !(V2 Int), 128 | viewport :: {-# UNPACK #-} !(V2 Int) 129 | } 130 | deriving (Eq, Show, Generic) 131 | 132 | -- | Make a `Picture` from a `PictureAtoms` at the given z-level. 133 | -- `PictureAtoms` with higher z-level are rendered over ones with lower z-level. 134 | makePicture :: Int -> Render () -> Picture 135 | makePicture zIndex action = 136 | Picture $ IM.singleton zIndex $ PictureRender action 137 | 138 | -- | Creates the `Picture` once and then reuses it in all subsequenct renders. If you have some static content, 139 | -- use this function to save some computation time. 140 | staticPicture :: Signal a Picture -> Signal a Picture 141 | staticPicture = once 142 | 143 | -- | Pack an `AlphaColour` so that it can be used for `PictureAtoms`. Include the /colour/ package to make colours! 144 | packAlphaColour :: AlphaColour Float -> V4 Word8 145 | packAlphaColour colour = 146 | let (RGB r g b) = toSRGB24 (colour `over` black) 147 | alpha = truncate $ alphaChannel colour * 255 148 | in V4 r g b alpha 149 | {-# INLINE packAlphaColour #-} 150 | 151 | -- | Pack a `Colour` so that it can be used for `PictureAtoms`. Include the /colour/ package to make colours! 152 | packColour :: Colour Float -> V4 Word8 153 | packColour colour = 154 | let (RGB r g b) = toSRGB24 colour 155 | in V4 r g b 255 156 | {-# INLINE packColour #-} 157 | 158 | renderScreen :: SDL.Window -> SDL.Renderer -> Camera -> Picture -> IO () 159 | renderScreen window renderer camera picture = do 160 | windowSize <- SDL.get (SDL.windowSize window) 161 | 162 | SDL.rendererDrawColor renderer SDL.$= V4 255 255 255 255 163 | SDL.clear renderer 164 | renderPicture (RenderContext window renderer) (computeCameraProjection (fromIntegral <$> windowSize) camera) picture 165 | SDL.present renderer 166 | 167 | data RenderContext = RenderContext 168 | { window :: !SDL.Window, 169 | renderer :: !SDL.Renderer 170 | } 171 | 172 | renderPicture :: RenderContext -> Projection2D Int -> Picture -> IO () 173 | renderPicture rc projection (Picture pictureParts) = forM_ pictureParts $ \picturePart -> renderPicturePart rc projection picturePart 174 | 175 | renderPicturePart :: RenderContext -> Projection2D Int -> PicturePart -> IO () 176 | renderPicturePart rc projection1 (PicturePart projection2 nestedParts) = forM_ nestedParts $ renderPicturePart rc (projection1 *** projection2) 177 | renderPicturePart rc projection (PictureRender (Render f)) = 178 | f rc projection 179 | 180 | -- | Draw a filled rectangle with the given colour 181 | drawRectangle :: V4 Word8 -> Rectangle -> Render () 182 | drawRectangle (V4 r g b a) (Rectangle position (V2 sizeX sizeY)) = Render $ \rc projection -> 183 | let vertices = VS.fromList $ makeVertex . fmap fromIntegral . applyProjection quot projection <$> [position, position + V2 sizeX 0, position + V2 sizeX sizeY, position + V2 0 sizeY] 184 | indices = VS.fromList [0, 1, 2, 3, 2, 0] 185 | in SDL.renderGeometry rc.renderer Nothing vertices indices 186 | where 187 | makeVertex (V2 dX dY) = 188 | SDL.Vertex 189 | (SDLRaw.FPoint dX dY) 190 | (SDLRaw.Color r g b a) 191 | (SDLRaw.FPoint 0 0) 192 | 193 | -- | Draw a filled polygon with the given colour 194 | drawPolygon :: V4 Word8 -> [V2 Int] -> Render () 195 | drawPolygon colour vertices = Render $ \rc projection -> 196 | let points = applyProjection quot projection <$> vertices 197 | xs = VS.fromList $ fmap (fromIntegral . getX) points 198 | ys = VS.fromList $ fmap (fromIntegral . getY) points 199 | in SDL.fillPolygon rc.renderer xs ys colour 200 | 201 | -- | Blit rectangular portions of an image to the screen. 202 | blitImage :: [Blit] -> Image -> Render () 203 | blitImage blits (Image texture (V2 iWidth iHeight)) = Render $ \rc projection -> 204 | let (vertices, indices) = bimap (VS.fromList . toList) (VS.fromList . toList) $ generateGeometry projection (S.empty, S.empty) 0 blits 205 | in SDL.renderGeometry rc.renderer (Just texture) vertices indices 206 | where 207 | generateGeometry :: Projection2D Int -> (S.Seq SDL.Vertex, S.Seq CInt) -> CInt -> [Blit] -> (S.Seq SDL.Vertex, S.Seq CInt) 208 | generateGeometry _ geometry _ [] = geometry 209 | generateGeometry projection (vertices, indices) n (Blit (Rectangle source (V2 sourceWidth sourceHeight)) (Rectangle dest (V2 destWidth destHeight)) : blits) = 210 | let sourceVertices = fmap fromIntegral . (source +) <$> [V2 0 0, V2 sourceWidth 0, V2 0 sourceHeight, V2 sourceWidth sourceHeight] 211 | destVertices = fmap fromIntegral . applyProjection quot projection . (dest +) <$> [V2 0 0, V2 destWidth 0, V2 0 destHeight, V2 destWidth destHeight] 212 | in generateGeometry 213 | projection 214 | (vertices <> S.fromList (zipWith makeVertex sourceVertices destVertices), indices <> S.fromList ((n +) <$> [0, 1, 2, 3, 2, 1])) 215 | (n + 4) 216 | blits 217 | makeVertex (V2 sX sY) (V2 dX dY) = 218 | SDL.Vertex 219 | (SDLRaw.FPoint dX dY) 220 | (SDLRaw.Color 255 255 255 255) 221 | ( SDLRaw.FPoint 222 | (sX / fromIntegral iWidth) 223 | (abs $ 1 - (sY / fromIntegral iHeight)) 224 | ) 225 | 226 | translatePicture :: V2 Int -> Picture -> Picture 227 | translatePicture v (Picture parts) = Picture $ IM.map translatePicturePart parts 228 | where 229 | translatePicturePart (PicturePart projection parts) = PicturePart (translateProjection v projection) parts 230 | translatePicturePart (PictureRender render) = PicturePart (translation v) $ S.fromList [PictureRender render] 231 | 232 | -- | Rotate the `Picture` around the origin (0,0) 233 | rotatePicture :: Float -> Picture -> Picture 234 | rotatePicture r (Picture parts) = Picture $ IM.map translatePicturePart parts 235 | where 236 | translatePicturePart (PicturePart projection parts) = PicturePart (approximateRotation r *** projection) parts 237 | translatePicturePart (PictureRender render) = PicturePart (approximateRotation r) $ S.fromList [PictureRender render] 238 | 239 | -- | Apply a homogenous projection to the picture. A projection can translate, rotate, reflect or skew a picture. 240 | projectPicture :: Projection2D Int -> Picture -> Picture 241 | projectPicture projection (Picture parts) = Picture $ IM.map projectPicturePart parts 242 | where 243 | projectPicturePart (PicturePart innerProjection parts) = PicturePart (projection *** innerProjection) parts 244 | projectPicturePart (PictureRender render) = PicturePart projection $ S.fromList [PictureRender render] 245 | 246 | computeCameraProjection :: V2 Int -> Camera -> Projection2D Int 247 | computeCameraProjection (V2 wx wy) (Camera (V2 cx cy) (V2 vx vy)) = 248 | zeroProjection {p00 = vx * vy, p11 = wx * vy, p22 = -wy * vx, p10 = -cx * wx * vy, p20 = vx * wy * (vy + cy)} 249 | 250 | data ImagePath = ImagePath 251 | { renderer :: !SDL.Renderer, 252 | path :: !Text 253 | } 254 | deriving (Eq, Show, Ord, Generic) 255 | 256 | instance Hashable ImagePath where 257 | hashWithSalt i (ImagePath renderer path) = 258 | let i' = genericHashWithSalt i renderer 259 | in hashWithSalt i' path 260 | 261 | -- | An `Image` contains the GPU texture of the image so that it can be used 262 | -- for rendering 263 | data Image = Image 264 | { texture :: !SDL.Texture, 265 | size :: !(V2 Int) 266 | } 267 | deriving (Eq) 268 | 269 | instance Asset ImagePath where 270 | type AssetValue ImagePath = Image 271 | type AssetEnv ImagePath = () 272 | loadAsset () (ImagePath renderer path) = do 273 | texture <- SDL.loadTexture renderer $ unpack path 274 | textureInfo <- SDL.queryTexture texture 275 | pure $ Image texture $ fromIntegral <$> V2 textureInfo.textureWidth textureInfo.textureHeight 276 | freeAsset _ image = do 277 | SDL.destroyTexture image.texture 278 | 279 | -- | Load an image from the given path during the setup phase such that you can use it for rendering 280 | withImage :: GameEnv -> Text -> (Image -> Signal a b) -> Signal a b 281 | withImage gameEnv path = withAsset gameEnv.assets () (ImagePath gameEnv.renderer path) 282 | 283 | newtype Render a = Render (RenderContext -> Projection2D Int -> IO a) 284 | deriving (Functor, Semigroup, Monoid) 285 | 286 | instance Applicative Render where 287 | pure a = Render $ \_ _ -> pure a 288 | (Render f) <*> (Render a) = Render $ \rc projection -> f rc projection <*> a rc projection 289 | {-# INLINE pure #-} 290 | {-# INLINE (<*>) #-} 291 | 292 | instance Monad Render where 293 | (Render makeA) >>= f = Render $ \rc projection -> do 294 | a <- makeA rc projection 295 | let (Render makeB) = f a 296 | makeB rc projection 297 | {-# INLINE (>>=) #-} 298 | 299 | getX :: V2 a -> a 300 | getX (V2 x _) = x 301 | 302 | getY :: V2 a -> a 303 | getY (V2 _ y) = y 304 | -------------------------------------------------------------------------------- /reactimate-game/src/Reactimate/Game/Input.hs: -------------------------------------------------------------------------------- 1 | module Reactimate.Game.Input 2 | ( inputEvents, 3 | keyboardState, 4 | mousePosition, 5 | mouseButtons, 6 | gameShouldQuit 7 | ) 8 | where 9 | 10 | import Linear (V2 (..)) 11 | import Reactimate 12 | import Reactimate.Game.Environment (GameEnv (..)) 13 | import Reactimate.Game.Graphics (Camera (..)) 14 | import SDL qualified 15 | 16 | -- | Handle SDL events as they happen. This can be useful if you want to catch events which happen in between simulations. 17 | inputEvents :: GameEnv -> Event SDL.Event 18 | inputEvents _ = callback $ \fin fire -> do 19 | eventWatch <- SDL.addEventWatch fire 20 | addFinalizer fin $ SDL.delEventWatch eventWatch 21 | 22 | -- | Get the current keyboard state. 23 | keyboardState :: GameEnv -> Behavior (SDL.Scancode -> Bool) 24 | keyboardState _ = makeBehavior $ arrIO $ \_ -> do 25 | SDL.getKeyboardState 26 | 27 | -- | Get the position of the mouse relative to the camera. 28 | mousePosition :: GameEnv -> Signal Camera (V2 Int) 29 | mousePosition gameEnv = arrIO $ \camera -> do 30 | windowSize <- fmap fromIntegral <$> SDL.get (SDL.windowSize gameEnv.window) 31 | realMousePosition <- fmap fromIntegral . SDL.unP <$> SDL.getAbsoluteMouseLocation 32 | let (V2 x y) = quot <$> (realMousePosition * camera.viewport) <*> windowSize 33 | (V2 _ vy) = camera.viewport 34 | pure $ V2 x (vy - y) 35 | 36 | -- | Get the current mouse button state 37 | mouseButtons :: GameEnv -> Behavior (SDL.MouseButton -> Bool) 38 | mouseButtons _ = makeBehavior $ arrIO $ const $ do 39 | SDL.getMouseButtons 40 | 41 | -- | Checks if a SDL Quit event was triggered 42 | gameShouldQuit :: GameEnv -> Behavior Bool 43 | gameShouldQuit gameEnv = 44 | makeBehavior $ 45 | accumulateEvent (||) False $ 46 | (== SDL.QuitEvent) . SDL.eventPayload <$> inputEvents gameEnv 47 | 48 | -------------------------------------------------------------------------------- /reactimate-game/src/Reactimate/Game/Projection2D.hs: -------------------------------------------------------------------------------- 1 | module Reactimate.Game.Projection2D where 2 | 3 | import Linear (V2) 4 | import Linear.V2 (V2 (..)) 5 | 6 | data Projection2D a = Projection2D 7 | { p00 :: {-# UNPACK #-} !a, 8 | p01 :: {-# UNPACK #-} !a, 9 | p02 :: {-# UNPACK #-} !a, 10 | p10 :: {-# UNPACK #-} !a, 11 | p11 :: {-# UNPACK #-} !a, 12 | p12 :: {-# UNPACK #-} !a, 13 | p20 :: {-# UNPACK #-} !a, 14 | p21 :: {-# UNPACK #-} !a, 15 | p22 :: {-# UNPACK #-} !a 16 | } 17 | deriving (Eq, Show) 18 | 19 | combineProjection :: (Num a) => Projection2D a -> Projection2D a -> Projection2D a 20 | combineProjection p1 p2 = 21 | Projection2D 22 | { p00 = p1.p00 * p2.p00 + p1.p01 * p2.p10 + p1.p02 * p2.p20, 23 | p01 = p1.p00 * p2.p01 + p1.p01 * p2.p11 + p1.p02 * p2.p21, 24 | p02 = p1.p00 * p2.p02 + p1.p01 * p2.p12 + p1.p02 * p2.p22, 25 | p10 = p1.p10 * p2.p00 + p1.p11 * p2.p10 + p1.p12 * p2.p20, 26 | p11 = p1.p10 * p2.p01 + p1.p11 * p2.p11 + p1.p12 * p2.p21, 27 | p12 = p1.p10 * p2.p02 + p1.p11 * p2.p12 + p1.p12 * p2.p22, 28 | p20 = p1.p20 * p2.p00 + p1.p21 * p2.p10 + p1.p22 * p2.p20, 29 | p21 = p1.p20 * p2.p01 + p1.p21 * p2.p11 + p1.p22 * p2.p21, 30 | p22 = p1.p20 * p2.p02 + p1.p21 * p2.p12 + p1.p22 * p2.p22 31 | } 32 | {-# INLINE combineProjection #-} 33 | 34 | (***) :: (Num a) => Projection2D a -> Projection2D a -> Projection2D a 35 | (***) = combineProjection 36 | {-# INLINE (***) #-} 37 | 38 | zeroProjection :: (Num a) => Projection2D a 39 | zeroProjection = 40 | Projection2D 41 | { p00 = 0, 42 | p01 = 0, 43 | p02 = 0, 44 | p10 = 0, 45 | p11 = 0, 46 | p12 = 0, 47 | p20 = 0, 48 | p21 = 0, 49 | p22 = 0 50 | } 51 | {-# INLINE zeroProjection #-} 52 | 53 | idProjection :: (Num a) => Projection2D a 54 | idProjection = zeroProjection {p00 = 1, p11 = 1, p22 = 1} 55 | {-# INLINE idProjection #-} 56 | 57 | translateProjection :: (Num a) => V2 a -> Projection2D a -> Projection2D a 58 | translateProjection (V2 x y) projection = 59 | projection {p10 = projection.p10 + projection.p00 * x, p20 = projection.p20 + projection.p00 * y} 60 | {-# INLINE translateProjection #-} 61 | 62 | translation :: (Num a) => V2 a -> Projection2D a 63 | translation (V2 x y) = 64 | idProjection {p10 = x, p20 = y} 65 | {-# INLINE translation #-} 66 | 67 | rotation :: (Floating a) => a -> Projection2D a 68 | rotation r = 69 | Projection2D 70 | 1 71 | 0 72 | 0 73 | 0 74 | (cos r) 75 | (sin r) 76 | 0 77 | (-sin r) 78 | (cos r) 79 | {-# INLINE rotation #-} 80 | 81 | approximateRotation :: (Integral a, Floating b, RealFrac b) => b -> Projection2D a 82 | approximateRotation r = 83 | Projection2D 84 | 360 85 | 0 86 | 0 87 | 0 88 | (round $ 360 * cos r) 89 | (round $ 360 * sin r) 90 | 0 91 | (round $ 360 * (-sin r)) 92 | (round $ 360 * cos r) 93 | {-# INLINE approximateRotation #-} 94 | 95 | rotateAtCenter :: (Floating a) => a -> Projection2D a -> Projection2D a 96 | rotateAtCenter r projection = 97 | let (V2 x y) = V2 projection.p10 projection.p20 98 | in (rotation r *** projection {p10 = 0, p20 = 0}) {p10 = x, p20 = y} 99 | {-# INLINE rotateAtCenter #-} 100 | 101 | approximatelyRotateAtCenter :: (Integral a, Floating b, RealFrac b) => b -> Projection2D a -> Projection2D a 102 | approximatelyRotateAtCenter r projection = 103 | let (V2 x y) = V2 projection.p10 projection.p20 104 | in (approximateRotation r *** projection {p10 = 0, p20 = 0}) {p10 = x * 360, p20 = y * 360} 105 | {-# INLINE approximatelyRotateAtCenter #-} 106 | 107 | rotationAround :: (Floating a) => a -> V2 a -> Projection2D a 108 | rotationAround r (V2 x y) = 109 | translation (V2 x y) *** rotation r *** translation (-V2 x y) 110 | {-# INLINE rotationAround #-} 111 | 112 | approximateRotationAround :: (Floating a, Integral b, RealFrac a) => a -> V2 b -> Projection2D b 113 | approximateRotationAround r (V2 x y) = 114 | translation (V2 x y) *** approximateRotation r *** translation (-V2 x y) 115 | {-# INLINE approximateRotationAround #-} 116 | 117 | applyProjection :: (Num a) => (a -> a -> a) -> Projection2D a -> V2 a -> V2 a 118 | applyProjection divide (Projection2D p00 p01 p02 p10 p11 p12 p20 p21 p22) (V2 x y) = 119 | let z = p00 + p01 * x + p02 * y 120 | in (`divide` z) <$> V2 (p10 + p11 * x + p12 * y) (p20 + p21 * x + p22 * y) 121 | {-# INLINE applyProjection #-} 122 | -------------------------------------------------------------------------------- /reactimate-game/src/Reactimate/Game/Setup.hs: -------------------------------------------------------------------------------- 1 | module Reactimate.Game.Setup 2 | ( setupGame, 3 | GameConfig (..), 4 | SDL.WindowConfig (..), 5 | SDL.defaultWindow, 6 | ) 7 | where 8 | 9 | import Control.Concurrent (threadDelay) 10 | import Data.IORef 11 | import Data.Text (Text) 12 | import GHC.Generics (Generic) 13 | import Reactimate 14 | import Reactimate.Game.Assets (makeAssets) 15 | import Reactimate.Game.Environment 16 | import Reactimate.Signal (Signal (..), unSignal) 17 | import Reactimate.Time (Time (..)) 18 | import SDL qualified 19 | 20 | data GameConfig = GameConfig 21 | { name :: !Text, 22 | window :: !SDL.WindowConfig, 23 | fps :: !Int 24 | } 25 | deriving (Eq, Show, Generic) 26 | 27 | -- | Initializes the game environment and provides you the `GameEnv`. You will need this for rendering and grabbing input. 28 | setupGame :: GameConfig -> (GameEnv -> Signal a b) -> Signal a b 29 | setupGame config signal = Signal $ \fin -> do 30 | SDL.initializeAll 31 | window <- SDL.createWindow config.name config.window 32 | addFinalizer fin $ SDL.destroyWindow window 33 | 34 | renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer 35 | addFinalizer fin $ SDL.destroyRenderer renderer 36 | 37 | assets <- makeAssets 38 | 39 | !buildTime <- SDL.time 40 | dTimeRef <- newIORef 0 41 | cTimeRef <- newIORef buildTime 42 | 43 | wantedTimeRef <- newIORef buildTime 44 | 45 | let gameEnv = GameEnv window renderer assets (Time dTimeRef cTimeRef) 46 | 47 | f <- unSignal (signal gameEnv) fin 48 | 49 | pure $ \a -> do 50 | SDL.pumpEvents 51 | oldTime <- readIORef gameEnv.time.cTime 52 | !newTime <- SDL.time 53 | let !dTime = newTime - oldTime 54 | writeIORef gameEnv.time.cTime newTime 55 | writeIORef gameEnv.time.dTime dTime 56 | 57 | b <- f a 58 | 59 | wantedTime <- readIORef wantedTimeRef 60 | threadDelay $ round $ min frameTime (max 0 $ wantedTime - newTime) * 10 ^ (6 :: Int) 61 | 62 | writeIORef wantedTimeRef (max newTime $ wantedTime + frameTime) 63 | 64 | pure b 65 | where 66 | frameTime = 1 / fromIntegral config.fps 67 | -------------------------------------------------------------------------------- /reactimate-game/src/Reactimate/Game/Shapes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Reactimate.Game.Shapes 4 | ( -- * Shapes 5 | BasicShape (..), 6 | ColouredShape (..), 7 | 8 | -- * Shape types 9 | Rectangle (..), 10 | Ellipse (..), 11 | Triangle (..), 12 | CircularArc (..), 13 | ) 14 | where 15 | 16 | import Data.Kind (Type) 17 | import Foreign 18 | import Linear.V2 (V2 (..)) 19 | import Linear.V4 (V4) 20 | 21 | data Ellipse = Ellipse 22 | { position :: {-# UNPACK #-} !(V2 Int), 23 | radii :: {-# UNPACK #-} !(V2 Int) 24 | } 25 | deriving (Eq, Show) 26 | 27 | data Rectangle = Rectangle 28 | { position :: {-# UNPACK #-} !(V2 Int), 29 | size :: {-# UNPACK #-} !(V2 Int) 30 | } 31 | deriving (Eq, Show) 32 | 33 | data Triangle = Triangle 34 | { position1 :: {-# UNPACK #-} !(V2 Int), 35 | position2 :: {-# UNPACK #-} !(V2 Int), 36 | position3 :: {-# UNPACK #-} !(V2 Int) 37 | } 38 | deriving (Eq, Show) 39 | 40 | data CircularArc = CircularArc 41 | { position :: {-# UNPACK #-} !(V2 Int), 42 | radius :: {-# UNPACK #-} !Int, 43 | startDegree :: {-# UNPACK #-} !Int, 44 | endDegree :: {-# UNPACK #-} !Int 45 | } 46 | deriving (Eq, Show) 47 | 48 | data BasicShape 49 | = BSRectangle !Rectangle 50 | | BSEllipse !Ellipse 51 | | BSTriangle !Triangle 52 | | BSCircularArc !CircularArc 53 | deriving (Eq, Show) 54 | 55 | data ColouredShape x = ColouredShape 56 | { colour :: V4 Word8, 57 | shape :: x 58 | } 59 | deriving (Eq, Show) 60 | 61 | instance Storable Ellipse where 62 | sizeOf _ = byteSize @(V2 Int) + byteSize @(V2 Int) 63 | alignment _ = 0 64 | peek ptr = do 65 | position <- peek $ castPtr ptr 66 | size <- peek (ptr `plusPtr` byteSize @(V2 Int)) 67 | pure $ Ellipse position size 68 | poke ptr (Ellipse position size) = do 69 | poke (castPtr ptr) position 70 | poke (ptr `plusPtr` byteSize @(V2 Int)) size 71 | 72 | instance Storable Rectangle where 73 | sizeOf _ = byteSize @(V2 Int) + byteSize @(V2 Int) 74 | alignment _ = 0 75 | peek ptr = do 76 | position <- peek $ castPtr ptr 77 | size <- peek (ptr `plusPtr` byteSize @(V2 Int)) 78 | pure $ Rectangle position size 79 | poke ptr (Rectangle position size) = do 80 | poke (castPtr ptr) position 81 | poke (ptr `plusPtr` byteSize @(V2 Int)) size 82 | 83 | instance Storable Triangle where 84 | sizeOf _ = 3 * byteSize @(V2 Int) 85 | alignment _ = 0 86 | peek ptr = do 87 | position1 <- peek $ castPtr ptr 88 | position2 <- peek $ castPtr (ptr `plusPtr` byteSize @(V2 Int)) 89 | position3 <- peek $ castPtr (ptr `plusPtr` (byteSize @(V2 Int) + byteSize @(V2 Int))) 90 | pure $ Triangle position1 position2 position3 91 | poke ptr (Triangle position1 position2 position3) = do 92 | poke (castPtr ptr) position1 93 | poke (castPtr (ptr `plusPtr` byteSize @(V2 Int))) position2 94 | poke (castPtr (ptr `plusPtr` (byteSize @(V2 Int) + byteSize @(V2 Int)))) position3 95 | 96 | instance Storable CircularArc where 97 | sizeOf _ = byteSize @(V2 Int) + 3 * byteSize @Int 98 | alignment _ = 0 99 | peek ptr = do 100 | position <- peek $ castPtr ptr 101 | radius <- peek (ptr `plusPtr` byteSize @Int) 102 | startDegree <- peek (ptr `plusPtr` (2 * byteSize @Int)) 103 | endDegree <- peek (ptr `plusPtr` (3 * byteSize @Int)) 104 | pure $ CircularArc position radius startDegree endDegree 105 | poke ptr (CircularArc position radius startDegree endDegree) = do 106 | poke (castPtr ptr) position 107 | poke (ptr `plusPtr` byteSize @Int) radius 108 | poke (ptr `plusPtr` (2 * byteSize @Int)) startDegree 109 | poke (ptr `plusPtr` (3 * byteSize @Int)) endDegree 110 | 111 | instance Storable BasicShape where 112 | sizeOf _ = byteSize @Word8 + maximum [byteSize @Rectangle, byteSize @Triangle, byteSize @Ellipse, byteSize @CircularArc] 113 | alignment _ = 0 114 | peek ptr = do 115 | type_ <- peek @Word8 (castPtr ptr) 116 | let shapePtr = ptr `plusPtr` byteSize @Word8 117 | case type_ of 118 | 0 -> BSRectangle <$> peek shapePtr 119 | 1 -> BSEllipse <$> peek shapePtr 120 | 2 -> BSTriangle <$> peek shapePtr 121 | 3 -> BSCircularArc <$> peek shapePtr 122 | _ -> error $ "Memory corruption. A primitive shape could not be read from " ++ show shapePtr 123 | poke ptr primitiveShape = do 124 | let shapePtr = ptr `plusPtr` byteSize @Word8 125 | case primitiveShape of 126 | BSRectangle rectangle -> do 127 | poke @Word8 (castPtr ptr) 0 128 | poke shapePtr rectangle 129 | BSEllipse ellipse -> do 130 | poke @Word8 (castPtr ptr) 1 131 | poke shapePtr ellipse 132 | BSTriangle triangle -> do 133 | poke @Word8 (castPtr ptr) 2 134 | poke shapePtr triangle 135 | BSCircularArc circularArc -> do 136 | poke @Word8 (castPtr ptr) 3 137 | poke shapePtr circularArc 138 | 139 | instance (Storable shape) => Storable (ColouredShape shape) where 140 | sizeOf _ = byteSize @(V4 Word8) + byteSize @shape 141 | alignment _ = 0 142 | peek ptr = do 143 | colour <- peek $ castPtr ptr 144 | shape <- peek (ptr `plusPtr` byteSize @(V4 Word8)) 145 | pure $ ColouredShape colour shape 146 | poke ptr (ColouredShape colour shape) = do 147 | poke (castPtr ptr) colour 148 | poke (ptr `plusPtr` byteSize @(V4 Word8)) shape 149 | 150 | byteSize :: forall (a :: Type). (Storable a) => Int 151 | byteSize = sizeOf (bottom :: a) 152 | where 153 | bottom = bottom 154 | -------------------------------------------------------------------------------- /reactimate-game/src/Reactimate/Game/Tasks.hs: -------------------------------------------------------------------------------- 1 | module Reactimate.Game.Tasks where 2 | 3 | -- data Tasks = 4 | 5 | -- addTask :: Tasks -> Int -> IO () -> IO () 6 | -- addTask = undefined 7 | -------------------------------------------------------------------------------- /reactimate-game/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | main :: IO () 4 | main = putStrLn "Test suite not yet implemented." 5 | -------------------------------------------------------------------------------- /reactimate-ldtk/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for signal-functions 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /reactimate-ldtk/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2024, Simre1 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Simre1 nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /reactimate-ldtk/README.md: -------------------------------------------------------------------------------- 1 | # Reactimate LDtk 2 | 3 | Load LDtk files and integrate them into your `reactimate` based games. It also has a matching framework to extract level information in a convenient way. 4 | 5 | ## Examples 6 | 7 | The following example loads `Level_0` from the project file. The `MatchRule Picture` extracts all entities from the level and generated a `Picture` with a red rectangle at their position. 8 | 9 | ```haskell 10 | renderLDtk :: FilePath -> Signal () Picture 11 | renderLDtk filepath = withLDtkRoot filepath $ \ldtkRoot -> withLevel ldtkRoot "Level_0" $ \level -> 12 | constant (withMatchRules rules level) >>> arr (,Nothing) 13 | where 14 | rules :: [MatchRule Picture] 15 | rules = pure $ matchEntity Nothing $ do 16 | entitySize <- getEntitySize 17 | entityPosition <- getEntityPosition 18 | pure $ makePicture 0 $ 19 | drawRectangle (packColour red) $ Rectangle entityPosition entitySize 20 | ``` 21 | 22 | 23 | -------------------------------------------------------------------------------- /reactimate-ldtk/examples/basic-example/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Data.Bool (bool) 4 | import Data.Colour.Names 5 | import Data.Vector.Storable qualified as VS 6 | import Reactimate 7 | import Reactimate.Game 8 | import Reactimate.LDtk 9 | import System.Environment (getArgs) 10 | import Debug.Trace 11 | 12 | gameConfig :: GameConfig 13 | gameConfig = GameConfig "ldtk example" defaultWindow {windowInitialSize = V2 512 512} 60 14 | 15 | main :: IO () 16 | main = do 17 | args <- getArgs 18 | case args of 19 | [ldtkPath] -> 20 | reactimate $ setupGame gameConfig $ \gameEnv -> 21 | renderLDtk ldtkPath 22 | >>> render gameEnv 23 | >>> sampleBehavior (bool Nothing (Just ()) <$> gameShouldQuit gameEnv) 24 | _ -> putStrLn "Run this example with the basic example ldtk file path as the argument" 25 | 26 | render :: GameEnv -> Signal Picture () 27 | render gameEnv = arr (Camera (V2 0 0) (V2 256 256),) >>> renderGame gameEnv 28 | 29 | renderLDtk :: FilePath -> Signal () Picture 30 | renderLDtk filepath = withLDtkRoot filepath $ \ldtkRoot -> withLevel ldtkRoot "Level_0" $ \level -> 31 | constant (withMatchRules rules level) >>> arr (,Nothing) 32 | where 33 | rules :: [MatchRule Picture] 34 | rules = pure $ matchEntity Nothing $ do 35 | entitySize <- getEntitySize 36 | entityPosition <- getEntityPosition 37 | pure $ makePicture 0 $ 38 | drawRectangle (packColour red) $ Rectangle entityPosition entitySize 39 | -------------------------------------------------------------------------------- /reactimate-ldtk/examples/basic-example/basic-examples.ldtk: -------------------------------------------------------------------------------- 1 | { 2 | "__header__": { 3 | "fileType": "LDtk Project JSON", 4 | "app": "LDtk", 5 | "doc": "https://ldtk.io/json", 6 | "schema": "https://ldtk.io/files/JSON_SCHEMA.json", 7 | "appAuthor": "Sebastien 'deepnight' Benard", 8 | "appVersion": "1.5.3", 9 | "url": "https://ldtk.io" 10 | }, 11 | "iid": "c61fe8e0-b0a0-11ee-915a-254da78b7d0b", 12 | "jsonVersion": "1.5.3", 13 | "appBuildId": 473703, 14 | "nextUid": 4, 15 | "identifierStyle": "Capitalize", 16 | "toc": [], 17 | "worldLayout": "Free", 18 | "worldGridWidth": 256, 19 | "worldGridHeight": 256, 20 | "defaultLevelWidth": 256, 21 | "defaultLevelHeight": 256, 22 | "defaultPivotX": 0, 23 | "defaultPivotY": 1, 24 | "defaultGridSize": 16, 25 | "defaultEntityWidth": 16, 26 | "defaultEntityHeight": 16, 27 | "bgColor": "#40465B", 28 | "defaultLevelBgColor": "#696A79", 29 | "minifyJson": false, 30 | "externalLevels": false, 31 | "exportTiled": false, 32 | "simplifiedExport": false, 33 | "imageExportMode": "None", 34 | "exportLevelBg": true, 35 | "pngFilePattern": null, 36 | "backupOnSave": false, 37 | "backupLimit": 10, 38 | "backupRelPath": null, 39 | "levelNamePattern": "Level_%idx", 40 | "tutorialDesc": null, 41 | "customCommands": [], 42 | "flags": [], 43 | "defs": { "layers": [ 44 | { 45 | "__type": "Entities", 46 | "identifier": "Entities", 47 | "type": "Entities", 48 | "uid": 2, 49 | "doc": null, 50 | "uiColor": null, 51 | "gridSize": 16, 52 | "guideGridWid": 0, 53 | "guideGridHei": 0, 54 | "displayOpacity": 1, 55 | "inactiveOpacity": 0.6, 56 | "hideInList": false, 57 | "hideFieldsWhenInactive": true, 58 | "canSelectWhenInactive": true, 59 | "renderInWorldView": true, 60 | "pxOffsetX": 0, 61 | "pxOffsetY": 0, 62 | "parallaxFactorX": 0, 63 | "parallaxFactorY": 0, 64 | "parallaxScaling": true, 65 | "requiredTags": [], 66 | "excludedTags": [], 67 | "autoTilesKilledByOtherLayerUid": null, 68 | "uiFilterTags": [], 69 | "useAsyncRender": false, 70 | "intGridValues": [], 71 | "intGridValuesGroups": [], 72 | "autoRuleGroups": [], 73 | "autoSourceLayerDefUid": null, 74 | "tilesetDefUid": null, 75 | "tilePivotX": 0, 76 | "tilePivotY": 0, 77 | "biomeFieldUid": null 78 | } 79 | ], "entities": [ 80 | { 81 | "identifier": "Entity", 82 | "uid": 1, 83 | "tags": [], 84 | "exportToToc": false, 85 | "allowOutOfBounds": false, 86 | "doc": null, 87 | "width": 16, 88 | "height": 16, 89 | "resizableX": false, 90 | "resizableY": false, 91 | "minWidth": null, 92 | "maxWidth": null, 93 | "minHeight": null, 94 | "maxHeight": null, 95 | "keepAspectRatio": false, 96 | "tileOpacity": 1, 97 | "fillOpacity": 1, 98 | "lineOpacity": 1, 99 | "hollow": false, 100 | "color": "#BE4A2F", 101 | "renderMode": "Rectangle", 102 | "showName": true, 103 | "tilesetId": null, 104 | "tileRenderMode": "FitInside", 105 | "tileRect": null, 106 | "uiTileRect": null, 107 | "nineSliceBorders": [], 108 | "maxCount": 0, 109 | "limitScope": "PerLevel", 110 | "limitBehavior": "MoveLastOne", 111 | "pivotX": 0, 112 | "pivotY": 0, 113 | "fieldDefs": [] 114 | } 115 | ], "tilesets": [], "enums": [], "externalEnums": [], "levelFields": [] }, 116 | "levels": [ 117 | { 118 | "identifier": "Level_0", 119 | "iid": "c620ac30-b0a0-11ee-915a-696edcf20d8d", 120 | "uid": 0, 121 | "worldX": 0, 122 | "worldY": 0, 123 | "worldDepth": 0, 124 | "pxWid": 256, 125 | "pxHei": 256, 126 | "__bgColor": "#696A79", 127 | "bgColor": null, 128 | "useAutoIdentifier": true, 129 | "bgRelPath": null, 130 | "bgPos": null, 131 | "bgPivotX": 0.5, 132 | "bgPivotY": 0.5, 133 | "__smartColor": "#ADADB5", 134 | "__bgPos": null, 135 | "externalRelPath": null, 136 | "fieldInstances": [], 137 | "layerInstances": [ 138 | { 139 | "__identifier": "Entities", 140 | "__type": "Entities", 141 | "__cWid": 16, 142 | "__cHei": 16, 143 | "__gridSize": 16, 144 | "__opacity": 1, 145 | "__pxTotalOffsetX": 0, 146 | "__pxTotalOffsetY": 0, 147 | "__tilesetDefUid": null, 148 | "__tilesetRelPath": null, 149 | "iid": "d5093370-b0a0-11ee-915a-8d583093fa95", 150 | "levelId": 0, 151 | "layerDefUid": 2, 152 | "pxOffsetX": 0, 153 | "pxOffsetY": 0, 154 | "visible": true, 155 | "optionalRules": [], 156 | "intGridCsv": [], 157 | "autoLayerTiles": [], 158 | "seed": 8974935, 159 | "overrideTilesetUid": null, 160 | "gridTiles": [], 161 | "entityInstances": [ 162 | { 163 | "__identifier": "Entity", 164 | "__grid": [0,15], 165 | "__pivot": [0,0], 166 | "__tags": [], 167 | "__tile": null, 168 | "__smartColor": "#BE4A2F", 169 | "iid": "ede362b0-b0a0-11ee-8ddc-27e3f7dc9058", 170 | "width": 16, 171 | "height": 16, 172 | "defUid": 1, 173 | "px": [0,240], 174 | "fieldInstances": [], 175 | "__worldX": 0, 176 | "__worldY": 240 177 | }, 178 | { 179 | "__identifier": "Entity", 180 | "__grid": [1,13], 181 | "__pivot": [0,0], 182 | "__tags": [], 183 | "__tile": null, 184 | "__smartColor": "#BE4A2F", 185 | "iid": "49f71390-b0a0-11ee-bb63-6127bfd37351", 186 | "width": 16, 187 | "height": 16, 188 | "defUid": 1, 189 | "px": [16,208], 190 | "fieldInstances": [], 191 | "__worldX": 16, 192 | "__worldY": 208 193 | }, 194 | { 195 | "__identifier": "Entity", 196 | "__grid": [4,12], 197 | "__pivot": [0,0], 198 | "__tags": [], 199 | "__tile": null, 200 | "__smartColor": "#BE4A2F", 201 | "iid": "4a47a490-b0a0-11ee-bb63-337a3daaf6db", 202 | "width": 16, 203 | "height": 16, 204 | "defUid": 1, 205 | "px": [64,192], 206 | "fieldInstances": [], 207 | "__worldX": 64, 208 | "__worldY": 192 209 | }, 210 | { 211 | "__identifier": "Entity", 212 | "__grid": [3,14], 213 | "__pivot": [0,0], 214 | "__tags": [], 215 | "__tile": null, 216 | "__smartColor": "#BE4A2F", 217 | "iid": "4a95eba0-b0a0-11ee-bb63-63b10b9d2706", 218 | "width": 16, 219 | "height": 16, 220 | "defUid": 1, 221 | "px": [48,224], 222 | "fieldInstances": [], 223 | "__worldX": 48, 224 | "__worldY": 224 225 | } 226 | ] 227 | } 228 | ], 229 | "__neighbours": [{ "levelIid": "a7a2f900-b0a0-11ee-ab3d-71a5b1404d9b", "dir": "n" }] 230 | }, 231 | { 232 | "identifier": "Level_1", 233 | "iid": "a7a2f900-b0a0-11ee-ab3d-71a5b1404d9b", 234 | "uid": 3, 235 | "worldX": 0, 236 | "worldY": -256, 237 | "worldDepth": 0, 238 | "pxWid": 256, 239 | "pxHei": 256, 240 | "__bgColor": "#696A79", 241 | "bgColor": null, 242 | "useAutoIdentifier": true, 243 | "bgRelPath": null, 244 | "bgPos": null, 245 | "bgPivotX": 0.5, 246 | "bgPivotY": 0.5, 247 | "__smartColor": "#ADADB5", 248 | "__bgPos": null, 249 | "externalRelPath": null, 250 | "fieldInstances": [], 251 | "layerInstances": [ 252 | { 253 | "__identifier": "Entities", 254 | "__type": "Entities", 255 | "__cWid": 16, 256 | "__cHei": 16, 257 | "__gridSize": 16, 258 | "__opacity": 1, 259 | "__pxTotalOffsetX": 0, 260 | "__pxTotalOffsetY": 0, 261 | "__tilesetDefUid": null, 262 | "__tilesetRelPath": null, 263 | "iid": "a7a32010-b0a0-11ee-ab3d-6f032a708597", 264 | "levelId": 3, 265 | "layerDefUid": 2, 266 | "pxOffsetX": 0, 267 | "pxOffsetY": 0, 268 | "visible": true, 269 | "optionalRules": [], 270 | "intGridCsv": [], 271 | "autoLayerTiles": [], 272 | "seed": 713185, 273 | "overrideTilesetUid": null, 274 | "gridTiles": [], 275 | "entityInstances": [ 276 | { 277 | "__identifier": "Entity", 278 | "__grid": [14,2], 279 | "__pivot": [0,0], 280 | "__tags": [], 281 | "__tile": null, 282 | "__smartColor": "#BE4A2F", 283 | "iid": "b1e88510-b0a0-11ee-ab3d-a130302688a2", 284 | "width": 16, 285 | "height": 16, 286 | "defUid": 1, 287 | "px": [224,32], 288 | "fieldInstances": [], 289 | "__worldX": 224, 290 | "__worldY": -224 291 | } 292 | ] 293 | } 294 | ], 295 | "__neighbours": [{ "levelIid": "c620ac30-b0a0-11ee-915a-696edcf20d8d", "dir": "s" }] 296 | } 297 | ], 298 | "worlds": [], 299 | "dummyWorldIid": "c6203700-b0a0-11ee-915a-e36cf5727c45" 300 | } -------------------------------------------------------------------------------- /reactimate-ldtk/reactimate-ldtk.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: reactimate-ldtk 3 | version: 0.1.0.0 4 | -- synopsis: 5 | -- description: 6 | license: BSD-3-Clause 7 | license-file: LICENSE 8 | author: Simre1 9 | maintainer: simre4775@gmail.com 10 | -- copyright: 11 | build-type: Simple 12 | extra-doc-files: CHANGELOG.md 13 | -- extra-source-files: 14 | 15 | common common 16 | ghc-options: -Wall 17 | default-language: GHC2021 18 | default-extensions: 19 | DataKinds 20 | DuplicateRecordFields 21 | OverloadedRecordDot 22 | build-depends: 23 | base ^>=4.17.2.1 24 | 25 | 26 | library 27 | import: common 28 | exposed-modules: 29 | Reactimate.LDtk 30 | hs-source-dirs: src 31 | build-depends: 32 | base ^>=4.17.2.1, 33 | reactimate, 34 | reactimate-game, 35 | vector, 36 | containers, 37 | unordered-containers, 38 | hashable, 39 | bytestring, 40 | text, 41 | ldtk-types, 42 | aeson, 43 | transformers 44 | 45 | executable basic-example 46 | import: common 47 | main-is: Main.hs 48 | hs-source-dirs: examples/basic-example 49 | build-depends: 50 | reactimate, 51 | reactimate-game, 52 | reactimate-ldtk, 53 | vector, 54 | colour 55 | -------------------------------------------------------------------------------- /reactimate-ldtk/src/Reactimate/LDtk.hs: -------------------------------------------------------------------------------- 1 | module Reactimate.LDtk 2 | ( withLDtkRoot, 3 | withLevel, 4 | LevelName, 5 | withMatchRules, 6 | MatchRule, 7 | Match, 8 | matchEntity, 9 | matchTiles, 10 | matchIntGrid, 11 | getLayerName, 12 | getEntityName, 13 | getEntityPosition, 14 | getGlobalEntityPosition, 15 | getEntitySize, 16 | getEntityField, 17 | getMatchObject, 18 | getLayer, 19 | getLevel, 20 | module LDtk, 21 | ) 22 | where 23 | 24 | import Control.Applicative 25 | import Data.Foldable 26 | import Data.Map qualified as M 27 | import Data.Maybe (fromMaybe) 28 | import Data.Text (Text) 29 | import LDtk 30 | import Reactimate 31 | import Reactimate.Game (V2 (..)) 32 | 33 | -- import QuickType 34 | 35 | -- | Load an `LDtk` file in the setup phase. 36 | withLDtkRoot :: FilePath -> (LDtkRoot -> Signal a b) -> Signal a b 37 | withLDtkRoot filepath = 38 | withSetup 39 | ( do 40 | maybeRoot <- loadLDtk filepath 41 | either fail pure maybeRoot 42 | ) 43 | 44 | type LevelName = Text 45 | 46 | -- | Switch to different `Level`s based on their name 47 | withLevel :: LDtkRoot -> LevelName -> (Level -> Signal a (b, Maybe LevelName)) -> Signal a b 48 | withLevel ldtkRoot initialLevel makeSignal = switchRepeatedly (makeSignal $ levels' M.! initialLevel) (makeSignal . (levels' M.!)) 49 | where 50 | allLevels = ldtkRoot.levels ++ (ldtkRoot.worlds >>= (.levels)) 51 | levels' = M.fromList $ zip ((.identifier) <$> allLevels) allLevels 52 | 53 | -- | Apply match rules in sequence to process a level. 54 | withMatchRules :: forall a. (Monoid a) => [MatchRule a] -> Level -> a 55 | withMatchRules rules level = 56 | flip foldMap level.layerInstances $ \layer -> 57 | let layerName = layer.__identifier 58 | matchers ruleMap = fromMaybe (ruleMap M.! Nothing) $ M.lookup (Just layerName) ruleMap 59 | entities = foldMap (\e -> fromMaybe mempty $ foldr ((<|>) . runMatch level layer e) Nothing (matchers entityRules)) layer.entityInstances 60 | autoTiles = fromMaybe mempty $ foldr ((<|>) . runMatch level layer layer.autoLayerTiles) Nothing (matchers tileRules) 61 | gridTiles = fromMaybe mempty $ foldr ((<|>) . runMatch level layer layer.gridTiles) Nothing (matchers tileRules) 62 | intGrid = fromMaybe mempty $ foldr ((<|>) . runMatch level layer layer.intGridCsv) Nothing (matchers intGridRules) 63 | in case layer.__type of 64 | IntGrid -> intGrid 65 | Entities -> entities 66 | Tiles -> gridTiles 67 | AutoLayer -> autoTiles 68 | where 69 | entityRules :: M.Map (Maybe Text) [Match Entity a] 70 | tileRules :: M.Map (Maybe Text) [Match [Tile] a] 71 | intGridRules :: M.Map (Maybe Text) [Match [Int] a] 72 | (entityRules, tileRules, intGridRules) = foldl' buildRulesMap (M.empty, M.empty, M.empty) rules 73 | buildRulesMap (entityRules, tileRules, intGridRules) (MatchRule maybeLayerName someMatch) = 74 | let alterF ruleMap match rules = Just $ fromMaybe [] (rules <|> M.lookup Nothing ruleMap) ++ [match] 75 | insert match key ruleMap = M.alter (alterF ruleMap match) key ruleMap 76 | in case someMatch of 77 | EntityMatch match -> (insert match Nothing $ insert match maybeLayerName entityRules, tileRules, intGridRules) 78 | TileMatch match -> (entityRules, insert match Nothing $ insert match maybeLayerName tileRules, intGridRules) 79 | IntGridMatch match -> (entityRules, tileRules, insert match Nothing $ insert match maybeLayerName intGridRules) 80 | {-# INLINE withMatchRules #-} 81 | 82 | data MatchRule a = MatchRule 83 | { matchedLayerName :: !(Maybe Text), 84 | match :: !(SomeMatch a) 85 | } 86 | 87 | matchEntity :: 88 | -- | Layer name filter 89 | Maybe Text -> 90 | Match Entity a -> 91 | MatchRule a 92 | matchEntity layerName = MatchRule layerName . EntityMatch 93 | {-# INLINE matchEntity #-} 94 | 95 | matchTiles :: 96 | -- | Layer name filter 97 | Maybe Text -> 98 | Match [Tile] a -> 99 | MatchRule a 100 | matchTiles layerName = MatchRule layerName . TileMatch 101 | {-# INLINE matchTiles #-} 102 | 103 | matchIntGrid :: 104 | -- | Layer name filter 105 | Maybe Text -> 106 | Match [Int] a -> 107 | MatchRule a 108 | matchIntGrid layerName = MatchRule layerName . IntGridMatch 109 | {-# INLINE matchIntGrid #-} 110 | 111 | data SomeMatch a = EntityMatch (Match Entity a) | TileMatch (Match [Tile] a) | IntGridMatch (Match [Int] a) 112 | 113 | newtype Match t a = Match ((Level, Layer, t) -> Maybe a) deriving (Functor) 114 | 115 | runMatch :: Level -> Layer -> t -> Match t a -> Maybe a 116 | runMatch level layer t (Match f) = f (level, layer, t) 117 | {-# INLINE runMatch #-} 118 | 119 | instance Applicative (Match t) where 120 | pure a = Match $ \_ -> pure a 121 | {-# INLINE pure #-} 122 | (Match f1) <*> (Match f2) = Match $ \l -> f1 l <*> f2 l 123 | {-# INLINE (<*>) #-} 124 | 125 | instance Monad (Match t) where 126 | (Match f1) >>= k = Match $ \l -> do 127 | a <- f1 l 128 | let (Match f2) = k a 129 | f2 l 130 | {-# INLINE (>>=) #-} 131 | 132 | instance Alternative (Match t) where 133 | (Match f1) <|> (Match f2) = Match $ \t -> f1 t <|> f2 t 134 | empty = Match $ const Nothing 135 | {-# INLINE empty #-} 136 | {-# INLINE (<|>) #-} 137 | 138 | instance MonadFail (Match t) where 139 | fail _ = Match $ const Nothing 140 | {-# INLINE fail #-} 141 | 142 | getLayer :: Match t Layer 143 | getLayer = Match $ \(_, l, _) -> pure l 144 | {-# INLINE getLayer #-} 145 | 146 | getLevel :: Match t Level 147 | getLevel = Match $ \(l, _, _) -> pure l 148 | {-# INLINE getLevel #-} 149 | 150 | getMatchObject :: Match t t 151 | getMatchObject = Match $ \(_, _, t) -> pure t 152 | {-# INLINE getMatchObject #-} 153 | 154 | getLayerName :: Match t Text 155 | getLayerName = Match $ \(_, l, _) -> pure l.__identifier 156 | {-# INLINE getLayerName #-} 157 | 158 | getEntityName :: Match Entity Text 159 | getEntityName = Match $ \(_, _, e) -> pure e.__identifier 160 | {-# INLINE getEntityName #-} 161 | 162 | -- | Bottom left entity position within a level 163 | getEntityPosition :: Match Entity (V2 Int) 164 | getEntityPosition = Match $ \(_, layer, entity) -> 165 | let (Pair x y) = entity.px 166 | (Pair pivotX pivotY) = entity.__pivot 167 | pivotOffset = fmap (`quot` 2) $ V2 entity.width entity.height * (round <$> (2 * V2 pivotX (pivotY - 1))) 168 | offset = V2 layer.__pxTotalOffsetX (-layer.__pxTotalOffsetY) 169 | in pure $ pivotOffset + offset + V2 x (layer.__cHei * layer.__gridSize - y) 170 | {-# INLINE getEntityPosition #-} 171 | 172 | getEntitySize :: Match Entity (V2 Int) 173 | getEntitySize = Match $ \(_, _, entity) -> 174 | pure $ V2 entity.width entity.height 175 | {-# INLINE getEntitySize #-} 176 | 177 | -- | Bottom left entity position based on global coordinates respecting level offsets 178 | getGlobalEntityPosition :: Match Entity (V2 Int) 179 | getGlobalEntityPosition = (+) <$> getEntityPosition <*> Match (\(level, _, _) -> pure $ V2 level.worldX (-level.worldY)) 180 | {-# INLINE getGlobalEntityPosition #-} 181 | 182 | getEntityField :: Text -> Match Entity FieldValue 183 | getEntityField fieldName = do 184 | entity <- getMatchObject 185 | maybe (fail "No field with that name") pure $ 186 | lookup fieldName $ 187 | (\field -> (field.__identifier, field.__value)) <$> entity.fieldInstances 188 | {-# INLINE getEntityField #-} 189 | -------------------------------------------------------------------------------- /reactimate-physics/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for reactimate-game 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /reactimate-physics/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2024, Simre1 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Simre1 nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /reactimate-physics/README.md: -------------------------------------------------------------------------------- 1 | # Reactimate Physics 2 | 3 | `reactimate-physics` is a library for `reactimate` for 2D physics using `chipmunk`. 4 | 5 | ## Examples 6 | 7 | There are some examples in the `examples` folder. 8 | -------------------------------------------------------------------------------- /reactimate-physics/examples/basic-example/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Data.Bool (bool) 4 | import Data.Colour.Names (black, blue, red) 5 | import Data.Vector.Storable qualified as VS 6 | import Reactimate 7 | import Reactimate.Physics2D 8 | import Reactimate.Game 9 | 10 | main :: IO () 11 | main = reactimate $ setupGame (GameConfig "Physics example" defaultWindow 60) $ \gameEnv -> 12 | withPhysics $ \space -> 13 | withSetup 14 | ( do 15 | space.gravity $= V2 0 (-200) 16 | 17 | body1 <- addDynamicBody space 1 (1 / 0) -- 1 / 0 -> locks rotation due to infinite inertia 18 | body1.position $= V2 250 300 19 | shape1 <- addBoxShape body1 (V2 100 100) 0 20 | shape1.friction $= 0.3 21 | 22 | body2 <- addDynamicBody space 1 (1 / 0) 23 | body2.position $= V2 350 500 24 | shape2 <- addBoxShape body2 (V2 100 100) 0 25 | shape2.friction $= 0.3 26 | 27 | static <- get space.staticBody 28 | static.position $= V2 300 50 29 | ground <- addBoxShape static (V2 600 100) 0 30 | ground.friction $= 0.5 31 | 32 | pure (body1, body2) 33 | ) 34 | $ \(body1, body2) -> 35 | actionIO (spaceStep space (1 / 60)) 36 | >>> arrIO (\_ -> (,) <$> get body1.position <*> get body2.position) 37 | >>> render 38 | >>> renderGame gameEnv 39 | >>> bool Nothing (Just ()) 40 | <$> sampleBehavior (gameShouldQuit gameEnv) 41 | 42 | render :: Signal (V2 Double, V2 Double) (Camera, Picture) 43 | render = 44 | arr $ \(pos1, pos2) -> 45 | ( Camera (V2 0 (-100)) (V2 800 600), 46 | makePicture 0 $ do 47 | drawRectangle (packColour red) $ Rectangle (round <$> pos1 - V2 50 50) (V2 100 100) 48 | drawRectangle (packColour blue) $ Rectangle (round <$> pos2 - V2 50 50) (V2 100 100) 49 | drawRectangle (packColour black) $ Rectangle (V2 0 0) (V2 600 100) 50 | 51 | ) 52 | -------------------------------------------------------------------------------- /reactimate-physics/examples/collision-example/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Control.Monad (when) 4 | import Data.Bool (bool) 5 | import Data.Colour.Names (black, blue, red) 6 | import Data.Foldable (traverse_) 7 | import Data.Vector.Storable qualified as VS 8 | import Reactimate 9 | import Reactimate.Physics2D 10 | import Reactimate.Game 11 | 12 | main :: IO () 13 | main = reactimate $ setupGame (GameConfig "Physics example" defaultWindow 60) $ \gameEnv -> 14 | withPhysics $ \space -> 15 | withSetup 16 | ( do 17 | space.gravity $= V2 0 (-200) 18 | 19 | body1 <- addDynamicBody space 1 (1 / 0) -- 1 / 0 -> locks rotation due to infinite inertia 20 | body1.position $= V2 250 300 21 | shape1 <- addBoxShape body1 (V2 100 100) 0 22 | shape1.friction $= 0.3 23 | 24 | body2 <- addDynamicBody space 1 (1 / 0) 25 | body2.position $= V2 350 500 26 | shape2 <- addBoxShape body2 (V2 100 100) 0 27 | shape2.friction $= 0.3 28 | 29 | static <- get space.staticBody 30 | static.position $= V2 300 50 31 | ground <- addBoxShape static (V2 600 100) 0 32 | ground.friction $= 0.5 33 | 34 | collisionEvent <- 35 | modifyDefaultCollisionHandler space $ 36 | idCollisionHandler 37 | { begin = Just $ \collision space -> do 38 | position <- collision.pointA 1 39 | 40 | (bodyA, bodyB) <- collision.bodies 41 | _ <- schedulePostStepWork space collision $ \space -> do 42 | when (bodyB == static) $ 43 | bodyApplyImpulseAtLocalPoint bodyA (V2 0 200) (V2 0 0) 44 | when (bodyA == static) $ 45 | bodyApplyImpulseAtLocalPoint bodyB (V2 0 200) (V2 0 0) 46 | 47 | bodies <- collision.bodies 48 | pure (True, Just bodies) 49 | } 50 | 51 | pure (body1, body2, collisionEvent) 52 | ) 53 | $ \(body1, body2, collisionEvent) -> 54 | actionIO (spaceStep space (1 / 60)) 55 | >>> arrIO (\_ -> (,) <$> get body1.position <*> get body2.position) 56 | >>> render 57 | >>> renderGame gameEnv 58 | >>> sampleEventAsList collisionEvent 59 | >>> arrIO 60 | ( traverse_ 61 | ( \(bodyA, bodyB) -> do 62 | posA <- get bodyA.position 63 | posB <- get bodyB.position 64 | putStrLn $ "Collision with bodies at: " ++ show posA ++ ", " ++ show posB 65 | ) 66 | ) 67 | >>> bool Nothing (Just ()) 68 | <$> sampleBehavior (gameShouldQuit gameEnv) 69 | 70 | render :: Signal (V2 Double, V2 Double) (Camera, Picture) 71 | render = 72 | arr $ \(pos1, pos2) -> 73 | ( Camera (V2 0 (-100)) (V2 800 600), 74 | makePicture 0 $ do 75 | drawRectangle (packColour red) $ Rectangle (round <$> pos1 - V2 50 50) (V2 100 100) 76 | drawRectangle (packColour blue) $ Rectangle (round <$> pos2 - V2 50 50) (V2 100 100) 77 | drawRectangle (packColour black) $ Rectangle (V2 0 0) (V2 600 100) 78 | 79 | ) 80 | -------------------------------------------------------------------------------- /reactimate-physics/examples/subspaces-example/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Data.Bool (bool) 4 | import Data.Colour.Names (black, blue, red) 5 | import Data.Vector.Storable qualified as VS 6 | import Reactimate 7 | import Reactimate.Physics2D 8 | import Reactimate.Game 9 | 10 | main :: IO () 11 | main = reactimate $ setupGame (GameConfig "Physics example" defaultWindow 60) $ \gameEnv -> 12 | withPhysics $ \space -> 13 | withSetup_ (space.gravity $= V2 0 (-200)) $ 14 | actionIO (spaceStep space (1 / 60)) 15 | >>> switchRepeatedly (setupFallingBodies space) (const $ setupFallingBodies space) 16 | >>> render 17 | >>> renderGame gameEnv 18 | >>> bool Nothing (Just ()) 19 | <$> sampleBehavior (gameShouldQuit gameEnv) 20 | 21 | render :: Signal (V2 Double, V2 Double) (Camera, Picture) 22 | render = 23 | arr $ \(pos1, pos2) -> 24 | ( Camera (V2 0 0) (V2 800 600), 25 | makePicture 0 $ do 26 | drawRectangle (packColour red) $ Rectangle (round <$> pos1 - V2 50 50) (V2 100 100) 27 | drawRectangle (packColour blue) $ Rectangle (round <$> pos2 - V2 50 50) (V2 100 100) 28 | ) 29 | 30 | -- As `setupFallingBodies` is switched out, the corresponding `Subspace` with its bodies is also removed from the `Space`. 31 | setupFallingBodies :: Space -> Signal a ((V2 Double, V2 Double), Maybe ()) 32 | setupFallingBodies space = withSubspace space $ \subspace -> withSetup (addBodies subspace (V2 400 500)) $ \(body1, body2) -> 33 | arrIO 34 | ( \_ -> do 35 | pos1@(V2 _ y1) <- get body1.position 36 | pos2@(V2 _ y2) <- get body2.position 37 | pure ((pos1, pos2), if y1 < 0 || y2 < 0 then Just () else Nothing) 38 | ) 39 | where 40 | addBodies :: Subspace -> V2 Double -> IO (Body, Body) 41 | addBodies space pos = do 42 | body1 <- addDynamicBody space 1 (1 / 0) 43 | body1.position $= pos + V2 0 100 44 | shape1 <- addBoxShape body1 (V2 100 100) 0 45 | shape1.friction $= 0.3 46 | 47 | body2 <- addDynamicBody space 1 (1 / 0) 48 | body2.position $= pos 49 | shape2 <- addBoxShape body2 (V2 100 100) 0 50 | shape2.friction $= 0.3 51 | 52 | pure (body1, body2) 53 | -------------------------------------------------------------------------------- /reactimate-physics/reactimate-physics.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: reactimate-physics 3 | version: 0.1.0.0 4 | -- synopsis: 5 | -- description: 6 | license: BSD-3-Clause 7 | license-file: LICENSE 8 | author: Simre1 9 | maintainer: simre4775@gmail.com 10 | -- copyright: 11 | category: Game 12 | build-type: Simple 13 | extra-doc-files: CHANGELOG.md 14 | -- extra-source-files: 15 | 16 | common common 17 | ghc-options: -Wall 18 | default-language: GHC2021 19 | default-extensions: 20 | OverloadedRecordDot 21 | DuplicateRecordFields 22 | LambdaCase 23 | build-depends: 24 | base ^>=4.17.2.1, 25 | vector, 26 | linear, 27 | text, 28 | colour, 29 | reactimate, 30 | containers 31 | 32 | library 33 | import: common 34 | exposed-modules: 35 | Reactimate.Physics2D 36 | 37 | hs-source-dirs: src 38 | build-depends: 39 | chiphunk, 40 | StateVar, 41 | hashable 42 | 43 | executable basic-example 44 | import: common 45 | main-is: Main.hs 46 | hs-source-dirs: examples/basic-example 47 | build-depends: 48 | reactimate-game, 49 | reactimate-physics 50 | 51 | executable subspaces-example 52 | import: common 53 | main-is: Main.hs 54 | hs-source-dirs: examples/subspaces-example 55 | build-depends: 56 | reactimate-game, 57 | reactimate-physics 58 | 59 | 60 | executable collision-example 61 | import: common 62 | main-is: Main.hs 63 | hs-source-dirs: examples/collision-example 64 | build-depends: 65 | reactimate-game, 66 | reactimate-physics 67 | 68 | -------------------------------------------------------------------------------- /reactimate-physics/screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Simre1/reactimate/5f25cf93bc1fc62c069876fb0881b1b1e52c0ad9/reactimate-physics/screenshot.png -------------------------------------------------------------------------------- /reactimate-physics/src/Reactimate/Physics2D.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | 3 | -- This module wraps functionality from the [chiphunk](https://hackage.haskell.org/package/chiphunk) library which uses the [chipmunk](https://chipmunk-physics.net/) physics library. 4 | module Reactimate.Physics2D 5 | ( withPhysics, 6 | 7 | -- * Space 8 | Space, 9 | spaceStep, 10 | withSubspace, 11 | Subspace, 12 | spaceGravity, 13 | C.spaceDamping, 14 | C.spaceIdleSpeedThreshold, 15 | C.spaceSleepTimeThreshold, 16 | C.spaceCollisionSlop, 17 | C.spaceCollisionBias, 18 | C.spaceCollisionPersistence, 19 | C.spaceCurrentTimeStep, 20 | C.spaceStaticBody, 21 | 22 | -- * Body 23 | Body, 24 | addDynamicBody, 25 | addKinematicBody, 26 | addStaticBody, 27 | removeBody, 28 | C.bodyType, 29 | C.BodyType (..), 30 | C.bodyMass, 31 | bodyPosition, 32 | bodyCenterOfGravity, 33 | bodyVelocity, 34 | bodyForce, 35 | bodyAngle, 36 | C.bodyAngularVelocity, 37 | C.bodyTorque, 38 | 39 | -- ** Moment calculation 40 | C.momentForCircle, 41 | momentForSegment, 42 | momentForPoly, 43 | C.momentForBox, 44 | 45 | -- ** Coordinate Conversion 46 | bodyLocalToWorld, 47 | bodyWorldToLocal, 48 | bodyVelocityAtWorldPoint, 49 | 50 | -- ** Apply Force 51 | bodyApplyForceAtWorldPoint, 52 | bodyApplyForceAtLocalPoint, 53 | bodyApplyImpulseAtWorldPoint, 54 | bodyApplyImpulseAtLocalPoint, 55 | 56 | -- * Shapes 57 | addCircleShape, 58 | addBoxShape, 59 | addPolyShape, 60 | addSegmentShape, 61 | removeShape, 62 | segmentShapeNeighbors, 63 | C.shapeSensor, 64 | C.shapeElasticity, 65 | C.shapeFriction, 66 | shapeSurfaceVelocity, 67 | C.shapeCollisionType, 68 | C.CollisionType, 69 | C.shapeMass, 70 | C.shapeDensity, 71 | C.shapeFilter, 72 | C.ShapeFilter (..), 73 | 74 | -- * Constraints 75 | C.Constraint, 76 | IsConstraint (..), 77 | constraintBodyA, 78 | constraintBodyB, 79 | constraintMaxForce, 80 | constraintErrorBias, 81 | constraintMaxBias, 82 | constraintCollideBodies, 83 | constraintImpulse, 84 | removeConstraint, 85 | 86 | -- ** Pin Joint 87 | PinJoint, 88 | addPinJoint, 89 | pinJointAnchorA, 90 | pinJointAnchorB, 91 | pinJointDistance, 92 | 93 | -- ** Slide Joint 94 | SlideJoint, 95 | addSlideJoint, 96 | slideJointAnchorA, 97 | slideJointAnchorB, 98 | slideJointMin, 99 | slideJointMax, 100 | 101 | -- ** Pivot Joint 102 | PivotJoint, 103 | addPivotJoint, 104 | pivotJointAnchorA, 105 | pivotJointAnchorB, 106 | addGrooveJoint, 107 | 108 | -- ** Groove Joint 109 | GrooveJoint, 110 | grooveJointGrooveA, 111 | grooveJointGrooveB, 112 | grooveJointAnchorB, 113 | 114 | -- ** Damped Spring 115 | DampedSpring, 116 | addDampedSpring, 117 | dampedSpringAnchorA, 118 | dampedSpringAnchorB, 119 | dampedSpringDistance, 120 | dampedSpringStiffness, 121 | dampedSpringDamping, 122 | 123 | -- ** Damped Rotary Spring, 124 | DampedRotarySpring, 125 | addDampedRotarySpring, 126 | dampedRotarySpringAngle, 127 | dampedRotarySpringStiffness, 128 | dampedRotarySpringDamping, 129 | 130 | -- ** Rotary Limit Joint 131 | RotaryLimitJoint, 132 | addRotaryLimitJoint, 133 | rotaryLimitJointMin, 134 | rotaryLimitJointMax, 135 | 136 | -- ** Ratchet Joint 137 | RatchetJoint, 138 | addRatchetJoint, 139 | ratchetJointAngle, 140 | ratchetJointPhase, 141 | ratchetJointRatchet, 142 | 143 | -- ** Gear Joint 144 | GearJoint, 145 | addGearJoint, 146 | gearJointPhase, 147 | gearJointRatio, 148 | 149 | -- ** Simple Motor 150 | SimpleMotor, 151 | addSimpleMotor, 152 | simpleMotorRate, 153 | 154 | -- * Collisions 155 | Collision, 156 | ModifiableCollision, 157 | 158 | -- ** Collision properties 159 | collisionRestitution, 160 | modifiableCollisionRestitution, 161 | collisionFriction, 162 | modifiableCollisionFriction, 163 | collisionSurfaceVelocity, 164 | modifiableCollisionSurfaceVelocity, 165 | collisionCount, 166 | modifiableCollisionCount, 167 | collisionNormal, 168 | modifiableCollisionNormal, 169 | collisionPointA, 170 | modifiableCollisionPointA, 171 | collisionPointB, 172 | modifiableCollisionPointB, 173 | collisionDepth, 174 | modifiableCollisionDepth, 175 | collisionIsFirstContact, 176 | modifiableCollisionIsFirstContact, 177 | collisionIsRemoval, 178 | modifiableCollisionIsRemoval, 179 | collisionShapes, 180 | modifiableCollisionShapes, 181 | collisionBodies, 182 | modifiableCollisionBodies, 183 | 184 | -- ** Modify Collision Handlers 185 | ModifyCollisionHandler (..), 186 | CollisionSpace, 187 | idCollisionHandler, 188 | modifyCollisionHandler, 189 | modifyWildcardCollisionHandler, 190 | modifyDefaultCollisionHandler, 191 | 192 | -- *** Safely change objects 193 | schedulePostStepWork, 194 | alwaysSchedulePostStepWork, 195 | 196 | -- *** Invoke more general handlers 197 | handleWildcardBeginA, 198 | handleWildcardBeginB, 199 | handleWildcardPreSolveA, 200 | handleWildcardPreSolveB, 201 | handleWildcardPostSolveA, 202 | handleWildcardPostSolveB, 203 | handleWildcardSeparateA, 204 | handleWildcardSeparateB, 205 | 206 | -- * StateVar 207 | StateVar, 208 | GettableStateVar, 209 | SettableStateVar, 210 | HasGetter (..), 211 | HasSetter (..), 212 | ) 213 | where 214 | 215 | import Chiphunk.Low (Body, Shape, Space, Vect (..)) 216 | import Chiphunk.Low qualified as C 217 | import Control.Monad (forM_, when) 218 | import Data.Foldable (traverse_) 219 | import Data.Hashable (Hashable (hash)) 220 | import Data.IORef 221 | import Data.IntMap.Strict qualified as IM 222 | import Data.Map.Strict qualified as M 223 | import Data.Maybe (isJust) 224 | import Data.Set qualified as S 225 | import Data.StateVar 226 | import Data.Unique (newUnique) 227 | import Data.Word (Word32) 228 | import Foreign (Storable (..)) 229 | import Foreign.Marshal (malloc) 230 | import Foreign.Marshal.Alloc (free) 231 | import Foreign.Ptr (castPtr) 232 | import Foreign.StablePtr 233 | import GHC.Records (HasField (..)) 234 | import Linear.V2 235 | import Reactimate 236 | import Reactimate.Signal (unSignal, withFinalizer) 237 | import Unsafe.Coerce (unsafeCoerce) 238 | 239 | -- SPACE 240 | 241 | -- | Allocates a `Space`, which is used for physics simulation. 242 | -- 243 | -- Do not use `Space` outside the signal. The `Space` will be freed when this signal function does not run anymore. 244 | withPhysics :: (Space -> Signal a b) -> Signal a b 245 | withPhysics = 246 | allocateResource 247 | ( \fin -> do 248 | space <- C.spaceNew 249 | 250 | postStepCallbacks <- newIORef emptyPostStepCallbacks 251 | stablePostStepCallbacks <- newStablePtr postStepCallbacks 252 | 253 | C.spaceUserData space $= castStablePtrToPtr stablePostStepCallbacks 254 | 255 | addFinalizer fin $ do 256 | shapesRef <- newIORef [] 257 | bodiesRef <- newIORef [] 258 | constraintsRef <- newIORef [] 259 | 260 | C.spaceEachShape space (\shape _ -> modifyIORef' shapesRef (shape :)) C.nullPtr 261 | 262 | C.spaceEachBody space (\body _ -> modifyIORef' bodiesRef (body :)) C.nullPtr 263 | 264 | C.spaceEachConstraint space (\body _ -> modifyIORef' constraintsRef (body :)) C.nullPtr 265 | 266 | C.spaceFree space 267 | 268 | shapes <- readIORef shapesRef 269 | forM_ shapes C.shapeFree 270 | 271 | constraints <- readIORef constraintsRef 272 | forM_ constraints C.constraintFree 273 | 274 | bodies <- readIORef bodiesRef 275 | forM_ bodies C.bodyFree 276 | pure space 277 | ) 278 | 279 | spaceStep :: Space -> Double -> IO () 280 | spaceStep space time = do 281 | C.spaceStep space time 282 | ptr <- get (C.spaceUserData space) 283 | postStepCallbacks <- deRefStablePtr (castPtrToStablePtr ptr) 284 | PostStepCallbacks unkeyed keyed <- readIORef postStepCallbacks 285 | writeIORef postStepCallbacks emptyPostStepCallbacks 286 | unkeyed 287 | forM_ keyed id 288 | 289 | -- | Global gravity applied to the space. Defaults to (V2 0 0). 290 | spaceGravity :: Space -> StateVar (V2 Double) 291 | spaceGravity space = mapStateVar v2ToVect vectToV2 (C.spaceGravity space) 292 | 293 | instance HasField "gravity" Space (StateVar (V2 Double)) where 294 | getField = spaceGravity 295 | 296 | instance HasField "damping" Space (StateVar Double) where 297 | getField = C.spaceDamping 298 | 299 | instance HasField "idleSpeedThreshold" Space (StateVar Double) where 300 | getField = C.spaceIdleSpeedThreshold 301 | 302 | instance HasField "sleepTimeThreshold" Space (StateVar Double) where 303 | getField = C.spaceSleepTimeThreshold 304 | 305 | instance HasField "collisionSlop" Space (StateVar Double) where 306 | getField = C.spaceCollisionSlop 307 | 308 | instance HasField "collisionBias" Space (StateVar Double) where 309 | getField = C.spaceCollisionBias 310 | 311 | instance HasField "collisionPersistence" Space (StateVar Word32) where 312 | getField = C.spaceCollisionPersistence 313 | 314 | instance HasField "currentTimeStep" Space (GettableStateVar Double) where 315 | getField = C.spaceCurrentTimeStep 316 | 317 | instance HasField "staticBody" Space (GettableStateVar Body) where 318 | getField = C.spaceStaticBody 319 | 320 | -- | A `Subspace` is a part of a `Space` and can be used to manage groups of bodies. 321 | -- If a `Subspace` is switched out, all its `Body`s are removed. 322 | data Subspace = Subspace 323 | { space :: Space, 324 | bodies :: StablePtr (IORef (S.Set Body)) 325 | } 326 | 327 | class IsSpace space where 328 | getSpace :: space -> Space 329 | addBody :: space -> Body -> IO () 330 | 331 | removeAndFreeBodyFromSpace :: Space -> Body -> IO () 332 | removeAndFreeBodyFromSpace space body = do 333 | shapesRef <- newIORef [] 334 | constraintsRef <- newIORef [] 335 | 336 | C.bodyEachShape 337 | body 338 | ( \_ shape _ -> modifyIORef' shapesRef (shape :) 339 | ) 340 | C.nullPtr 341 | 342 | C.bodyEachConstraint 343 | body 344 | ( \_ constraint _ -> modifyIORef' constraintsRef (constraint :) 345 | ) 346 | C.nullPtr 347 | 348 | constraints <- readIORef constraintsRef 349 | forM_ constraints $ \constraint -> do 350 | C.spaceRemoveConstraint space constraint 351 | C.constraintFree constraint 352 | 353 | shapes <- readIORef shapesRef 354 | forM_ shapes $ \shape -> do 355 | C.spaceRemoveShape space shape 356 | C.shapeFree shape 357 | 358 | C.spaceRemoveBody space body 359 | C.bodyFree body 360 | 361 | -- | Removes a `Body` and it's shapes from the `Space`. You may not use the `Body` afterwards. 362 | removeBody :: Body -> IO () 363 | removeBody body = do 364 | space <- get (C.bodySpace body) 365 | bodiesPtr <- get (C.bodyUserData body) 366 | when (bodiesPtr /= C.nullPtr) $ do 367 | bodiesRef <- deRefStablePtr (castPtrToStablePtr bodiesPtr) 368 | modifyIORef' bodiesRef (S.delete body) 369 | removeAndFreeBodyFromSpace space body 370 | 371 | instance IsSpace Space where 372 | getSpace = id 373 | addBody space body = do 374 | C.spaceAddBody space body 375 | C.bodyUserData body $= C.nullPtr 376 | 377 | instance IsSpace Subspace where 378 | getSpace = (.space) 379 | addBody (Subspace space bodiesPtr) body = do 380 | C.spaceAddBody space body 381 | C.bodyUserData body $= castStablePtrToPtr bodiesPtr 382 | bodies <- deRefStablePtr bodiesPtr 383 | modifyIORef' bodies $ S.insert body 384 | 385 | -- | Creates a `Subspace` which keeps tracks of its contained bodies. All bodies of 386 | -- the `Subspace` get deleted after the `withSubspace` gets switched out. 387 | withSubspace :: (IsSpace space) => space -> (Subspace -> Signal a b) -> Signal a b 388 | withSubspace space = allocateResource $ \fin -> do 389 | bodiesRef <- newIORef S.empty 390 | addFinalizer fin $ do 391 | bodies <- readIORef bodiesRef 392 | forM_ bodies $ \body -> 393 | removeAndFreeBodyFromSpace (getSpace space) body 394 | bodiesPtr <- newStablePtr bodiesRef 395 | pure $ Subspace (getSpace space) bodiesPtr 396 | 397 | -- BODIES 398 | 399 | -- | Add a dynamic body with mass and inertia. 400 | addDynamicBody :: 401 | (IsSpace space) => 402 | space -> 403 | -- | Mass of the body 404 | Double -> 405 | -- | Moment of the body. It's best to use the `moment*` functions for this. 406 | Double -> 407 | IO Body 408 | addDynamicBody space mass inertia = do 409 | body <- C.bodyNew mass inertia 410 | addBody space body 411 | pure body 412 | 413 | -- | Add a kinematic body which is not affected by forces. Control it by setting it's velocity 414 | addKinematicBody :: (IsSpace space) => space -> IO Body 415 | addKinematicBody space = do 416 | body <- C.bodyNewKinematic 417 | addBody space body 418 | pure body 419 | 420 | -- | Add a static body. Static bodies have infinite mass and you should not move them. 421 | addStaticBody :: (IsSpace space) => space -> IO Body 422 | addStaticBody space = do 423 | body <- C.bodyNewStatic 424 | addBody space body 425 | pure body 426 | 427 | -- | World position of the body 428 | bodyPosition :: Body -> StateVar (V2 Double) 429 | bodyPosition body = 430 | let bodyPos = C.bodyPosition body 431 | in makeStateVar 432 | (vectToV2 <$> get bodyPos) 433 | ( \pos -> do 434 | bodyPos $= v2ToVect pos 435 | space <- get (C.bodySpace body) 436 | C.spaceReindexShapesForBody space body 437 | ) 438 | 439 | -- | Rotation of the angle 440 | bodyAngle :: Body -> StateVar Double 441 | bodyAngle body = 442 | let bodyAngle' = C.bodyAngle body 443 | in makeStateVar 444 | (get bodyAngle') 445 | ( \angle -> do 446 | bodyAngle' $= angle 447 | space <- get (C.bodySpace body) 448 | C.spaceReindexShapesForBody space body 449 | ) 450 | 451 | -- | Location of the center of gravity in body local coordinates. 452 | -- The default value is (0, 0), meaning the center of gravity is the same as the position of the body. 453 | bodyCenterOfGravity :: Body -> StateVar (V2 Double) 454 | bodyCenterOfGravity body = mapStateVar v2ToVect vectToV2 (C.bodyCenterOfGravity body) 455 | 456 | -- | Linear velocity of the center of gravity of the body 457 | bodyVelocity :: Body -> StateVar (V2 Double) 458 | bodyVelocity body = mapStateVar v2ToVect vectToV2 (C.bodyVelocity body) 459 | 460 | -- | Force applied to the center of gravity of the body. This value is reset for every time step. 461 | bodyForce :: Body -> StateVar (V2 Double) 462 | bodyForce body = mapStateVar v2ToVect vectToV2 (C.bodyForce body) 463 | 464 | -- | Calculate the moment of inertia for a line segment. The endpoints a and b are relative to the body. 465 | momentForSegment :: 466 | -- | Mass 467 | Double -> 468 | -- | Start 469 | V2 Double -> 470 | -- | End 471 | V2 Double -> 472 | -- | Thickness 473 | Double -> 474 | Double 475 | momentForSegment mass start end = C.momentForSegment mass (v2ToVect start) (v2ToVect end) 476 | 477 | -- Calculate the moment of inertia for a solid polygon shape assuming its center of gravity is at its centroid. The offset is added to each vertex. 478 | momentForPoly :: 479 | -- | Mass 480 | Double -> 481 | -- | Vertices 482 | [V2 Double] -> 483 | -- | Offset 484 | V2 Double -> 485 | -- | Thickness 486 | Double -> 487 | Double 488 | momentForPoly mass vertices offset = C.momentForPoly mass (fmap v2ToVect vertices) (v2ToVect offset) 489 | 490 | -- | Convert from body local coordinates to world space coordinates 491 | bodyLocalToWorld :: Body -> V2 Double -> IO (V2 Double) 492 | bodyLocalToWorld body local = vectToV2 <$> C.bodyLocalToWorld body (v2ToVect local) 493 | 494 | -- | Convert from world space coordinates to body local coordinates. 495 | bodyWorldToLocal :: Body -> V2 Double -> IO (V2 Double) 496 | bodyWorldToLocal body world = vectToV2 <$> C.bodyWorldToLocal body (v2ToVect world) 497 | 498 | -- | Absolute velocity of the rigid body at the given world point. 499 | bodyVelocityAtWorldPoint :: Body -> V2 Double -> IO (V2 Double) 500 | bodyVelocityAtWorldPoint body world = vectToV2 <$> C.bodyVelocityAtWorldPoint body (v2ToVect world) 501 | 502 | -- | Add the force to body as if applied from the world point. 503 | bodyApplyForceAtWorldPoint :: 504 | Body -> 505 | -- | force 506 | V2 Double -> 507 | -- | point 508 | V2 Double -> 509 | IO () 510 | bodyApplyForceAtWorldPoint body force point = C.bodyApplyForceAtWorldPoint body (v2ToVect force) (v2ToVect point) 511 | 512 | -- | Add the local force to body as if applied from the body local point. 513 | bodyApplyForceAtLocalPoint :: 514 | Body -> 515 | -- | force 516 | V2 Double -> 517 | -- | point 518 | V2 Double -> 519 | IO () 520 | bodyApplyForceAtLocalPoint body force point = C.bodyApplyForceAtLocalPoint body (v2ToVect force) (v2ToVect point) 521 | 522 | -- | Add the impulse to body as if applied from the world point. 523 | bodyApplyImpulseAtWorldPoint :: 524 | Body -> 525 | -- | impulse 526 | V2 Double -> 527 | -- | point 528 | V2 Double -> 529 | IO () 530 | bodyApplyImpulseAtWorldPoint body impulse point = C.bodyApplyImpulseAtWorldPoint body (v2ToVect impulse) (v2ToVect point) 531 | 532 | -- | Add the local impulse to body as if applied from the body local point. 533 | bodyApplyImpulseAtLocalPoint :: 534 | Body -> 535 | -- | impulse 536 | V2 Double -> 537 | -- | point 538 | V2 Double -> 539 | IO () 540 | bodyApplyImpulseAtLocalPoint body impulse point = C.bodyApplyImpulseAtLocalPoint body (v2ToVect impulse) (v2ToVect point) 541 | 542 | instance HasField "position" Body (StateVar (V2 Double)) where 543 | getField = bodyPosition 544 | 545 | instance HasField "centerOfGravity" Body (StateVar (V2 Double)) where 546 | getField = bodyCenterOfGravity 547 | 548 | instance HasField "velocity" Body (StateVar (V2 Double)) where 549 | getField = bodyVelocity 550 | 551 | instance HasField "force" Body (StateVar (V2 Double)) where 552 | getField = bodyForce 553 | 554 | instance HasField "angle" Body (StateVar Double) where 555 | getField = C.bodyAngle 556 | 557 | instance HasField "angularVelocity" Body (StateVar Double) where 558 | getField = C.bodyAngularVelocity 559 | 560 | instance HasField "torque" Body (StateVar Double) where 561 | getField = C.bodyTorque 562 | 563 | -- SHAPES 564 | addCircleShape :: 565 | Body -> 566 | -- | Radius 567 | Double -> 568 | -- | Offset from the body coordinates 569 | V2 Double -> 570 | IO Shape 571 | addCircleShape body radius centerOfGravity = do 572 | shape <- C.circleShapeNew body radius (v2ToVect centerOfGravity) 573 | space <- get $ C.bodySpace body 574 | C.spaceAddShape space shape 575 | pure shape 576 | 577 | -- | Add a box shape centered around the body center 578 | addBoxShape :: 579 | Body -> 580 | -- | Box size 581 | V2 Double -> 582 | -- | Radius for smooth edges 583 | Double -> 584 | IO Shape 585 | addBoxShape body (V2 height width) boxRadius = do 586 | shape <- C.boxShapeNew body height width boxRadius 587 | space <- get $ C.bodySpace body 588 | C.spaceAddShape space shape 589 | pure shape 590 | 591 | addSegmentShape :: 592 | Body -> 593 | -- | Start point 594 | V2 Double -> 595 | -- | End point 596 | V2 Double -> 597 | -- | Thickness 598 | Double -> 599 | IO Shape 600 | addSegmentShape body start end thickness = do 601 | shape <- C.segmentShapeNew body (v2ToVect start) (v2ToVect end) thickness 602 | space <- get $ C.bodySpace body 603 | C.spaceAddShape space shape 604 | pure shape 605 | 606 | addPolyShape :: 607 | Body -> 608 | -- | Vertices local to body 609 | [V2 Double] -> 610 | IO Shape 611 | addPolyShape body vects = do 612 | shape <- C.polyShapeNew body (fmap v2ToVect vects) (C.Transform 0 0 0 0 0 0) 0 613 | space <- get $ C.bodySpace body 614 | C.spaceAddShape space shape 615 | pure shape 616 | 617 | -- | Remove a shape from its 'Body' 618 | removeShape :: Shape -> IO () 619 | removeShape shape = do 620 | space <- get (C.shapeSpace shape) 621 | C.spaceRemoveShape space shape 622 | C.shapeFree shape 623 | 624 | -- | When you have a number of segment shapes that are all joined together, things can still collide with the “cracks” between the segments. 625 | -- By setting the neighbor segment endpoints you can tell Chipmunk to avoid colliding with the inner parts of the crack. 626 | segmentShapeNeighbors :: Shape -> SettableStateVar (V2 Double, V2 Double) 627 | segmentShapeNeighbors shape = makeSettableStateVar $ \(v1, v2) -> C.segmentShapeNeighbors shape C.$= (v2ToVect v1, v2ToVect v2) 628 | 629 | -- | The surface velocity of the object. Useful for creating conveyor belts or players that move around. 630 | -- This value is only used when calculating friction, not resolving the collision. 631 | shapeSurfaceVelocity :: Shape -> StateVar (V2 Double) 632 | shapeSurfaceVelocity shape = mapStateVar v2ToVect vectToV2 (C.shapeSurfaceVelocity shape) 633 | 634 | instance HasField "sensor" Shape (StateVar Bool) where 635 | getField = C.shapeSensor 636 | 637 | instance HasField "elasticity" Shape (StateVar Double) where 638 | getField = C.shapeElasticity 639 | 640 | instance HasField "friction" Shape (StateVar Double) where 641 | getField = C.shapeFriction 642 | 643 | instance HasField "surfaceVelocity" Shape (StateVar (V2 Double)) where 644 | getField = shapeSurfaceVelocity 645 | 646 | instance HasField "collisionType" Shape (StateVar C.CollisionType) where 647 | getField = C.shapeCollisionType 648 | 649 | instance HasField "mass" Shape (StateVar Double) where 650 | getField = C.shapeMass 651 | 652 | instance HasField "density" Shape (StateVar Double) where 653 | getField = C.shapeDensity 654 | 655 | instance HasField "filter" Shape (StateVar C.ShapeFilter) where 656 | getField = C.shapeFilter 657 | 658 | -- CONSTRAINTS 659 | 660 | class IsConstraint c where 661 | getConstraint :: c -> C.Constraint 662 | 663 | instance IsConstraint C.Constraint where 664 | getConstraint = id 665 | 666 | -- | The first body constraint is attached to 667 | constraintBodyA :: (IsConstraint c) => c -> GettableStateVar Body 668 | constraintBodyA = C.constraintBodyA . getConstraint 669 | 670 | -- | The second body constraint is attached to 671 | constraintBodyB :: (IsConstraint c) => c -> GettableStateVar Body 672 | constraintBodyB = C.constraintBodyB . getConstraint 673 | 674 | -- | The maximum force that the constraint can use to act on the two bodies. Defaults to INFINITY. 675 | constraintMaxForce :: (IsConstraint c) => c -> StateVar Double 676 | constraintMaxForce = C.constraintMaxForce . getConstraint 677 | 678 | -- | The percentage of joint error that remains unfixed after a second. This works exactly the same as the collision bias property of a space, but applies to fixing error (stretching) of joints instead of overlapping collisions. 679 | constraintErrorBias :: (IsConstraint c) => c -> StateVar Double 680 | constraintErrorBias = C.constraintErrorBias . getConstraint 681 | 682 | -- | Get the maximum speed at which the constraint can apply error correction. Defaults to INFINITY. 683 | constraintMaxBias :: (IsConstraint c) => c -> StateVar Double 684 | constraintMaxBias = C.constraintMaxBias . getConstraint 685 | 686 | -- | Constraints can be used for filtering collisions too. When two bodies collide, Chipmunk ignores the collisions if this property is set to False on any constraint that connects the two bodies. Defaults to True. 687 | -- 688 | -- This can be used to create a chain that self collides, but adjacent links in the chain do not collide. 689 | constraintCollideBodies :: (IsConstraint c) => c -> StateVar Bool 690 | constraintCollideBodies = C.constraintCollideBodies . getConstraint 691 | 692 | -- | The most recent impulse that constraint applied. To convert this to a force, divide by the timestep passed to spaceStep. You can use this to implement breakable joints to check if the force they attempted to apply exceeded a certain threshold. 693 | constraintImpulse :: (IsConstraint c) => c -> GettableStateVar Double 694 | constraintImpulse = C.constraintImpulse . getConstraint 695 | 696 | -- | Remove a constraint from its bodies 697 | removeConstraint :: (IsConstraint c) => c -> IO () 698 | removeConstraint c = do 699 | let constraint = getConstraint c 700 | space <- C.constraintSpace constraint 701 | C.spaceRemoveConstraint space constraint 702 | C.constraintFree constraint 703 | 704 | -- | Connect two bodies via anchor points on those bodies. The distance between the two anchor points is measured when the joint is created. 705 | -- If you want to set a specific distance, use the setter function to override it 706 | newtype PinJoint = PinJoint C.Constraint 707 | 708 | instance IsConstraint PinJoint where 709 | getConstraint (PinJoint c) = c 710 | 711 | instance HasField "bodyA" PinJoint (GettableStateVar Body) where 712 | getField = constraintBodyA 713 | 714 | instance HasField "bodyB" PinJoint (GettableStateVar Body) where 715 | getField = constraintBodyB 716 | 717 | instance HasField "maxForce" PinJoint (StateVar Double) where 718 | getField = constraintMaxForce 719 | 720 | instance HasField "errorBias" PinJoint (StateVar Double) where 721 | getField = constraintErrorBias 722 | 723 | instance HasField "maxBias" PinJoint (StateVar Double) where 724 | getField = constraintMaxBias 725 | 726 | instance HasField "collideBodies" PinJoint (StateVar Bool) where 727 | getField = constraintCollideBodies 728 | 729 | instance HasField "impulse" PinJoint (GettableStateVar Double) where 730 | getField = constraintImpulse 731 | 732 | addPinJoint :: 733 | -- | body 1 734 | Body -> 735 | -- | anchor 1 736 | V2 Double -> 737 | -- | body 2 738 | Body -> 739 | -- | anchor 2 740 | V2 Double -> 741 | IO PinJoint 742 | addPinJoint body1 anchor1 body2 anchor2 = do 743 | pinJoint <- C.pinJointNew body1 body2 (v2ToVect anchor1) (v2ToVect anchor2) 744 | space <- get (C.bodySpace body1) 745 | C.spaceAddConstraint space pinJoint 746 | pure $ PinJoint pinJoint 747 | 748 | pinJointAnchorA :: PinJoint -> StateVar (V2 Double) 749 | pinJointAnchorA (PinJoint c) = mapStateVar v2ToVect vectToV2 (C.pinJointAnchorA c) 750 | 751 | pinJointAnchorB :: PinJoint -> StateVar (V2 Double) 752 | pinJointAnchorB (PinJoint c) = mapStateVar v2ToVect vectToV2 (C.pinJointAnchorB c) 753 | 754 | pinJointDistance :: PinJoint -> StateVar Double 755 | pinJointDistance (PinJoint c) = C.pinJointDist c 756 | 757 | instance HasField "anchorA" PinJoint (StateVar (V2 Double)) where 758 | getField = pinJointAnchorA 759 | 760 | instance HasField "anchorB" PinJoint (StateVar (V2 Double)) where 761 | getField = pinJointAnchorB 762 | 763 | instance HasField "distance" PinJoint (StateVar Double) where 764 | getField = pinJointDistance 765 | 766 | -- | Connect two bodies via anchor points forcing distance to remain in range. 767 | newtype SlideJoint = SlideJoint C.Constraint 768 | 769 | instance IsConstraint SlideJoint where 770 | getConstraint (SlideJoint c) = c 771 | 772 | instance HasField "bodyA" SlideJoint (GettableStateVar Body) where 773 | getField = constraintBodyA 774 | 775 | instance HasField "bodyB" SlideJoint (GettableStateVar Body) where 776 | getField = constraintBodyB 777 | 778 | instance HasField "maxForce" SlideJoint (StateVar Double) where 779 | getField = constraintMaxForce 780 | 781 | instance HasField "errorBias" SlideJoint (StateVar Double) where 782 | getField = constraintErrorBias 783 | 784 | instance HasField "maxBias" SlideJoint (StateVar Double) where 785 | getField = constraintMaxBias 786 | 787 | instance HasField "collideBodies" SlideJoint (StateVar Bool) where 788 | getField = constraintCollideBodies 789 | 790 | instance HasField "impulse" SlideJoint (GettableStateVar Double) where 791 | getField = constraintImpulse 792 | 793 | addSlideJoint :: 794 | -- | body 1 795 | Body -> 796 | -- | anchor 1 797 | V2 Double -> 798 | -- | body 2 799 | Body -> 800 | -- | anchor 2 801 | V2 Double -> 802 | -- | minimum distance 803 | Double -> 804 | -- | maximum distance 805 | Double -> 806 | IO SlideJoint 807 | addSlideJoint body1 anchor1 body2 anchor2 minDistance maxDistance = do 808 | slideJoint <- C.slideJointNew body1 body2 (v2ToVect anchor1) (v2ToVect anchor2) minDistance maxDistance 809 | space <- get (C.bodySpace body1) 810 | C.spaceAddConstraint space slideJoint 811 | pure $ SlideJoint slideJoint 812 | 813 | slideJointAnchorA :: SlideJoint -> StateVar (V2 Double) 814 | slideJointAnchorA (SlideJoint c) = mapStateVar v2ToVect vectToV2 (C.slideJointAnchorA c) 815 | 816 | slideJointAnchorB :: SlideJoint -> StateVar (V2 Double) 817 | slideJointAnchorB (SlideJoint c) = mapStateVar v2ToVect vectToV2 (C.slideJointAnchorB c) 818 | 819 | slideJointMin :: SlideJoint -> StateVar Double 820 | slideJointMin (SlideJoint c) = C.slideJointMin c 821 | 822 | slideJointMax :: SlideJoint -> StateVar Double 823 | slideJointMax (SlideJoint c) = C.slideJointMax c 824 | 825 | instance HasField "anchorA" SlideJoint (StateVar (V2 Double)) where 826 | getField = slideJointAnchorA 827 | 828 | instance HasField "anchorB" SlideJoint (StateVar (V2 Double)) where 829 | getField = slideJointAnchorB 830 | 831 | instance HasField "min" SlideJoint (StateVar Double) where 832 | getField = slideJointMin 833 | 834 | instance HasField "max" SlideJoint (StateVar Double) where 835 | getField = slideJointMax 836 | 837 | newtype PivotJoint = PivotJoint C.Constraint 838 | 839 | instance IsConstraint PivotJoint where 840 | getConstraint (PivotJoint c) = c 841 | 842 | instance HasField "bodyA" PivotJoint (GettableStateVar Body) where 843 | getField = constraintBodyA 844 | 845 | instance HasField "bodyB" PivotJoint (GettableStateVar Body) where 846 | getField = constraintBodyB 847 | 848 | instance HasField "maxForce" PivotJoint (StateVar Double) where 849 | getField = constraintMaxForce 850 | 851 | instance HasField "errorBias" PivotJoint (StateVar Double) where 852 | getField = constraintErrorBias 853 | 854 | instance HasField "maxBias" PivotJoint (StateVar Double) where 855 | getField = constraintMaxBias 856 | 857 | instance HasField "collideBodies" PivotJoint (StateVar Bool) where 858 | getField = constraintCollideBodies 859 | 860 | instance HasField "impulse" PivotJoint (GettableStateVar Double) where 861 | getField = constraintImpulse 862 | 863 | addPivotJoint :: 864 | -- | body 1 865 | Body -> 866 | -- | anchor 1 867 | V2 Double -> 868 | -- | body 2 869 | Body -> 870 | -- | anchor 2 871 | V2 Double -> 872 | IO PivotJoint 873 | addPivotJoint body1 anchor1 body2 anchor2 = do 874 | pivotJoint <- C.pivotJointNew2 body1 body2 (v2ToVect anchor1) (v2ToVect anchor2) 875 | space <- get (C.bodySpace body1) 876 | C.spaceAddConstraint space pivotJoint 877 | pure $ PivotJoint pivotJoint 878 | 879 | pivotJointAnchorA :: PivotJoint -> StateVar (V2 Double) 880 | pivotJointAnchorA (PivotJoint c) = mapStateVar v2ToVect vectToV2 (C.pivotJointAnchorA c) 881 | 882 | pivotJointAnchorB :: PivotJoint -> StateVar (V2 Double) 883 | pivotJointAnchorB (PivotJoint c) = mapStateVar v2ToVect vectToV2 (C.pivotJointAnchorB c) 884 | 885 | instance HasField "anchorA" PivotJoint (StateVar (V2 Double)) where 886 | getField = pivotJointAnchorA 887 | 888 | instance HasField "anchorB" PivotJoint (StateVar (V2 Double)) where 889 | getField = pivotJointAnchorB 890 | 891 | -- | Pivot is attached to groove on first body and to anchor on the second. All coordinates are body local. 892 | newtype GrooveJoint = GrooveJoint C.Constraint 893 | 894 | instance IsConstraint GrooveJoint where 895 | getConstraint (GrooveJoint c) = c 896 | 897 | instance HasField "bodyA" GrooveJoint (GettableStateVar Body) where 898 | getField = constraintBodyA 899 | 900 | instance HasField "bodyB" GrooveJoint (GettableStateVar Body) where 901 | getField = constraintBodyB 902 | 903 | instance HasField "maxForce" GrooveJoint (StateVar Double) where 904 | getField = constraintMaxForce 905 | 906 | instance HasField "errorBias" GrooveJoint (StateVar Double) where 907 | getField = constraintErrorBias 908 | 909 | instance HasField "maxBias" GrooveJoint (StateVar Double) where 910 | getField = constraintMaxBias 911 | 912 | instance HasField "collideBodies" GrooveJoint (StateVar Bool) where 913 | getField = constraintCollideBodies 914 | 915 | instance HasField "impulse" GrooveJoint (GettableStateVar Double) where 916 | getField = constraintImpulse 917 | 918 | addGrooveJoint :: 919 | -- | body 1 920 | Body -> 921 | -- | endpoint 1 on body 1 922 | V2 Double -> 923 | -- | endpoint 2 on body 1 924 | V2 Double -> 925 | -- | body 2 926 | Body -> 927 | -- | anchor on body 2 928 | V2 Double -> 929 | IO GrooveJoint 930 | addGrooveJoint body1 endpoint1 endpoint2 body2 anchor = do 931 | grooveJoint <- C.grooveJointNew body1 body2 (v2ToVect endpoint1) (v2ToVect endpoint2) (v2ToVect anchor) 932 | space <- get (C.bodySpace body1) 933 | C.spaceAddConstraint space grooveJoint 934 | pure $ GrooveJoint grooveJoint 935 | 936 | grooveJointGrooveA :: GrooveJoint -> StateVar (V2 Double) 937 | grooveJointGrooveA (GrooveJoint c) = mapStateVar v2ToVect vectToV2 (C.grooveJointGrooveA c) 938 | 939 | grooveJointGrooveB :: GrooveJoint -> StateVar (V2 Double) 940 | grooveJointGrooveB (GrooveJoint c) = mapStateVar v2ToVect vectToV2 (C.grooveJointGrooveB c) 941 | 942 | grooveJointAnchorB :: GrooveJoint -> StateVar (V2 Double) 943 | grooveJointAnchorB (GrooveJoint c) = mapStateVar v2ToVect vectToV2 (C.grooveJointAnchorB c) 944 | 945 | instance HasField "grooveA" GrooveJoint (StateVar (V2 Double)) where 946 | getField = grooveJointGrooveA 947 | 948 | instance HasField "grooveB" GrooveJoint (StateVar (V2 Double)) where 949 | getField = grooveJointGrooveB 950 | 951 | instance HasField "anchorB" GrooveJoint (StateVar (V2 Double)) where 952 | getField = grooveJointAnchorB 953 | 954 | newtype DampedSpring = DampedSpring C.Constraint 955 | 956 | instance IsConstraint DampedSpring where 957 | getConstraint (DampedSpring c) = c 958 | 959 | instance HasField "bodyA" DampedSpring (GettableStateVar Body) where 960 | getField = constraintBodyA 961 | 962 | instance HasField "bodyB" DampedSpring (GettableStateVar Body) where 963 | getField = constraintBodyB 964 | 965 | instance HasField "maxForce" DampedSpring (StateVar Double) where 966 | getField = constraintMaxForce 967 | 968 | instance HasField "errorBias" DampedSpring (StateVar Double) where 969 | getField = constraintErrorBias 970 | 971 | instance HasField "maxBias" DampedSpring (StateVar Double) where 972 | getField = constraintMaxBias 973 | 974 | instance HasField "collideBodies" DampedSpring (StateVar Bool) where 975 | getField = constraintCollideBodies 976 | 977 | instance HasField "impulse" DampedSpring (GettableStateVar Double) where 978 | getField = constraintImpulse 979 | 980 | addDampedSpring :: 981 | -- | body 1 982 | Body -> 983 | -- | anchor 1 984 | V2 Double -> 985 | -- | body 2 986 | Body -> 987 | -- | anchor 2 988 | V2 Double -> 989 | -- | distance of spring 990 | Double -> 991 | -- | spring constant 992 | Double -> 993 | -- | spring damping 994 | Double -> 995 | IO DampedSpring 996 | addDampedSpring body1 anchor1 body2 anchor2 distance springConstant damping = do 997 | dampedSpring <- C.dampedSpringNew body1 body2 (v2ToVect anchor1) (v2ToVect anchor2) distance springConstant damping 998 | space <- get (C.bodySpace body1) 999 | C.spaceAddConstraint space dampedSpring 1000 | pure $ DampedSpring dampedSpring 1001 | 1002 | dampedSpringAnchorA :: DampedSpring -> StateVar (V2 Double) 1003 | dampedSpringAnchorA (DampedSpring c) = mapStateVar v2ToVect vectToV2 (C.dampedSpringAnchorA c) 1004 | 1005 | dampedSpringAnchorB :: DampedSpring -> StateVar (V2 Double) 1006 | dampedSpringAnchorB (DampedSpring c) = mapStateVar v2ToVect vectToV2 (C.dampedSpringAnchorB c) 1007 | 1008 | dampedSpringDistance :: DampedSpring -> StateVar Double 1009 | dampedSpringDistance (DampedSpring c) = C.dampedSpringRestLength c 1010 | 1011 | dampedSpringStiffness :: DampedSpring -> StateVar Double 1012 | dampedSpringStiffness (DampedSpring c) = C.dampedSpringStiffness c 1013 | 1014 | dampedSpringDamping :: DampedSpring -> StateVar Double 1015 | dampedSpringDamping (DampedSpring c) = C.dampedSpringDamping c 1016 | 1017 | instance HasField "anchorA" DampedSpring (StateVar (V2 Double)) where 1018 | getField = dampedSpringAnchorA 1019 | 1020 | instance HasField "anchorB" DampedSpring (StateVar (V2 Double)) where 1021 | getField = dampedSpringAnchorB 1022 | 1023 | instance HasField "distance" DampedSpring (StateVar Double) where 1024 | getField = dampedSpringDistance 1025 | 1026 | instance HasField "stiffness" DampedSpring (StateVar Double) where 1027 | getField = dampedSpringStiffness 1028 | 1029 | instance HasField "damping" DampedSpring (StateVar Double) where 1030 | getField = dampedSpringDamping 1031 | 1032 | newtype DampedRotarySpring = DampedRotarySpring C.Constraint 1033 | 1034 | instance IsConstraint DampedRotarySpring where 1035 | getConstraint (DampedRotarySpring c) = c 1036 | 1037 | instance HasField "bodyA" DampedRotarySpring (GettableStateVar Body) where 1038 | getField = constraintBodyA 1039 | 1040 | instance HasField "bodyB" DampedRotarySpring (GettableStateVar Body) where 1041 | getField = constraintBodyB 1042 | 1043 | instance HasField "maxForce" DampedRotarySpring (StateVar Double) where 1044 | getField = constraintMaxForce 1045 | 1046 | instance HasField "errorBias" DampedRotarySpring (StateVar Double) where 1047 | getField = constraintErrorBias 1048 | 1049 | instance HasField "maxBias" DampedRotarySpring (StateVar Double) where 1050 | getField = constraintMaxBias 1051 | 1052 | instance HasField "collideBodies" DampedRotarySpring (StateVar Bool) where 1053 | getField = constraintCollideBodies 1054 | 1055 | instance HasField "impulse" DampedRotarySpring (GettableStateVar Double) where 1056 | getField = constraintImpulse 1057 | 1058 | addDampedRotarySpring :: 1059 | -- | body 1 1060 | Body -> 1061 | -- | body 2 1062 | Body -> 1063 | -- | angle of the spring 1064 | Double -> 1065 | -- | spring constant 1066 | Double -> 1067 | -- | damping 1068 | Double -> 1069 | IO DampedRotarySpring 1070 | addDampedRotarySpring body1 body2 angle springConstant damping = do 1071 | dampedRotarySpring <- C.dampedRotarySpringNew body1 body2 angle springConstant damping 1072 | space <- get (C.bodySpace body1) 1073 | C.spaceAddConstraint space dampedRotarySpring 1074 | pure $ DampedRotarySpring dampedRotarySpring 1075 | 1076 | dampedRotarySpringAngle :: DampedRotarySpring -> StateVar Double 1077 | dampedRotarySpringAngle (DampedRotarySpring c) = C.dampedRotarySpringRestAngle c 1078 | 1079 | dampedRotarySpringStiffness :: DampedRotarySpring -> StateVar Double 1080 | dampedRotarySpringStiffness (DampedRotarySpring c) = C.dampedRotarySpringStiffness c 1081 | 1082 | dampedRotarySpringDamping :: DampedRotarySpring -> StateVar Double 1083 | dampedRotarySpringDamping (DampedRotarySpring c) = C.dampedRotarySpringDamping c 1084 | 1085 | instance HasField "angle" DampedRotarySpring (StateVar Double) where 1086 | getField = dampedRotarySpringAngle 1087 | 1088 | instance HasField "stiffness" DampedRotarySpring (StateVar Double) where 1089 | getField = dampedRotarySpringStiffness 1090 | 1091 | instance HasField "damping" DampedRotarySpring (StateVar Double) where 1092 | getField = dampedRotarySpringDamping 1093 | 1094 | -- | Constrains the relative rotations of two bodies. It is implemented so that it’s possible to for the range to be greater than a full revolution. 1095 | newtype RotaryLimitJoint = RotaryLimitJoint C.Constraint 1096 | 1097 | instance IsConstraint RotaryLimitJoint where 1098 | getConstraint (RotaryLimitJoint c) = c 1099 | 1100 | instance HasField "bodyA" RotaryLimitJoint (GettableStateVar Body) where 1101 | getField = constraintBodyA 1102 | 1103 | instance HasField "bodyB" RotaryLimitJoint (GettableStateVar Body) where 1104 | getField = constraintBodyB 1105 | 1106 | instance HasField "maxForce" RotaryLimitJoint (StateVar Double) where 1107 | getField = constraintMaxForce 1108 | 1109 | instance HasField "errorBias" RotaryLimitJoint (StateVar Double) where 1110 | getField = constraintErrorBias 1111 | 1112 | instance HasField "maxBias" RotaryLimitJoint (StateVar Double) where 1113 | getField = constraintMaxBias 1114 | 1115 | instance HasField "collideBodies" RotaryLimitJoint (StateVar Bool) where 1116 | getField = constraintCollideBodies 1117 | 1118 | instance HasField "impulse" RotaryLimitJoint (GettableStateVar Double) where 1119 | getField = constraintImpulse 1120 | 1121 | addRotaryLimitJoint :: 1122 | -- | body 1 1123 | Body -> 1124 | -- body 2 1125 | Body -> 1126 | -- | minimum angle 1127 | Double -> 1128 | -- | maximum angle 1129 | Double -> 1130 | IO RotaryLimitJoint 1131 | addRotaryLimitJoint body1 body2 minAngle maxAngle = do 1132 | rotaryLimitJoint <- C.rotaryLimitJointNew body1 body2 minAngle maxAngle 1133 | space <- get (C.bodySpace body1) 1134 | C.spaceAddConstraint space rotaryLimitJoint 1135 | pure $ RotaryLimitJoint rotaryLimitJoint 1136 | 1137 | rotaryLimitJointMin :: RotaryLimitJoint -> StateVar Double 1138 | rotaryLimitJointMin (RotaryLimitJoint c) = C.rotaryLimitJointMin c 1139 | 1140 | rotaryLimitJointMax :: RotaryLimitJoint -> StateVar Double 1141 | rotaryLimitJointMax (RotaryLimitJoint c) = C.rotaryLimitJointMax c 1142 | 1143 | instance HasField "min" RotaryLimitJoint (StateVar Double) where 1144 | getField = rotaryLimitJointMin 1145 | 1146 | instance HasField "max" RotaryLimitJoint (StateVar Double) where 1147 | getField = rotaryLimitJointMax 1148 | 1149 | -- | Works like a socket wrench. 1150 | newtype RatchetJoint = RatchetJoint C.Constraint 1151 | 1152 | instance IsConstraint RatchetJoint where 1153 | getConstraint (RatchetJoint c) = c 1154 | 1155 | instance HasField "bodyA" RatchetJoint (GettableStateVar Body) where 1156 | getField = constraintBodyA 1157 | 1158 | instance HasField "bodyB" RatchetJoint (GettableStateVar Body) where 1159 | getField = constraintBodyB 1160 | 1161 | instance HasField "maxForce" RatchetJoint (StateVar Double) where 1162 | getField = constraintMaxForce 1163 | 1164 | instance HasField "errorBias" RatchetJoint (StateVar Double) where 1165 | getField = constraintErrorBias 1166 | 1167 | instance HasField "maxBias" RatchetJoint (StateVar Double) where 1168 | getField = constraintMaxBias 1169 | 1170 | instance HasField "collideBodies" RatchetJoint (StateVar Bool) where 1171 | getField = constraintCollideBodies 1172 | 1173 | instance HasField "impulse" RatchetJoint (GettableStateVar Double) where 1174 | getField = constraintImpulse 1175 | 1176 | addRatchetJoint :: 1177 | -- | body 1 1178 | Body -> 1179 | -- | body 2 1180 | Body -> 1181 | -- | The initial offset to use when deciding where the ratchet angles are 1182 | Double -> 1183 | -- | The distance between “clicks” 1184 | Double -> 1185 | IO RatchetJoint 1186 | addRatchetJoint body1 body2 minAngle maxAngle = do 1187 | ratchetJoint <- C.ratchetJointNew body1 body2 minAngle maxAngle 1188 | space <- get (C.bodySpace body1) 1189 | C.spaceAddConstraint space ratchetJoint 1190 | pure $ RatchetJoint ratchetJoint 1191 | 1192 | ratchetJointAngle :: RatchetJoint -> StateVar Double 1193 | ratchetJointAngle (RatchetJoint c) = C.ratchetJointAngle c 1194 | 1195 | ratchetJointPhase :: RatchetJoint -> StateVar Double 1196 | ratchetJointPhase (RatchetJoint c) = C.ratchetJointPhase c 1197 | 1198 | ratchetJointRatchet :: RatchetJoint -> StateVar Double 1199 | ratchetJointRatchet (RatchetJoint c) = C.ratchetJointRatchet c 1200 | 1201 | instance HasField "angle" RatchetJoint (StateVar Double) where 1202 | getField = ratchetJointAngle 1203 | 1204 | instance HasField "phase" RatchetJoint (StateVar Double) where 1205 | getField = ratchetJointPhase 1206 | 1207 | instance HasField "ratchet" RatchetJoint (StateVar Double) where 1208 | getField = ratchetJointRatchet 1209 | 1210 | -- | Keeps the angular velocity ratio of a pair of bodies constant. 1211 | newtype GearJoint = GearJoint C.Constraint 1212 | 1213 | instance IsConstraint GearJoint where 1214 | getConstraint (GearJoint c) = c 1215 | 1216 | instance HasField "bodyA" GearJoint (GettableStateVar Body) where 1217 | getField = constraintBodyA 1218 | 1219 | instance HasField "bodyB" GearJoint (GettableStateVar Body) where 1220 | getField = constraintBodyB 1221 | 1222 | instance HasField "maxForce" GearJoint (StateVar Double) where 1223 | getField = constraintMaxForce 1224 | 1225 | instance HasField "errorBias" GearJoint (StateVar Double) where 1226 | getField = constraintErrorBias 1227 | 1228 | instance HasField "maxBias" GearJoint (StateVar Double) where 1229 | getField = constraintMaxBias 1230 | 1231 | instance HasField "collideBodies" GearJoint (StateVar Bool) where 1232 | getField = constraintCollideBodies 1233 | 1234 | instance HasField "impulse" GearJoint (GettableStateVar Double) where 1235 | getField = constraintImpulse 1236 | 1237 | addGearJoint :: 1238 | -- | body 1 1239 | Body -> 1240 | -- | body 2 1241 | Body -> 1242 | -- | initial angular offset 1243 | Double -> 1244 | -- | ratio 1245 | Double -> 1246 | IO GearJoint 1247 | addGearJoint body1 body2 offset ratio = do 1248 | gearJoint <- C.gearJointNew body1 body2 offset ratio 1249 | space <- get (C.bodySpace body1) 1250 | C.spaceAddConstraint space gearJoint 1251 | pure $ GearJoint gearJoint 1252 | 1253 | gearJointPhase :: GearJoint -> StateVar Double 1254 | gearJointPhase (GearJoint c) = C.gearJointPhase c 1255 | 1256 | gearJointRatio :: GearJoint -> StateVar Double 1257 | gearJointRatio (GearJoint c) = C.gearJointRatio c 1258 | 1259 | instance HasField "phase" GearJoint (StateVar Double) where 1260 | getField = gearJointPhase 1261 | 1262 | instance HasField "ratio" GearJoint (StateVar Double) where 1263 | getField = gearJointRatio 1264 | 1265 | -- | Keeps the relative angular velocity of a pair of bodies constant. You will usually want to set an force (torque) maximum for motors as otherwise they will be able to apply a nearly infinite torque to keep the bodies moving. 1266 | newtype SimpleMotor = SimpleMotor C.Constraint 1267 | 1268 | instance IsConstraint SimpleMotor where 1269 | getConstraint (SimpleMotor c) = c 1270 | 1271 | instance HasField "bodyA" SimpleMotor (GettableStateVar Body) where 1272 | getField = constraintBodyA 1273 | 1274 | instance HasField "bodyB" SimpleMotor (GettableStateVar Body) where 1275 | getField = constraintBodyB 1276 | 1277 | instance HasField "maxForce" SimpleMotor (StateVar Double) where 1278 | getField = constraintMaxForce 1279 | 1280 | instance HasField "errorBias" SimpleMotor (StateVar Double) where 1281 | getField = constraintErrorBias 1282 | 1283 | instance HasField "maxBias" SimpleMotor (StateVar Double) where 1284 | getField = constraintMaxBias 1285 | 1286 | instance HasField "collideBodies" SimpleMotor (StateVar Bool) where 1287 | getField = constraintCollideBodies 1288 | 1289 | instance HasField "impulse" SimpleMotor (GettableStateVar Double) where 1290 | getField = constraintImpulse 1291 | 1292 | addSimpleMotor :: 1293 | -- | body 1 1294 | Body -> 1295 | -- | body 2 1296 | Body -> 1297 | -- | relative angular velocity 1298 | Double -> 1299 | IO SimpleMotor 1300 | addSimpleMotor body1 body2 angularVelocity = do 1301 | simpleMotor <- C.simpleMotorNew body1 body2 angularVelocity 1302 | space <- get (C.bodySpace body1) 1303 | C.spaceAddConstraint space simpleMotor 1304 | pure $ SimpleMotor simpleMotor 1305 | 1306 | simpleMotorRate :: SimpleMotor -> StateVar Double 1307 | simpleMotorRate (SimpleMotor c) = C.simpleMotorRate c 1308 | 1309 | instance HasField "rate" SimpleMotor (StateVar Double) where 1310 | getField = simpleMotorRate 1311 | 1312 | -- Collisions 1313 | 1314 | -- | A 'Collision' happens when two shapes touch 1315 | newtype Collision = Collision C.Arbiter 1316 | 1317 | -- | For a `ModifiableCollision`, friction, restitution and surface velocity may be changed 1318 | newtype ModifiableCollision = ModifiableCollision C.Arbiter 1319 | 1320 | collisionRestitution :: Collision -> GettableStateVar Double 1321 | collisionRestitution (Collision arbiter) = get (C.arbiterRestitution arbiter) 1322 | 1323 | modifiableCollisionRestitution :: ModifiableCollision -> StateVar Double 1324 | modifiableCollisionRestitution (ModifiableCollision arbiter) = C.arbiterRestitution arbiter 1325 | 1326 | instance HasField "restitution" Collision (GettableStateVar Double) where 1327 | getField = collisionRestitution 1328 | 1329 | instance HasField "restitution" ModifiableCollision (StateVar Double) where 1330 | getField = modifiableCollisionRestitution 1331 | 1332 | collisionFriction :: Collision -> GettableStateVar Double 1333 | collisionFriction (Collision arbiter) = get (C.arbiterFriction arbiter) 1334 | 1335 | modifiableCollisionFriction :: ModifiableCollision -> StateVar Double 1336 | modifiableCollisionFriction (ModifiableCollision arbiter) = C.arbiterFriction arbiter 1337 | 1338 | instance HasField "friction" Collision (GettableStateVar Double) where 1339 | getField = collisionFriction 1340 | 1341 | instance HasField "friction" ModifiableCollision (StateVar Double) where 1342 | getField = modifiableCollisionFriction 1343 | 1344 | collisionSurfaceVelocity :: Collision -> GettableStateVar (V2 Double) 1345 | collisionSurfaceVelocity (Collision arbiter) = vectToV2 <$> get (C.arbiterSurfaceVelocity arbiter) 1346 | 1347 | modifiableCollisionSurfaceVelocity :: ModifiableCollision -> StateVar (V2 Double) 1348 | modifiableCollisionSurfaceVelocity (ModifiableCollision arbiter) = mapStateVar v2ToVect vectToV2 $ C.arbiterSurfaceVelocity arbiter 1349 | 1350 | instance HasField "surfaceVelocity" Collision (GettableStateVar (V2 Double)) where 1351 | getField = collisionSurfaceVelocity 1352 | 1353 | instance HasField "surfaceVelocity" ModifiableCollision (StateVar (V2 Double)) where 1354 | getField = modifiableCollisionSurfaceVelocity 1355 | 1356 | collisionCount :: Collision -> GettableStateVar Int 1357 | collisionCount (Collision arbiter) = C.arbiterCount arbiter 1358 | 1359 | modifiableCollisionCount :: ModifiableCollision -> GettableStateVar Int 1360 | modifiableCollisionCount (ModifiableCollision arbiter) = C.arbiterCount arbiter 1361 | 1362 | instance HasField "count" Collision (GettableStateVar Int) where 1363 | getField = collisionCount 1364 | 1365 | instance HasField "count" ModifiableCollision (GettableStateVar Int) where 1366 | getField = modifiableCollisionCount 1367 | 1368 | collisionNormal :: Collision -> GettableStateVar (V2 Double) 1369 | collisionNormal (Collision arbiter) = vectToV2 <$> C.arbiterNormal arbiter 1370 | 1371 | modifiableCollisionNormal :: ModifiableCollision -> GettableStateVar (V2 Double) 1372 | modifiableCollisionNormal (ModifiableCollision arbiter) = vectToV2 <$> C.arbiterNormal arbiter 1373 | 1374 | instance HasField "normal" Collision (GettableStateVar (V2 Double)) where 1375 | getField = collisionNormal 1376 | 1377 | instance HasField "normal" ModifiableCollision (GettableStateVar (V2 Double)) where 1378 | getField = modifiableCollisionNormal 1379 | 1380 | collisionPointA :: Collision -> Int -> GettableStateVar (V2 Double) 1381 | collisionPointA (Collision arbiter) i = vectToV2 <$> C.arbiterPointA arbiter i 1382 | 1383 | modifiableCollisionPointA :: ModifiableCollision -> Int -> GettableStateVar (V2 Double) 1384 | modifiableCollisionPointA (ModifiableCollision arbiter) i = vectToV2 <$> C.arbiterPointA arbiter i 1385 | 1386 | instance HasField "pointA" Collision (Int -> GettableStateVar (V2 Double)) where 1387 | getField = collisionPointA 1388 | 1389 | instance HasField "pointA" ModifiableCollision (Int -> GettableStateVar (V2 Double)) where 1390 | getField = modifiableCollisionPointA 1391 | 1392 | collisionPointB :: Collision -> Int -> GettableStateVar (V2 Double) 1393 | collisionPointB (Collision arbiter) i = vectToV2 <$> C.arbiterPointB arbiter i 1394 | 1395 | modifiableCollisionPointB :: ModifiableCollision -> Int -> GettableStateVar (V2 Double) 1396 | modifiableCollisionPointB (ModifiableCollision arbiter) i = vectToV2 <$> C.arbiterPointB arbiter i 1397 | 1398 | instance HasField "pointB" Collision (Int -> GettableStateVar (V2 Double)) where 1399 | getField = collisionPointB 1400 | 1401 | instance HasField "pointB" ModifiableCollision (Int -> GettableStateVar (V2 Double)) where 1402 | getField = modifiableCollisionPointB 1403 | 1404 | collisionDepth :: Collision -> Int -> GettableStateVar Double 1405 | collisionDepth (Collision arbiter) = C.arbiterDepth arbiter 1406 | 1407 | modifiableCollisionDepth :: ModifiableCollision -> Int -> GettableStateVar Double 1408 | modifiableCollisionDepth (ModifiableCollision arbiter) = C.arbiterDepth arbiter 1409 | 1410 | instance HasField "depth" Collision (Int -> GettableStateVar Double) where 1411 | getField = collisionDepth 1412 | 1413 | instance HasField "depth" ModifiableCollision (Int -> GettableStateVar Double) where 1414 | getField = modifiableCollisionDepth 1415 | 1416 | collisionIsFirstContact :: Collision -> GettableStateVar Bool 1417 | collisionIsFirstContact (Collision arbiter) = C.arbiterIsFirstContact arbiter 1418 | 1419 | modifiableCollisionIsFirstContact :: ModifiableCollision -> GettableStateVar Bool 1420 | modifiableCollisionIsFirstContact (ModifiableCollision arbiter) = C.arbiterIsFirstContact arbiter 1421 | 1422 | instance HasField "isFirstContact" Collision (GettableStateVar Bool) where 1423 | getField = collisionIsFirstContact 1424 | 1425 | instance HasField "isFirstContact" ModifiableCollision (GettableStateVar Bool) where 1426 | getField = modifiableCollisionIsFirstContact 1427 | 1428 | collisionIsRemoval :: Collision -> GettableStateVar Bool 1429 | collisionIsRemoval (Collision arbiter) = C.arbiterIsRemoval arbiter 1430 | 1431 | modifiableCollisionIsRemoval :: ModifiableCollision -> GettableStateVar Bool 1432 | modifiableCollisionIsRemoval (ModifiableCollision arbiter) = C.arbiterIsRemoval arbiter 1433 | 1434 | instance HasField "isRemoval" Collision (GettableStateVar Bool) where 1435 | getField = collisionIsRemoval 1436 | 1437 | instance HasField "isRemoval" ModifiableCollision (GettableStateVar Bool) where 1438 | getField = modifiableCollisionIsRemoval 1439 | 1440 | collisionShapes :: Collision -> GettableStateVar (Shape, Shape) 1441 | collisionShapes (Collision arbiter) = C.arbiterShapes arbiter 1442 | 1443 | modifiableCollisionShapes :: ModifiableCollision -> GettableStateVar (Shape, Shape) 1444 | modifiableCollisionShapes (ModifiableCollision arbiter) = C.arbiterShapes arbiter 1445 | 1446 | instance HasField "shapes" Collision (GettableStateVar (Shape, Shape)) where 1447 | getField = collisionShapes 1448 | 1449 | instance HasField "shapes" ModifiableCollision (GettableStateVar (Shape, Shape)) where 1450 | getField = modifiableCollisionShapes 1451 | 1452 | collisionBodies :: Collision -> GettableStateVar (Body, Body) 1453 | collisionBodies (Collision arbiter) = C.arbiterBodies arbiter 1454 | 1455 | modifiableCollisionBodies :: ModifiableCollision -> GettableStateVar (Body, Body) 1456 | modifiableCollisionBodies (ModifiableCollision arbiter) = C.arbiterBodies arbiter 1457 | 1458 | instance HasField "bodies" Collision (GettableStateVar (Body, Body)) where 1459 | getField = collisionBodies 1460 | 1461 | instance HasField "bodies" ModifiableCollision (GettableStateVar (Body, Body)) where 1462 | getField = modifiableCollisionBodies 1463 | 1464 | newtype CollisionSpace = CollisionSpace C.Space 1465 | 1466 | instance IsSpace CollisionSpace where 1467 | getSpace (CollisionSpace space) = space 1468 | addBody (CollisionSpace space) = addBody space 1469 | 1470 | class IsCollision collision where 1471 | getArbiter :: collision -> C.Arbiter 1472 | 1473 | instance IsCollision Collision where 1474 | getArbiter (Collision collision) = collision 1475 | 1476 | instance IsCollision ModifiableCollision where 1477 | getArbiter (ModifiableCollision collision) = collision 1478 | 1479 | -- | Schedule an action to be done after the physics update is done. 1480 | -- This is useful since you may not add to/remove from the space during a collision callback 1481 | -- 1482 | -- `schedulePostStepWork` will only schedule one action for each shape pair and returns `False` if this collision already was given to `schedulePostStepWork`. 1483 | -- Use `alwaysSchedulePostStepWork` if you do not want this. 1484 | schedulePostStepWork :: (IsCollision collision) => CollisionSpace -> collision -> (Space -> IO ()) -> IO Bool 1485 | schedulePostStepWork (CollisionSpace space) collision action = do 1486 | let arbiter = getArbiter collision 1487 | (shape1, shape2) <- C.arbiterShapes arbiter 1488 | let key = hash shape1 * hash shape2 1489 | addKeyedCallback space key (action space) 1490 | 1491 | -- | Schedule an action to be done after the physics update is done. 1492 | -- This is useful since you may not add to/remove from the space during a collision callback 1493 | -- 1494 | -- `alwaysSchedulePostStepWork ` might schedule an action twice, once for collision (shapeA, shapeB) and once for collision (shapeB, shapeA). 1495 | -- Use `schedulePostStepWork` if you want to avoid this. 1496 | alwaysSchedulePostStepWork :: CollisionSpace -> (Space -> IO ()) -> IO () 1497 | alwaysSchedulePostStepWork (CollisionSpace space) action = do 1498 | addCallback space (action space) 1499 | 1500 | -- | Keeps track of the changes you want to apply to a collision handler 1501 | data ModifyCollisionHandler a = ModifyCollisionHandler 1502 | { collisionTypes :: !(C.CollisionType -> C.CollisionType -> (C.CollisionType, C.CollisionType)), 1503 | begin :: !(Maybe (Collision -> CollisionSpace -> IO (Bool, Maybe a))), 1504 | preSolve :: !(Maybe (ModifiableCollision -> CollisionSpace -> IO (Bool, Maybe a))), 1505 | postSolve :: !(Maybe (Collision -> CollisionSpace -> IO (Maybe a))), 1506 | separate :: !(Maybe (Collision -> CollisionSpace -> IO (Maybe a))) 1507 | } 1508 | 1509 | -- | Does not change the collision handler 1510 | idCollisionHandler :: ModifyCollisionHandler a 1511 | idCollisionHandler = 1512 | ModifyCollisionHandler 1513 | { collisionTypes = (,), 1514 | begin = Nothing, 1515 | preSolve = Nothing, 1516 | postSolve = Nothing, 1517 | separate = Nothing 1518 | } 1519 | 1520 | -- | Change the behavior of a collision handler between two collision types. 1521 | -- 1522 | -- Also returns an `Event` which triggers whenever the handlers in `ModifyCollisionHandler` trigger one. 1523 | modifyCollisionHandler :: Space -> C.CollisionType -> C.CollisionType -> ModifyCollisionHandler a -> IO (Event a) 1524 | modifyCollisionHandler space typeA typeB mch = do 1525 | handlerPtr <- C.spaceAddCollisionHandler space typeA typeB 1526 | modifyCollisionHandlerPtr handlerPtr mch 1527 | 1528 | -- | Change the behavior of a wildcard collision handler 1529 | -- 1530 | -- Also returns an `Event` which triggers whenever the handlers in `ModifyCollisionHandler` trigger one. 1531 | modifyWildcardCollisionHandler :: Space -> C.CollisionType -> ModifyCollisionHandler a -> IO (Event a) 1532 | modifyWildcardCollisionHandler space typeA mch = do 1533 | handlerPtr <- C.spaceAddWildcardHandler space typeA 1534 | modifyCollisionHandlerPtr handlerPtr mch 1535 | 1536 | -- | Change the behavior of the default collision handler 1537 | -- 1538 | -- Also returns an `Event` which triggers whenever the handlers in `ModifyCollisionHandler` trigger one. 1539 | modifyDefaultCollisionHandler :: Space -> ModifyCollisionHandler a -> IO (Event a) 1540 | modifyDefaultCollisionHandler space mch = do 1541 | handlerPtr <- C.spaceAddDefaultCollisionHandler space 1542 | modifyCollisionHandlerPtr handlerPtr mch 1543 | 1544 | -- | Use the wildcard begin wildcard handler for shape of body A 1545 | handleWildcardBeginA :: Collision -> CollisionSpace -> IO Bool 1546 | handleWildcardBeginA (Collision arbiter) (CollisionSpace space) = C.arbiterCallWildcardBeginA arbiter space 1547 | 1548 | -- | Use the wildcard begin wildcard handler for shape of body B 1549 | handleWildcardBeginB :: Collision -> CollisionSpace -> IO Bool 1550 | handleWildcardBeginB (Collision arbiter) (CollisionSpace space) = C.arbiterCallWildcardBeginB arbiter space 1551 | 1552 | -- | Use the wildcard presolve handler for shape of body A 1553 | handleWildcardPreSolveA :: ModifiableCollision -> CollisionSpace -> IO Bool 1554 | handleWildcardPreSolveA (ModifiableCollision arbiter) (CollisionSpace space) = C.arbiterCallWildcardPreSolveA arbiter space 1555 | 1556 | -- | Use the wildcard presolve handler for shape of body B 1557 | handleWildcardPreSolveB :: ModifiableCollision -> CollisionSpace -> IO Bool 1558 | handleWildcardPreSolveB (ModifiableCollision arbiter) (CollisionSpace space) = C.arbiterCallWildcardPreSolveB arbiter space 1559 | 1560 | -- | Use the wildcard postsolve handler for shape of body A 1561 | handleWildcardPostSolveA :: Collision -> CollisionSpace -> IO () 1562 | handleWildcardPostSolveA (Collision arbiter) (CollisionSpace space) = C.arbiterCallWildcardPostSolveA arbiter space 1563 | 1564 | -- | Use the wildcard postsolve handler for shape of body B 1565 | handleWildcardPostSolveB :: Collision -> CollisionSpace -> IO () 1566 | handleWildcardPostSolveB (Collision arbiter) (CollisionSpace space) = C.arbiterCallWildcardPostSolveB arbiter space 1567 | 1568 | -- | Use the wildcard separate handler for shape of body A 1569 | handleWildcardSeparateA :: Collision -> CollisionSpace -> IO () 1570 | handleWildcardSeparateA (Collision arbiter) (CollisionSpace space) = C.arbiterCallWildcardSeparateA arbiter space 1571 | 1572 | -- | Use the wildcard separate handler for shape of body B 1573 | handleWildcardSeparateB :: Collision -> CollisionSpace -> IO () 1574 | handleWildcardSeparateB (Collision arbiter) (CollisionSpace space) = C.arbiterCallWildcardSeparateB arbiter space 1575 | 1576 | modifyCollisionHandlerPtr :: C.CollisionHandlerPtr -> ModifyCollisionHandler a -> IO (Event a) 1577 | modifyCollisionHandlerPtr handlerPtr (ModifyCollisionHandler collisionTypes begin preSolve postSolve separate) = do 1578 | eventTriggers <- newIORef M.empty 1579 | 1580 | let updateCollisionTypes ch = 1581 | let (newCollisionTypeA, newCollisionTypeB) = collisionTypes (C.chTypeA ch) (C.chTypeB ch) 1582 | in ch {C.chTypeA = newCollisionTypeA, C.chTypeB = newCollisionTypeB} 1583 | updateBegin <- makeCallback eventTriggers begin Collision id C.mkCallbackB (\cb h -> h {C.chBeginFunc = cb}) 1584 | updatePreSolve <- makeCallback eventTriggers preSolve ModifiableCollision id C.mkCallbackB (\cb h -> h {C.chPreSolveFunc = cb}) 1585 | updatePostSolve <- makeCallback eventTriggers postSolve Collision ((),) C.mkCallback (\cb h -> h {C.chPostSolveFunc = cb}) 1586 | updateSeparate <- makeCallback eventTriggers separate Collision ((),) C.mkCallback (\cb h -> h {C.chSeparateFunc = cb}) 1587 | 1588 | C.modifyCollisionHandler handlerPtr $ pure . updateBegin . updatePreSolve . updatePostSolve . updateSeparate . updateCollisionTypes 1589 | 1590 | let event = callback $ \fin trigger -> do 1591 | key <- newUnique 1592 | modifyIORef' eventTriggers $ M.insert key trigger 1593 | addFinalizer fin $ modifyIORef' eventTriggers $ M.delete key 1594 | 1595 | if or [isJust begin, isJust preSolve, isJust postSolve, isJust separate] 1596 | then pure event 1597 | else pure mempty 1598 | where 1599 | makeCallback eventTriggers maybeCallback makeCollision extractResult makeCallback insertFunction = 1600 | case maybeCallback of 1601 | Nothing -> pure id 1602 | Just f -> do 1603 | let newF arbiter collisionSpace _ = do 1604 | (b, ma) <- extractResult <$> f (makeCollision arbiter) (CollisionSpace collisionSpace) 1605 | case ma of 1606 | Nothing -> pure b 1607 | Just a -> readIORef eventTriggers >>= traverse_ ($ a) >> pure b 1608 | 1609 | cb <- makeCallback newF 1610 | 1611 | pure (insertFunction cb) 1612 | 1613 | data PostStepCallbacks = PostStepCallbacks 1614 | { unkeyedCallbacks :: !(IO ()), 1615 | keyedCallbacks :: !(IM.IntMap (IO ())) 1616 | } 1617 | 1618 | emptyPostStepCallbacks :: PostStepCallbacks 1619 | emptyPostStepCallbacks = PostStepCallbacks mempty mempty 1620 | 1621 | -- | Add a post step callback with a key. If the key already exists, then the action will not be added and `False` is returned. 1622 | addKeyedCallback :: Space -> Int -> IO () -> IO Bool 1623 | addKeyedCallback space key action = do 1624 | callbacks <- get (C.spaceUserData space) >>= deRefStablePtr . castPtrToStablePtr 1625 | atomicModifyIORef' callbacks $ \postStepCallbacks -> 1626 | let exists = IM.member key postStepCallbacks.keyedCallbacks 1627 | in if exists 1628 | then (postStepCallbacks, False) 1629 | else (postStepCallbacks {keyedCallbacks = IM.insert key action postStepCallbacks.keyedCallbacks}, True) 1630 | 1631 | -- | Add a post step callback 1632 | addCallback :: Space -> IO () -> IO () 1633 | addCallback space action = do 1634 | callbacks <- get (C.spaceUserData space) >>= deRefStablePtr . castPtrToStablePtr 1635 | modifyIORef' callbacks $ \postStepCallbacks -> 1636 | postStepCallbacks {unkeyedCallbacks = postStepCallbacks.unkeyedCallbacks >> action} 1637 | 1638 | v2ToVect :: V2 Double -> Vect 1639 | v2ToVect (V2 x y) = Vect x y 1640 | 1641 | vectToV2 :: Vect -> V2 Double 1642 | vectToV2 (Vect x y) = V2 x y 1643 | -------------------------------------------------------------------------------- /reactimate-physics/test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | main :: IO () 4 | main = putStrLn "Test suite not yet implemented." 5 | -------------------------------------------------------------------------------- /reactimate/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for signal-functions 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /reactimate/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2024, Simre1 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Simre1 nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /reactimate/README.md: -------------------------------------------------------------------------------- 1 | # Reactimate 2 | 3 | `reactimate` is a library implementing the AFRP (Arrowized Functional Reactive Programming) paradigm. In contrast to other libraries, `reactimate` uses `IO` effects to increase performance and a concrete base type to eliminate typeclass performance problems. 4 | In addition, `reactimate` has some support for pull-based FRP, making it possible to deal with events which happen in-between simulation cycles. 5 | 6 | ## Signal 7 | 8 | The most important type is the `Signal`. A `Signal a b` represents a computation which uses `a` as input and produces `b` as output. `reactimate` implements a lot of combinators to work with those `Signal`s. 9 | 10 | Here, we use the `arr` function from the `Arrow` typeclass to create a simple `Signal` from the `(+5)` function. 11 | ```haskell 12 | add5 :: Signal Int Int 13 | add5 = arr (+5) 14 | ``` 15 | 16 | We can easily execute signals in sequence with the `>>>` combinator. 17 | ```haskell 18 | add10 :: Signal Int Int 19 | add10 = add5 >>> add5 20 | ``` 21 | 22 | ### Running signals 23 | 24 | Typically, you will run `Signal`s with `reactimate`. It will run the given `Signal` over and over again until it finally produces a `Just` value and then returns that value. 25 | ```haskell 26 | main :: IO () 27 | main = do 28 | result <- reactimate someSignal 29 | putStrLn result 30 | 31 | someSignal :: Signal () (Maybe String) 32 | someSignal = ... 33 | ``` 34 | 35 | With `reactimate`, it is easily possible to implement a game loop or some other simulation loop. 36 | 37 | ### Stateful signals 38 | 39 | `Signal`s can store some internal state during their execution. In general, `Signal`s do **not** produce the same output for the same input! 40 | 41 | State can be easily integreated in a `Signal` with the `feedback` function: 42 | ```haskell 43 | feedback :: b -> Signal (a, b) b -> Signal a b 44 | 45 | sum :: Signal Int Int 46 | sum = feedback 0 $ arr \(input, acc) -> input + acc 47 | ``` 48 | 49 | `feedback` takes some initial state and then accumulates this state over simulations. The state from the last execution is fed back as input. The `sum` signal produces the sum of all its inputs by keeping track of the last output. 50 | 51 | 52 | ### Experimental Pull-Push-based FRP 53 | 54 | Conventional AFRP evaluates at a set frequency in time. If events happen in-between two evaluations, they can only be processed in the next evaluation. 55 | Therefore, it is not possible to do something in the exact moment the event occurs. 56 | 57 | `reactimate` has support for such events which happen outside of the simulation and occur at any time. 58 | The idea is to evaluate the signal not at a specific frequency, but rather evaluate the signal whenever the event happens. 59 | 60 | Here is an example: 61 | 62 | ```haskell 63 | increasingEvent :: Event () 64 | increasingEvent = mapEvent (sumUp >>> arrIO print) (pulse 2 1) 65 | 66 | main :: IO () 67 | main = reactimateEvent $ Nothing <$ increasingEvent 68 | ``` 69 | 70 | `pulse 2 1` emits an event with payload 1 every 2 seconds. `sumUp >>> arrIO print` sums up all inputs and prints the output. 71 | `sampleEvent` will wait until its given event produces a `Just` value. This never happens here, so it just runs forever. 72 | 73 | ## Microbenchmarks 74 | 75 | Beware that micro benchmarks may not reflect 1 to 1 on real applications. The actual performance gain on applications still needs to be tested. 76 | 77 | ``` 78 | Countdown benchmark/Yampa mean 27.80 ms ( +- 192.7 μs ) 79 | Countdown benchmark/dunai mean 70.35 ms ( +- 261.6 μs ) 80 | Countdown benchmark/reactimate mean 388.0 μs ( +- 409.2 ns ) 81 | 82 | Integrate benchmark/Yampa mean 98.37 ms ( +- 229.2 μs ) 83 | Integrate benchmark/reactimate mean 9.719 ms ( +- 45.72 μs ) 84 | 85 | Chaining (>>>) benchmark/Yampa mean 26.71 ms ( +- 407.0 μs ) 86 | Chaining (>>>) benchmark/dunai mean 75.62 ms ( +- 3.863 ms ) 87 | Chaining (>>>) benchmark/reactimate mean 3.703 ms ( +- 61.67 μs ) 88 | ``` 89 | 90 | ## Acknowledgements 91 | 92 | Heavily inspired by [Yampa](https://github.com/ivanperez-keera/Yampa) and [dunai](https://github.com/ivanperez-keera/dunai). 93 | -------------------------------------------------------------------------------- /reactimate/bench/Main.hs: -------------------------------------------------------------------------------- 1 | import Control.Arrow (Arrow (..)) 2 | import Control.Category ((>>>)) 3 | import Data.Foldable (Foldable (..)) 4 | import Data.MonadicStreamFunction qualified as MSF 5 | import Data.MonadicStreamFunction.InternalCore qualified as MSF 6 | import FRP.Yampa qualified as Y 7 | import Gauge.Main 8 | import Reactimate.Run qualified as Signal 9 | import Reactimate.Stateful qualified as Signal 10 | import Reactimate.Time qualified as Signal 11 | 12 | count :: Int 13 | count = 100000 14 | 15 | -- this is not super realistic since Yampa does some time calculation as well 16 | yampaCountBench :: IO () 17 | yampaCountBench = do 18 | Y.reactimate 19 | (pure ()) 20 | (\_ -> pure (0, Just ())) 21 | (\_ !b -> if b == 0 then pure True else pure False) 22 | (Y.loopPre count (arr (\((), !x) -> (x - 1, x - 1)))) 23 | 24 | signalCountBench :: IO () 25 | signalCountBench = do 26 | !x <- Signal.reactimate $ Signal.feedbackState count (arr (\((), !x) -> (x - 1, x - 1))) >>> arr (\x -> if x == 0 then Just x else Nothing) 27 | pure () 28 | 29 | msfCountBench :: IO () 30 | msfCountBench = do 31 | !x <- reactimate $ MSF.feedback count (arr (\((), !x) -> (x - 1, x - 1))) >>> arr (\x -> if x == 0 then Just x else Nothing) 32 | pure () 33 | where 34 | reactimate :: MSF.MSF IO () (Maybe a) -> IO a 35 | reactimate mSignal = do 36 | (b, next) <- MSF.unMSF mSignal () 37 | case b of 38 | Nothing -> reactimate next 39 | Just x -> pure x 40 | 41 | integrateSamples :: Int 42 | integrateSamples = 1000000 43 | 44 | yampaIntegrateBench :: Double -> Double 45 | yampaIntegrateBench x = last (Y.embed (pure (x :: Double) >>> Y.integral) (Y.deltaEncode 0.1 [1 .. integrateSamples])) 46 | 47 | signalIntegrateBench :: IO Double 48 | signalIntegrateBench = 49 | Signal.fold 50 | (\_ x -> x) 51 | 0 52 | (Signal.withFixedTime 0.1 $ \time -> pure 1 >>> Signal.integrate time (*)) 53 | [1 .. integrateSamples] 54 | 55 | chainTest :: (Arrow a) => a Double Double 56 | chainTest = foldl' (\a _ -> a >>> a) (arr (+ 1)) [0 .. 16] 57 | 58 | yampaChainBench :: Double -> Double 59 | yampaChainBench x = last $ Y.embed chainTest (x, []) 60 | 61 | signalChainBench :: IO Double 62 | signalChainBench = last <$> Signal.sample chainTest [0] 63 | 64 | msfChainBench :: IO Double 65 | msfChainBench = last <$> MSF.embed chainTest [0] 66 | 67 | main :: IO () 68 | main = do 69 | defaultMain 70 | [ bgroup "Countdown benchmark" [bench "Yampa" $ nfIO yampaCountBench, bench "dunai" $ nfIO msfCountBench, bench "reactimate" $ nfIO signalCountBench], 71 | bgroup "Integrate benchmark" [bench "Yampa" $ nf yampaIntegrateBench 1, bench "reactimate" $ nfIO signalIntegrateBench], 72 | bgroup "Chaining (>>>) benchmark" [bench "Yampa" $ nf yampaChainBench 0, bench "dunai" $ nfIO msfChainBench, bench "reactimate" $ nfIO signalChainBench] 73 | ] 74 | -------------------------------------------------------------------------------- /reactimate/reactimate.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: reactimate 3 | version: 0.1.0.0 4 | -- synopsis: 5 | -- description: 6 | license: BSD-3-Clause 7 | license-file: LICENSE 8 | author: Simre1 9 | maintainer: simre4775@gmail.com 10 | -- copyright: 11 | build-type: Simple 12 | extra-doc-files: CHANGELOG.md 13 | -- extra-source-files: 14 | 15 | common common 16 | ghc-options: -Wall 17 | default-language: GHC2021 18 | default-extensions: 19 | DataKinds 20 | build-depends: 21 | base >=4.17.2.1 22 | 23 | library 24 | import: common 25 | exposed-modules: 26 | Reactimate, 27 | Reactimate.Signal, 28 | Reactimate.Run, 29 | Reactimate.Time, 30 | Reactimate.Sampling, 31 | Reactimate.Stateful, 32 | Reactimate.Switching, 33 | Reactimate.Setup, 34 | Reactimate.Basic, 35 | Reactimate.Event, 36 | Reactimate.Delay, 37 | Reactimate.Random 38 | hs-source-dirs: src 39 | ghc-options: -O2 40 | build-depends: 41 | containers, 42 | vector, 43 | async >= 2.2, 44 | random 45 | 46 | executable bench 47 | import: common 48 | build-depends: 49 | reactimate, 50 | Yampa, 51 | dunai, 52 | gauge 53 | hs-source-dirs: bench 54 | main-is: Main.hs 55 | ghc-options: -O2 56 | -------------------------------------------------------------------------------- /reactimate/src/Reactimate.hs: -------------------------------------------------------------------------------- 1 | -- | @reactimate@ implements signal which are well suited for simulations, game loops and complicated stream processing. 2 | -- It's also possible to react to events as they are happening and integrate them into signal functions. 3 | module Reactimate 4 | ( Signal, 5 | 6 | -- * Basic signals 7 | identity, 8 | constant, 9 | arr, 10 | arr2, 11 | arrIO, 12 | actionIO, 13 | dup, 14 | 15 | -- * Combinators 16 | (>>>), 17 | (<<<), 18 | (&&&), 19 | (***), 20 | first, 21 | second, 22 | (|||), 23 | (+++), 24 | left, 25 | right, 26 | 27 | -- * Stateful signals 28 | feedback, 29 | feedbackState, 30 | feedbackLazyState, 31 | scan, 32 | 33 | -- * Delay signals 34 | delaySample, 35 | once, 36 | 37 | -- * Switch signals 38 | caseOf, 39 | switch, 40 | switchRepeatedly, 41 | 42 | -- * Signal Setup 43 | withSetup, 44 | withSetup_, 45 | allocateResource, 46 | addFinalizer, 47 | 48 | -- * Time in signals 49 | Time, 50 | withTime, 51 | withFixedTime, 52 | currentTime, 53 | deltaTime, 54 | integrate, 55 | 56 | -- * Random signals, 57 | generateRandom, 58 | generateRandomRange, 59 | generateRandomWithRNG, 60 | generateRandomRangeWithRNG, 61 | 62 | -- * Run signals 63 | reactimate, 64 | sample, 65 | fold, 66 | reactimateEvent, 67 | limitSampleRate, 68 | resample, 69 | resampleInThread, 70 | 71 | -- * Events 72 | Event, 73 | Behavior, 74 | Dynamic, 75 | makeBehavior, 76 | pulseEvent, 77 | instantEvent, 78 | callback, 79 | mapEvent, 80 | mapBehavior, 81 | holdEvent, 82 | dynamicToEvent, 83 | dynamicToBehavior, 84 | -- ** Sampling events 85 | accumulateEvent, 86 | sampleEvent, 87 | sampleEventAsList, 88 | sampleBehavior, 89 | sampleDynamic, 90 | ) 91 | where 92 | 93 | import Control.Arrow 94 | import Reactimate.Basic 95 | import Reactimate.Delay 96 | import Reactimate.Event 97 | import Reactimate.Random 98 | import Reactimate.Run 99 | import Reactimate.Sampling 100 | import Reactimate.Setup 101 | import Reactimate.Signal 102 | import Reactimate.Stateful 103 | import Reactimate.Switching 104 | import Reactimate.Time 105 | -------------------------------------------------------------------------------- /reactimate/src/Reactimate/Basic.hs: -------------------------------------------------------------------------------- 1 | module Reactimate.Basic where 2 | 3 | import Control.Arrow (Arrow (..)) 4 | import Reactimate.Signal 5 | 6 | -- | Duplicating the input may be useful for various other arrow combinators. 7 | dup :: Signal a (a, a) 8 | dup = arr (\a -> (a, a)) 9 | {-# INLINE dup #-} 10 | 11 | -- | Same as `arr` but for functions with two arguments. 12 | arr2 :: (a -> b -> c) -> Signal (a, b) c 13 | arr2 f = arr (uncurry f) 14 | {-# INLINE arr2 #-} 15 | 16 | -- | Same as `id` but for signal functions 17 | identity :: Signal a a 18 | identity = arr id 19 | {-# INLINE identity #-} 20 | 21 | -- | Same as `const` but for signal functions 22 | constant :: b -> Signal a b 23 | constant = pure 24 | {-# INLINE constant #-} 25 | 26 | -- | Run an IO action during a signal function. 27 | arrIO :: (a -> IO b) -> Signal a b 28 | arrIO f = Signal $ \_ -> pure f 29 | {-# INLINE arrIO #-} 30 | 31 | -- | Run an IO action during a signal function without input. 32 | actionIO :: IO a -> Signal x a 33 | actionIO action = Signal $ \_ -> pure (const action) 34 | {-# INLINE actionIO #-} 35 | -------------------------------------------------------------------------------- /reactimate/src/Reactimate/Delay.hs: -------------------------------------------------------------------------------- 1 | module Reactimate.Delay where 2 | 3 | import Data.IORef 4 | import Reactimate.Signal 5 | 6 | -- | Delay the execution by one sample 7 | delaySample :: a -> Signal a a 8 | delaySample initial = Signal $ \_ -> do 9 | delayRef <- newIORef initial 10 | pure $ \a' -> do 11 | a <- readIORef delayRef 12 | writeIORef delayRef a' 13 | pure a 14 | {-# INLINE delaySample #-} 15 | 16 | -- | Evaluate the signal once and then return its result 17 | once :: Signal a b -> Signal a b 18 | once (Signal signal) = Signal $ \fin -> do 19 | ref <- newIORef Nothing 20 | f <- signal fin 21 | pure $ \a -> do 22 | maybeB <- readIORef ref 23 | case maybeB of 24 | Just b -> pure b 25 | Nothing -> do 26 | !b <- f a 27 | writeIORef ref (Just b) 28 | pure b 29 | {-# INLINE once #-} 30 | -------------------------------------------------------------------------------- /reactimate/src/Reactimate/Event.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecursiveDo #-} 2 | 3 | module Reactimate.Event where 4 | 5 | import Control.Applicative (liftA2) 6 | import Control.Arrow ((>>>)) 7 | import Control.Concurrent 8 | import Control.Concurrent.Async 9 | import Control.Monad (forever, (>=>)) 10 | import Data.IORef 11 | import Reactimate.Basic (identity) 12 | import Reactimate.Signal 13 | 14 | -- | Events are like @Signal () a@, they produce values of @a@ and require no input. 15 | -- Events occure at some unknown time, so they cannot simply be sampled with run functions like 'reactimate'. 16 | -- Instead, you can think of @Event r a@ as a @Signal r () a@ which is whenever the event happens, completely independent from the main loop. 17 | data Event a where 18 | Event :: 19 | { signal :: !(Signal x a), 20 | hook :: Finalizer -> (x -> IO ()) -> IO () 21 | } -> 22 | Event a 23 | 24 | -- | A `Dynamic` changes it's value over time based on an `Event`. They always have a value and you can get an `Event` to determine when this happens. 25 | data Dynamic a = Dynamic 26 | { event :: !(Event a), 27 | initialValue :: !a 28 | } 29 | 30 | -- | A `Behavior` changes it's value over time. However, you cannot know exactly when this happens. You cannot get an `Event` from a `Behavior`. 31 | newtype Behavior a = Behavior (Signal () a) deriving (Functor, Applicative) 32 | 33 | instance Functor Event where 34 | fmap f (Event signal hook) = Event (fmap f signal) hook 35 | {-# INLINE fmap #-} 36 | 37 | instance Semigroup (Event a) where 38 | (Event signal1 hook1) <> (Event signal2 hook2) = Event identity $ \fin push -> do 39 | f1 <- unSignal signal1 fin 40 | f2 <- unSignal signal2 fin 41 | hook1 fin (f1 >=> push) 42 | hook2 fin (f2 >=> push) 43 | 44 | instance Monoid (Event a) where 45 | mempty = Event identity $ \_ _ -> pure () 46 | 47 | instance Functor Dynamic where 48 | fmap f (Dynamic event a) = Dynamic (fmap f event) (f a) 49 | 50 | instance Applicative Dynamic where 51 | pure = Dynamic mempty 52 | liftA2 53 | f 54 | (Dynamic (Event signalA hookA) initialValueA) 55 | (Dynamic (Event signalB hookB) initialValueB) = Dynamic event (f initialValueA initialValueB) 56 | where 57 | event = Event identity $ \fin trigger -> do 58 | refA <- newIORef initialValueA 59 | refB <- newIORef initialValueB 60 | 61 | fA <- unSignal signalA fin 62 | fB <- unSignal signalB fin 63 | 64 | hookA fin $ \x -> do 65 | a <- fA x 66 | writeIORef refA a 67 | b <- readIORef refB 68 | trigger $ f a b 69 | hookB fin $ \x -> do 70 | b <- fB x 71 | writeIORef refB b 72 | a <- readIORef refA 73 | trigger $ f a b 74 | 75 | -- | Emits an event and then waits @frameTime@ seconds. 76 | -- If producing events is little work, this should approximate a frequency @1/frameTime@. 77 | pulseEvent :: Double -> a -> Event a 78 | pulseEvent frameTime a = Event identity $ \fin push -> do 79 | asyncRef <- async $ forever $ do 80 | push a 81 | threadDelay $ round (frameTime * 1000000) 82 | addFinalizer fin $ cancel asyncRef 83 | 84 | -- | Trigger exactly one event as soon as you sample 85 | instantEvent :: a -> Event a 86 | instantEvent a = Event identity $ \_ push -> do 87 | push a 88 | 89 | -- | Create an event from a callback. The first argument should take a @a -> IO ()@ function and use it to trigger events. 90 | -- 91 | -- You can also use the environment, though you need to keep thread-safety in mind. If you need to run some clean-up code, 92 | -- add it to the `Finalizer`. 93 | -- 94 | -- @ 95 | -- callback $ \\triggerEvent -> do 96 | -- cleanUp <- someFunctionTakingCallback triggerEvent 97 | -- pure cleanUp 98 | -- @ 99 | callback :: (Finalizer -> (a -> IO ()) -> IO ()) -> Event a 100 | callback = Event identity 101 | 102 | -- | Fold an event over time and return the latest value. 103 | -- 104 | -- __The accumulator carries over to the next sampling step.__ 105 | accumulateEvent :: (b -> a -> b) -> b -> Event a -> Signal () b 106 | accumulateEvent accumulate initial (Event signal hook) = Signal $ \fin -> mdo 107 | ref <- newIORef initial 108 | f <- unSignal signal fin 109 | hook fin $ \x -> do 110 | a <- f x 111 | modifyIORef' ref (`accumulate` a) 112 | pure $ \_ -> readIORef ref 113 | 114 | -- | Fold all events which happened since the last sample. 115 | -- 116 | -- __The accumulator will reset to the initial value at each sampling.__ 117 | sampleEvent :: (b -> a -> b) -> b -> Event a -> Signal () b 118 | sampleEvent accumulate initial (Event signal hook) = Signal $ \fin -> mdo 119 | ref <- newIORef initial 120 | f <- unSignal signal fin 121 | hook fin $ \x -> do 122 | a <- f x 123 | modifyIORef' ref (`accumulate` a) 124 | pure $ \_ -> atomicModifyIORef' ref (initial,) 125 | 126 | -- | Get the most recent inner `Event` of the outer `Event`. This fires an event when the most recent inner `Event` fires. 127 | switchEvents :: Event (Event a) -> Event a 128 | switchEvents (Event signal hook) = Event identity $ \fin trigger -> do 129 | makeEvent <- unSignal signal fin 130 | innerFinRef <- newFinalizer >>= newIORef 131 | hook fin $ \x -> do 132 | (Event innerSignal innerHook) <- makeEvent x 133 | 134 | readIORef innerFinRef >>= runFinalizer 135 | innerFin <- newFinalizer 136 | writeIORef innerFinRef innerFin 137 | makeA <- unSignal innerSignal innerFin 138 | 139 | innerHook innerFin $ \y -> do 140 | makeA y >>= trigger 141 | 142 | addFinalizer fin $ 143 | readIORef innerFinRef >>= runFinalizer 144 | 145 | -- | Switch a `Dynamic`. Contrary to `switchEvents`, this will also trigger an event when `Event` switches to a new Dynamic. 146 | switchDynamics :: forall a. Event (Dynamic a) -> Event a 147 | switchDynamics (Event signal hook) = Event identity $ \fin trigger -> do 148 | makeEvent <- unSignal signal fin 149 | innerFinRef <- newFinalizer >>= newIORef 150 | hook fin $ \x -> do 151 | (Dynamic (Event innerSignal innerHook) initialValue) <- makeEvent x 152 | 153 | readIORef innerFinRef >>= runFinalizer 154 | innerFin <- newFinalizer 155 | writeIORef innerFinRef innerFin 156 | makeA <- unSignal innerSignal innerFin 157 | 158 | trigger initialValue 159 | 160 | innerHook innerFin $ \y -> do 161 | makeA y >>= trigger 162 | 163 | addFinalizer fin $ 164 | readIORef innerFinRef >>= runFinalizer 165 | 166 | -- | Get the currently active `Event`. 167 | joinEvents :: forall a. Dynamic (Event a) -> Event a 168 | joinEvents (Dynamic (Event outerSignal outerHook) (Event startSignal startHook)) = Event identity $ \fin trigger -> do 169 | makeEvent <- unSignal outerSignal fin 170 | 171 | startFin <- newFinalizer 172 | innerFinRef <- newIORef startFin 173 | 174 | startF <- unSignal startSignal startFin 175 | startHook startFin (startF >=> trigger) 176 | 177 | outerHook fin $ \x -> do 178 | (Event innerSignal innerHook) <- makeEvent x 179 | 180 | readIORef innerFinRef >>= runFinalizer 181 | innerFin <- newFinalizer 182 | writeIORef innerFinRef innerFin 183 | makeA <- unSignal innerSignal innerFin 184 | 185 | innerHook innerFin $ \y -> do 186 | makeA y >>= trigger 187 | 188 | addFinalizer fin $ 189 | readIORef innerFinRef >>= runFinalizer 190 | 191 | -- | Join a `Dynamic` to get the inner `Dynamic`. 192 | joinDynamic :: forall a. Dynamic (Dynamic a) -> Dynamic a 193 | joinDynamic (Dynamic (Event outerSignal outerHook) (Dynamic (Event startSignal startHook) startValue)) = Dynamic joinedEvent startValue 194 | where 195 | joinedEvent :: Event a 196 | joinedEvent = Event identity $ \fin trigger -> do 197 | makeEvent <- unSignal outerSignal fin 198 | 199 | startFin <- newFinalizer 200 | innerFinRef <- newIORef startFin 201 | startF <- unSignal startSignal startFin 202 | 203 | startHook startFin (startF >=> trigger) 204 | 205 | outerHook fin $ \x -> do 206 | (Dynamic (Event innerSignal innerHook) value) <- makeEvent x 207 | 208 | trigger value 209 | 210 | readIORef innerFinRef >>= runFinalizer 211 | innerFin <- newFinalizer 212 | writeIORef innerFinRef innerFin 213 | makeA <- unSignal innerSignal innerFin 214 | 215 | innerHook innerFin $ \y -> do 216 | makeA y >>= trigger 217 | 218 | addFinalizer fin $ 219 | readIORef innerFinRef >>= runFinalizer 220 | 221 | -- | Grab all unseen events as a list 222 | sampleEventAsList :: Event a -> Signal () [a] 223 | sampleEventAsList = fmap ($ []) . sampleEvent (\f a -> f . (a :)) id 224 | 225 | -- | Map a signal function over an event. 226 | mapEvent :: Signal a b -> Event a -> Event b 227 | mapEvent signal2 (Event signal1 hook) = Event (signal1 >>> signal2) hook 228 | 229 | -- | Sample a `Dynamic`. 230 | sampleDynamic :: Dynamic a -> Signal () a 231 | sampleDynamic (Dynamic event initialValue) = Signal $ \r -> unSignal (sampleEvent (\_ x -> x) initialValue event) r 232 | 233 | -- | Sample a `Behavior`. 234 | sampleBehavior :: Behavior a -> Signal () a 235 | sampleBehavior (Behavior signal) = signal 236 | 237 | -- | Map a signal function over a `Behavior`. 238 | mapBehavior :: Signal a b -> Behavior a -> Behavior b 239 | mapBehavior signal2 (Behavior signal1) = Behavior $ signal1 >>> signal2 240 | 241 | -- | Hold the value of an `Event` to a `Dynamic` with initial value @a@. 242 | holdEvent :: a -> Event a -> Dynamic a 243 | holdEvent a event = Dynamic event a 244 | 245 | -- | Extracts the `Event` from a `Dynamic` 246 | dynamicToEvent :: Dynamic a -> Event a 247 | dynamicToEvent (Dynamic event _) = event 248 | 249 | -- | Get a `Behavior` from a `Dynamic` 250 | dynamicToBehavior :: Dynamic a -> Behavior a 251 | dynamicToBehavior (Dynamic (Event signal hook) initialValue) = makeBehavior $ Signal $ \fin -> do 252 | f <- unSignal signal fin 253 | 254 | ref <- newIORef initialValue 255 | 256 | hook fin (f >=> writeIORef ref) 257 | 258 | pure $ \_ -> 259 | readIORef ref 260 | 261 | -- | Make a `Behavior` 262 | makeBehavior :: Signal () a -> Behavior a 263 | makeBehavior = Behavior 264 | -------------------------------------------------------------------------------- /reactimate/src/Reactimate/Random.hs: -------------------------------------------------------------------------------- 1 | module Reactimate.Random where 2 | 3 | import Control.Arrow (Arrow (..)) 4 | import Reactimate.Basic 5 | import Reactimate.Signal 6 | import Reactimate.Stateful 7 | import System.Random 8 | 9 | 10 | -- | Generates a pseudo-random signal with the global RNG 11 | generateRandom :: (Random a) => Signal x a 12 | generateRandom = arrIO $ const randomIO 13 | 14 | -- | Generates a pseudo-random signal in the given range 15 | generateRandomRange :: (Random a) => (a, a) -> Signal x a 16 | generateRandomRange range = arrIO $ const $ randomRIO range 17 | 18 | -- | Generates a pseudo-random signal with the given generator 19 | generateRandomWithRNG :: (RandomGen g, Random a) => g -> Signal x a 20 | generateRandomWithRNG g = feedbackState g $ arr (random . snd) 21 | 22 | -- | Generates a pseudo-random signal in the given range with the given generator 23 | generateRandomRangeWithRNG :: (Random a, RandomGen g) => g -> (a, a) -> Signal x a 24 | generateRandomRangeWithRNG g range = feedbackState g $ arr (randomR range . snd) 25 | -------------------------------------------------------------------------------- /reactimate/src/Reactimate/Run.hs: -------------------------------------------------------------------------------- 1 | module Reactimate.Run where 2 | 3 | import Control.Concurrent (newEmptyMVar, readMVar) 4 | import Control.Concurrent.MVar (putMVar) 5 | import Control.Monad 6 | import Data.IORef (modifyIORef', newIORef, readIORef) 7 | import Reactimate.Event 8 | import Reactimate.Signal 9 | 10 | -- | Run a signal function repeatedly until it produces a `Just` value. 11 | -- 12 | -- You may want to combine `reactimate` with `limitSampleRate`. 13 | reactimate :: Signal () (Maybe a) -> IO a 14 | reactimate signal = 15 | withFinalizer $ \fin -> do 16 | f <- unSignal signal fin 17 | let loop = do 18 | v <- f () 19 | maybe loop pure v 20 | loop 21 | {-# INLINE reactimate #-} 22 | 23 | -- | Sample a signal function until the input list is exhausted. 24 | -- 25 | -- Beware that the whole [b] needs to be produced before it can return! This can lead to bad performance 26 | -- in terms of memory and runtime. 27 | sample :: Signal a b -> [a] -> IO [b] 28 | sample signal inputs = do 29 | withFinalizer 30 | $ \fin -> do 31 | f <- unSignal signal fin 32 | traverse f inputs 33 | {-# INLINE sample #-} 34 | 35 | -- | Fold a signal function strictly until the input list is exhausted. 36 | fold :: (x -> b -> x) -> x -> Signal a b -> [a] -> IO x 37 | fold combine initial signal inputs = do 38 | withFinalizer 39 | $ \fin -> do 40 | f <- unSignal signal fin 41 | state <- newIORef initial 42 | forM_ inputs $ \a -> do 43 | b <- f a 44 | modifyIORef' state (`combine` b) 45 | readIORef state 46 | {-# INLINE fold #-} 47 | 48 | reactimateEvent :: Event (Maybe a) -> IO a 49 | reactimateEvent (Event signal hook) = 50 | withFinalizer $ \fin -> do 51 | mvar <- newEmptyMVar 52 | f <- unSignal signal fin 53 | hook fin $ \x -> do 54 | maybeA <- f x 55 | maybe mempty (putMVar mvar) maybeA 56 | readMVar mvar 57 | {-# INLINE reactimateEvent #-} 58 | -------------------------------------------------------------------------------- /reactimate/src/Reactimate/Sampling.hs: -------------------------------------------------------------------------------- 1 | module Reactimate.Sampling where 2 | 3 | import Control.Concurrent (threadDelay) 4 | import Control.Concurrent.Async 5 | import Control.Monad (forever, when) 6 | import Data.IORef 7 | import Data.Sequence (Seq) 8 | import Data.Sequence qualified as S 9 | import Data.Word (Word64) 10 | import GHC.Clock (getMonotonicTimeNSec) 11 | import Reactimate.Signal 12 | import Reactimate.Time 13 | 14 | -- | Resamples a Signal with the first argument as the specified @frameTime@ within the same thread. The resampled Signal will have a fixed time delta of @frameTime@. 15 | -- The inputs and outputs are collected in a sequence. 16 | resample :: Double -> Time -> (Time -> Signal (Seq a) b) -> Signal a (Seq b) 17 | resample frameTime time signal = Signal $ \fin -> do 18 | f <- unSignal (withFixedTime frameTime signal) fin 19 | nextSampleTimeRef <- newIORef 0 20 | inputRef <- newIORef S.empty 21 | outputRef <- newIORef S.empty 22 | ct <- unSignal (currentTime time) fin 23 | 24 | pure $ \a -> do 25 | modifyIORef' inputRef (S.:|> a) 26 | 27 | initialSampleTime <- readIORef nextSampleTimeRef 28 | when (initialSampleTime <= 1) $ do 29 | -- no sampling has been done yet in this branch, so schedule the next sample to now 30 | ct () >>= writeIORef nextSampleTimeRef 31 | 32 | let go = do 33 | nextSampleTime <- readIORef nextSampleTimeRef 34 | now <- ct () 35 | 36 | when (now >= nextSampleTime) $ do 37 | inputs <- readIORef inputRef 38 | writeIORef inputRef S.empty 39 | b <- f inputs 40 | modifyIORef' outputRef (S.:|> b) 41 | writeIORef nextSampleTimeRef (nextSampleTime + frameTime) 42 | go 43 | 44 | go 45 | 46 | bs <- readIORef outputRef 47 | writeIORef outputRef S.empty 48 | pure bs 49 | 50 | -- \| Samples a signal function in another thread. You may want to limit sampling speed with `limitSampleRate`. 51 | resampleInThread :: Signal (Seq a) b -> Signal a (Seq b) 52 | resampleInThread signal = Signal $ \fin -> do 53 | f <- unSignal signal fin 54 | inputRef <- newIORef S.empty 55 | outputRef <- newIORef S.empty 56 | 57 | asyncRef <- async $ forever $ do 58 | inputs <- atomicModifyIORef' inputRef (S.empty,) 59 | output <- f inputs 60 | modifyIORef' outputRef (S.:|> output) 61 | 62 | addFinalizer fin (cancel asyncRef) 63 | 64 | pure $ \a -> do 65 | modifyIORef' inputRef (S.:|> a) 66 | atomicModifyIORef' outputRef (S.empty,) 67 | 68 | -- | Limit the real world samples per second. The first argument is samples per second. 69 | limitSampleRate :: Double -> Signal a b -> Signal a b 70 | limitSampleRate frameTime' (Signal signal) = Signal $ \fin -> do 71 | f <- signal fin 72 | timeRef <- newIORef 0 73 | pure $ \a -> do 74 | b <- f a 75 | oldTime <- readIORef timeRef 76 | cTime <- getMonotonicTimeNSec 77 | let !waitTime = nanos - fromIntegral (cTime - oldTime) 78 | if waitTime > 0 79 | then do 80 | writeIORef timeRef $ oldTime + nanosW64 81 | threadDelay (waitTime `quot` 1000) 82 | else writeIORef timeRef cTime 83 | pure b 84 | where 85 | frameTime = 1 / frameTime' 86 | nanos :: Int 87 | nanos = round $ frameTime * 10 ^ (9 :: Int) 88 | nanosW64 :: Word64 89 | nanosW64 = round $ frameTime * 10 ^ (9 :: Int) 90 | {-# INLINE limitSampleRate #-} 91 | -------------------------------------------------------------------------------- /reactimate/src/Reactimate/Setup.hs: -------------------------------------------------------------------------------- 1 | module Reactimate.Setup where 2 | 3 | import Reactimate.Signal 4 | 5 | -- | Allocate some resources and add them to the environment. 6 | -- Use the `Finalizer` to destroy the resource. 7 | allocateResource :: (Finalizer -> IO r) -> (r -> Signal a b) -> Signal a b 8 | allocateResource f signal = Signal $ \fin -> do 9 | res <- f fin 10 | unSignal (signal res) fin 11 | {-# INLINE allocateResource #-} 12 | 13 | -- | Do some setup before any signal functions actually run. 14 | -- The setup action will be run **once** before any signal functions produce outputs. 15 | withSetup :: IO r -> (r -> Signal a b) -> Signal a b 16 | withSetup setup signal = Signal $ \fin -> do 17 | r <- setup 18 | unSignal (signal r) fin 19 | {-# INLINE withSetup #-} 20 | 21 | -- | Do some setup before any signal functions actually run. 22 | -- The setup action will be run **once** before any signal functions produce outputs. 23 | withSetup_ :: IO r -> Signal a b -> Signal a b 24 | withSetup_ setup signal = Signal $ \fin -> do 25 | _ <- setup 26 | unSignal signal fin 27 | {-# INLINE withSetup_ #-} 28 | -------------------------------------------------------------------------------- /reactimate/src/Reactimate/Signal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Reactimate.Signal where 4 | 5 | import Control.Arrow 6 | import Control.Category 7 | import Control.Exception (bracket) 8 | import Control.Monad (join, (>=>)) 9 | import Data.IORef 10 | import Prelude hiding (id, (.)) 11 | 12 | -- | A signal function takes @a@s and produces @b@. They can also do IO. 13 | -- Typically, you would repeatedly get input and run the signal function continously it. 14 | -- 15 | -- The @r@ argument is the environment for the setup phase. It may be used similar to the ReaderT pattern. 16 | -- 17 | -- Signal functions have a __setup__ and a __run__ phase: 18 | -- 19 | -- 1. The setup phase is run once at the beginning and produces a run function 20 | -- 2. The run phase is run as often as you want 21 | -- 22 | -- Notice that `Signal` is an instance of `Functor`, `Applicative` and `Arrow`! 23 | newtype Signal a b = Signal (Finalizer -> IO (a -> IO b)) 24 | 25 | instance Functor (Signal a) where 26 | fmap f (Signal m) = Signal $ \fin -> fmap (fmap f .) (m fin) 27 | {-# INLINE fmap #-} 28 | 29 | instance Applicative (Signal a) where 30 | pure a = Signal $ \_ -> pure $ \_ -> pure a 31 | (Signal signal1) <*> (Signal signal2) = Signal $ \fin -> do 32 | f1 <- signal1 fin 33 | f2 <- signal2 fin 34 | pure $ \a -> f1 a <*> f2 a 35 | {-# INLINE pure #-} 36 | {-# INLINE (<*>) #-} 37 | 38 | instance Category Signal where 39 | id = Signal $ \_ -> pure $ \a -> pure a 40 | (Signal signal1) . (Signal signal2) = Signal $ \fin -> do 41 | f1 <- signal1 fin 42 | f2 <- signal2 fin 43 | pure $ f2 >=> f1 44 | {-# INLINE id #-} 45 | {-# INLINE (.) #-} 46 | 47 | instance Arrow Signal where 48 | arr f = Signal $ \_ -> pure $ pure . f 49 | first (Signal signal) = Signal $ \fin -> do 50 | f <- signal fin 51 | pure $ \(a, b) -> (,b) <$> f a 52 | second (Signal signal) = Signal $ \fin -> do 53 | f <- signal fin 54 | pure $ \(a, b) -> (a,) <$> f b 55 | (Signal signal1) *** (Signal signal2) = Signal $ \fin -> do 56 | f1 <- signal1 fin 57 | f2 <- signal2 fin 58 | pure $ \(a, b) -> (,) <$> f1 a <*> f2 b 59 | (Signal signal1) &&& (Signal signal2) = Signal $ \fin -> do 60 | f1 <- signal1 fin 61 | f2 <- signal2 fin 62 | pure $ \a -> (,) <$> f1 a <*> f2 a 63 | {-# INLINE arr #-} 64 | {-# INLINE first #-} 65 | {-# INLINE second #-} 66 | {-# INLINE (***) #-} 67 | {-# INLINE (&&&) #-} 68 | 69 | instance ArrowChoice Signal where 70 | left signal = Signal $ \fin -> do 71 | f <- unSignal signal fin 72 | pure $ \case 73 | Left a -> Left <$> f a 74 | Right d -> pure $ Right d 75 | 76 | right signal = Signal $ \fin -> do 77 | f <- unSignal signal fin 78 | pure $ \case 79 | Right a -> Right <$> f a 80 | Left d -> pure $ Left d 81 | 82 | signal1 +++ signal2 = Signal $ \fin -> do 83 | f1 <- unSignal signal1 fin 84 | f2 <- unSignal signal2 fin 85 | pure $ \case 86 | Left a -> Left <$> f1 a 87 | Right a -> Right <$> f2 a 88 | signal1 ||| signal2 = Signal $ \fin -> do 89 | f1 <- unSignal signal1 fin 90 | f2 <- unSignal signal2 fin 91 | pure $ \case 92 | Left a -> f1 a 93 | Right a -> f2 a 94 | {-# INLINE left #-} 95 | {-# INLINE right #-} 96 | {-# INLINE (+++) #-} 97 | {-# INLINE (|||) #-} 98 | 99 | -- | Unwrap a signal function and feed in the environment @r@. The outer `IO` is the setup, which produces the run action. 100 | unSignal :: Signal a b -> Finalizer -> IO (a -> IO b) 101 | unSignal (Signal signal) = signal 102 | {-# INLINE unSignal #-} 103 | 104 | -- | A `Finalizer` contains some clean-up code. 105 | -- Usually, they are run when the execution of the signal function stops 106 | newtype Finalizer = Finalizer (IORef (IO ())) 107 | 108 | -- | Add a clean-up function to a `Finalizer` 109 | addFinalizer :: Finalizer -> IO () -> IO () 110 | addFinalizer (Finalizer ref) fin = modifyIORef' ref (fin >>) 111 | {-# INLINE addFinalizer #-} 112 | 113 | -- | Make a new `Finalizer` 114 | newFinalizer :: IO Finalizer 115 | newFinalizer = Finalizer <$> newIORef (pure ()) 116 | {-# INLINE newFinalizer #-} 117 | 118 | -- | Run the clean-up code from finalizer 119 | runFinalizer :: Finalizer -> IO () 120 | runFinalizer (Finalizer ref) = join $ readIORef ref 121 | {-# INLINE runFinalizer #-} 122 | 123 | -- | Run some code with a `Finalizer` and then run the clean-up code. 124 | -- 125 | -- You should not return the `Finalizer` and run it again. This has already been done. 126 | withFinalizer :: (Finalizer -> IO a) -> IO a 127 | withFinalizer = 128 | bracket 129 | newFinalizer 130 | runFinalizer 131 | {-# INLINE withFinalizer #-} 132 | -------------------------------------------------------------------------------- /reactimate/src/Reactimate/Stateful.hs: -------------------------------------------------------------------------------- 1 | module Reactimate.Stateful where 2 | 3 | import Control.Arrow ((>>>)) 4 | import Data.IORef 5 | import Reactimate.Basic 6 | import Reactimate.Signal 7 | 8 | -- | Feeds the output back as input. 9 | feedback :: b -> Signal (a, b) b -> Signal a b 10 | feedback !initial (Signal signal) = Signal $ \fin -> do 11 | f <- signal fin 12 | stateRef <- newIORef initial 13 | pure $ \a -> do 14 | !b <- readIORef stateRef 15 | !nextB <- f (a,b) 16 | writeIORef stateRef nextB 17 | pure nextB 18 | {-# INLINE feedback #-} 19 | 20 | -- | Feeds the output state back as input. The state @s@ is strict. 21 | feedbackState :: s -> Signal (a, s) (b, s) -> Signal a b 22 | feedbackState !initial (Signal signal) = Signal $ \fin -> do 23 | f <- signal fin 24 | stateRef <- newIORef initial 25 | pure $ \a -> do 26 | !s <- readIORef stateRef 27 | (b, !s') <- f (a, s) 28 | writeIORef stateRef s' 29 | pure b 30 | {-# INLINE feedbackState #-} 31 | 32 | -- | Feeds the output state back as input. The state @s@ is lazy, so beware space leaks. 33 | feedbackLazyState :: s -> Signal (a, s) (b, s) -> Signal a b 34 | feedbackLazyState initial (Signal signal) = Signal $ \fin -> do 35 | f <- signal fin 36 | stateRef <- newIORef initial 37 | pure $ \a -> do 38 | s <- readIORef stateRef 39 | (b, s') <- f (a, s) 40 | writeIORef stateRef s' 41 | pure b 42 | {-# INLINE feedbackLazyState #-} 43 | 44 | -- | Scan along time. The first function will be run each execution with the input @a@, produce the output @b@ and reuse @b@ as state for the next iteration. 45 | scan :: (b -> a -> b) -> b -> Signal a b 46 | scan f initial = feedback initial (arr2 (flip f)) 47 | {-# INLINE scan #-} 48 | 49 | -- | Sums up the input values 50 | sumUp :: (Num a) => Signal a a 51 | sumUp = scan (+) 0 52 | {-# INLINE sumUp #-} 53 | 54 | -- | Computes a moving mean of the input values 55 | -- 56 | -- The first parameter @alpha@ must be in the intervall [0,1] and controls how strongly recent samples are weighted. 57 | -- Small @alpha@ near 0 leads to slower but smoother convergence. Big @alpha@ leads to quick convergence but a jagged curve. 58 | movingMean :: (Fractional a) => a -> Signal a a 59 | movingMean alpha = scan (\b a -> b + alpha * (a - b)) 0 60 | {-# INLINE movingMean #-} 61 | -------------------------------------------------------------------------------- /reactimate/src/Reactimate/Switching.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecursiveDo #-} 2 | 3 | module Reactimate.Switching where 4 | 5 | import Control.Monad (when) 6 | import Data.IORef 7 | import Data.Vector qualified as V 8 | import Reactimate.Signal 9 | 10 | -- | 'caseOf' is a powerful combinator to implement switching behavior. It is similar to case expressions, but for signal functions. 11 | -- 12 | -- The first argument determines some @c@. The second argument takes the @c@ and decides which signal function should be used. 13 | -- The signal functions generated by the second function keep their state across executions, i.e. when they get selected multiple times, 14 | -- they keep their state. 15 | -- 16 | -- Beware that this function should not be used when @c@ has many (~dozens) cases, since the setup phase will be run for each case. 17 | caseOf :: forall c a b. (Bounded c, Enum c) => Signal a c -> (c -> Signal a b) -> Signal a b 18 | caseOf decider makeSignal = Signal $ \fin -> do 19 | when (fromEnum (maxBound :: c) - fromEnum (minBound :: c) > 100) $ 20 | fail "You probably do not want to use `caseSignal` with so many cases. Use `manyCaseSignal` if you really want to." 21 | unSignal (manyCaseSignal decider makeSignal) fin 22 | {-# INLINE caseOf #-} 23 | 24 | -- | Same as `caseOf` but will not error when you have a @c@ with many cases. 25 | manyCaseSignal :: (Bounded c, Enum c) => Signal a c -> (c -> Signal a b) -> Signal a b 26 | manyCaseSignal (Signal makeDecider) makeSignal = Signal $ \fin -> do 27 | decide <- makeDecider fin 28 | signals <- V.fromList <$> traverse (\c -> unSignal (makeSignal c) fin) [minBound .. maxBound] 29 | pure $ \a -> do 30 | c <- decide a 31 | let step = signals V.! fromEnum c 32 | step a 33 | {-# INLINE manyCaseSignal #-} 34 | 35 | -- | Switch out a signal function with another when you produce a @Just c@ value once. 36 | -- The next signal function will become active instantly. After a `Signal` has been switched out, it's outputs might be corrupted. 37 | switch :: Signal a (b, Maybe c) -> (c -> Signal a b) -> Signal a b 38 | switch signal kont = Signal $ \fin -> mdo 39 | newFin <- newFinalizer 40 | f <- unSignal signal newFin 41 | 42 | stepRef <- newIORef $ \a -> do 43 | (b, maybeC) <- f a 44 | case maybeC of 45 | Nothing -> pure b 46 | Just c -> do 47 | newStep <- unSignal (kont c) fin 48 | writeIORef stepRef newStep 49 | runFinalizer newFin 50 | newStep a 51 | 52 | pure $ \a -> do 53 | step <- readIORef stepRef 54 | step a 55 | 56 | -- | Switch out a signal function with another when you produce a @Just c@ value continously. 57 | -- The next signal function will become active instantly. After a `Signal` has been switched out, it's outputs might be corrupted. 58 | -- 59 | -- `switchRepeatedly` is more efficient than `switch` if you switch often. 60 | switchRepeatedly :: Signal a (b, Maybe c) -> (c -> Signal a (b, Maybe c)) -> Signal a b 61 | switchRepeatedly signal kont = Signal $ \_ -> mdo 62 | let switchingF fin step a = do 63 | (b, maybeC) <- step a 64 | case maybeC of 65 | Nothing -> pure b 66 | Just c -> do 67 | newFin <- newFinalizer 68 | newStep <- unSignal (kont c) newFin 69 | writeIORef stepRef (switchingF newFin newStep) 70 | runFinalizer fin 71 | switchingF newFin newStep a 72 | 73 | newFin <- newFinalizer 74 | f <- unSignal signal newFin 75 | stepRef <- newIORef (switchingF newFin f) 76 | 77 | pure $ \a -> do 78 | step <- readIORef stepRef 79 | step a 80 | -------------------------------------------------------------------------------- /reactimate/src/Reactimate/Time.hs: -------------------------------------------------------------------------------- 1 | module Reactimate.Time (Time(..), withTime, withFixedTime, deltaTime, currentTime, integrate) where 2 | 3 | import Control.Arrow 4 | import Control.Category (Category (id)) 5 | import Data.IORef (IORef, newIORef, readIORef) 6 | import GHC.Clock (getMonotonicTime) 7 | import GHC.IORef (writeIORef) 8 | import GHC.Records 9 | import Reactimate.Basic (arrIO) 10 | import Reactimate.Signal 11 | import Reactimate.Stateful (feedbackState) 12 | import Prelude hiding (id) 13 | 14 | -- | Tracks `currentTime` and `deltaTime`. 15 | data Time = Time 16 | { dTime :: {-# UNPACK #-} !(IORef Double), 17 | cTime :: {-# UNPACK #-} !(IORef Double) 18 | } 19 | deriving (Eq) 20 | 21 | -- | Gives you a 'Time' based on real data. 22 | -- 'Time' contains the total runtime as well as a delta time which is the time between executions of signal functions. 23 | withTime :: (Time -> Signal a b) -> Signal a b 24 | withTime signal = Signal $ \fin -> do 25 | !buildTime <- getMonotonicTime 26 | dTimeRef <- newIORef 0 27 | timeRef <- newIORef buildTime 28 | let time = Time dTimeRef timeRef 29 | step <- unSignal (signal time) fin 30 | pure $ \a -> do 31 | oldTime <- readIORef timeRef 32 | !newTime <- getMonotonicTime 33 | let !dTime = newTime - oldTime 34 | writeIORef timeRef newTime 35 | writeIORef dTimeRef dTime 36 | 37 | step a 38 | {-# INLINE withTime #-} 39 | 40 | -- | Gives you a 'Time' based on a fixed delta. Each execution will have the same delta and the runtime 41 | -- will be @deltaTime * runNumber@. 42 | withFixedTime :: Double -> (Time -> Signal a b) -> Signal a b 43 | withFixedTime fixedDelta signal = Signal $ \fin -> do 44 | dTimeRef <- newIORef fixedDelta 45 | timeRef <- newIORef 0 46 | let time = Time dTimeRef timeRef 47 | step <- unSignal (signal time) fin 48 | pure $ \a -> do 49 | oldTime <- readIORef timeRef 50 | let !newTime = oldTime + fixedDelta 51 | writeIORef timeRef newTime 52 | step a 53 | {-# INLINE withFixedTime #-} 54 | 55 | -- | Get the duration of the last execution which can be used to do some interpolation based on time. 56 | deltaTime :: Time -> Signal x Double 57 | deltaTime time = arrIO (const $ readIORef $ getField @"dTime" time) 58 | {-# INLINE deltaTime #-} 59 | 60 | -- | Get the total runtime. 61 | currentTime :: Time -> Signal x Double 62 | currentTime time = arrIO (const $ readIORef $ getField @"cTime" time) 63 | {-# INLINE currentTime #-} 64 | 65 | -- | Integrate a value based on 'deltaTime'. The first parameter is the needed scalar multiplication for `a`. 66 | integrate :: (Num a) => Time -> (Double -> a -> a) -> Signal a a 67 | integrate time scale = 68 | deltaTime time &&& id 69 | >>> feedbackState 70 | 0 71 | ( arr $ \((dt, value), !previous) -> 72 | let !next = previous + scale dt value in (next, next) 73 | ) 74 | {-# INLINE integrate #-} 75 | --------------------------------------------------------------------------------